+++ /dev/null
-# Dear Distribution Packager. This use of require is intentional.
-# Module::Install detects Build.PL usage and acts accordingly.
-require 'Makefile.PL';
Revision history for DBIx::Class
+ - Added search_related_rs method to ResultSet
+ - add a make_column_dirty method to Row to force updates
+ - throw a clear exception when user tries multi-has_many prefetch
+ - SQLT parser prefixes index names with ${table}_idx_ to avoid clashes
+ - mark ResultSetManager as deprecated and undocument it
+ - pod fix (RT #32988)
+ - add Test::Exception to test requirements (RT #34256)
+ - make ash's build_requires/META.yml fixes work better
+ - is_deferable support on relations used by the SQL::Translator
+ parser
+ - Refactored DBIx::Class::Schema::Versioned
+ - Syntax errors from resultset components are now reported correctly
+ - sqltargs respected correctly in deploy et al.
+ - Added support for savepoints, and using them automatically in
+ nested transactions if auto_savepoint is set in connect_info.
+ - Changed naming scheme for constraints and keys in the sqlt parser;
+ names should now be consistent and collision-free.
+ - Improve handling of explicit key attr in ResultSet::find
+ - Add warnings for non-unique ResultSet::find queries
+ - Changed Storage::DBI::Replication to Storage::DBI::Replicated, fixed
+ some problems using this with versioned databases, added some docs
+ - By default now deploy/diff et al. will ignore constraint and index
+ names
+
+0.08010 2008-03-01 10:30
+ - Fix t/94versioning.t so it passes with latest SQL::Translator
+
+0.08009 2008-01-20 13:30
+ - Made search_rs smarter about when to preserve the cache to fix
+ mm prefetch usage
+ - Added Storage::DBI subclass for MSSQL over ODBC.
+ - Added freeze, thaw and dclone methods to Schema so that thawed
+ objects will get re-attached to the schema.
+ - Moved dbicadmin to JSON::Any wrapped JSON.pm for a sane API
+ (also fixes RT #32393)
+ - introduced DBIx::Class::set_inflated_columns
+ - DBIx::Class::Row::copy uses set_inflated_columns
+
+0.08008 2007-11-16 14:30:00
+ - Fixed join merging bug (test from Zby)
+ - When adding relationships, it will throw an exception if you get the
+ foreign and self parts the wrong way round in the condition
+ - ResultSetColumn::func() now returns all results if called in list
+ context; this makes things like func('DISTINCT') work as expected
+ - Many-to-many relationships now warn if the utility methods would
+ clash
+ - InflateColumn::DateTime now accepts an extra parameter of timezone
+ to set timezone on the DT object (thanks Sergio Salvi)
+ - Added sqlt_deploy_hook to result classes so that indexes can be
+ added.
+ - Added startup checks to warn loudly if we appear to be running on
+ RedHat systems from perl-5.8.8-10 and up that have the bless/overload
+ patch applied (badly) which causes 2x -> 100x performance penalty.
+ (Jon Schutz)
+ - ResultSource::reverse_relationship_info can distinguish between
+ sources using the same table
+ - Row::insert will now not fall over if passed duplicate related objects
+ - Row::copy will not fall over if you have two relationships to the
+ same source with a unique constraint on it
+
+0.08007 2007-09-04 19:36:00
+ - patch for Oracle datetime inflation (abram@arin.net)
+ - added on_disconnect_do
+ - on_connect_do and on_disconnect_do take coderefs and arrayrefs
+
+0.08006 2007-08-12 15:12:00
+ - Move to using Class::C3::Componentised
+ - Remove warn statement from DBIx::Class::Row
+
+0.08005 2007-08-06
+ - add timestamp fix re rt.cpan 26978 - no test yet but change
+ clearly should cause no regressions
+ - provide alias for related_resultset via local() so it's set
+ correctly at resultset construction time (fixes RestrictWithObject)
+ - fixes bind params in debug statements
+ (original test from abraxxa)
+ - fixed storage->connected fork bug
+ (test and fix from Radu Greab)
+ - add 1; to AccessorGroup.pm for stuff that still uses it
+ - refactor Statistics to create debugging filehandle to fix bug with
+ closed STDERR, update docs and modify Versioned to use Statistics
+ (original fix from diz)
+
+0.08004 2007-08-06 19:00:00
+ - fix storage connect code to not trigger bug via auto-viv
+ (test from aherzog)
+ - fixup cursor_class to be an 'inherited' attr for per-package defaults
+ - add default_resultset_attributes entry to Schema
+ - optimisation in DBI::Cursor to check software_limit before falling
+ back to base Cursor->all
+ - fix bug with create_multi not inserting non-storage objects
+ (test and fix from davinchi)
+ - DBIx::Class::AccessorGroup made empty subclass of
+ Class::Accessor::Grouped
+ - fixed an ugly bug regarding $dbh->{AutoCommit} and transactions
+ - ensure_class_loaded handles non-classnames better.
+ - non-destructive hashref handling for connect_info options
+ - count no longer returns negative values after slice
+ (report and test from JOHANL)
+ - rebless before building datetime_parser
+ (patch from mattlaw / Matt Lawrence)
+
+0.08003 2007-07-14 18:01:00
+ - improved populate bulk_insert mode
+ - fixed up multi_create to be more intelligent about PK<->PK rels
+ - fix many-many rels to not use set_columns
+ - Unmarked deploy as experimental since it isn't anymore
+ - Removed Cwd dep since it's not required and causes problems
+ with debian packaging
+ - Patch to fix ? in data for NoBindVars (from Tom Hukins)
+ - Restored mk_classaccessor method for compatibility
+ - Fixed group_by problem with oracle limit syntax
+ - Fixed attr merging problem
+ - Fixed $rs->get_column w/prefetch problem
+
+0.08002 2007-06-20 06:10:00
+ - add scope guard to Row::insert to ensure rollback gets called
+ - more heuristics in Row::insert to try and get insert order right
+ - eliminate vestigial code in PK::Auto
+ - more expressive DBI errors
+ - soften errors during deploy
+ - ensure_connected before txn_begin to catch stomping on transaction
+ depth
+ - new method "rethrow" for our exception objects
+
+0.08001 2007-06-17 21:21:02
+ - Cleaned up on_connect handling for versioned
+ - removed DateTime use line from multi_create test
+ - hid DBIx::ContextualFetch::st override in CDBICompat
+
+0.08000 2007-06-17 18:06:12
+ - Fixed DBIC_TRACE debug filehandles to set ->autoflush(1)
+ - Fixed circular dbh<->storage in HandleError with weakref
+
+0.07999_06 2007-06-13 04:45:00
+ - tweaked Row.pm to make last_insert_id take multiple column names
+ - Fixed DBIC::Storage::DBI::Cursor::DESTROY bug that was
+ messing up exception handling
+ - added exception objects to eliminate stacktrace/Carp::Clan
+ output redundancy
+ - setting $ENV{DBIC_TRACE} defaults stacktrace on.
+ - added stacktrace option to Schema, makes throw_exception
+ use "confess"
+ - make database handles use throw_exception by default
+ - make database handles supplied by a coderef use our
+ standard HandleError/RaiseError/PrintError
+ - add "unsafe" connect_info option to suppress our setting
+ of HandleError/RaiseError/PrintError
+ - removed several redundant evals whose sole purpose was to
+ provide extra debugging info
+ - fixed page-within-page bug (reported by nilsonsfj)
+ - fixed rare bug when database is disconnected inbetween
+ "$dbh->prepare_cached" and "$sth->execute"
+
+0.07999_05 2007-06-07 23:00:00
+ - Made source_name rw in ResultSource
+ - Fixed up SQL::Translator test/runtime dependencies
+ - Fixed t/60core.t in the absence of DateTime::Format::MySQL
+ - Test cleanup and doc note (ribasushi)
+
+0.07999_04 2007-06-01 14:04:00
+ - pulled in Replication storage from branch and marked EXPERIMENTAL
+ - fixup to ensure join always LEFT after first LEFT join depthwise
+ - converted the vendor tests to use schema objects intead of schema
+ classes, made cleaned more reliable with END blocks
+ - versioning support via DBIx::Class::Schema::Versioned
+ - find/next now return undef rather than () on fail from Bernhard Graf
+ - rewritten collapse_result to fix prefetch
+ - moved populate to resultset
+ - added support for creation of related rows via insert and populate
+ - transaction support more robust now in the face of varying AutoCommit
+ and manual txn_begin usage
+ - unbreak back-compat for Row/ResultSet->new_result
+ - Added Oracle/WhereJoins.pm for Oracle >= 8 to support
+ Oracle <= 9i, and provide Oracle with a better join method for
+ later versions. (I use the term better loosely.)
+ - The SQL::T parser class now respects a relationship attribute of
+ is_foreign_key_constrain to allow explicit control over wether or
+ not a foreign constraint is needed
+ - resultset_class/result_class now (again) auto loads the specified
+ class; requires Class::Accessor::Grouped 0.05002+
+ - added get_inflated_columns to Row
+ - %colinfo accessor and inflate_column now work together
+ - More documentation updates
+ - Error messages from ->deploy made more informative
+ - connect_info will now always return the arguments it was
+ originally given
+ - A few small efficiency improvements for load_classes
+ and compose_namespace
+
+0.07006 2007-04-17 23:18:00
+ - Lots of documentation updates
+ - deploy now takes an optional 'source_names' parameter (dec)
+ - Quoting for for columns_info_for
+ - RT#25683 fixed (multiple open sths on DBD::Sybase)
+ - CDBI compat infers has_many from has_a (Schwern)
+ - Fix ddl_filename transformation (Carl Vincent)
+
+0.07999_02 2007-01-25 20:11:00
+ - add support for binding BYTEA and similar parameters (w/Pg impl)
+ - add support to Ordered for multiple ordering columns
- mark DB.pm and compose_connection as deprecated
- switch tests to compose_namespace
+ - ResultClass::HashRefInflator added
+ - Changed row and rs objects to not have direct handle to a source,
+ instead a (schema,source_name) tuple of type ResultSourceHandle
+
+0.07005 2007-01-10 18:36:00
+ - fixup changes file
+ - remove erroneous .orig files - oops
+
+0.07004 2007-01-09 21:52:00
+ - fix find_related-based queries to correctly grep the unique key
+ - fix InflateColumn to inflate/deflate all refs but scalar refs
+
+0.07003 2006-11-16 11:52:00
+ - fix for rt.cpan.org #22740 (use $^X instead of hardcoded "perl")
+ - Tweaks to resultset to allow inflate_result to return an array
+ - Fix UTF8Columns to work under Perl <= 5.8.0
+ - Fix up new_result in ResultSet to avoid alias-related bugs
+ - Made new/update/find handle 'single' rel accessor correctly
+ - Fix NoBindVars to be safer and handle non-true bind values
+ - Don't blow up if columns_info_for returns useless results
+ - Documentation updates
0.07999_01 2006-10-05 21:00:00
- add connect_info option "disable_statement_caching"
You can make it work like before via
__PACKAGE__->column_info_from_storage(1) for now
- Replaced DBIx::Class::AccessorGroup and Class::Data::Accessor with
- Class::Accessor::Grouped. Only user noticible change is to
- table_class on ResultSourceProxy::Table (i.e. table objects in
- schemas) and, resultset_class and result_class in ResultSource.
+ Class::Accessor::Grouped. Only user noticible change is to
+ table_class on ResultSourceProxy::Table (i.e. table objects in
+ schemas) and, resultset_class and result_class in ResultSource.
These accessors no longer automatically require the classes when
set.
-0.07003 2006-11-16 11:52:00
- - fix for rt.cpan.org #22740 (use $^X instead of hardcoded "perl")
- - Tweaks to resultset to allow inflate_result to return an array
- - Fix UTF8Columns to work under Perl <= 5.8.0
- - Fix up new_result in ResultSet to avoid alias-related bugs
- - Made new/update/find handle 'single' rel accessor correctly
- - Fix NoBindVars to be safer and handle non-true bind values
- - Don't blow up if columns_info_for returns useless results
- - Documentation updates
-
0.07002 2006-09-14 21:17:32
- fix quote tests for recent versions of SQLite
- added reference implementation of Manual::Example
- fixes to pass test suite on Windows
- rewrote and cleaned up SQL::Translator tests
- changed relationship helpers to only call ensure_class_loaded when the
- join condition is inferred
+ join condition is inferred
- rewrote many_to_many implementation, now provides helpers for adding
and deleting objects without dealing with the link table
- reworked InflateColumn implementation to lazily deflate where
- changed join merging to not create a rel_2 alias when adding a join
that already exists in a parent resultset
- Storage::DBI::deployment_statements now calls ensure_connected
- if it isn't passed a type
+ if it isn't passed a type
- fixed Componentized::ensure_class_loaded
- InflateColumn::DateTime supports date as well as datetime
- split Storage::DBI::MSSQL into MSSQL and Sybase::MSSQL
- - fixed wrong debugging hook call in Storage::DBI
- - set connect_info properly before setting any ->sql_maker things
+ - fixed wrong debugging hook call in Storage::DBI
+ - set connect_info properly before setting any ->sql_maker things
0.06999_02 2006-06-09 23:58:33
- Fixed up POD::Coverage tests, filled in some POD holes
0.05002 2006-02-06 12:12:03
- Added recommends for Class::Inspector
- - Added skip_all to t/40resultsetmanager.t if no Class::Inspector available
+ - Added skip_all to t/40resultsetmanager.t if no Class::Inspector
+ available
0.05001 2006-02-05 15:28:10
- debug output now prints NULL for undef params
0.04999_04 2006-01-24 21:48:21
- more documentation improvements
- - add columns_info_for for vendor-specific column info (Zbigniew Lukasiak)
- - add SQL::Translator::Producer for DBIx::Class table classes (Jess Robinson)
+ - add columns_info_for for vendor-specific column info (Zbigniew
+ Lukasiak)
+ - add SQL::Translator::Producer for DBIx::Class table classes (Jess
+ Robinson)
- add unique constraint declaration (Daniel Westermann-Clark)
- add new update_or_create method (Daniel Westermann-Clark)
- rename ResultSetInstance class to ResultSetProxy, ResultSourceInstance
0.04999_03 2006-01-20 06:05:27
- imported Jess Robinson's SQL::Translator::Parser::DBIx::Class
- - lots of internals cleanup to eliminate result_source_instance requirement
+ - lots of internals cleanup to eliminate result_source_instance
+ requirement
- added register_column and register_relationship class APIs
- made Storage::DBI use prepare_cached safely (thanks to Tim Bunce)
- many documentation improvements (thanks guys!)
- - added ->connection, ->connect, ->register_source and ->clone schema methods
+ - added ->connection, ->connect, ->register_source and ->clone schema
+ methods
- Use croak instead of die for user errors.
0.04999_02 2006-01-14 07:17:35
0.01 2005-08-08 17:10:00
- initial release
+
# Skip maint stuff
^maint/
+# Avoid copies to .orig
+\.orig$
+
# Dont use Module::Build anymore
-# Build.PL
+^Build.PL$
-use inc::Module::Install 0.64;
+use inc::Module::Install 0.67;
+use strict;
+use warnings;
+
+use 5.006001; # delete this line if you want to send patches for earlier.
name 'DBIx-Class';
-all_from 'lib/DBIx/Class.pm';
perl_version '5.006001';
+all_from 'lib/DBIx/Class.pm';
-requires 'Cwd' => 3.19;
requires 'Data::Page' => 2.00;
requires 'Scalar::Util' => 0;
requires 'SQL::Abstract' => 1.20;
requires 'SQL::Abstract::Limit' => 0.101;
requires 'Class::C3' => 0.13;
+requires 'Class::C3::Componentised' => 0;
requires 'Storable' => 0;
requires 'Carp::Clan' => 0;
requires 'DBI' => 1.40;
requires 'Module::Find' => 0;
requires 'Class::Inspector' => 0;
-requires 'Class::Accessor::Grouped' => 0.03;
+requires 'Class::Accessor::Grouped' => 0.05002;
+requires 'JSON::Any' => 1.00;
+requires 'Scope::Guard' => 0.03;
+requires 'Path::Class' => 0;
# Perl 5.8.0 doesn't have utf8::is_utf8()
requires 'Encode' => 0 if ($] <= 5.008000);
-build_requires 'DBD::SQLite' => 1.11;
+test_requires 'DBD::SQLite' => 1.13;
+test_requires 'Test::Builder' => 0.33;
+test_requires 'Test::Warn' => 0.08;
+test_requires 'Test::NoWarnings' => 0.08;
+test_requires 'Test::Exception' => 0;
install_script 'script/dbicadmin';
tests "t/*.t t/*/*.t";
+# re-build README and require CDBI modules for testing if we're in a checkout
+
+my @force_build_requires_if_author = qw(
+ DBIx::ContextualFetch
+ Class::Trigger
+ Time::Piece
+);
+
+if ($Module::Install::AUTHOR) {
+
+ foreach my $module (@force_build_requires_if_author) {
+ build_requires $module;
+ }
+
+ system('pod2text lib/DBIx/Class.pm > README');
+}
+
+auto_provides;
+
auto_install;
WriteAll;
+
+
+if ($Module::Install::AUTHOR) {
+ # Need to do this _after_ WriteAll else it looses track of them
+ Meta->{values}{build_requires} = [ grep {
+ my $ok = 1;
+ foreach my $module (@force_build_requires_if_author) {
+ if ($_->[0] =~ /$module/) {
+ $ok = 0;
+ last;
+ }
+ }
+ $ok;
+ } @{Meta->{values}{build_requires}} ];
+
+ my @scalar_keys = Module::Install::Metadata::Meta_TupleKeys();
+ my $cr = Module::Install::Metadata->can("Meta_TupleKeys");
+ {
+ no warnings 'redefine';
+ *Module::Install::Metadata::Meta_TupleKeys = sub {
+ return $cr->(@_), 'resources';
+ };
+ }
+ Meta->{values}{resources} = [
+ [ 'MailingList', 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class' ],
+ [ 'IRC', 'irc://irc.perl.org/#dbix-class' ],
+ ];
+ Meta->write;
+}
+
+
+
use vars qw($VERSION);
use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
+use DBIx::Class::StartupCheck;
+
sub mk_classdata {
- my $self = shift;
- $self->mk_group_accessors('inherited', $_[0]);
- $self->set_inherited(@_) if @_ > 1;
+ shift->mk_classaccessor(@_);
+}
+
+sub mk_classaccessor {
+ my $self = shift;
+ $self->mk_group_accessors('inherited', $_[0]);
+ $self->set_inherited(@_) if @_ > 1;
}
sub component_base_class { 'DBIx::Class' }
# 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.07999_01';
+$VERSION = '0.08099_02';
+
+$VERSION = eval $VERSION; # numify for warning-free dev releases
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code,@attrs) = @_;
DBIx::Class - Extensible and flexible object <-> relational mapper.
+=head1 GETTING HELP/SUPPORT
+
+The community can be found via:
+
+ Mailing list: http://lists.scsys.co.uk/mailman/listinfo/dbix-class/
+
+ SVN: http://dev.catalyst.perl.org/repos/bast/DBIx-Class/
+
+ SVNWeb: http://dev.catalyst.perl.org/svnweb/bast/browse/DBIx-Class/
+
+ IRC: irc.perl.org#dbix-class
+
=head1 SYNOPSIS
-Create a schema class called DB/Main.pm:
+Create a schema class called MyDB/Schema.pm:
- package DB::Main;
+ package MyDB::Schema;
use base qw/DBIx::Class::Schema/;
__PACKAGE__->load_classes();
1;
-Create a table class to represent artists, who have many CDs, in DB/Main/Artist.pm:
+Create a table class to represent artists, who have many CDs, in
+MyDB/Schema/Artist.pm:
- package DB::Main::Artist;
+ package MyDB::Schema::Artist;
use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/ artistid name /);
__PACKAGE__->set_primary_key('artistid');
- __PACKAGE__->has_many(cds => 'DB::Main::CD');
+ __PACKAGE__->has_many(cds => 'MyDB::Schema::CD');
1;
-A table class to represent a CD, which belongs to an artist, in DB/Main/CD.pm:
+A table class to represent a CD, which belongs to an artist, in
+MyDB/Schema/CD.pm:
- package DB::Main::CD;
+ package MyDB::Schema::CD;
use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('cd');
- __PACKAGE__->add_columns(qw/ cdid artist title year /);
+ __PACKAGE__->add_columns(qw/ cdid artistid title year /);
__PACKAGE__->set_primary_key('cdid');
- __PACKAGE__->belongs_to(artist => 'DB::Main::Artist');
+ __PACKAGE__->belongs_to(artist => 'MyDB::Schema::Artist', 'artistid');
1;
Then you can use these classes in your application's code:
# Connect to your database.
- use DB::Main;
- my $schema = DB::Main->connect($dbi_dsn, $user, $pass, \%dbi_params);
+ use MyDB::Schema;
+ my $schema = MyDB::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.
{ order_by => 'title' }
);
- # Create a result set that will fetch the artist relationship
+ # Create a result set that will fetch the artist data
# at the same time as it fetches CDs, using only one query.
my $millennium_cds_rs = $schema->resultset('CD')->search(
{ year => 2000 },
);
my $cd = $millennium_cds_rs->next; # SELECT ... FROM cds JOIN artists ...
- my $cd_artist_name = $cd->artist->name; # Already has the data so no query
+ my $cd_artist_name = $cd->artist->name; # Already has the data so no 2nd query
+ # new() makes a DBIx::Class::Row object but doesnt insert it into the DB.
+ # create() is the same as new() then insert().
my $new_cd = $schema->resultset('CD')->new({ title => 'Spoon' });
$new_cd->artist($cd->artist);
$new_cd->insert; # Auto-increment primary key filled in after INSERT
$schema->txn_do(sub { $new_cd->update }); # Runs the update in a transaction
- $millennium_cds_rs->update({ year => 2002 }); # Single-query bulk update
+ # change the year of all the millennium CDs at once
+ $millennium_cds_rs->update({ year => 2002 });
=head1 DESCRIPTION
This is an SQL to OO mapper with an object API inspired by L<Class::DBI>
-(and a compatibility layer as a springboard for porting) and a resultset API
+(with a compatibility layer as a springboard for porting) and a resultset API
that allows abstract encapsulation of database operations. It aims to make
representing queries in your code as perl-ish as possible while still
providing access to as many of the capabilities of the database as possible,
including retrieving related records from multiple tables in a single query,
-JOIN, LEFT JOIN, COUNT, DISTINCT, GROUP BY and HAVING support.
+JOIN, LEFT JOIN, COUNT, DISTINCT, GROUP BY, ORDER BY and HAVING support.
DBIx::Class can handle multi-column primary and foreign keys, complex
queries and database-level paging, and does its best to only query the
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).
-This project is still under rapid development, so features added in the
-latest major release may not work 100% yet -- check the Changes if you run
-into trouble, and beware of anything explicitly marked EXPERIMENTAL. Failing
-test cases are *always* welcome and point releases are put out rapidly as
-bugs are found and fixed.
+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.
+Failing test cases are *always* welcome and point releases are put out rapidly
+as bugs are found and fixed.
-Even so, we do our best to maintain full backwards compatibility for published
-APIs, since DBIx::Class is used in production in a number of organisations.
-The test suite is quite substantial, and several developer releases are
-generally made to CPAN before the -current branch is merged back to trunk for
-a major release.
-
-The community can be found via:
+We do our best to maintain full backwards compatibility for published
+APIs, since DBIx::Class is used in production in many organisations,
+and even backwards incompatible changes to non-published APIs will be fixed
+if they're reported and doing so doesn't cost the codebase anything.
- Mailing list: http://lists.rawmode.org/mailman/listinfo/dbix-class/
-
- SVN: http://dev.catalyst.perl.org/repos/bast/trunk/DBIx-Class/
-
- Wiki: http://dbix-class.shadowcatsystems.co.uk/
-
- IRC: irc.perl.org#dbix-class
+The test suite is quite substantial, and several developer releases
+are generally made to CPAN before the branch for the next release is
+merged back to trunk for a major release.
=head1 WHERE TO GO NEXT
mst: Matt S. Trout <mst@shadowcatsystems.co.uk>
+(I mostly consider myself "project founder" these days but the AUTHOR heading
+is traditional :)
+
=head1 CONTRIBUTORS
abraxxa: Alexander Hartmaier <alex_hartmaier@hotmail.com>
+aherzog: Adam Herzog <adam@herzogdesigns.com>
+
andyg: Andy Grundman <andy@hybridized.org>
ank: Andres Kievsky
ash: Ash Berlin <ash@cpan.org>
+bert: Norbert Csongradi <bert@cpan.org>
+
blblack: Brandon L. Black <blblack@gmail.com>
bluefeet: Aran Deltac <bluefeet@cpan.org>
+bricas: Brian Cassidy <bricas@cpan.org>
+
captainL: Luke Saunders <luke.saunders@gmail.com>
castaway: Jess Robinson
clkao: CL Kao
+da5id: David Jack Olrik <djo@cpan.org>
+
+debolaz: Anders Nor Berle <berle@cpan.org>
+
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
-draven: Marcus Ramberg <mramberg@cpan.org>
+dnm: Justin Wheeler <jwheeler@datademons.com>
dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
jguenther: Justin Guenther <jguenther@cpan.org>
+jnapiorkowski: John Napiorkowski <jjn1056@yahoo.com>
+
+jon: Jon Schutz <jjschutz@cpan.org>
+
+jshirley: J. Shirley <jshirley@gmail.com>
+
konobi: Scott McWhirter
-LTJake: Brian Cassidy <bricas@cpan.org>
+marcus: Marcus Ramberg <mramberg@cpan.org>
+
+mattlaw: Matt Lawrence
+
+ned: Neil de Carteret
nigel: Nigel Metheringham <nigelm@cpan.org>
Numa: Dan Sully <daniel@cpan.org>
+oyse: Øystein Torget <oystein.torget@dnv.com>
+
paulm: Paul Makepeace
penguin: K J Cheetham
+perigrin: Chris Prather <chris@prather.org>
+
phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
quicksilver: Jules Bean
+rdj: Ryan D Johnson <ryan@innerfence.com>
+
sc_: Just Another Perl Hacker
scotty: Scotty Allen <scotty@scottyallen.com>
+semifor: Marc Mims <marc@questright.com>
+
sszabo: Stephan Szabo <sszabo@bigpanda.com>
+teejay : Aaron Trevena <teejay@cpan.org>
+
Todd Lipcon
+Tom Hukins
+
typester: Daisuke Murase <typester@cpan.org>
+victori: Victor Igumnov <victori@cpan.org>
+
wdh: Will Hawes
willert: Sebastian Willert <willert@cpan.org>
--- /dev/null
+package DBIx::Class::AccessorGroup;
+
+use strict;
+use warnings;
+
+use base qw/Class::Accessor::Grouped/;
+
+1;
+
+=head1 NAME
+
+DBIx::Class::AccessorGroup - See Class::Accessor::Grouped
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This class now exists in its own right on CPAN as Class::Accessor::Grouped
+
+1;
+
+=head1 AUTHORS
+
+Matt S. Trout <mst@shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
use base qw/DBIx::Class::Core DBIx::Class::DB/;
use Carp::Clan qw/^DBIx::Class/;
-eval {
- require Class::Trigger;
- require DBIx::ContextualFetch;
-};
-croak "Class::Trigger and DBIx::ContextualFetch is required for CDBICompat" if $@;
+# Modules CDBICompat needs that DBIx::Class does not.
+my @Extra_Modules = qw(
+ Class::Trigger
+ DBIx::ContextualFetch
+ Clone
+);
+
+my @didnt_load;
+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")
+ if @didnt_load;
+
__PACKAGE__->load_own_components(qw/
Constraints
Triggers
ReadOnly
- GetSet
LiveObjectIndex
AttributeAPI
Stringify
Constructor
AccessorMapping
ColumnCase
- HasA
- HasMany
- MightHave
+ Relationships
+ Copy
LazyLoading
AutoUpdate
TempColumns
+ GetSet
Retrieve
Pager
ColumnGroups
- ImaDBI/);
+ ColumnsAsHash
+ AbstractSearch
+ ImaDBI
+ Iterator
+/);
#DBIx::Class::ObjIndexStubs
1;
=head1 SYNOPSIS
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/CDBICompat Core DB/);
+ package My::CDBI;
+ use base qw/DBIx::Class::CDBICompat/;
+
+ ...continue as Class::DBI...
=head1 DESCRIPTION
DBIx::Class features a fully featured compatibility layer with L<Class::DBI>
-to ease transition for existing CDBI users. In fact, this class is just a
-receipe containing all the features emulated. If you like, you can choose
-which features to emulate by building your own class and loading it like
-this:
+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 Plugins
+
+CDBICompat is good enough that many CDBI plugins will work with CDBICompat, but many of the plugin features are better done with DBIx::Class methods.
+
+=head3 Class::DBI::AbstractSearch
+
+C<search_where()> is fully emulated using DBIC's search. Aside from emulation there's no reason to use C<search_where()>.
+
+=head3 Class::DBI::Plugin::NoCache
+
+C<nocache> is fully emulated.
+
+=head3 Class::DBI::Sweet
+The features of CDBI::Sweet are better done using DBIC methods which are almost exactly the same. It even uses L<Data::Page>.
+
+=head3 Class::DBI::Plugin::DeepAbstractSearch
+
+This plugin will work, but it is more efficiently done using DBIC's native search facilities. The major difference is that DBIC will not infer the join for you, you have to tell it the join tables.
+
+
+=head2 Choosing Features
+
+In fact, this class is just a receipe containing all the features emulated.
+If you like, you can choose which features to emulate by building your
+own class and loading it like this:
+
+ package My::DB;
__PACKAGE__->load_own_components(qw/CDBICompat/);
this will automatically load the features included in My::DB::CDBICompat,
CDBICompat::MightHave
/);
-=head1 COMPONENTS
-=over 4
+=head1 LIMITATIONS
-=item AccessorMapping
+=head2 Unimplemented
-=item AttributeAPI
+The following methods and classes are not emulated, maybe in the future.
-=item AutoUpdate
-
-Allows you to turn on automatic updates for column values.
-
-=item ColumnCase
-
-=item ColumnGroups
+=over 4
-=item Constraints
+=item Class::DBI::Query
-=item Constructor
+Deprecated in Class::DBI.
-=item DestroyWarning
+=item Class::DBI::Column
-=item GetSet
+Not documented in Class::DBI. CDBICompat's columns() returns a plain string, not an object.
-=item HasA
+=item data_type()
-=item HasMany
+Undocumented CDBI method.
-=item ImaDBI
+=back
-=item LazyLoading
+=head2 Limited Support
-=item LiveObjectIndex
+The following elements of Class::DBI have limited support.
-The live object index tries to ensure there is only one version of a object
-in the perl interpreter.
+=over 4
-=item MightHave
+=item Class::DBI::Relationship
-=item ObjIndexStubs
+The semi-documented Class::DBI::Relationship objects returned by C<meta_info($type, $col)> are mostly emulated except for their C<args> method.
-=item ReadOnly
+=item Relationships
-=item Retrieve
+Relationships between tables (has_a, has_many...) must be delcared after all tables in the relationship have been declared. Thus the usual CDBI idiom of declaring columns and relationships for each class together will not work. They must instead be done like so:
-=item Stringify
+ package Foo;
+ use base qw(Class::DBI);
+
+ Foo->table("foo");
+ Foo->columns( All => qw(this that bar) );
-=item TempColumns
+ package Bar;
+ use base qw(Class::DBI);
+
+ Bar->table("bar");
+ Bar->columns( All => qw(up down) );
-=item Triggers
+ # Now that Foo and Bar are declared it is safe to declare a
+ # relationship between them
+ Foo->has_a( bar => "Bar" );
-=item PassThrough
=back
--- /dev/null
+package # hide form PAUSE
+ DBIx::Class::CDBICompat::AbstractSearch;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::AbstractSearch
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates L<Class::DBI::AbstractSearch>.
+
+=cut
+
+# The keys are mostly the same.
+my %cdbi2dbix = (
+ limit => 'rows',
+);
+
+sub search_where {
+ my $class = shift;
+ my $where = (ref $_[0]) ? $_[0] : { @_ };
+ my $attr = (ref $_[0]) ? $_[1] : {};
+
+ # Translate the keys
+ $attr->{$cdbi2dbix{$_}} = delete $attr->{$_} for keys %cdbi2dbix;
+
+ return $class->resultset_instance->search($where, $attr);
+}
+
+1;
sub mk_group_accessors {
my ($class, $group, @cols) = @_;
- unless ($class->can('accessor_name') || $class->can('mutator_name')) {
- return $class->next::method($group => @cols);
- }
+
foreach my $col (@cols) {
- my $ro_meth = ($class->can('accessor_name')
- ? $class->accessor_name($col)
- : $col);
- my $wo_meth = ($class->can('mutator_name')
- ? $class->mutator_name($col)
- : $col);
- #warn "$col $ro_meth $wo_meth";
- if ($ro_meth eq $wo_meth) {
+ my $ro_meth = $class->accessor_name_for($col);
+ my $wo_meth = $class->mutator_name_for($col);
+
+ # warn "class: $class / col: $col / ro: $ro_meth / wo: $wo_meth\n";
+ if ($ro_meth eq $wo_meth or # they're the same
+ $wo_meth eq $col) # or only the accessor is custom
+ {
$class->next::method($group => [ $ro_meth => $col ]);
} else {
$class->mk_group_ro_accessors($group => [ $ro_meth => $col ]);
}
}
+
+sub accessor_name_for {
+ my ($class, $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)
+ }
+
+ return $column;
+}
+
+
sub new {
my ($class, $attrs, @rest) = @_;
$class->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH';
foreach my $col ($class->columns) {
- if ($class->can('accessor_name')) {
- my $acc = $class->accessor_name($col);
+ my $acc = $class->accessor_name_for($col);
$attrs->{$col} = delete $attrs->{$acc} if exists $attrs->{$acc};
- }
- if ($class->can('mutator_name')) {
- my $mut = $class->mutator_name($col);
+
+ my $mut = $class->mutator_name_for($col);
$attrs->{$col} = delete $attrs->{$mut} if exists $attrs->{$mut};
- }
}
return $class->next::method($attrs, @rest);
}
sub add_columns {
my ($class, @cols) = @_;
- $class->mk_group_accessors(column => @cols);
- $class->result_source_instance->add_columns(map lc, @cols);
+ return $class->result_source_instance->add_columns(map lc, @cols);
}
sub has_a {
- my ($class, $col, @rest) = @_;
- $class->next::method(lc($col), @rest);
- $class->mk_group_accessors('inflated_column' => $col);
- return 1;
+ my($self, $col, @rest) = @_;
+
+ $self->_declare_has_a(lc $col, @rest);
+ $self->_mk_inflated_column_accessor($col);
+
+ return 1;
}
sub has_many {
return \%new_query;
}
-sub _mk_group_accessors {
- my ($class, $type, $group, @fields) = @_;
- #warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields);
- my @extra;
- foreach (@fields) {
- my ($acc, $field) = ref $_ ? @$_ : ($_, $_);
- #warn "$acc ".lc($acc)." $field";
- next if defined &{"${class}::${acc}"};
- push(@extra, [ lc $acc => $field ]);
- }
- return $class->next::method($type, $group,
- @fields, @extra);
+sub _deploy_accessor {
+ my($class, $name, $accessor) = @_;
+
+ return if $class->_has_custom_accessor($name);
+
+ $class->next::method(lc $name => $accessor);
+ return $class->next::method($name => $accessor);
}
+
sub new {
my ($class, $attrs, @rest) = @_;
my %att;
use strict;
use warnings;
+use Storable 'dclone';
+
use base qw/DBIx::Class::Row/;
__PACKAGE__->mk_classdata('_column_groups' => { });
my $proto = shift;
my $class = ref $proto || $proto;
my $group = shift || "All";
+ $class->_init_result_source_instance();
+
$class->_add_column_group($group => @_) if @_;
return $class->all_columns if $group eq "All";
return $class->primary_column if $group eq "Primary";
sub _add_column_group {
my ($class, $group, @cols) = @_;
+ $class->mk_group_accessors(column => @cols);
$class->add_columns(@cols);
$class->_register_column_group($group => @cols);
}
+sub add_columns {
+ my ($class, @cols) = @_;
+ $class->result_source_instance->add_columns(@cols);
+}
+
sub _register_column_group {
my ($class, $group, @cols) = @_;
- my $groups = { %{$class->_column_groups} };
+ # Must do a complete deep copy else column groups
+ # might accidentally be shared.
+ my $groups = dclone $class->_column_groups;
if ($group eq 'Primary') {
$class->set_primary_key(@cols);
- $groups->{'Essential'}{$_} ||= {} for @cols;
+ $groups->{'Essential'}{$_} ||= 1 for @cols;
}
if ($group eq 'All') {
unless (exists $class->_column_groups->{'Primary'}) {
- $groups->{'Primary'}{$cols[0]} = {};
+ $groups->{'Primary'}{$cols[0]} = 1;
$class->set_primary_key($cols[0]);
}
unless (exists $class->_column_groups->{'Essential'}) {
- $groups->{'Essential'}{$cols[0]} = {};
+ $groups->{'Essential'}{$cols[0]} = 1;
}
}
- $groups->{$group}{$_} ||= {} for @cols;
+ $groups->{$group}{$_} ||= 1 for @cols;
$class->_column_groups($groups);
}
+# CDBI will never overwrite an accessor, but it only uses one
+# accessor for all column types. DBIC uses many different
+# accessor types so, for example, if you declare a column()
+# and then a has_a() for that same column it must overwrite.
+#
+# To make this work CDBICompat has decide if an accessor
+# method was put there by itself and only then overwrite.
+{
+ my %our_accessors;
+
+ sub _has_custom_accessor {
+ my($class, $name) = @_;
+
+ no strict 'refs';
+ my $existing_accessor = *{$class .'::'. $name}{CODE};
+ return $existing_accessor && !$our_accessors{$existing_accessor};
+ }
+
+ sub _deploy_accessor {
+ my($class, $name, $accessor) = @_;
+
+ return if $class->_has_custom_accessor($name);
+
+ {
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$class .'::'. $name} = $accessor;
+ }
+
+ $our_accessors{$accessor}++;
+
+ return 1;
+ }
+}
+
+sub _mk_group_accessors {
+ my ($class, $type, $group, @fields) = @_;
+
+ # So we don't have to do lots of lookups inside the loop.
+ my $maker = $class->can($type) unless ref $type;
+
+ # warn "$class $type $group\n";
+ foreach my $field (@fields) {
+ if( $field eq 'DESTROY' ) {
+ carp("Having a data accessor named DESTROY in ".
+ "'$class' is unwise.");
+ }
+
+ my $name = $field;
+
+ ($name, $field) = @$field if ref $field;
+
+ my $accessor = $class->$maker($group, $field);
+ my $alias = "_${name}_accessor";
+
+ # warn " $field $alias\n";
+ {
+ no strict 'refs';
+
+ $class->_deploy_accessor($name, $accessor);
+ $class->_deploy_accessor($alias, $accessor);
+ }
+ }
+}
+
sub all_columns { return shift->result_source_instance->columns; }
sub primary_column {
return wantarray ? @pri : $pri[0];
}
+sub _essential {
+ return shift->columns("Essential");
+}
+
sub find_column {
my ($class, $col) = @_;
return $col if $class->has_column($col);
--- /dev/null
+package
+ DBIx::Class::CDBICompat::ColumnsAsHash;
+
+use strict;
+use warnings;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::ColumnsAsHash
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates the I<undocumnted> behavior of Class::DBI where the object can be accessed as a hash of columns. This is often used as a performance hack.
+
+ my $column = $row->{column};
+
+=head2 Differences from Class::DBI
+
+If C<DBIC_CDBICOMPAT_HASH_WARN> is true it will warn when a column is accessed as a hash key.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ my $new = $class->next::method(@_);
+
+ $new->_make_columns_as_hash;
+
+ return $new;
+}
+
+sub inflate_result {
+ my $class = shift;
+
+ my $new = $class->next::method(@_);
+
+ $new->_make_columns_as_hash;
+
+ return $new;
+}
+
+
+sub _make_columns_as_hash {
+ my $self = shift;
+
+ for my $col ($self->columns) {
+ if( exists $self->{$col} ) {
+ warn "Skipping mapping $col to a hash key because it exists";
+ }
+
+ tie $self->{$col}, 'DBIx::Class::CDBICompat::Tied::ColumnValue',
+ $self, $col;
+ }
+}
+
+
+package DBIx::Class::CDBICompat::Tied::ColumnValue;
+
+use Carp;
+use Scalar::Util qw(weaken isweak);
+
+
+sub TIESCALAR {
+ my($class, $obj, $col) = @_;
+ my $self = [$obj, $col];
+ weaken $self->[0];
+
+ return bless $self, $_[0];
+}
+
+sub FETCH {
+ my $self = shift;
+ my($obj, $col) = @$self;
+
+ my $class = ref $obj;
+ my $id = $obj->id;
+ carp "Column '$col' of '$class/$id' was fetched as a hash"
+ if $ENV{DBIC_CDBICOMPAT_HASH_WARN};
+
+ return $obj->column_info($col)->{_inflate_info}
+ ? $obj->get_inflated_column($col)
+ : $obj->get_column($col);
+}
+
+sub STORE {
+ my $self = shift;
+ my($obj, $col) = @$self;
+
+ my $class = ref $obj;
+ my $id = $obj->id;
+ carp "Column '$col' of '$class/$id' was stored as a hash"
+ if $ENV{DBIC_CDBICOMPAT_HASH_WARN};
+
+ return $obj->column_info($col)->{_inflate_info}
+ ? $obj->set_inflated_column($col => shift)
+ : $obj->set_column($col => shift);
+}
+
+1;
package # hide from PAUSE
DBIx::Class::CDBICompat::Constructor;
+use base qw(DBIx::Class::CDBICompat::ImaDBI);
+
use strict;
use warnings;
+use Carp;
+
+__PACKAGE__->set_sql(Retrieve => <<'');
+SELECT __ESSENTIAL__
+FROM __TABLE__
+WHERE %s
+
sub add_constructor {
- my ($class, $meth, $sql) = @_;
- $class = ref $class if ref $class;
- no strict 'refs';
- *{"${class}::${meth}"} =
- sub {
- my ($class, @args) = @_;
- return $class->search_literal($sql, @args);
+ my ($class, $method, $fragment) = @_;
+ return croak("constructors needs a name") unless $method;
+
+ no strict 'refs';
+ my $meth = "$class\::$method";
+ return carp("$method already exists in $class")
+ if *$meth{CODE};
+
+ *$meth = sub {
+ my $self = shift;
+ $self->sth_to_objects($self->sql_Retrieve($fragment), \@_);
};
}
--- /dev/null
+package # hide from PAUSE
+ DBIx::Class::CDBICompat::Copy;
+
+use strict;
+use warnings;
+
+use Carp;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Copy
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates C<<Class::DBI->copy($new_id)>>.
+
+=cut
+
+
+# CDBI's copy will take an id in addition to a hash ref.
+sub copy {
+ my($self, $arg) = @_;
+ return $self->next::method($arg) if ref $arg;
+
+ my @primary_columns = $self->primary_columns;
+ croak("Need hash-ref to edit copied column values")
+ if @primary_columns > 1;
+
+ return $self->next::method({ $primary_columns[0] => $arg });
+}
+
+1;
}
sub set {
- return shift->set_column(@_);
+ my($self, %data) = @_;
+
+ # set_columns() is going to do a string comparison before setting.
+ # This breaks on DateTime objects (whose comparison is arguably broken)
+ # so we stringify anything first.
+ for my $key (keys %data) {
+ next unless ref $data{$key};
+ $data{$key} = "$data{$key}";
+ }
+
+ return shift->set_columns(\%data);
}
1;
+++ /dev/null
-package # hide from PAUSE
- DBIx::Class::CDBICompat::HasA;
-
-use strict;
-use warnings;
-
-sub has_a {
- my ($self, $col, $f_class, %args) = @_;
- $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col);
- $self->ensure_class_loaded($f_class);
- if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
- if (!ref $args{'inflate'}) {
- my $meth = $args{'inflate'};
- $args{'inflate'} = sub { $f_class->$meth(shift); };
- }
- if (!ref $args{'deflate'}) {
- my $meth = $args{'deflate'};
- $args{'deflate'} = sub { shift->$meth; };
- }
- $self->inflate_column($col, \%args);
- return 1;
- }
-
- $self->belongs_to($col, $f_class);
- return 1;
-}
-
-sub search {
- my $self = shift;
- my $attrs = {};
- if (@_ > 1 && ref $_[$#_] eq 'HASH') {
- $attrs = { %{ pop(@_) } };
- }
- my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
- : {@_})
- : undef());
- if (ref $where eq 'HASH') {
- foreach my $key (keys %$where) { # has_a deflation hack
- $where->{$key} = ''.$where->{$key}
- if eval { $where->{$key}->isa('DBIx::Class') };
- }
- }
- $self->next::method($where, $attrs);
-}
-
-1;
+++ /dev/null
-package # hide from PAUSE
- DBIx::Class::CDBICompat::HasMany;
-
-use strict;
-use warnings;
-
-sub has_many {
- my ($class, $rel, $f_class, $f_key, $args) = @_;
-
- my @f_method;
-
- if (ref $f_class eq 'ARRAY') {
- ($f_class, @f_method) = @$f_class;
- }
-
- if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
-
- $args ||= {};
- if (delete $args->{no_cascade_delete}) {
- $args->{cascade_delete} = 0;
- }
-
- $class->next::method($rel, $f_class, $f_key, $args);
-
- if (@f_method) {
- no strict 'refs';
- no warnings 'redefine';
- my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
- *{"${class}::${rel}"} =
- sub {
- my $rs = shift->search_related($rel => @_);
- $rs->{attrs}{record_filter} = $post_proc;
- return (wantarray ? $rs->all : $rs);
- };
- return 1;
- }
-
-}
-
-1;
use base qw/DBIx::Class/;
+__PACKAGE__->mk_classdata('sql_transformer_class' =>
+ 'DBIx::Class::CDBICompat::SQLTransformer');
+
__PACKAGE__->mk_classdata('_transform_sql_handler_order'
- => [ qw/TABLE ESSENTIAL JOIN/ ] );
+ => [ qw/TABLE ESSENTIAL JOIN IDENTIFIER/ ] );
__PACKAGE__->mk_classdata('_transform_sql_handlers' =>
{
'ESSENTIAL' =>
sub {
my ($self, $class, $data) = @_;
- return join(' ', $class->columns('Essential')) unless $data;
- return join(' ', $self->{_classes}{$data}->columns('Essential'));
+ $class = $data ? $self->{_classes}{$data} : $class;
+ return join(', ', $class->columns('Essential'));
+ },
+ 'IDENTIFIER' =>
+ sub {
+ my ($self, $class, $data) = @_;
+ $class = $data ? $self->{_classes}{$data} : $class;
+ return join ' AND ', map "$_ = ?", $class->primary_columns;
},
'JOIN' =>
sub {
sub {
my ($class, @args) = @_;
my $sth = $class->$meth;
- $sth->execute(@args);
- return $class->sth_to_objects($sth);
+ return $class->sth_to_objects($sth, \@args);
};
}
}
sub sth_to_objects {
- my ($class, $sth) = @_;
+ my ($class, $sth, $execute_args) = @_;
+
+ $sth->execute(@$execute_args);
+
my @ret;
while (my $row = $sth->fetchrow_hashref) {
push(@ret, $class->inflate_result($class->result_source_instance, $row));
}
+
return @ret;
}
sub transform_sql {
my ($class, $sql, @args) = @_;
- my $attrs = { };
- foreach my $key (@{$class->_transform_sql_handler_order}) {
- my $h = $class->_transform_sql_handlers->{$key};
- $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg;
- }
- #warn $sql;
- return sprintf($sql, @args);
+
+ my $tclass = $class->sql_transformer_class;
+ $class->ensure_class_loaded($tclass);
+ my $t = $tclass->new($class, $sql, @args);
+
+ return sprintf($t->sql, $t->args);
}
-package DBIx::ContextualFetch::st;
+package
+ DBIx::ContextualFetch::st; # HIDE FROM PAUSE THIS IS NOT OUR CLASS
no warnings 'redefine';
--- /dev/null
+package DBIx::Class::CDBICompat::Iterator;
+
+use strict;
+use warnings;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Iterator
+
+=head1 SYNOPSIS
+
+See DBIx::Class::CDBICompat for directions for use.
+
+=head1 DESCRIPTION
+
+Emulates the extra behaviors of the Class::DBI search iterator.
+
+=head2 Differences from DBIx::Class result set
+
+The CDBI iterator returns true if there were any results, false otherwise. The DBIC result set always returns true.
+
+=cut
+
+
+sub _init_result_source_instance {
+ my $class = shift;
+
+ my $table = $class->next::method(@_);
+ $table->resultset_class("DBIx::Class::CDBICompat::Iterator::ResultSet");
+
+ return $table;
+}
+
+
+
+package DBIx::Class::CDBICompat::Iterator::ResultSet;
+
+use strict;
+use warnings;
+
+use base qw(DBIx::Class::ResultSet);
+
+sub _bool {
+ # Performance hack so internal checks whether the result set
+ # exists won't do a SQL COUNT.
+ return 1 if caller =~ /^DBIx::Class::/;
+
+ return $_[0]->count;
+}
+
+1;
return $rs;
}
+
+# 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;
+
+ my @dirty_columns = keys %{$self->{_dirty_columns}};
+
+ my $ret = $self->next::method(@_);
+ $self->_clear_column_data(@dirty_columns);
+
+ return $ret;
+}
+
+
+# And again for create
+sub create {
+ my $class = shift;
+ my($data) = @_;
+
+ my @columns = keys %$data;
+
+ my $obj = $class->next::method(@_);
+ return $obj unless defined $obj;
+
+ my %primary_cols = map { $_ => 1 } $class->primary_columns;
+ my @data_cols = grep !$primary_cols{$_}, @columns;
+ $obj->_clear_column_data(@data_cols);
+
+ return $obj;
+}
+
+
+sub _clear_column_data {
+ my $self = shift;
+
+ delete $self->{_column_data}{$_} for @_;
+ delete $self->{_inflated_column}{$_} for @_;
+}
+
+
sub get_column {
my ($self, $col) = @_;
if ((ref $self) && (!exists $self->{'_column_data'}{$col})
$self->next::method(@_[1..$#_]);
}
+# CDBI does not explicitly declare auto increment columns, so
+# we just clear out our primary columns before copying.
+sub copy {
+ my($self, $changes) = @_;
+
+ for my $col ($self->primary_columns) {
+ $changes->{$col} = undef unless exists $changes->{$col};
+ }
+
+ return $self->next::method($changes);
+}
+
+sub discard_changes {
+ my($self) = shift;
+
+ delete $self->{_column_data}{$_} for $self->is_changed;
+ delete $self->{_dirty_columns};
+ delete $self->{_relationship_data};
+
+ return $self;
+}
+
sub _ident_cond {
my ($class) = @_;
return join(" AND ", map { "$_ = ?" } $class->primary_columns);
# $self->ident_condition);
# Not sure why the first one works and this doesn't :(
my @val = $cursor->next;
-#warn "Flesh: ".join(', ', @want, '=>', @val);
+
+ return unless @val; # object must have been deleted from the database
+
foreach my $w (@want) {
$self->{'_column_data'}{$w} = shift @val;
}
__PACKAGE__->mk_classdata('live_object_index' => { });
__PACKAGE__->mk_classdata('live_object_init_count' => { });
+# Caching is on by default, but a classic CDBI hack to turn it off is to
+# set this variable false.
+$Class::DBI::Weaken_Is_Available = 1
+ unless defined $Class::DBI::Weaken_Is_Available;
+__PACKAGE__->mk_classdata('__nocache' => 0);
+
+sub nocache {
+ my $class = shift;
+
+ return $class->__nocache(@_) if @_;
+
+ return 1 if $Class::DBI::Weaken_Is_Available == 0;
+ return $class->__nocache;
+}
+
# Ripped from Class::DBI 0.999, all credit due to Tony Bowden for this code,
# all blame due to me for whatever bugs I introduced porting it.
delete @$live{ keys %$live };
}
+
# And now the fragments to tie it in to DBIx::Class::Table
sub insert {
my ($self, @rest) = @_;
$self->next::method(@rest);
+
+ return $self if $self->nocache;
+
# Because the insert will die() if it can't insert into the db (or should)
# we can be sure the object *was* inserted if we got this far. In which
# case, given primary keys are unique and ID only returns a
sub inflate_result {
my ($class, @rest) = @_;
my $new = $class->next::method(@rest);
+
+ return $new if $new->nocache;
+
if (my $key = $new->ID) {
#warn "Key $key";
my $live = $class->live_object_index;
return $new;
}
-sub discard_changes {
- my ($self) = @_;
- if (my $key = $self->ID) {
- $self->remove_from_object_index;
- my $ret = $self->next::method;
- $self->live_object_index->{$key} = $self if $self->in_storage;
- return $ret;
- } else {
- return $self->next::method;
- }
-}
-
1;
+++ /dev/null
-package # hide from PAUSE
- DBIx::Class::CDBICompat::MightHave;
-
-use strict;
-use warnings;
-
-sub might_have {
- my ($class, $rel, $f_class, @columns) = @_;
- if (ref $columns[0] || !defined $columns[0]) {
- return $class->next::method($rel, $f_class, @columns);
- } else {
- return $class->next::method($rel, $f_class, undef,
- { proxy => \@columns });
- }
-}
-
-1;
--- /dev/null
+package # hide from PAUSE
+ DBIx::Class::CDBICompat::NoObjectIndex;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::NoObjectIndex
+
+=head1 SYNOPSIS
+
+ Part of CDBICompat
+
+=head1 DESCRIPTION
+
+Defines empty methods for object indexing. They do nothing.
+
+Using NoObjectIndex instead of LiveObjectIndex and nocache(1) is a little
+faster because it removes code from the object insert and retrieve chains.
+
+=cut
+
+sub nocache { return 1 }
+
+sub purge_object_index_every {}
+
+sub purge_dead_from_object_index {}
+
+sub remove_from_object_index {}
+
+sub clear_object_index {}
+
+1;
+++ /dev/null
-package # hide from PAUSE
- DBIx::Class::CDBICompat::ObjIndexStubs;
-
-use strict;
-use warnings;
-
-sub remove_from_object_index { }
-
-sub clear_object_index { }
-
-1;
--- /dev/null
+package
+ DBIx::Class::CDBICompat::Relationship;
+
+use strict;
+use warnings;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Relationship
+
+=head1 DESCRIPTION
+
+Emulate the Class::DBI::Relationship object returned from C<meta_info()>.
+
+=cut
+
+my %method2key = (
+ name => 'type',
+ class => 'self_class',
+ accessor => 'accessor',
+ foreign_class => 'class',
+ args => 'args',
+);
+
+sub new {
+ my($class, $args) = @_;
+
+ return bless $args, $class;
+}
+
+for my $method (keys %method2key) {
+ my $key = $method2key{$method};
+ my $code = sub {
+ $_[0]->{$key};
+ };
+
+ no strict 'refs';
+ *{$method} = $code;
+}
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBIx::Class::CDBICompat::Relationships;
+
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+use Clone;
+use DBIx::Class::CDBICompat::Relationship;
+
+__PACKAGE__->mk_classdata('__meta_info' => {});
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Relationships
+
+=head1 DESCRIPTION
+
+Emulate C<has_a>, C<has_many>, C<might_have> and C<meta_info>.
+
+=cut
+
+sub has_a {
+ my($self, $col, @rest) = @_;
+
+ $self->_declare_has_a($col, @rest);
+ $self->_mk_inflated_column_accessor($col);
+
+ return 1;
+}
+
+
+sub _declare_has_a {
+ my ($self, $col, $f_class, %args) = @_;
+ $self->throw_exception( "No such column ${col}" )
+ unless $self->has_column($col);
+ $self->ensure_class_loaded($f_class);
+
+ my $rel_info;
+
+ if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
+ if (!ref $args{'inflate'}) {
+ my $meth = $args{'inflate'};
+ $args{'inflate'} = sub { $f_class->$meth(shift); };
+ }
+ if (!ref $args{'deflate'}) {
+ my $meth = $args{'deflate'};
+ $args{'deflate'} = sub { shift->$meth; };
+ }
+ $self->inflate_column($col, \%args);
+
+ $rel_info = {
+ class => $f_class
+ };
+ }
+ else {
+ $self->belongs_to($col, $f_class);
+ $rel_info = $self->result_source_instance->relationship_info($col);
+ }
+
+ $rel_info->{args} = \%args;
+
+ $self->_extend_meta(
+ has_a => $col,
+ $rel_info
+ );
+
+ return 1;
+}
+
+sub _mk_inflated_column_accessor {
+ my($class, $col) = @_;
+
+ return $class->mk_group_accessors('inflated_column' => $col);
+}
+
+sub has_many {
+ my ($class, $rel, $f_class, $f_key, $args) = @_;
+
+ my @f_method;
+
+ if (ref $f_class eq 'ARRAY') {
+ ($f_class, @f_method) = @$f_class;
+ }
+
+ if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
+
+ $args ||= {};
+ my $cascade = delete $args->{cascade} || '';
+ if (delete $args->{no_cascade_delete} || $cascade eq 'None') {
+ $args->{cascade_delete} = 0;
+ }
+ elsif( $cascade eq 'Delete' ) {
+ $args->{cascade_delete} = 1;
+ }
+ elsif( length $cascade ) {
+ warn "Unemulated cascade option '$cascade' in $class->has_many($rel => $f_class)";
+ }
+
+ if( !$f_key and !@f_method ) {
+ $class->ensure_class_loaded($f_class);
+ my $f_source = $f_class->result_source_instance;
+ ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
+ $f_source->relationships;
+ }
+
+ $class->next::method($rel, $f_class, $f_key, $args);
+
+ my $rel_info = $class->result_source_instance->relationship_info($rel);
+ $args->{mapping} = \@f_method;
+ $args->{foreign_key} = $f_key;
+ $rel_info->{args} = $args;
+
+ $class->_extend_meta(
+ has_many => $rel,
+ $rel_info
+ );
+
+ if (@f_method) {
+ no strict 'refs';
+ no warnings 'redefine';
+ my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
+ *{"${class}::${rel}"} =
+ sub {
+ my $rs = shift->search_related($rel => @_);
+ $rs->{attrs}{record_filter} = $post_proc;
+ return (wantarray ? $rs->all : $rs);
+ };
+ return 1;
+ }
+
+}
+
+
+sub might_have {
+ my ($class, $rel, $f_class, @columns) = @_;
+
+ my $ret;
+ if (ref $columns[0] || !defined $columns[0]) {
+ $ret = $class->next::method($rel, $f_class, @columns);
+ } else {
+ $ret = $class->next::method($rel, $f_class, undef,
+ { proxy => \@columns });
+ }
+
+ my $rel_info = $class->result_source_instance->relationship_info($rel);
+ $rel_info->{args}{import} = \@columns;
+
+ $class->_extend_meta(
+ might_have => $rel,
+ $rel_info
+ );
+
+ return $ret;
+}
+
+
+sub _extend_meta {
+ my ($class, $type, $rel, $val) = @_;
+ my %hash = %{ Clone::clone($class->__meta_info || {}) };
+
+ $val->{self_class} = $class;
+ $val->{type} = $type;
+ $val->{accessor} = $rel;
+
+ $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val);
+ $class->__meta_info(\%hash);
+}
+
+
+sub meta_info {
+ my ($class, $type, $rel) = @_;
+ my $meta = $class->__meta_info;
+ return $meta unless $type;
+
+ my $type_meta = $meta->{$type};
+ return $type_meta unless $rel;
+ return $type_meta->{$rel};
+}
+
+
+sub search {
+ my $self = shift;
+ my $attrs = {};
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = { %{ pop(@_) } };
+ }
+ my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
+ : {@_})
+ : undef());
+ if (ref $where eq 'HASH') {
+ foreach my $key (keys %$where) { # has_a deflation hack
+ $where->{$key} = ''.$where->{$key}
+ if eval { $where->{$key}->isa('DBIx::Class') };
+ }
+ }
+ $self->next::method($where, $attrs);
+}
+
+1;
sub retrieve_from_sql {
my ($class, $cond, @rest) = @_;
+
$cond =~ s/^\s*WHERE//i;
- $class->search_literal($cond, @rest);
+
+ if( $cond =~ s/\bLIMIT (\d+)\s*$//i ) {
+ push @rest, { rows => $1 };
+ }
+
+ return $class->search_literal($cond, @rest);
+}
+
+sub construct {
+ my $class = shift;
+ my $obj = $class->resultset_instance->new_result(@_);
+ $obj->in_storage(1);
+
+ return $obj;
}
sub retrieve_all { shift->search }
sub count_all { shift->count }
- # Contributed by Numa. No test for this though.
+
+sub maximum_value_of {
+ my($class, $col) = @_;
+ return $class->resultset_instance->get_column($col)->max;
+}
+
+sub minimum_value_of {
+ my($class, $col) = @_;
+ return $class->resultset_instance->get_column($col)->min;
+}
1;
--- /dev/null
+package DBIx::Class::CDBICompat::SQLTransformer;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::SQLTransformer - Transform SQL
+
+=head1 DESCRIPTION
+
+This is a copy of L<Class::DBI::SQL::Transformer> from Class::DBI 3.0.17.
+It is here so we can be compatible with L<Class::DBI> without having it
+installed.
+
+=cut
+
+sub new {
+ my ($me, $caller, $sql, @args) = @_;
+ bless {
+ _caller => $caller,
+ _sql => $sql,
+ _args => [@args],
+ _transformed => 0,
+ } => $me;
+}
+
+sub sql {
+ my $self = shift;
+ $self->_do_transformation if !$self->{_transformed};
+ return $self->{_transformed_sql};
+}
+
+sub args {
+ my $self = shift;
+ $self->_do_transformation if !$self->{_transformed};
+ return @{ $self->{_transformed_args} };
+}
+
+sub _expand_table {
+ my $self = shift;
+ my ($class, $alias) = split /=/, shift, 2;
+ my $caller = $self->{_caller};
+ my $table = $class ? $class->table : $caller->table;
+ $self->{cmap}{ $alias || $table } = $class || ref $caller || $caller;
+ ($alias ||= "") &&= " $alias";
+ return $table . $alias;
+}
+
+sub _expand_join {
+ my $self = shift;
+ my $joins = shift;
+ my @table = split /\s+/, $joins;
+
+ my $caller = $self->{_caller};
+ my %tojoin = map { $table[$_] => $table[ $_ + 1 ] } 0 .. $#table - 1;
+ my @sql;
+ while (my ($t1, $t2) = each %tojoin) {
+ my ($c1, $c2) = map $self->{cmap}{$_}
+ || $caller->_croak("Don't understand table '$_' in JOIN"), ($t1, $t2);
+
+ my $join_col = sub {
+ my ($c1, $c2) = @_;
+ my $meta = $c1->meta_info('has_a');
+ my ($col) = grep $meta->{$_}->foreign_class eq $c2, keys %$meta;
+ $col;
+ };
+
+ my $col = $join_col->($c1 => $c2) || do {
+ ($c1, $c2) = ($c2, $c1);
+ ($t1, $t2) = ($t2, $t1);
+ $join_col->($c1 => $c2);
+ };
+
+ $caller->_croak("Don't know how to join $c1 to $c2") unless $col;
+ push @sql, sprintf " %s.%s = %s.%s ", $t1, $col, $t2, $c2->primary_column;
+ }
+ return join " AND ", @sql;
+}
+
+sub _do_transformation {
+ my $me = shift;
+ my $sql = $me->{_sql};
+ my @args = @{ $me->{_args} };
+ my $caller = $me->{_caller};
+
+ $sql =~ s/__TABLE\(?(.*?)\)?__/$me->_expand_table($1)/eg;
+ $sql =~ s/__JOIN\((.*?)\)__/$me->_expand_join($1)/eg;
+ $sql =~ s/__ESSENTIAL__/join ", ", $caller->_essential/eg;
+ $sql =~
+ s/__ESSENTIAL\((.*?)\)__/join ", ", map "$1.$_", $caller->_essential/eg;
+ if ($sql =~ /__IDENTIFIER__/) {
+ my $key_sql = join " AND ", map "$_=?", $caller->primary_columns;
+ $sql =~ s/__IDENTIFIER__/$key_sql/g;
+ }
+
+ $me->{_transformed_sql} = $sql;
+ $me->{_transformed_args} = [@args];
+ $me->{_transformed} = 1;
+ return 1;
+}
+
+1;
+
use warnings;
use base qw/DBIx::Class/;
+use Carp;
+
__PACKAGE__->mk_classdata('_temp_columns' => { });
sub _add_column_group {
my ($class, $group, @cols) = @_;
- if ($group eq 'TEMP') {
- $class->_register_column_group($group => @cols);
- $class->mk_group_accessors('temp' => @cols);
- my %tmp = %{$class->_temp_columns};
- $tmp{$_} = 1 for @cols;
- $class->_temp_columns(\%tmp);
- } else {
- return $class->next::method($group, @cols);
+
+ return $class->next::method($group, @cols) unless $group eq 'TEMP';
+
+ my %new_cols = map { $_ => 1 } @cols;
+ my %tmp_cols = %{$class->_temp_columns};
+
+ for my $existing_col ( grep $new_cols{$_}, $class->columns ) {
+ # Already been declared TEMP
+ next if $tmp_cols{$existing_col};
+
+ carp "Declaring column $existing_col as TEMP but it already exists";
}
+
+ $class->_register_column_group($group => @cols);
+ $class->mk_group_accessors('temp' => @cols);
+
+ $class->_temp_columns({ %tmp_cols, %new_cols });
}
sub new {
my ($class, $attrs, @rest) = @_;
- my %temp;
- foreach my $key (keys %$attrs) {
- $temp{$key} = delete $attrs->{$key} if $class->_temp_columns->{$key};
- }
+
+ my $temp = $class->_extract_temp_data($attrs);
+
my $new = $class->next::method($attrs, @rest);
- foreach my $key (keys %temp) {
- $new->set_temp($key, $temp{$key});
- }
+
+ $new->set_temp($_, $temp->{$_}) for keys %$temp;
+
return $new;
}
+sub _extract_temp_data {
+ my($self, $data) = @_;
+
+ my %temp;
+ foreach my $key (keys %$data) {
+ $temp{$key} = delete $data->{$key} if $self->_temp_columns->{$key};
+ }
+
+ return \%temp;
+}
sub find_column {
my ($class, $col, @rest) = @_;
return $class->next::method($col, @rest);
}
+sub set {
+ my($self, %data) = @_;
+
+ my $temp_data = $self->_extract_temp_data(\%data);
+
+ $self->set_temp($_, $temp_data->{$_}) for keys %$temp_data;
+
+ return $self->next::method(%data);
+}
+
sub get_temp {
my ($self, $column) = @_;
$self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
sub insert {
my $self = shift;
+
+ return $self->create(@_) unless ref $self;
+
$self->call_trigger('before_create');
$self->next::method(@_);
$self->call_trigger('after_create');
use strict;
use warnings;
-use Class::C3;
-use Class::Inspector;
+use base 'Class::C3::Componentised';
use Carp::Clan qw/^DBIx::Class/;
sub inject_base {
}
}
- # Yes, this is hack. But it *does* work. Please don't submit tickets about
- # it on the basis of the comments in Class::C3, the author was on #dbix-class
- # while I was implementing this.
-
- my $table = { Class::C3::_dump_MRO_table };
- eval "package $target; import Class::C3;" unless exists $table->{$target};
-}
-
-sub load_components {
- my $class = shift;
- my $base = $class->component_base_class;
- my @comp = map { /^\+(.*)$/ ? $1 : "${base}::$_" } grep { $_ !~ /^#/ } @_;
- $class->_load_components(@comp);
- Class::C3::reinitialize();
-}
-
-sub load_own_components {
- my $class = shift;
- my @comp = map { "${class}::$_" } grep { $_ !~ /^#/ } @_;
- $class->_load_components(@comp);
-}
-
-sub _load_components {
- my ($class, @comp) = @_;
- foreach my $comp (@comp) {
- $class->ensure_class_loaded($comp);
- }
- $class->inject_base($class => @comp);
-}
-
-# Given a class name, tests to see if it is already loaded or otherwise
-# defined. If it is not yet loaded, the package is require'd, and an exception
-# is thrown if the class is still not loaded.
-#
-# TODO: handle ->has_many('rel', 'Class'...) instead of
-# ->has_many('rel', 'Some::Schema::Class'...)
-#
-# BUG: For some reason, packages with syntax errors are added to %INC on
-# require
-sub ensure_class_loaded {
- my ($class, $f_class) = @_;
- return if Class::Inspector->loaded($f_class);
- eval "require $f_class"; # require needs a bareword or filename
- if ($@) {
- if ($class->can('throw_exception')) {
- $class->throw_exception($@);
- } else {
- croak $@;
- }
- }
-}
-
-# Returns true if the specified class is installed or already loaded, false
-# otherwise
-sub ensure_class_found {
- my ($class, $f_class) = @_;
- return Class::Inspector->loaded($f_class) ||
- Class::Inspector->installed($f_class);
+ $class->next::method($target, @to_inject);
}
# Returns a true value if the specified class is installed and loaded
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/
- Serialize::Storable
Relationship
InflateColumn
PK::Auto
PK
Row
- ResultSourceProxy::Table
- /);
+ ResultSourceProxy::Table/);
1;
=head2 next
-Virtual method. Advances the cursor to the next row.
+Virtual method. Advances the cursor to the next row. Returns an array of
+column values (the result of L<DBI/fetchrow_array> method).
=cut
use DBIx::Class::Storage::DBI;
use DBIx::Class::ClassResolver::PassThrough;
use DBI;
+use Scalar::Util;
unless ($INC{"DBIx/Class/CDBICompat.pm"}) {
warn "IMPORTANT: DBIx::Class::DB is DEPRECATED AND *WILL* BE REMOVED. DO NOT USE.\n";
=cut
sub resultset_instance {
- my $class = ref $_[0] || $_[0];
- my $source = $class->result_source_instance;
- if ($source->result_class ne $class) {
- $source = $source->new($source);
- $source->result_class($class);
+ $_[0]->result_source_instance->resultset
+}
+
+=head2 result_source_instance
+
+Returns an instance of the result source for this class
+
+=cut
+
+__PACKAGE__->mk_classdata('_result_source_instance' => []);
+
+sub result_source_instance {
+ my $class = shift;
+ $class = ref $class || $class;
+
+ return $class->_result_source_instance([$_[0], $class]) if @_;
+
+ my($source, $result_class) = @{$class->_result_source_instance};
+ return unless Scalar::Util::blessed($source);
+
+ if ($result_class ne $class) { # new class
+ # Give this new class it's own source and register it.
+
+ $source = $source->new({
+ %$source,
+ source_name => $class,
+ result_class => $class
+ } );
+ $class->_result_source_instance([$source, $class]);
+ if (my $coderef = $class->can('schema_instance')) {
+ $coderef->($class)->register_class($class, $class);
+ }
}
- return $source->resultset;
+ return $source;
}
=head2 resolve_class
--- /dev/null
+package DBIx::Class::Exception;
+
+use strict;
+use warnings;
+
+use Carp::Clan qw/^DBIx::Class/;
+use Scalar::Util qw/blessed/;
+
+use overload
+ '""' => sub { shift->{msg} },
+ fallback => 1;
+
+=head1 NAME
+
+DBIx::Class::Exception - Exception objects for DBIx::Class
+
+=head1 DESCRIPTION
+
+Exception objects of this class are used in internally by
+he 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.
+
+These objects stringify to the contained error message, and use
+overload fallback to give natural boolean/numeric values.
+
+=head1 METHODS
+
+=head2 throw
+
+=over 4
+
+=item Arguments: $exception_scalar, $stacktrace
+
+=back
+
+This is meant for internal use by L<DBIx::Class>'s C<throw_exception>
+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>.
+
+ DBIx::Class::Exception->throw('Foo');
+ eval { ... }; DBIx::Class::Exception->throw($@) if $@;
+
+=cut
+
+sub throw {
+ my ($class, $msg, $stacktrace) = @_;
+
+ # Don't re-encapsulate exception objects of any kind
+ die $msg if blessed($msg);
+
+ # use Carp::Clan's croak if we're not stack tracing
+ if(!$stacktrace) {
+ local $@;
+ eval { croak $msg };
+ $msg = $@
+ }
+ else {
+ $msg = Carp::longmess($msg);
+ }
+
+ my $self = { msg => $msg };
+ bless $self => $class;
+
+ die $self;
+}
+
+=head2 rethrow
+
+This method provides some syntactic sugar in order to
+re-throw exceptions.
+
+=cut
+
+sub rethrow {
+ die shift;
+}
+
+=head1 AUTHORS
+
+Brandon L. Black <blblack@gmail.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
=head1 NAME
-DBIx::Class::InflateColumn - Automatically create objects from column data
+DBIx::Class::InflateColumn - Automatically create references from column data
=head1 SYNOPSIS
=head1 DESCRIPTION
-This component translates column data into objects, i.e. "inflating"
-the column data. It also "deflates" objects into an appropriate format
+This component translates column data into references, i.e. "inflating"
+the column data. It also "deflates" references into an appropriate format
for the database.
It can be used, for example, to automatically convert to and from
-L<DateTime> objects for your date and time fields.
+L<DateTime> objects for your date and time fields. There's a
+conveniece component to actually do that though, try
+L<DBIx::Class::InflateColumn::DateTime>.
+
+It will handle all types of references except scalar references. It
+will not handle scalar values, these are ignored and thus passed
+through to L<SQL::Abstract>. This is to allow setting raw values to
+"just work". Scalar references are passed through to the database to
+deal with, to allow such settings as C< \'year + 1'> and C< \'DEFAULT' >
+to work.
+
+If you want to filter plain scalar values and replace them with
+something else, contribute a filtering component.
=head1 METHODS
The coderefs you set for inflate and deflate are called with two parameters,
the first is the value of the column to be inflated/deflated, the second is the
-row object itself. Thus you can call C<< ->result_source->schema->storage->dbh >> on
-it, to feed to L<DateTime::Format::DBI>.
+row object itself. Thus you can call C<< ->result_source->schema->storage->dbh >> in your inflate/defalte subs, to feed to L<DateTime::Format::DBI>.
In this example, calls to an event's C<insert_time> accessor return a
L<DateTime> object. This L<DateTime> object is later "deflated" when
$self->throw_exception("inflate_column needs attr hashref")
unless ref $attrs eq 'HASH';
$self->column_info($col)->{_inflate_info} = $attrs;
- $self->mk_group_accessors('inflated_column' => $col);
+ $self->mk_group_accessors('inflated_column' => [$self->column_info($col)->{accessor} || $col, $col]);
return 1;
}
sub _deflated_column {
my ($self, $col, $value) = @_;
- return $value unless ref $value; # If it's not an object, don't touch it
+# return $value unless ref $value && blessed($value); # If it's not an object, don't touch it
+ ## Leave scalar refs (ala SQL::Abstract literal SQL), untouched, deflate all other refs
+ return $value unless (ref $value && ref($value) ne 'SCALAR');
my $info = $self->column_info($col) or
$self->throw_exception("No column info for $col");
return $value unless exists $info->{_inflate_info};
=cut
sub set_inflated_column {
- my ($self, $col, $obj) = @_;
- $self->set_column($col, $self->_deflated_column($col, $obj));
- if (blessed $obj) {
- $self->{_inflated_column}{$col} = $obj;
+ my ($self, $col, $inflated) = @_;
+ $self->set_column($col, $self->_deflated_column($col, $inflated));
+# if (blessed $inflated) {
+ if (ref $inflated && ref($inflated) ne 'SCALAR') {
+ $self->{_inflated_column}{$col} = $inflated;
} else {
delete $self->{_inflated_column}{$col};
}
- return $obj;
+ return $inflated;
}
=head2 store_inflated_column
=cut
sub store_inflated_column {
- my ($self, $col, $obj) = @_;
- unless (blessed $obj) {
+ my ($self, $col, $inflated) = @_;
+# unless (blessed $inflated) {
+ unless (ref $inflated && ref($inflated) ne 'SCALAR') {
delete $self->{_inflated_column}{$col};
- $self->store_column($col => $obj);
- return $obj;
+ $self->store_column($col => $inflated);
+ return $inflated;
}
delete $self->{_column_data}{$col};
- return $self->{_inflated_column}{$col} = $obj;
-}
-
-=head2 get_column
-
-Gets a column value in the same way as L<DBIx::Class::Row/get_column>. If there
-is an inflated value stored that has not yet been deflated, it is deflated
-when the method is invoked.
-
-=cut
-
-sub get_column {
- my ($self, $col) = @_;
- if (exists $self->{_inflated_column}{$col}
- && !exists $self->{_column_data}{$col}) {
- $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}));
- }
- return $self->next::method($col);
-}
-
-=head2 get_columns
-
-Returns the get_column info for all columns as a hash,
-just like L<DBIx::Class::Row/get_columns>. Handles inflation just
-like L</get_column>.
-
-=cut
-
-sub get_columns {
- my $self = shift;
- if (exists $self->{_inflated_column}) {
- foreach my $col (keys %{$self->{_inflated_column}}) {
- $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
- unless exists $self->{_column_data}{$col};
- }
- }
- return $self->next::method;
-}
-
-=head2 has_column_loaded
-
-Like L<DBIx::Class::Row/has_column_loaded>, but also returns true if there
-is an inflated value stored.
-
-=cut
-
-sub has_column_loaded {
- my ($self, $col) = @_;
- return 1 if exists $self->{_inflated_column}{$col};
- return $self->next::method($col);
-}
-
-=head2 update
-
-Updates a row in the same way as L<DBIx::Class::Row/update>, handling
-inflation and deflation of columns appropriately.
-
-=cut
-
-sub update {
- my ($class, $attrs, @rest) = @_;
- foreach my $key (keys %{$attrs||{}}) {
- if (ref $attrs->{$key} && $class->has_column($key)
- && exists $class->column_info($key)->{_inflate_info}) {
- $class->set_inflated_column($key, delete $attrs->{$key});
- }
- }
- return $class->next::method($attrs, @rest);
-}
-
-=head2 new
-
-Creates a row in the same way as L<DBIx::Class::Row/new>, handling
-inflation and deflation of columns appropriately.
-
-=cut
-
-sub new {
- my ($class, $attrs, @rest) = @_;
- my $inflated;
- foreach my $key (keys %{$attrs||{}}) {
- $inflated->{$key} = delete $attrs->{$key}
- if ref $attrs->{$key} && $class->has_column($key)
- && exists $class->column_info($key)->{_inflate_info};
- }
- my $obj = $class->next::method($attrs, @rest);
- $obj->{_inflated_column} = $inflated if $inflated;
- return $obj;
+ return $self->{_inflated_column}{$col} = $inflated;
}
=head1 SEE ALSO
Daniel Westermann-Clark <danieltwc@cpan.org> (documentation)
+Jess Robinson <cpan@desert-island.demon.co.uk>
+
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
columns to be of the datetime, timestamp or date datatype.
package Event;
- __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime Core/);
__PACKAGE__->add_columns(
starts_when => { data_type => 'datetime' }
);
print "This event starts the month of ".
$event->starts_when->month_name();
+If you want to set a specific timezone for that field, use:
+
+ __PACKAGE__->add_columns(
+ starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago" } }
+ );
+
=head1 DESCRIPTION
This module figures out the type of DateTime::Format::* class to
that this feature is new as of 0.07, so it may not be perfect yet - bug
reports to the list very much welcome).
-For more help with components, see L<DBIx::Class::Manual::Component>.
+For more help with using components, see L<DBIx::Class::Manual::Component/USING>.
=cut
$self->next::method($column, $info, @rest);
return unless defined($info->{data_type});
my $type = lc($info->{data_type});
- $type = 'datetime' if ($type eq 'timestamp');
+ $type = 'datetime' if ($type =~ /^timestamp/);
+ my $timezone;
+ if ( exists $info->{extra} and exists $info->{extra}{timezone} and defined $info->{extra}{timezone} ) {
+ $timezone = $info->{extra}{timezone};
+ }
+
if ($type eq 'datetime' || $type eq 'date') {
my ($parse, $format) = ("parse_${type}", "format_${type}");
$self->inflate_column(
{
inflate => sub {
my ($value, $obj) = @_;
- $obj->_datetime_parser->$parse($value);
+ my $dt = $obj->_datetime_parser->$parse($value);
+ $dt->set_time_zone($timezone) if $timezone;
+ return $dt;
},
deflate => sub {
my ($value, $obj) = @_;
+ $value->set_time_zone($timezone) if $timezone;
$obj->_datetime_parser->$format($value);
},
}
--- /dev/null
+package DBIx::Class::InflateColumn::File;
+
+use strict;
+use warnings;
+use base 'DBIx::Class';
+use File::Path;
+use File::Copy;
+use Path::Class;
+
+__PACKAGE__->load_components(qw/InflateColumn/);
+
+sub register_column {
+ my ($self, $column, $info, @rest) = @_;
+ $self->next::method($column, $info, @rest);
+ return unless defined($info->{is_file_column});
+
+ $self->inflate_column($column => {
+ inflate => sub {
+ my ($value, $obj) = @_;
+ $obj->_inflate_file_column($column, $value);
+ },
+ deflate => sub {
+ my ($value, $obj) = @_;
+ $obj->_save_file_column($column, $value);
+ },
+ });
+}
+
+sub _file_column_file {
+ my ($self, $column, $filename) = @_;
+
+ my $column_info = $self->column_info($column);
+
+ return unless $column_info->{is_file_column};
+
+ my $id = $self->id || $self->throw_exception(
+ 'id required for filename generation'
+ );
+
+ $filename ||= $self->$column->{filename};
+ return Path::Class::file(
+ $column_info->{file_column_path}, $id, $filename,
+ );
+}
+
+sub delete {
+ my ( $self, @rest ) = @_;
+
+ for ( $self->columns ) {
+ if ( $self->column_info($_)->{is_file_column} ) {
+ rmtree( [$self->_file_column_file($_)->dir], 0, 0 );
+ last; # if we've deleted one, we've deleted them all
+ }
+ }
+
+ return $self->next::method(@rest);
+}
+
+sub insert {
+ my $self = shift;
+
+ # cache our file columns so we can write them to the fs
+ # -after- we have a PK
+ my %file_column;
+ for ( $self->columns ) {
+ if ( $self->column_info($_)->{is_file_column} ) {
+ $file_column{$_} = $self->$_;
+ $self->store_column($_ => $self->$_->{filename});
+ }
+ }
+
+ $self->next::method(@_);
+
+ # write the files to the fs
+ while ( my ($col, $file) = each %file_column ) {
+ $self->_save_file_column($col, $file);
+ }
+
+ return $self;
+}
+
+
+sub _inflate_file_column {
+ my ( $self, $column, $value ) = @_;
+
+ my $fs_file = $self->_file_column_file($column, $value);
+
+ return { handle => $fs_file->open('r'), filename => $value };
+}
+
+sub _save_file_column {
+ my ( $self, $column, $value ) = @_;
+
+ return unless ref $value;
+
+ my $fs_file = $self->_file_column_file($column, $value->{filename});
+ mkpath [$fs_file->dir];
+
+ File::Copy::copy($value->{handle}, $fs_file);
+
+ $self->_file_column_callback($value, $self, $column);
+
+ return $value->{filename};
+}
+
+=head1 NAME
+
+DBIx::Class::InflateColumn::File - map files from the Database to the filesystem.
+
+=head1 SYNOPSIS
+
+In your L<DBIx::Class> table class:
+
+ __PACKAGE__->load_components( "PK::Auto", "InflateColumn::File", "Core" );
+
+ # define your columns
+ __PACKAGE__->add_columns(
+ "id",
+ {
+ data_type => "integer",
+ is_auto_increment => 1,
+ is_nullable => 0,
+ size => 4,
+ },
+ "filename",
+ {
+ data_type => "varchar",
+ is_file_column => 1,
+ file_column_path =>'/tmp/uploaded_files',
+ # or for a Catalyst application
+ # file_column_path => MyApp->path_to('root','static','files'),
+ default_value => undef,
+ is_nullable => 1,
+ size => 255,
+ },
+ );
+
+
+In your L<Catalyst::Controller> class:
+
+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({
+ subject => 'blah',
+ filename => {
+ handle => $c->req->upload('myupload')->fh,
+ filename => $c->req->upload('myupload')->basename
+ },
+ body => '....'
+ });
+ $c->stash->{entry}=$entry;
+
+
+And Place the following in your TT template
+
+ Article Subject: [% entry.subject %]
+ Uploaded File:
+ <a href="/static/files/[% entry.id %]/[% entry.filename.filename %]">File</a>
+ Body: [% entry.body %]
+
+The file will be stored on the filesystem for later retrieval. Calling delete
+on your resultset will delete the file from the filesystem. Retrevial of the
+record automatically inflates the column back to the set hash with the
+IO::File handle and filename.
+
+=head1 DESCRIPTION
+
+InflateColumn::File
+
+=head1 METHODS
+
+=head2 _file_column_callback ($file,$ret,$target)
+
+method made to be overridden for callback purposes.
+
+=cut
+
+sub _file_column_callback {}
+
+=head1 AUTHOR
+
+Victor Igumnov
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
=head1 SECTIONS
+=head2 L<DBIx::Class::Manual::FAQ>
+
+Short answers and doc pointers to questions.
+
=head2 L<DBIx::Class::Manual::Intro>
Beginner guide to using DBIx::Class.
An example of slightly more complex usage.
+=head2 L<DBIx::Class::Manual::Joining>
+
+How to translate known SQL JOINs into DBIx-Class-ish.
+
=head2 L<DBIx::Class::Manual::Cookbook>
Convenient recipes for DBIC usage.
DBIx::Class::Manual::Cookbook - Miscellaneous recipes
-=head1 RECIPES
+=head1 SEARCHING
-=head2 Searching
-
-=head3 Paged results
+=head2 Paged results
When you expect a large number of results, you can ask L<DBIx::Class> for a
-paged resultset, which will fetch only a small number of records at a time:
+paged resultset, which will fetch only a defined number of records at a time:
my $rs = $schema->resultset('Artist')->search(
undef,
return $rs->page(1); # DBIx::Class::ResultSet containing first 10 records
-In either of the above cases, you can return a L<Data::Page> object for the
+In either of the above cases, you can get a L<Data::Page> object for the
resultset (suitable for use in e.g. a template) using the C<pager> method:
return $rs->pager();
-=head3 Complex WHERE clauses
+=head2 Complex WHERE clauses
Sometimes you need to formulate a query using specific operators:
For more information on generating complex queries, see
L<SQL::Abstract/WHERE CLAUSES>.
-=head3 Using specific columns
+=head2 Arbitrary SQL through a custom ResultSource
+
+Sometimes you have to run arbitrary SQL because your query is too complex
+(e.g. it contains Unions, Sub-Selects, Stored Procedures, etc.) or has to
+be optimized for your database in a special way, but you still want to
+get the results as a L<DBIx::Class::ResultSet>.
+The recommended way to accomplish this is by defining a separate ResultSource
+for your query. You can then inject complete SQL statements using a scalar
+reference (this is a feature of L<SQL::Abstract>).
+
+Say you want to run a complex custom query on your user data, here's what
+you have to add to your User class:
+
+ package My::Schema::User;
+
+ use base qw/DBIx::Class/;
+
+ # ->load_components, ->table, ->add_columns, etc.
+
+ # Make a new ResultSource based on the User class
+ my $source = __PACKAGE__->result_source_instance();
+ my $new_source = $source->new( $source );
+ $new_source->source_name( 'UserFriendsComplex' );
+
+ # Hand in your query as a scalar reference
+ # It will be added as a sub-select after FROM,
+ # so pay attention to the surrounding brackets!
+ $new_source->name( \<<SQL );
+ ( SELECT u.* FROM user u
+ INNER JOIN user_friends f ON u.id = f.user_id
+ WHERE f.friend_user_id = ?
+ UNION
+ SELECT u.* FROM user u
+ INNER JOIN user_friends f ON u.id = f.friend_user_id
+ WHERE f.user_id = ? )
+ SQL
+
+ # Finally, register your new ResultSource with your Schema
+ My::Schema->register_source( 'UserFriendsComplex' => $new_source );
+
+Next, you can execute your complex query using bind parameters like this:
+
+ my $friends = [ $schema->resultset( 'UserFriendsComplex' )->search( {},
+ {
+ bind => [ 12345, 12345 ]
+ }
+ ) ];
+
+... and you'll get back a perfect L<DBIx::Class::ResultSet>.
+
+=head2 Using specific columns
When you only want specific columns from a table, you can use
C<columns> to specify which ones you need. This is useful to avoid
This is a shortcut for C<select> and C<as>, see below. C<columns>
cannot be used together with C<select> and C<as>.
-=head3 Using database functions or stored procedures
+=head2 Using database functions or stored procedures
The combination of C<select> and C<as> can be used to return the result of a
database function or stored procedure as a column value. You use C<select> to
);
# Equivalent SQL:
- # SELECT name name, LENGTH( name ) name_length
+ # SELECT name name, LENGTH( name )
# FROM artist
-If your alias exists as a column in your base class (i.e. it was added
-with C<add_columns>), you just access it as normal. Our C<Artist>
-class has a C<name> column, so we just use the C<name> accessor:
+Note that the C< as > attribute has absolutely nothing to with the sql
+syntax C< SELECT foo AS bar > (see the documentation in
+L<DBIx::Class::ResultSet/ATTRIBUTES>). If your alias exists as a
+column in your base class (i.e. it was added with C<add_columns>), you
+just access it as normal. Our C<Artist> class has a C<name> column, so
+we just use the C<name> accessor:
my $artist = $rs->first();
my $name = $artist->name();
# Or use DBIx::Class::AccessorGroup:
__PACKAGE__->mk_group_accessors('column' => 'name_length');
-=head3 SELECT DISTINCT with multiple columns
+=head2 SELECT DISTINCT with multiple columns
my $rs = $schema->resultset('Foo')->search(
{},
select => [
{ distinct => [ $source->columns ] }
],
- as => [ $source->columns ]
+ as => [ $source->columns ] # remember 'as' is not the same as SQL AS :-)
}
);
- my $count = $rs->next->get_column('count');
-
-=head3 SELECT COUNT(DISTINCT colname)
+=head2 SELECT COUNT(DISTINCT colname)
my $rs = $schema->resultset('Foo')->search(
{},
}
);
-=head3 Grouping results
+ my $count = $rs->next->get_column('count');
+
+=head2 Grouping results
L<DBIx::Class> supports C<GROUP BY> as follows:
# LEFT JOIN cd cds ON ( cds.artist = me.artistid )
# GROUP BY name
-=head3 Predefined searches
+Please see L<DBIx::Class::ResultSet/ATTRIBUTES> documentation if you
+are in any way unsure about the use of the attributes above (C< join
+>, C< select >, C< as > and C< group_by >).
+
+=head2 Predefined searches
You can write your own L<DBIx::Class::ResultSet> class by inheriting from it
and define often used searches as methods:
To use your resultset, first tell DBIx::Class to create an instance of it
for you, in your My::DBIC::Schema::CD class:
+ # class definition as normal
+ __PACKAGE__->load_components(qw/ Core /);
+ __PACKAGE__->table('cd');
+
+ # tell DBIC to use the custom ResultSet class
__PACKAGE__->resultset_class('My::DBIC::ResultSet::CD');
+Note that C<resultset_class> must be called after C<load_components> and C<table>, or you will get errors about missing methods.
+
Then call your new method in your code:
my $ordered_cds = $schema->resultset('CD')->search_cds_ordered();
+=head2 Using SQL functions on the left hand side of a comparison
-=head3 Predefined searches without writing a ResultSet class
+Using SQL functions on the left hand side of a comparison is generally
+not a good idea since it requires a scan of the entire table. However,
+it can be accomplished with C<DBIx::Class> when necessary.
-Alternatively you can automatically generate a DBIx::Class::ResultSet
-class by using the ResultSetManager component and tagging your method
-as ResultSet:
+If you do not have quoting on, simply include the function in your search
+specification as you would any column:
- __PACKAGE__->load_components(qw/ ResultSetManager Core /);
+ $rs->search({ 'YEAR(date_of_birth)' => 1979 });
- sub search_cds_ordered : ResultSet {
- my ($self) = @_;
- return $self->search(
- {},
- { order_by => 'name DESC' },
- );
- }
+With quoting on, or for a more portable solution, use the C<where>
+attribute:
-Then call your method in the same way from your code:
+ $rs->search({}, { where => \'YEAR(date_of_birth) = 1979' });
- my $ordered_cds = $schema->resultset('CD')->search_cds_ordered();
+=begin hidden
+
+(When the bind args ordering bug is fixed, this technique will be better
+and can replace the one above.)
+
+With quoting on, or for a more portable solution, use the C<where> and
+C<bind> attributes:
+
+ $rs->search({}, {
+ where => \'YEAR(date_of_birth) = ?',
+ bind => [ 1979 ]
+ });
+
+=end hidden
+
+=head1 JOINS AND PREFETCHING
=head2 Using joins and prefetch
join => [qw/ artist /],
order_by => [qw/ artist.name /]
}
- };
+ );
# Equivalent SQL:
# SELECT cd.* FROM cd
definitely use data from a related table. Pre-fetching related tables when you
only need columns from the main table will make performance worse!
-=head3 Multi-step joins
+=head2 Multi-step joins
Sometimes you want to join more than one relationship deep. In this example,
we want to find all C<Artist> objects who have C<CD>s whose C<LinerNotes>
my $tag = $rs->first;
print $tag->cd->artist->name;
-=head2 Columns of data
+=head1 ROW-LEVEL OPERATIONS
+
+=head2 Retrieving a row object's Schema
+
+It is possible to get a Schema object from a row object like so:
+
+ my $schema = $cd->result_source->schema;
+ # use the schema as normal:
+ my $artist_rs = $schema->resultset('Artist');
+
+This can be useful when you don't want to pass around a Schema object to every
+method.
+
+=head2 Getting the value of the primary key for the last database insert
+
+AKA getting last_insert_id
+
+If you are using PK::Auto (which is a core component as of 0.07), this is
+straightforward:
+
+ my $foo = $rs->create(\%blah);
+ # do more stuff
+ my $id = $foo->id; # foo->my_primary_key_field will also work.
+
+If you are not using autoincrementing primary keys, this will probably
+not work, but then you already know the value of the last primary key anyway.
+
+=head2 Stringification
+
+Employ the standard stringification technique by using the C<overload>
+module.
+
+To make an object stringify itself as a single column, use something
+like this (replace C<foo> with the column/method of your choice):
+
+ use overload '""' => sub { shift->name}, fallback => 1;
+
+For more complex stringification, you can use an anonymous subroutine:
+
+ use overload '""' => sub { $_[0]->name . ", " .
+ $_[0]->address }, fallback => 1;
+
+=head3 Stringification Example
+
+Suppose we have two tables: C<Product> and C<Category>. The table
+specifications are:
+
+ Product(id, Description, category)
+ Category(id, Description)
+
+C<category> is a foreign key into the Category table.
+
+If you have a Product object C<$obj> and write something like
+
+ print $obj->category
+
+things will not work as expected.
+
+To obtain, for example, the category description, you should add this
+method to the class defining the Category table:
+
+ use overload "" => sub {
+ my $self = shift;
+
+ return $self->Description;
+ }, fallback => 1;
+
+=head2 Want to know if find_or_create found or created a row?
+
+Just use C<find_or_new> instead, then check C<in_storage>:
+
+ my $obj = $rs->find_or_new({ blah => 'blarg' });
+ unless ($obj->in_storage) {
+ $obj->insert;
+ # do whatever else you wanted if it was a new row
+ }
+
+=head2 Dynamic Sub-classing DBIx::Class proxy classes
+
+AKA multi-class object inflation from one table
+
+L<DBIx::Class> classes are proxy classes, therefore some different
+techniques need to be employed for more than basic subclassing. In
+this example we have a single user table that carries a boolean bit
+for admin. We would like like to give the admin users
+objects(L<DBIx::Class::Row>) the same methods as a regular user but
+also special admin only methods. It doesn't make sense to create two
+seperate proxy-class files for this. We would be copying all the user
+methods into the Admin class. There is a cleaner way to accomplish
+this.
+
+Overriding the C<inflate_result> method within the User proxy-class
+gives us the effect we want. This method is called by
+L<DBIx::Class::ResultSet> when inflating a result from storage. So we
+grab the object being returned, inspect the values we are looking for,
+bless it if it's an admin object, and then return it. See the example
+below:
+
+B<Schema Definition>
+
+ package DB::Schema;
+
+ use base qw/DBIx::Class::Schema/;
+
+ __PACKAGE__->load_classes(qw/User/);
+
+
+B<Proxy-Class definitions>
+
+ package DB::Schema::User;
+
+ use strict;
+ use warnings;
+ use base qw/DBIx::Class/;
+
+ ### Defined what our admin class is for ensure_class_loaded
+ my $admin_class = __PACKAGE__ . '::Admin';
+
+ __PACKAGE__->load_components(qw/Core/);
+
+ __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 {
+ print "I am a regular user.\n";
+ return ;
+ }
+
+
+ package DB::Schema::User::Admin;
+
+ use strict;
+ use warnings;
+ use base qw/DB::Schema::User/;
+
+ sub hello
+ {
+ print "I am an admin.\n";
+ return;
+ }
+
+ sub do_admin_stuff
+ {
+ print "I am doing admin stuff\n";
+ return ;
+ }
+
+B<Test File> test.pl
+
+ use warnings;
+ use strict;
+ use DB::Schema;
+
+ my $user_data = { email => 'someguy@place.com',
+ password => 'pass1',
+ admin => 0 };
+
+ my $admin_data = { email => 'someadmin@adminplace.com',
+ password => 'pass2',
+ admin => 1 };
+
+ my $schema = DB::Schema->connection('dbi:Pg:dbname=test');
+
+ $schema->resultset('User')->create( $user_data );
+ $schema->resultset('User')->create( $admin_data );
+
+ ### Now we search for them
+ my $user = $schema->resultset('User')->single( $user_data );
+ my $admin = $schema->resultset('User')->single( $admin_data );
+
+ print ref $user, "\n";
+ print ref $admin, "\n";
+
+ print $user->password , "\n"; # pass1
+ print $admin->password , "\n";# pass2; inherited from User
+ print $user->hello , "\n";# I am a regular user.
+ print $admin->hello, "\n";# I am an admin.
+
+ ### The statement below will NOT print
+ print "I can do admin stuff\n" if $user->can('do_admin_stuff');
+ ### The statement below will print
+ print "I can do admin stuff\n" if $admin->can('do_admin_stuff');
+
+=head2 Skip object creation for faster results
+
+DBIx::Class is not built for speed, it's built for convenience and
+ease of use, but sometimes you just need to get the data, and skip the
+fancy objects.
+
+To do this simply use L<DBIx::Class::ResultClass::HashRefInflator>.
+
+ my $rs = $schema->resultset('CD');
+
+ $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
+
+ my $hash_ref = $rs->find(1);
+
+Wasn't that easy?
+
+=head2 Get raw data for blindingly fast results
+
+If the L<HashRefInflator|DBIx::Class::ResultClass::HashRefInflator> solution
+above is not fast enough for you, you can use a DBIx::Class to return values
+exactly as they come out of the data base with none of the convenience methods
+wrapped round them.
+
+This is used like so:-
+
+ my $cursor = $rs->cursor
+ while (my @vals = $cursor->next) {
+ # use $val[0..n] here
+ }
+
+You will need to map the array offsets to particular columns (you can
+use the I<select> attribute of C<search()> to force ordering).
+
+=head1 RESULTSET OPERATIONS
+
+=head2 Getting Schema from a ResultSet
+
+To get the schema object from a result set, do the following:
+
+ $rs->result_source->schema
+
+=head2 Getting Columns Of Data
+
+AKA Aggregating Data
If you want to find the sum of a particular column there are several
ways, the obvious one is to use search:
{},
{
select => [ { sum => 'Cost' } ],
- as => [ 'total_cost' ],
+ as => [ 'total_cost' ], # remember this 'as' is for DBIx::Class::ResultSet not SQL
}
);
my $tc = $rs->first->get_column('total_cost');
Which will of course only work if your database supports this function.
See L<DBIx::Class::ResultSetColumn> for more documentation.
-=head2 Using relationships
+=head2 Creating a result set from a set of rows
+
+Sometimes you have a (set of) row objects that you want to put into a
+resultset without the need to hit the DB again. You can do that by using the
+L<set_cache|DBIx::Class::Resultset/set_cache> method:
-=head3 Create a new row in a related table
+ my @uploadable_groups;
+ while (my $group = $groups->next) {
+ if ($group->can_upload($self)) {
+ push @uploadable_groups, $group;
+ }
+ }
+ my $new_rs = $self->result_source->resultset;
+ $new_rs->set_cache(\@uploadable_groups);
+ return $new_rs;
- my $book->create_related('author', { name => 'Fred'});
-=head3 Search in a related table
+=head1 USING RELATIONSHIPS
+
+=head2 Create a new row in a related table
+
+ my $author = $book->create_related('author', { name => 'Fred'});
+
+=head2 Search in a related table
Only searches for books named 'Titanic' by the author in $author.
- my $author->search_related('books', { name => 'Titanic' });
+ my $books_rs = $author->search_related('books', { name => 'Titanic' });
-=head3 Delete data in a related table
+=head2 Delete data in a related table
Deletes only the book named Titanic by the author in $author.
- my $author->delete_related('books', { name => 'Titanic' });
+ $author->delete_related('books', { name => 'Titanic' });
-=head3 Ordering a relationship result set
+=head2 Ordering a relationship result set
If you always want a relation to be ordered, you can specify this when you
create the relationship.
-To order C<< $book->pages >> by descending page_number.
-
- Book->has_many('pages' => 'Page', 'book', { order_by => \'page_number DESC'} );
+To order C<< $book->pages >> by descending page_number, create the relation
+as follows:
+ __PACKAGE__->has_many('pages' => 'Page', 'book', { order_by => \'page_number DESC'} );
+=head2 Many-to-many relationships
-=head2 Transactions
+This is straightforward using L<ManyToMany|DBIx::Class::Relationship/many_to_many>:
-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:
+ package My::User;
+ use base 'DBIx::Class';
+ __PACKAGE__->load_components('Core');
+ __PACKAGE__->table('user');
+ __PACKAGE__->add_columns(qw/id name/);
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->has_many('user_address' => 'My::UserAddress', 'user');
+ __PACKAGE__->many_to_many('addresses' => 'user_address', 'address');
+
+ package My::UserAddress;
+ use base 'DBIx::Class';
+ __PACKAGE__->load_components('Core');
+ __PACKAGE__->table('user_address');
+ __PACKAGE__->add_columns(qw/user address/);
+ __PACKAGE__->set_primary_key(qw/user address/);
+ __PACKAGE__->belongs_to('user' => 'My::User');
+ __PACKAGE__->belongs_to('address' => 'My::Address');
+
+ package My::Address;
+ use base 'DBIx::Class';
+ __PACKAGE__->load_components('Core');
+ __PACKAGE__->table('address');
+ __PACKAGE__->add_columns(qw/id street town area_code country/);
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->has_many('user_address' => 'My::UserAddress', 'address');
+ __PACKAGE__->many_to_many('users' => 'user_address', 'user');
+
+ $rs = $user->addresses(); # get all addresses for a user
+ $rs = $address->users(); # get all users for an address
+
+=head1 TRANSACTIONS
+
+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:
my $genus = $schema->resultset('Genus')->find(12);
$genus->add_to_species({ name => 'troglodyte' });
$genus->wings(2);
$genus->update;
- $schema->txn_do($coderef2); # Can have a nested transaction
+ $schema->txn_do($coderef2); # Can have a nested transaction. Only the outer will actualy commit
return $genus->species;
};
transactions (for databases that support them) will hopefully be added
in the future.
-=head2 Many-to-many relationships
-
-This is straightforward using L<DBIx::Class::Relationship::ManyToMany>:
-
- package My::DB;
- # ... set up connection ...
-
- package My::User;
- use base 'My::DB';
- __PACKAGE__->table('user');
- __PACKAGE__->add_columns(qw/id name/);
- __PACKAGE__->set_primary_key('id');
- __PACKAGE__->has_many('user_address' => 'My::UserAddress', 'user');
- __PACKAGE__->many_to_many('addresses' => 'user_address', 'address');
-
- package My::UserAddress;
- use base 'My::DB';
- __PACKAGE__->table('user_address');
- __PACKAGE__->add_columns(qw/user address/);
- __PACKAGE__->set_primary_key(qw/user address/);
- __PACKAGE__->belongs_to('user' => 'My::User');
- __PACKAGE__->belongs_to('address' => 'My::Address');
-
- package My::Address;
- use base 'My::DB';
- __PACKAGE__->table('address');
- __PACKAGE__->add_columns(qw/id street town area_code country/);
- __PACKAGE__->set_primary_key('id');
- __PACKAGE__->has_many('user_address' => 'My::UserAddress', 'address');
- __PACKAGE__->many_to_many('users' => 'user_address', 'user');
-
- $rs = $user->addresses(); # get all addresses for a user
- $rs = $address->users(); # get all users for an address
+=head1 SQL
-=head2 Setting default values for a row
+=head2 Creating Schemas From An Existing Database
-It's as simple as overriding the C<new> method. Note the use of
-C<next::method>.
+L<DBIx::Class::Schema::Loader> will connect to a database and create a
+L<DBIx::Class::Schema> and associated sources by examining the database.
- sub new {
- my ( $class, $attrs ) = @_;
-
- $attrs->{foo} = 'bar' unless defined $attrs->{foo};
+The recommend way of achieving this is to use the
+L<make_schema_at|DBIx::Class::Schema::Loader/make_schema_at> method:
- $class->next::method($attrs);
- }
+ 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" ])'
-For more information about C<next::method>, look in the L<Class::C3>
-documentation. See also L<DBIx::Class::Manual::Component> for more
-ways to write your own base classes to do this.
+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.
-People looking for ways to do "triggers" with DBIx::Class are probably
-just looking for this.
+=head2 Creating DDL SQL
-=head2 Stringification
+The following functionality requires you to have L<SQL::Translator>
+(also known as "SQL Fairy") installed.
-Employ the standard stringification technique by using the C<overload>
-module.
+To create a set of database-specific .sql files for the above schema:
-To make an object stringify itself as a single column, use something
-like this (replace C<foo> with the column/method of your choice):
+ my $schema = My::Schema->connect($dsn);
+ $schema->create_ddl_dir(['MySQL', 'SQLite', 'PostgreSQL'],
+ '0.1',
+ './dbscriptdir/'
+ );
- use overload '""' => 'foo', fallback => 1;
+By default this will create schema files in the current directory, for
+MySQL, SQLite and PostgreSQL, using the $VERSION from your Schema.pm.
-For more complex stringification, you can use an anonymous subroutine:
+To create a new database using the schema:
- use overload '""' => sub { $_[0]->name . ", " .
- $_[0]->address }, fallback => 1;
+ my $schema = My::Schema->connect($dsn);
+ $schema->deploy({ add_drop_tables => 1});
-=head3 Stringification Example
+To import created .sql files using the mysql client:
-Suppose we have two tables: C<Product> and C<Category>. The table
-specifications are:
+ mysql -h "host" -D "database" -u "user" -p < My_Schema_1.0_MySQL.sql
- Product(id, Description, category)
- Category(id, Description)
+To create C<ALTER TABLE> conversion scripts to update a database to a
+newer version of your schema at a later point, first set a new
+C<$VERSION> in your Schema file, then:
-C<category> is a foreign key into the Category table.
+ my $schema = My::Schema->connect($dsn);
+ $schema->create_ddl_dir(['MySQL', 'SQLite', 'PostgreSQL'],
+ '0.2',
+ '/dbscriptdir/',
+ '0.1'
+ );
-If you have a Product object C<$obj> and write something like
+This will produce new database-specific .sql files for the new version
+of the schema, plus scripts to convert from version 0.1 to 0.2. This
+requires that the files for 0.1 as created above are available in the
+given directory to diff against.
- print $obj->category
+=head2 Select from dual
-things will not work as expected.
+Dummy tables are needed by some databases to allow calling functions
+or expressions that aren't based on table content, for examples of how
+this applies to various database types, see:
+L<http://troels.arvin.dk/db/rdbms/#other-dummy_table>.
-To obtain, for example, the category description, you should add this
-method to the class defining the Category table:
+Note: If you're using Oracles dual table don't B<ever> do anything
+other than a select, if you CRUD on your dual table you *will* break
+your database.
- use overload "" => sub {
- my $self = shift;
+Make a table class as you would for any other table
+
+ package MyAppDB::Dual;
+ use strict;
+ use warnings;
+ use base 'DBIx::Class';
+ __PACKAGE__->load_components("Core");
+ __PACKAGE__->table("Dual");
+ __PACKAGE__->add_columns(
+ "dummy",
+ { data_type => "VARCHAR2", is_nullable => 0, size => 1 },
+ );
+
+Once you've loaded your table class select from it using C<select>
+and C<as> instead of C<columns>
+
+ my $rs = $schema->resultset('Dual')->search(undef,
+ { select => [ 'sydate' ],
+ as => [ 'now' ]
+ },
+ );
+
+All you have to do now is be careful how you access your resultset, the below
+will not work because there is no column called 'now' in the Dual table class
+
+ while (my $dual = $rs->next) {
+ print $dual->now."\n";
+ }
+ # Can't locate object method "now" via package "MyAppDB::Dual" at headshot.pl line 23.
+
+You could of course use 'dummy' in C<as> instead of 'now', or C<add_columns> to
+your Dual class for whatever you wanted to select from dual, but that's just
+silly, instead use C<get_column>
+
+ while (my $dual = $rs->next) {
+ print $dual->get_column('now')."\n";
+ }
+
+Or use C<cursor>
+
+ my $cursor = $rs->cursor;
+ while (my @vals = $cursor->next) {
+ print $vals[0]."\n";
+ }
+
+Or use L<DBIx::Class::ResultClass::HashRefInflator>
+
+ $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
+ while ( my $dual = $rs->next ) {
+ print $dual->{now}."\n";
+ }
+
+Here are some example C<select> conditions to illustrate the different syntax
+you could use for doing stuff like
+C<oracles.heavily(nested(functions_can('take', 'lots'), OF), 'args')>
+
+ # get a sequence value
+ select => [ 'A_SEQ.nextval' ],
+
+ # get create table sql
+ select => [ { 'dbms_metadata.get_ddl' => [ "'TABLE'", "'ARTIST'" ]} ],
+
+ # get a random num between 0 and 100
+ select => [ { "trunc" => [ { "dbms_random.value" => [0,100] } ]} ],
+
+ # what year is it?
+ select => [ { 'extract' => [ \'year from sysdate' ] } ],
+
+ # do some math
+ select => [ {'round' => [{'cos' => [ \'180 * 3.14159265359/180' ]}]}],
+
+ # which day of the week were you born on?
+ select => [{'to_char' => [{'to_date' => [ "'25-DEC-1980'", "'dd-mon-yyyy'" ]}, "'day'"]}],
+
+ # select 16 rows from dual
+ select => [ "'hello'" ],
+ as => [ 'world' ],
+ group_by => [ 'cube( 1, 2, 3, 4 )' ],
+
+
- return $self->Description;
- }, fallback => 1;
+=head2 Adding Indexes And Functions To Your SQL
-=head2 Disconnecting cleanly
+Often you will want indexes on columns on your table to speed up searching. To
+do this, create a method called C<sqlt_deploy_hook> in the relevant source
+class:
-If you find yourself quitting an app with Control-C a lot during
-development, you might like to put the following signal handler in
-your main database class to make sure it disconnects cleanly:
+ package My::Schema::Artist;
- $SIG{INT} = sub {
- __PACKAGE__->storage->disconnect;
- };
+ __PACKAGE__->table('artist');
+ __PACKAGE__->add_columns(id => { ... }, name => { ... })
-=head2 Schema import/export
+ sub sqlt_deploy_hook {
+ my ($self, $sqlt_table) = @_;
-This functionality requires you to have L<SQL::Translator> (also known as
-"SQL Fairy") installed.
+ $sqlt_table->add_index(name => 'idx_name', fields => ['name']);
+ }
-To create a DBIx::Class schema from an existing database:
+ 1;
- sqlt --from DBI
- --to DBIx::Class::File
- --prefix "MySchema" > MySchema.pm
+Sometimes you might want to change the index depending on the type of the
+database for which SQL is being generated:
-To create a MySQL database from an existing L<DBIx::Class> schema, convert the
-schema to MySQL's dialect of SQL:
+ my ($db_type = $sqlt_table->schema->translator->producer_type)
+ =~ s/^SQL::Translator::Producer:://;
- sqlt --from SQL::Translator::Parser::DBIx::Class
- --to MySQL
- --DBIx::Class "MySchema.pm" > Schema1.sql
-
-And import using the mysql client:
+You can also add hooks to the schema level to stop certain tables being
+created:
- mysql -h "host" -D "database" -u "user" -p < Schema1.sql
+ package My::Schema;
-=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:
+ sub sqlt_deploy_hook {
+ my ($self, $sqlt_schema) = @_;
- use MyDB;
- use SQL::Translator;
-
- my $schema = MyDB->schema_instance;
-
- my $translator = SQL::Translator->new(
- debug => $debug || 0,
- trace => $trace || 0,
- no_comments => $no_comments || 0,
- show_warnings => $show_warnings || 0,
- add_drop_table => $add_drop_table || 0,
- validate => $validate || 0,
- parser_args => {
- 'DBIx::Schema' => $schema,
- },
- producer_args => {
- 'prefix' => 'My::Schema',
- },
- );
-
- $translator->parser('SQL::Translator::Parser::DBIx::Class');
- $translator->producer('SQL::Translator::Producer::DBIx::Class::File');
-
- my $output = $translator->translate(@args) or die
- "Error: " . $translator->error;
-
- print $output;
+ $sqlt_schema->drop_table('table_name');
+ }
-You could use L<Module::Find> to search for all subclasses in the MyDB::*
-namespace, which is currently left as an exercise for the reader.
+You could also add views or procedures to the output using
+L<SQL::Translator::Schema/add_view> or
+L<SQL::Translator::Schema/add_procedure>.
=head2 Schema versioning
=back
-=head3 Create a DBIx::Class schema
+B<Create a DBIx::Class schema>
This can either be done manually, or generated from an existing database as
-described under C<Schema import/export>.
-
-=head3 Save the schema
+described under L</Creating Schemas From An Existing Database>
-Use C<sqlt> to transform your schema into an SQL script suitable for your
-customer's database. E.g. for MySQL:
+B<Save the schema>
- sqlt --from SQL::Translator::Parser::DBIx::Class
- --to MySQL
- --DBIx::Class "MySchema.pm" > Schema1.mysql.sql
+Call L<DBIx::Class::Schema/create_ddl_dir> as above under L</Creating DDL SQL>.
-If you need to target databases from multiple vendors, just generate an SQL
-script suitable for each. To support PostgreSQL too:
-
- sqlt --from SQL::Translator::DBIx::Class
- --to PostgreSQL
- --DBIx::Class "MySchema.pm" > Schema1.pgsql.sql
-
-=head3 Deploy to customers
+B<Deploy to customers>
There are several ways you could deploy your schema. These are probably
beyond the scope of this recipe, but might include:
=back
-=head3 Modify the schema to change functionality
+B<Modify the schema to change functionality>
+
+As your application evolves, it may be necessary to modify your schema
+to change functionality. Once the changes are made to your schema in
+DBIx::Class, export the modified schema and the conversion scripts as
+in L</Creating DDL SQL>.
+
+B<Deploy update to customers>
-As your application evolves, it may be necessary to modify your schema to
-change functionality. Once the changes are made to your schema in DBIx::Class,
-export the modified schema as before, taking care not to overwrite the original:
+Add the L<DBIx::Class::Schema::Versioned> schema component to your
+Schema class. This will add a new table to your database called
+C<dbix_class_schema_vesion> which will keep track of which version is installed
+and warn if the user trys to run a newer schema version than the
+database thinks it has.
- sqlt --from SQL::Translator::DBIx::Class
- --to MySQL
- --DBIx::Class "Anything.pm" > Schema2.mysql.sql
+Alternatively, you can send the conversion sql scripts to your
+customers as above.
-Next, use sqlt-diff to create an SQL script that will update the customer's
-database schema:
+=head2 Setting quoting for the generated SQL.
+
+If the database contains column names with spaces and/or reserved words, they
+need to be quoted in the SQL queries. This is done using:
+
+ __PACKAGE__->storage->sql_maker->quote_char([ qw/[ ]/] );
+ __PACKAGE__->storage->sql_maker->name_sep('.');
+
+The first sets the quote characters. Either a pair of matching
+brackets, or a C<"> or C<'>:
+
+ __PACKAGE__->storage->sql_maker->quote_char('"');
- sqlt-diff --to MySQL Schema1=MySQL Schema2=MySQL > SchemaUpdate.mysql.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.
-=head3 Deploy update to customers
+In most cases you should set these as part of the arguments passed to
+L<DBIx::Class::Schema/conect>:
-The schema update can be deployed to customers using the same method as before.
+ my $schema = My::Schema->connect(
+ 'dbi:mysql:my_db',
+ 'db_user',
+ 'db_password',
+ {
+ quote_char => '"',
+ name_sep => '.'
+ }
+ )
=head2 Setting limit dialect for SQL::Abstract::Limit
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)
-=head2 Setting quoting for the generated SQL.
+The limit dialect can also be set at connect time by specifying a
+C<limit_dialect> key in the final hash as shown above.
-If the database contains column names with spaces and/or reserved words, they
-need to be quoted in the SQL queries. This is done using:
+=head1 BOOTSTRAPPING/MIGRATING
- __PACKAGE__->storage->sql_maker->quote_char([ qw/[ ]/] );
- __PACKAGE__->storage->sql_maker->name_sep('.');
+=head2 Easy migration from class-based to schema-based setup
-The first sets the quote characters. Either a pair of matching
-brackets, or a C<"> or C<'>:
+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:
+
+ use MyDB;
+ use SQL::Translator;
+
+ my $schema = MyDB->schema_instance;
+
+ my $translator = SQL::Translator->new(
+ debug => $debug || 0,
+ trace => $trace || 0,
+ no_comments => $no_comments || 0,
+ show_warnings => $show_warnings || 0,
+ add_drop_table => $add_drop_table || 0,
+ validate => $validate || 0,
+ parser_args => {
+ 'DBIx::Schema' => $schema,
+ },
+ producer_args => {
+ 'prefix' => 'My::Schema',
+ },
+ );
+
+ $translator->parser('SQL::Translator::Parser::DBIx::Class');
+ $translator->producer('SQL::Translator::Producer::DBIx::Class::File');
+
+ my $output = $translator->translate(@args) or die
+ "Error: " . $translator->error;
- __PACKAGE__->storage->sql_maker->quote_char('"');
+ print $output;
-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.
+You could use L<Module::Find> to search for all subclasses in the MyDB::*
+namespace, which is currently left as an exercise for the reader.
-=head2 Overloading methods
+=head1 OVERLOADING METHODS
-L<DBIx::Class> uses the L<Class::C3> package, which provides for redispatch of
-method calls. You have to use calls to C<next::method> to overload methods.
-More information on using L<Class::C3> with L<DBIx::Class> can be found in
+L<DBIx::Class> uses the L<Class::C3> package, which provides for redispatch of
+method calls, useful for things like default values and triggers. You have to
+use calls to C<next::method> to overload methods. More information on using
+L<Class::C3> with L<DBIx::Class> can be found in
L<DBIx::Class::Manual::Component>.
-=head3 Changing one field whenever another changes
+=head2 Setting default values for a row
+
+It's as simple as overriding the C<new> method. Note the use of
+C<next::method>.
+
+ sub new {
+ my ( $class, $attrs ) = @_;
+
+ $attrs->{foo} = 'bar' unless defined $attrs->{foo};
+
+ my $new = $class->next::method($attrs);
+
+ return $new;
+ }
+
+For more information about C<next::method>, look in the L<Class::C3>
+documentation. See also L<DBIx::Class::Manual::Component> for more
+ways to write your own base classes to do this.
+
+People looking for ways to do "triggers" with DBIx::Class are probably
+just looking for this.
+
+=head2 Changing one field whenever another changes
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
Note that the hard work is done by the call to C<next::method>, which
redispatches your call to store_column in the superclass(es).
-=head3 Automatically creating related objects
+=head2 Automatically creating related objects
You might have a class C<Artist> which has many C<CD>s. Further, if you
want to create a C<CD> object every time you insert an C<Artist> object.
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.
-=head2 Debugging DBIx::Class objects with Data::Dumper
+=head2 Wrapping/overloading a column accessor
+
+B<Problem:>
+
+Say you have a table "Camera" and want to associate a description
+with each camera. For most cameras, you'll be able to generate the description from
+the other columns. However, in a few special cases you may want to associate a
+custom description with a camera.
+
+B<Solution:>
+
+In your database schema, define a description field in the "Camera" table that
+can contain text and null values.
+
+In DBIC, we'll overload the column accessor to provide a sane default if no
+custom description is defined. The accessor will either return or generate the
+description, depending on whether the field is null or not.
+
+First, in your "Camera" schema class, define the description field as follows:
+
+ __PACKAGE__->add_columns(description => { accessor => '_description' });
+
+Next, we'll define the accessor-wrapper subroutine:
+
+ sub description {
+ my $self = shift;
+
+ # If there is an update to the column, we'll let the original accessor
+ # deal with it.
+ return $self->_description(@_) if @_;
+
+ # Fetch the column value.
+ my $description = $self->_description;
+
+ # If there's something in the description field, then just return that.
+ return $description if defined $description && length $descripton;
+
+ # Otherwise, generate a description.
+ return $self->generate_description;
+ }
+
+=head1 DEBUGGING AND PROFILING
+
+=head2 DBIx::Class objects with Data::Dumper
L<Data::Dumper> can be a very useful tool for debugging, but sometimes it can
be hard to find the pertinent data in all the data it can generate.
will automagically clean up your data before printing it. See
L<Data::Dumper/EXAMPLES> for more information.
-=head2 Retrieving a row object's Schema
-
-It is possible to get a Schema object from a row object like so:
-
- my $schema = $cd->result_source->schema;
- # use the schema as normal:
- my $artist_rs = $schema->resultset('Artist');
-
-This can be useful when you don't want to pass around a Schema object to every
-method.
-
=head2 Profiling
When you enable L<DBIx::Class::Storage>'s debugging it prints the SQL
my $sql = shift();
my $params = @_;
- print "Executing $sql: ".join(', ', @params)."\n";
+ $self->print("Executing $sql: ".join(', ', @params)."\n");
$start = time();
}
my $sql = shift();
my @params = @_;
- printf("Execution took %0.4f seconds.\n", time() - $start);
+ my $elapsed = sprintf("%0.4f", time() - $start);
+ $self->print("Execution took $elapsed seconds.\n");
$start = undef;
}
You can then install that class as the debugging object:
- __PACKAGE__->storage()->debugobj(new My::Profiler());
- __PACKAGE__->storage()->debug(1);
+ __PACKAGE__->storage->debugobj(new My::Profiler());
+ __PACKAGE__->storage->debug(1);
A more complicated example might involve storing each execution of SQL in an
array:
You could then create average, high and low execution times for an SQL
statement and dig down to see if certain parameters cause aberrant behavior.
+You might want to check out L<DBIx::Class::QueryLog> as well.
-=head2 Getting the value of the primary key for the last database insert
-
-AKA getting last_insert_id
-
-If you are using PK::Auto, this is straightforward:
-
- my $foo = $rs->create(\%blah);
- # do more stuff
- my $id = $foo->id; # foo->my_primary_key_field will also work.
-
-If you are not using autoincrementing primary keys, this will probably
-not work, but then you already know the value of the last primary key anyway.
-
-=head2 Dynamic Sub-classing DBIx::Class proxy classes
-(AKA multi-class object inflation from one table)
-
-L<DBIx::Class> classes are proxy classes, therefore some different
-techniques need to be employed for more than basic subclassing. In
-this example we have a single user table that carries a boolean bit
-for admin. We would like like to give the admin users
-objects(L<DBIx::Class::Row>) the same methods as a regular user but
-also special admin only methods. It doesn't make sense to create two
-seperate proxy-class files for this. We would be copying all the user
-methods into the Admin class. There is a cleaner way to accomplish
-this.
-
-Overriding the C<inflate_result> method within the User proxy-class
-gives us the effect we want. This method is called by
-L<DBIx::Class::ResultSet> when inflating a result from storage. So we
-grab the object being returned, inspect the values we are looking for,
-bless it if it's an admin object, and then return it. See the example
-below:
-
-B<Schema Definition>
-
- package DB::Schema;
-
- use base qw/DBIx::Class::Schema/;
-
- __PACKAGE__->load_classes(qw/User/);
-
-
-B<Proxy-Class definitions>
-
- package DB::Schema::User;
-
- use strict;
- use warnings;
- use base qw/DBIx::Class/;
-
- ### Defined what our admin class is for ensure_class_loaded
- my $admin_class = __PACKAGE__ . '::Admin';
-
- __PACKAGE__->load_components(qw/Core/);
-
- __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 {
- print "I am a regular user.\n";
- return ;
- }
-
-
- package DB::Schema::User::Admin;
-
- use strict;
- use warnings;
- use base qw/DB::Schema::User/;
-
- sub hello
- {
- print "I am an admin.\n";
- return;
- }
-
- sub do_admin_stuff
- {
- print "I am doing admin stuff\n";
- return ;
- }
-
-B<Test File> test.pl
-
- use warnings;
- use strict;
- use DB::Schema;
-
- my $user_data = { email => 'someguy@place.com',
- password => 'pass1',
- admin => 0 };
-
- my $admin_data = { email => 'someadmin@adminplace.com',
- password => 'pass2',
- admin => 1 };
-
- my $schema = DB::Schema->connection('dbi:Pg:dbname=test');
-
- $schema->resultset('User')->create( $user_data );
- $schema->resultset('User')->create( $admin_data );
-
- ### Now we search for them
- my $user = $schema->resultset('User')->single( $user_data );
- my $admin = $schema->resultset('User')->single( $admin_data );
-
- print ref $user, "\n";
- print ref $admin, "\n";
-
- print $user->password , "\n"; # pass1
- print $admin->password , "\n";# pass2; inherited from User
- print $user->hello , "\n";# I am a regular user.
- print $admin->hello, "\n";# I am an admin.
-
- ### The statement below will NOT print
- print "I can do admin stuff\n" if $user->can('do_admin_stuff');
- ### The statement below will print
- print "I can do admin stuff\n" if $admin->can('do_admin_stuff');
-
-=head2 Skip object creation for faster results
-
-DBIx::Class is not built for speed, it's built for convenience and
-ease of use, but sometimes you just need to get the data, and skip the
-fancy objects. Luckily this is also fairly easy using
-C<inflate_result>:
-
- # Define a class which just returns the results as a hashref:
- package My::HashRefInflator;
-
- ## $me is the hashref of cols/data from the immediate resultsource
- ## $prefetch is a deep hashref of all the data from the prefetched
- ## related sources.
-
- sub mk_hash {
- my ($me, $rest) = @_;
-
- return { %$me,
- map { ($_ => mk_hash(@{$rest->{$_}})) } keys %$rest
- };
- }
-
- sub inflate_result {
- my ($self, $source, $me, $prefetch) = @_;
- return mk_hash($me, $prefetch);
- }
-
- # Change the object inflation to a hashref for just this resultset:
- $rs->result_class('My::HashRefInflator');
-
- my $datahashref = $rs->next;
- foreach my $col (keys %$datahashref) {
- if(!ref($datahashref->{$col})) {
- # It's a plain value
- }
- elsif(ref($datahashref->{$col} eq 'HASH')) {
- # It's a related value in a hashref
- }
- }
-
-=head2 Want to know if find_or_create found or created a row?
-
-Just use C<find_or_new> instead, then check C<in_storage>:
-
- my $obj = $rs->find_or_new({ blah => 'blarg' });
- unless ($obj->in_storage) {
- $obj->insert;
- # do whatever else you wanted if it was a new row
- }
=cut
my $interval = "now() - interval '12 hours'";
->search({last_attempt => { '<' => \$interval } })
+=item .. search with an SQL function on the left hand side?
+
+To use an SQL function on the left hand side of a comparison:
+
+ ->search({}, { where => \'YEAR(date_of_birth)=1979' });
+
+=begin hidden
+
+(When the bind arg ordering bug is fixed, the previous example can be
+replaced with the following.)
+
+ ->search({}, { where => \'YEAR(date_of_birth)=?', bind => [ 1979 ] });
+
+=end hidden
+
+Or, if you have quoting off:
+
+ ->search({ 'YEAR(date_of_birth' => 1979 });
+
=item .. find more help on constructing searches?
Behind the scenes, DBIx::Class uses L<SQL::Abstract> to help construct
L<DBIx::Class::ResultSetColumn>, see it's documentation and the
L<Cookbook|DBIx::Class::Manual::Cookbook> for details.
+=item .. fetch a formatted column?
+
+In your table schema class, create a "private" column accessor with:
+
+ __PACKAGE__->add_columns(my_column => { accessor => '_hidden_my_column' });
+
+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.
+
+=item .. fetch a single (or topmost) row?
+
+Sometimes you many only want a single record back from a search. A quick
+way to get that single row is to first run your search as usual:
+
+ ->search->(undef, { order_by => "id DESC" })
+
+Then call L<DBIx::Class::ResultSet/slice> and ask it only to return 1 row:
+
+ ->slice(0,1)
+
+These two calls can be combined into a single statement:
+
+ ->search->(undef, { order_by => "id DESC" })->slice(0,1)
+
+Why slice instead of L<DBIx::Class::ResultSet/first> or L<DBIx::Class::ResultSet/single>?
+If supported by the database, slice will use LIMIT/OFFSET to hint to the database that we
+really only need one row. This can result in a significant speed improvement.
+
+=item .. refresh a row from storage?
+
+Use L<DBIx::Class::PK/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
+using the row's primary key.
+
=back
=head2 Inserting and updating data
inserted key, you can tell it the name of the sequence in the
C<column_info> supplied with C<add_columns>.
- ->add_columns({ id => { sequence => 'mysequence' } });
+ ->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
=item .. insert many rows of data efficiently?
->update({ somecolumn => \'othercolumn' })
+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.
+
+ ->somecolumn()
+
+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:
+
+ ->update->discard_changes
+
+ to update the database and refresh the object in one step.
+
+=item .. store JSON/YAML in a column and have it deflate/inflate automatically?
+
+You can use L<DBIx::Class::InflateColumn> to accomplish YAML/JSON storage transparently.
+
+If you want to use JSON, then in your table schema class, do the following:
+
+ use JSON;
+
+ __PACKAGE__->add_columns(qw/ ... my_column ../)
+ __PACKAGE__->inflate_column('my_column', {
+ inflate => sub { jsonToObj(shift) },
+ deflate => sub { objToJson(shift) },
+ });
+
+For YAML, in your table schema class, do the following:
+
+ use YAML;
+
+ __PACKAGE__->add_columns(qw/ ... my_column ../)
+ __PACKAGE__->inflate_column('my_column', {
+ inflate => sub { YAML::Load(shift) },
+ deflate => sub { YAML::Dump(shift) },
+ });
+
+This technique is an easy way to store supplemental unstructured data in a table. Be
+careful not to overuse this capability, however. If you find yourself depending more
+and more on some data within the inflated column, then it may be time to factor that
+data out.
+
=back
=head2 Misc
search again or relationship accessors. The SQL query is only run when
you ask the resultset for an actual row object.
+=item How do I deal with tables that lack a primary key?
+
+If your table lacks a primary key, DBIx::Class can't work out which row
+it should operate on, for example to delete or update. However, a
+UNIQUE constraint on one or more columns allows DBIx::Class to uniquely
+identify the row, so you can tell L<DBIx::Class::ResultSource> these
+columns act as a primary key, even if they don't from the database's
+point of view:
+
+ $resultset->set_primary_key(@column);
+
=back
=head2 Notes for CDBI users
particular column or group of columns (a-la cdbi Stringfy column
group, or stringify_self method) ?
-See L<Cookbook/Stringification>
+See L<DBIx::Class::Manual::Cookbook/Stringification>
=back
=head1 INTRODUCTION
-So, you are bored with SQL, and want a native Perl interface for your
-database? Or you've been doing this for a while with L<Class::DBI>,
-and think there's a better way? You've come to the right place.
+You're bored with SQL, and want a native Perl interface for your database? Or
+you've been doing this for a while with L<Class::DBI>, and think there's a
+better way? You've come to the right place.
=head1 THE DBIx::Class WAY
-Here are a few simple tips that will help you get your bearings
-with DBIx::Class.
+Here are a few simple tips that will help you get your bearings with
+DBIx::Class.
-=head2 Tables become ResultSources
+=head2 Tables become Result classes
+
+DBIx::Class needs to know what your Table structure looks like. You
+do that by defining Result classes. Result classes are defined by
+calling methods proxied to L<DBIx::Class::ResultSource>. Each Result
+class defines one Table, which defines the Columns it has, along with
+any Relationships it has to other tables. (And oh, so much more
+besides) The important thing to understand:
+
+ A Result class == Table
-DBIx::Class needs to know what your Table structure looks like. You do that
-by defining L<DBIx::Class::ResultSource>s. Each table get's a ResultSource,
-which defines the Columns it has, along with any Relationships it has to
-other tables. (And oh, so much more besides) The important thing to
-understand:
-
- A ResultSource == Table
-
(most of the time, but just bear with my simplification)
=head2 It's all about the ResultSet
-So, we've got some ResultSources defined. Now, we want to actually use
-those definitions to help us translate the queries we need into
-handy perl objects!
+So, we've got some ResultSources defined. Now, we want to actually use those
+definitions to help us translate the queries we need into handy perl objects!
+
+Let's say we defined a ResultSource for an "album" table with three columns:
+"albumid", "artist", and "title". Any time we want to query this table, we'll
+be creating a L<DBIx::Class::ResultSet> from its ResultSource. For example, the
+results of:
-Let's say we defined a ResultSource for an "album" table with three
-columns: "albumid", "artist", and "title". Any time we want to query
-this table, we'll be creating a L<DBIx::Class::ResultSet> from it's
-ResultSource. For example, the results of:
+ SELECT albumid, artist, title FROM album;
- SELECT albumid, artist, title FROM album;
-
-Would be retrieved by creating a ResultSet object from the album
-table's ResultSource, likely by using the "search" method.
+Would be retrieved by creating a ResultSet object from the album table's
+ResultSource, likely by using the "search" method.
-DBIx::Class doesn't limit you to creating only simple ResultSets --
-if you wanted to do something like:
+DBIx::Class doesn't limit you to creating only simple ResultSets -- if you
+wanted to do something like:
+
+ SELECT title FROM album GROUP BY title;
- SELECT title FROM album GROUP BY title;
-
You could easily achieve it.
The important thing to understand:
- Any time you would reach for a SQL query in DBI, you are
- creating a DBIx::Class::ResultSet.
+ Any time you would reach for a SQL query in DBI, you are
+ creating a DBIx::Class::ResultSet.
=head2 Search is like "prepare"
-DBIx::Class tends to wait until it absolutely must fetch information
-from the database. If you are returning a ResultSet, the query won't
-execute until you use a method that wants to access the data. (Such
-as "next", or "first")
+DBIx::Class tends to wait until it absolutely must fetch information from the
+database. If you are returning a ResultSet, the query won't execute until you
+use a method that wants to access the data. (Such as "next", or "first")
The important thing to understand:
- Setting up a ResultSet does not execute the query; retrieving
- the data does.
+ Setting up a ResultSet does not execute the query; retrieving
+ the data does.
+
+=head2 Search results are returned as Rows
+
+Rows of the search from the database are blessed into
+L<DBIx::Class::Row> objects.
=head1 SETTING UP DBIx::Class
-Let's look at how you can set and use your first native L<DBIx::Class>
-tree.
+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 L<DBIx::Class::Schema::Loader>.
+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
+L<DBIx::Class::Schema::Loader>.
=head2 Setting it up manually
package My::Schema;
use base qw/DBIx::Class::Schema/;
-In this class you load your result_source ("table", "model") classes, which
-we will define later, using the load_classes() method. You can specify which
+In this class you load your result_source ("table", "model") classes, which we
+will define later, using the load_classes() method. You can specify which
classes to load manually:
# load My::Schema::Album and My::Schema::Artist
__PACKAGE__->load_components(qw/ PK::Auto Core /);
-C<PK::Auto> is supported for many databases; see
-L<DBIx::Class::Storage::DBI> for more information.
+C<PK::Auto> is supported for many databases; see L<DBIx::Class::Storage::DBI>
+for more information.
Set the table for your class:
__PACKAGE__->add_columns(qw/ albumid artist title /);
-Each column can also be set up with its own accessor, data_type and other
-pieces of information that it may be useful to have, just pass C<add_columns>
-a hash such as:
+Each column can also be set up with its own accessor, data_type and other pieces
+of information that it may be useful to have -- just pass C<add_columns> a hash:
__PACKAGE__->add_columns(albumid =>
{ accessor => 'album',
}
);
-Most of this data isn't yet used directly by DBIx::Class, but various related
-modules such as L<DBIx::Class::WebForm> make use of it. Also it allows you
-to create your database tables from your Schema, instead of the other way
-around. See L<SQL::Translator> for details.
+DBIx::Class doesn't directly use most of this data yet, but various related
+modules such as L<DBIx::Class::WebForm> make use of it. Also it allows you to
+create your database tables from your Schema, instead of the other way around.
+See L<SQL::Translator> for details.
See L<DBIx::Class::ResultSource> for more details of the possible column
attributes.
__PACKAGE__->set_primary_key( qw/ albumid artistid / );
-Define relationships that the class has with any other classes by using
-either C<belongs_to> to describe a column which contains an ID of another
-table, or C<has_many> to make a predefined accessor for fetching objects
-that contain this tables foreign key in one of their columns:
+Define this class' relationships with other classes using either C<belongs_to>
+to describe a column which contains an ID of another Table, or C<has_many> to
+make a predefined accessor for fetching objects that contain this Table's
+foreign key:
__PACKAGE__->has_many('albums', 'My::Schema::Artist', 'album_id');
-More information about the various types of relationships available, and
-how you can design your own, can be found in L<DBIx::Class::Relationship>.
+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>
-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 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:
package My::Schema;
use base qw/DBIx::Class::Schema::Loader/;
1;
-The actual autoloading process will occur when you create a connected
-instance of your schema below.
+The actual autoloading process will occur when you create a connected instance
+of your schema below.
-L<DBIx::Class::Schema::Loader> takes lots of other options. For more
-information, consult its documentation.
+See the L<DBIx::Class::Schema::Loader> documentation for more information on its
+many options.
=head2 Connecting
-To connect to your Schema, you also need to provide the connection details.
-The arguments are the same as you would use for L<DBI/connect>:
+To connect to your Schema, you need to provide the connection details. The
+arguments are the same as for L<DBI/connect>:
my $schema = My::Schema->connect('dbi:SQLite:/home/me/myapp/my.db');
-You can create as many different schema instances as you need. So if you have
-a second database you want to access:
+You can create as many different schema instances as you need. So if you have a
+second database you want to access:
my $other_schema = My::Schema->connect( $dsn, $user, $password, $attrs );
-Note that L<DBIx::Class::Schema> does not cache connections for you. If you
-use multiple connections, you need to do this manually.
+Note that L<DBIx::Class::Schema> does not cache connections for you. If you use
+multiple connections, you need to do this manually.
-To execute some sql statements on every connect you can add them as an option
-in a special fifth argument to connect, like so:
+To execute some sql statements on every connect you can add them as an option in
+a special fifth argument to connect:
my $another_schema = My::Schema->connect(
$dsn,
{ on_connect_do => \@on_connect_sql_statments }
);
-For more information about this and other special C<connect()>-time options,
-see L<DBIx::Class::Schema::Storage::DBI/connect_info>.
+See L<DBIx::Class::Schema::Storage::DBI/connect_info> for more information about
+this and other special C<connect>-time options.
=head2 Basic usage
Once you've defined the basic classes, either manually or using
L<DBIx::Class::Schema::Loader>, you can start interacting with your database.
-To access your database using your $schema object, you can fetch a L<DBIx::Class::Manual::Glossary/"ResultSet">
-representing each of your tables by calling the ->resultset method.
+To access your database using your $schema object, you can fetch a
+L<DBIx::Class::Manual::Glossary/"ResultSet"> representing each of your tables by
+calling the C<resultset> method.
The simplest way to get a record is by primary key:
my $album = $schema->resultset('Album')->find(14);
-This will run a C<SELECT> with C<albumid = 14> in the C<WHERE> clause,
-and return an instance of C<My::Schema::Album> that represents this
-row. Once you have that row, you can access and update columns:
+This will run a C<SELECT> with C<albumid = 14> in the C<WHERE> clause, and
+return an instance of C<My::Schema::Album> that represents this row. Once you
+have that row, you can access and update columns:
$album->title('Physical Graffiti');
my $title = $album->title; # $title holds 'Physical Graffiti'
-If you prefer, you can use the C<set_column> and C<get_column>
-accessors instead:
+If you prefer, you can use the C<set_column> and C<get_column> accessors
+instead:
$album->set_column('title', 'Presence');
$title = $album->get_column('title');
-Just like with L<Class::DBI>, you call C<update> to commit your
-changes to the database:
+Just like with L<Class::DBI>, you call C<update> to commit your changes to the
+database:
$album->update;
-If needed, you can throw away your local changes like this:
+If needed, you can throw away your local changes:
$album->discard_changes if $album->is_changed;
-As you can see, C<is_changed> allows you to check if there are local
-changes to your object.
+As you can see, C<is_changed> allows you to check if there are local changes to
+your object.
=head2 Adding and removing rows
-To create a new record in the database, you can use the C<create>
-method. It returns an instance of C<My::Schema::Album> that can be
-used to access the data in the new record:
+To create a new record in the database, you can use the C<create> method. It
+returns an instance of C<My::Schema::Album> that can be used to access the data
+in the new record:
my $new_album = $schema->resultset('Album')->create({
title => 'Wish You Were Here',
$new_album->year('1975');
$new_album->update;
-Likewise, you can remove it from the database like this:
+Likewise, you can remove it from the database:
$new_album->delete;
-You can also remove records without retrieving them first, by calling
-delete directly on a ResultSet object.
+You can also remove records without retrieving them first, by calling delete
+directly on a ResultSet object.
# Delete all of Falco's albums
$schema->resultset('Album')->search({ artist => 'Falco' })->delete;
=head2 Finding your objects
-L<DBIx::Class> provides a few different ways to retrieve data from
-your database. Here's one example:
+L<DBIx::Class> provides a few different ways to retrieve data from your
+database. Here's one example:
# Find all of Santana's albums
my $rs = $schema->resultset('Album')->search({ artist => 'Santana' });
-In scalar context, as above, C<search> returns a
-L<DBIx::Class::ResultSet> object. It can be used to peek at the first
-album returned by the database:
+In scalar context, as above, C<search> returns a L<DBIx::Class::ResultSet>
+object. It can be used to peek at the first album returned by the database:
my $album = $rs->first;
print $album->title;
$rs->update({ year => 2001 });
-For more information on what you can do with a
-L<DBIx::Class::ResultSet>, see L<DBIx::Class::ResultSet/METHODS>.
-
-In list context, the C<search> method returns all of the matching
-rows:
+In list context, the C<search> method returns all of the matching rows:
# Fetch immediately all of Carlos Santana's albums
my @albums = $schema->resultset('Album')->search(
# Find albums whose artist starts with 'Jimi'
my $rs = $schema->resultset('Album')->search_like({ artist => 'Jimi%' });
-Or you can provide your own C<WHERE> clause, like:
+Or you can provide your own C<WHERE> clause:
# Find Peter Frampton albums from the year 1986
my $where = 'artist = ? AND year = ?';
my @bind = ( 'Peter Frampton', 1986 );
my $rs = $schema->resultset('Album')->search_literal( $where, @bind );
-The preferred way to generate complex queries is to provide a
-L<SQL::Abstract> construct to C<search>:
+The preferred way to generate complex queries is to provide a L<SQL::Abstract>
+construct to C<search>:
my $rs = $schema->resultset('Album')->search({
artist => { '!=', 'Janis Joplin' },
year => { '<' => 1980 },
- albumid => [ 1, 14, 15, 65, 43 ]
+ albumid => { '-in' => [ 1, 14, 15, 65, 43 ] }
});
This results in something like the following C<WHERE> clause:
AND year < 1980
AND albumid IN (1, 14, 15, 65, 43)
-For more examples of complex queries, see
-L<DBIx::Class::Manual::Cookbook>.
+For more examples of complex queries, see L<DBIx::Class::Manual::Cookbook>.
The search can also be modified by passing another hash with
attributes:
C<@albums> then holds the two most recent Bob Marley albums.
+For more information on what you can do with a L<DBIx::Class::ResultSet>, see
+L<DBIx::Class::ResultSet/METHODS>.
+
For a complete overview of the available attributes, see
L<DBIx::Class::ResultSet/ATTRIBUTES>.
+=head1 NOTES
+
+=head2 Problems on RHEL5/CentOS5
+
+There is a problem with slow performance of certain DBIx::Class operations in
+perl-5.8.8-10 and later on RedHat and related systems, due to a bad backport of
+a "use overload" related bug. The problem is in the Perl binary itself, not in
+DBIx::Class. If your system has this problem, you will see a warning on
+startup, with some options as to what to do about it.
+
=head1 SEE ALSO
=over 4
--- /dev/null
+=head1 NAME
+
+DBIx::Class::Manual::Joining - Manual on joining tables with DBIx::Class
+
+=head1 DESCRIPTION
+
+This document should help you to use L<DBIx::Class> if you are trying
+to convert your normal SQL queries into DBIx::Class based queries, if
+you use joins extensively (and also probably if you don't).
+
+=head1 WHAT ARE JOINS
+
+If you ended up here and you don't actually know what joins are yet,
+then you should likely try the L<DBIx::Class::Manual::Intro>
+instead. Skip this part if you know what joins are..
+
+But I'll explain anyway. Assuming you have created your database in a
+more or less sensible way, you will end up with several tables that
+contain C<related> information. For example, you may have a table
+containing information about C<CDs>, containing the CD title and it's
+year of publication, and another table containing all the C<Track>s
+for the CDs, one track per row.
+
+When you wish to extract information about a particular CD and all
+it's tracks, You can either fetch the CD row, then make another query
+to fetch the tracks, or you can use a join. Compare:
+
+ SELECT ID, Title, Year FROM CD WHERE Title = 'Funky CD';
+ # .. Extract the ID, which is 10
+ SELECT Name, Artist FROM Tracks WHERE CDID = 10;
+
+ SELECT cd.ID, cd.Title, cd.Year, tracks.Name, tracks.Artist FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD';
+
+So, joins are a way of extending simple select statements to include
+fields from other, related, tables. There are various types of joins,
+depending on which combination of the data you wish to retrieve, see
+L<MySQL's doc on JOINs|http://dev.mysql.com/doc/refman/5.0/en/join.html>.
+
+=head1 DEFINING JOINS AND RELATIONSHIPS
+
+In L<DBIx::Class> each relationship between two tables needs to first
+be defined in the L<ResultSource|DBIx::Class::Manual::Glossary/ResultSource> for the
+table. If the relationship needs to be accessed in both directions
+(i.e. Fetch all tracks of a CD, and fetch the CD data for a Track),
+then it needs to be defined in both tables.
+
+For the CDs/Tracks example, that means writing, in C<MySchema::CD>:
+
+ MySchema::CD->has_many('tracks', 'MySchema::Tracks');
+
+And in C<MySchema::Tracks>:
+
+ MySchema::Tracks->belongs_to('cd', 'MySchema::CD', 'CDID');
+
+There are several other types of relationships, they are more
+comprehensively described in L<DBIx::Class::Relationship>.
+
+=head1 USING JOINS
+
+Once you have defined all your relationships, using them in actual
+joins is fairly simple. The type of relationship that you chose
+e.g. C<has_many>, already indicates what sort of join will be
+performed. C<has_many> produces a C<LEFT JOIN> for example, which will
+fetch all the rows on the left side, whether there are matching rows
+on the right (table being joined to), or not. You can force other
+types of joins in your relationship, see the
+L<DBIx::Class::Relationship> docs.
+
+When performing either a L<search|DBIx::Class::ResultSet/search> or a
+L<find|DBIx::Class::ResultSet/find> operation, you can specify which
+C<relations> to also fetch data from (or sort by), using the
+L<join|DBIx::Class::ResultSet/join> attribute, like this:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD' },
+ { join => 'tracks',
+ '+select' => [ 'tracks.Name', 'tracks.Artist' ],
+ '+as' => [ 'TrackName', 'ArtistName' ]
+ }
+ );
+
+If you don't recognise most of this syntax, you should probably go
+read L<DBIx::Class::ResultSet/search> and
+L<DBIx::Class::ResultSet/ATTRIBUTES>, but here's a quick break down:
+
+The first argument to search is a hashref of the WHERE attributes, in
+this case a simple restriction on the Title column. The second
+argument is a hashref of attributes to the search, '+select' adds
+extra columns to the select (from the joined table(s) or from
+calculations), and '+as' gives aliases to those fields.
+
+'join' specifies which C<relationships> to include in the query. The
+distinction between C<relationships> and C<tables> is important here,
+only the C<relationship> names are valid.
+
+This example should magically produce SQL like the second select in
+L</WHAT ARE JOINS> above.
+
+=head1 COMPLEX JOINS AND STUFF
+
+=head2 Across multiple relations
+
+For simplicity in the example above, the C<Artist> was shown as a
+simple text field in the C<Tracks> table, in reality, you'll want to
+have the artists in their own table as well, thus to fetch the
+complete set of data we'll need to join to the Artist table too.
+
+In C<MySchema::Tracks>:
+
+ MySchema::Tracks->belongs_to('artist', 'MySchema::Artist', 'ArtistID');
+
+The search:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD' },
+ { join => { 'tracks' => 'artist' },
+ '+select' => [ 'tracks.Name', 'artist.Artist' ],
+ '+as' => [ 'TrackName', 'ArtistName' ]
+ }
+ );
+
+Which is:
+
+ SELECT me.ID, me.Title, me.Year, tracks.Name, artist.Artist FROM CD me JOIN Tracks tracks ON CD.ID = tracks.CDID JOIN Artists artist ON tracks.ArtistID = artist.ID WHERE me.Title = 'Funky CD';
+
+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!):
+
+ join => { room => { table => 'leg' } }
+
+To join two relations at the same level, use an arrayref instead:
+
+ join => { room => [ 'chair', 'table' ] }
+
+Or combine the two:
+
+ join => { room => [ 'chair', { table => 'leg' } ]
+
+=head2 Table aliases
+
+As an aside to all the discussion on joins, note that L<DBIx::Class>
+uses the C<relation names> as table aliases. This is important when
+you need to add grouping or ordering to your queries:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD' },
+ { join => { 'tracks' => 'artist' },
+ order_by => [ 'tracks.Name', 'artist.Artist' ],
+ '+select' => [ 'tracks.Name', 'artist.Artist' ],
+ '+as' => [ 'TrackName', 'ArtistName' ]
+ }
+ );
+
+ SELECT me.ID, me.Title, me.Year, tracks.Name, artist.Artist FROM CD me JOIN Tracks tracks ON CD.ID = tracks.CDID JOIN Artists artist ON tracks.ArtistID = artist.ID WHERE me.Title = 'Funky CD' ORDER BY tracks.Name, artist.Artist;
+
+This is essential if any of your tables have columns with the same names.
+
+Note that the table of the resultsource the search was performed on, is always aliased to C<me>.
+
+=head2 Joining to the same table twice
+
+There is no magic to this, just do it. The table aliases will
+automatically be numbered:
+
+ join => [ 'room', 'room' ]
+
+The aliases are: C<room> and C<room_2>.
+
+=cut
+
--- /dev/null
+
+=head1 NAME
+
+DBIx::Class::Manual::Reading - How to read and write DBIx::Class POD.
+
+=head1 DESCRIPTION
+
+This doc should help users to understand how the examples and
+documentation found in the L<DBIx::Class> distribution can be
+interpreted.
+
+Writers of DBIx::Class POD should also check here to make sure their
+additions are consistent with the rest of the documentation.
+
+=head1 METHODS
+
+Methods should be documented in the files which also contain the code
+for the method, or that file should be hidden from PAUSE completely,
+in which case the methods are documented in the file which loads
+it. Methods may also be documented and refered to in files
+representing the major objects or components on which they can be
+called.
+
+For example, L<DBIx::Class::Relationship> documents the methods
+actually coded in the helper relationship classes like
+DBIx::Class::Relationship::BelongsTo. The BelongsTo file itself is
+hidden from pause as it has no documentation. The accessors created by
+relationships should be mentioned in L<DBIx::Class::Row>, the major
+object that they will be called on.
+
+=head2 Method documentation
+
+=over
+
+=item *
+
+Each method starts with a "head2" statement of it's name.
+
+=item *
+
+The header is followed by a one-item list.
+
+The single item provides a list of all possible values for the
+arguments of the method in order, separated by C<, >, preceeded by the
+text "Arguments: "
+
+Example (for the belongs_to relationship):
+
+ =item Arguments: $accessor_name, $related_class, $fk_column|\%cond|\@cond?, \%attr?
+
+The following possible argument sigils can be shown:
+
+=over
+
+=item *
+
+$var - A scalar (string or numeric) variable.
+
+=item *
+
+\%var - A variable containing reference to a hash.
+
+=item *
+
+\@var - A variable containing a reference to an array.
+
+=item *
+
+\$var - A variable containing a reference to a scalar variable.
+
+=item *
+
+? - Optional, should be placed after the argument type and name.
+
+=item *
+
+| - Alternate argument types.
+
+=back
+
+NOTES:
+
+If several arguments are optional, it is always possible to pass
+C<undef> as one optional argument in order to skip it and provide a
+value for the following ones. This does not need to be indicated in
+the Arguments line, it is assumed.
+
+The C<?> for optional arguments always applies to the entire argument
+value, not a particular type or argument.
+
+=item *
+
+The argument list is followed by a single paragraph describing what
+the method does.
+
+=item *
+
+The description paragraph is followed by another list. Each item in
+the list explains one of the possible argument/type combinations.
+
+=item *
+
+The argument list is followed by some examples of how to use the
+method, using it's various types of arguments.
+
+The examples can also include ways to use the results if
+applicable. For instance if the documentation is for a relationship
+type, the examples can include how to call the resulting relation
+accessor, how to use the relation name in a search and so on.
+
+If some of the examples assume default values, these should be shown
+with and without the actual arguments, with hints about the equivalent
+calls.
+
+The example should be followed by one or more paragraphs explaining
+what it does.
+
+Examples and explaining paragraphs can be repeated as necessary.
+
+=back
+
+=head1 AUTHORS
+
+see L<DBIx::Class>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+
L<DBI> version 1.50 and L<DBD::Pg> 1.43 are known to work.
+=head2 ... Can't locate object method "source_name" via package ...
+
+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, so for a schema C< MySchema > you need to
+specify a fully qualified namespace: C< package MySchema::MyTable; >
+for example.
+
+=head2 syntax error at or near "<something>" ...
+
+This can happen if you have a relation whose name is a word reserved by your
+database, e.g. "user":
+
+ package My::Schema::User;
+ ...
+ __PACKAGE__->table('users');
+ __PACKAGE__->add_columns(qw/ id name /);
+ __PACKAGE__->set_primary_key('id');
+ ...
+ 1;
+
+ package My::Schema::ACL;
+ ...
+ __PACKAGE__->table('acl');
+ __PACKAGE__->add_columns(qw/ user_id /);
+ __PACKAGE__->belongs_to( 'user' => 'My::Schema::User', 'user_id' );
+ ...
+ 1;
+
+ $schema->resultset('ACL')->search(
+ {},
+ {
+ join => [qw/ user /],
+ '+select' => [ 'user.name' ]
+ }
+ );
+
+The SQL generated would resemble something like:
+
+ SELECT me.user_id, user.name FROM acl me
+ JOIN users user ON me.user_id = user.id
+
+If, as is likely, your database treats "user" as a reserved word, you'd end
+up with the following errors:
+
+1) syntax error at or near "." - due to "user.name" in the SELECT clause
+
+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
+details.
+
+Note that quoting may lead to problems with C<order_by> clauses, see
+L<... column "foo DESC" does not exist ...> for info on avoiding those.
+
+=head2 column "foo DESC" does not exist ...
+
+This can happen if you've turned on quoting and then done something like
+this:
+
+ $rs->search( {}, { order_by => [ 'name DESC' ] } );
+
+This results in SQL like this:
+
+ ... ORDER BY "name DESC"
+
+The solution is to pass your order_by items as scalar references to avoid
+quoting:
+
+ $rs->search( {}, { order_by => [ \'name DESC' ] } );
+
+Now you'll get SQL like this:
+
+ ... ORDER BY name DESC
+
=cut
name TEXT NOT NULL,
position INTEGER NOT NULL
);
- # Optional: group_id INTEGER NOT NULL
-In your Schema or DB class add Ordered to the top
+Optionally, add one or more columns to specify groupings, allowing you
+to maintain independent ordered lists within one table:
+
+ CREATE TABLE items (
+ item_id INTEGER PRIMARY KEY AUTOINCREMENT,
+ name TEXT NOT NULL,
+ position INTEGER NOT NULL,
+ group_id INTEGER NOT NULL
+ );
+
+Or even
+
+ CREATE TABLE items (
+ item_id INTEGER PRIMARY KEY AUTOINCREMENT,
+ name TEXT NOT NULL,
+ position INTEGER NOT NULL,
+ group_id INTEGER NOT NULL,
+ other_group_id INTEGER NOT NULL
+ );
+
+In your Schema or DB class add "Ordered" to the top
of the component list.
__PACKAGE__->load_components(qw( Ordered ... ));
package My::Item;
__PACKAGE__->position_column('position');
- __PACKAGE__->grouping_column('group_id'); # optional
-Thats it, now you can change the position of your objects.
+If you are using one grouping column, specify it as follows:
+
+ __PACKAGE__->grouping_column('group_id');
+
+Or if you have multiple grouping columns:
+
+ __PACKAGE__->grouping_column(['group_id', 'other_group_id']);
+
+That's it, now you can change the position of your objects.
#!/use/bin/perl
use My::Item;
$item->move_first();
$item->move_last();
$item->move_to( $position );
+ $item->move_to_group( 'groupname' );
+ $item->move_to_group( 'groupname', $position );
+ $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'} );
+ $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'}, $position );
=head1 DESCRIPTION
__PACKAGE__->position_column('position');
Sets and retrieves the name of the column that stores the
-positional value of each record. Default to "position".
+positional value of each record. Defaults to "position".
=cut
__PACKAGE__->grouping_column('group_id');
-This method specified a column to limit all queries in
+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.
my $rs = $item->siblings();
my @siblings = $item->siblings();
-Returns either a result set or an array of all other objects
+Returns either a resultset or an array of all other objects
excluding the one you called it on.
=cut
my $sibling = $item->first_sibling();
Returns the first sibling object, or 0 if the first sibling
-is this sibliing.
+is this sibling.
=cut
sub first_sibling {
my( $self ) = @_;
return 0 if ($self->get_column($self->position_column())==1);
+
return ($self->result_source->resultset->search(
{
$self->position_column => 1,
my $sibling = $item->last_sibling();
-Return 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 $sibling = $item->previous_sibling();
-Returns the sibling that resides one position back. Undef
-is returned if the current object is the first one.
+Returns the sibling that resides one position back. Returns undef
+if the current object is the first one.
=cut
my $sibling = $item->next_sibling();
-Returns the sibling that resides one position foward. Undef
-is returned if the current object is the last one.
+Returns the sibling that resides one position forward. Returns undef
+if the current object is the last one.
=cut
$item->move_previous();
-Swaps position with the sibling on position previous in the list.
-1 is returned on success, and 0 is returned if the objects is already
-the first one.
+Swaps position with the sibling in the position previous in
+the list. Returns 1 on success, and 0 if the object is
+already the first one.
=cut
$item->move_next();
-Swaps position with the sibling in the next position. 1 is returned on
-success, and 0 is returned if the object is already the last in the list.
+Swaps position with the sibling in the next position in the
+list. Returns 1 on success, and 0 if the object is already
+the last in the list.
=cut
$item->move_first();
-Moves the object to the first position. 1 is returned on
-success, and 0 is returned if the object is already the first.
+Moves the object to the first position in the list. Returns 1
+on success, and 0 if the object is already the first.
=cut
$item->move_last();
-Moves the object to the very last position. 1 is returned on
-success, and 0 is returned if the object is already the last one.
+Moves the object to the last position in the list. Returns 1
+on success, and 0 if the object is already the last one.
=cut
$item->move_to( $position );
-Moves the object to the specified position. 1 is returned on
-success, and 0 is returned if the object is already at the
-specified position.
+Moves the object to the specified position. Returns 1 on
+success, and 0 if the object is already at the specified
+position.
=cut
$self->_grouping_clause(),
});
my $op = ($from_position>$to_position) ? '+' : '-';
- $rs->update({ $position_column => \"$position_column $op 1" });
+ $rs->update({ $position_column => \"$position_column $op 1" }); #" Sorry, GEdit bug
+ $self->{_ORDERED_INTERNAL_UPDATE} = 1;
$self->update({ $position_column => $to_position });
return 1;
}
+
+
+=head2 move_to_group
+
+ $item->move_to_group( $group, $position );
+
+Moves the object to the specified position of the specified
+group, or to the end of the group if $position is undef.
+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
+grouping column is in use, or as a hashref of column => value pairs
+if multiple grouping columns are in use.
+
+=cut
+
+sub move_to_group {
+ my( $self, $to_group, $to_position ) = @_;
+
+ # if we're given a string, turn it into a hashref
+ unless (ref $to_group eq 'HASH') {
+ $to_group = {($self->_grouping_columns)[0] => $to_group};
+ }
+
+ my $position_column = $self->position_column;
+ #my @grouping_columns = $self->_grouping_columns;
+
+ return 0 if ( ! defined($to_group) );
+ return 0 if ( defined($to_position) and $to_position < 1 );
+ return 0 if ( $self->_is_in_group($to_group)
+ and ((not defined($to_position))
+ or (defined($to_position) and $self->$position_column==$to_position)
+ )
+ );
+
+ # Move to end of current group and adjust siblings
+ $self->move_last;
+
+ $self->set_columns($to_group);
+ my $new_group_count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
+ if (!defined($to_position) or $to_position > $new_group_count) {
+ $self->{_ORDERED_INTERNAL_UPDATE} = 1;
+ $self->update({ $position_column => $new_group_count + 1 });
+ }
+ else {
+ my @between = ($to_position, $new_group_count);
+
+ my $rs = $self->result_source->resultset->search({
+ $position_column => { -between => [ @between ] },
+ $self->_grouping_clause(),
+ });
+ $rs->update({ $position_column => \"$position_column + 1" }); #"
+ $self->{_ORDERED_INTERNAL_UPDATE} = 1;
+ $self->update({ $position_column => $to_position });
+ }
+
+ return 1;
+}
+
=head2 insert
Overrides the DBIC insert() method by providing a default
return $self->next::method( @_ );
}
+=head2 update
+
+Overrides the DBIC update() method by checking for a change
+to the position and/or group columns. Movement within a
+group or to another group is handled by repositioning
+the appropriate siblings. Position defaults to the end
+of a new group if it has been changed to undef.
+
+=cut
+
+sub update {
+ my $self = shift;
+
+ if ($self->{_ORDERED_INTERNAL_UPDATE}) {
+ delete $self->{_ORDERED_INTERNAL_UPDATE};
+ return $self->next::method( @_ );
+ }
+
+ $self->set_columns($_[0]) if @_ > 0;
+ my %changes = $self->get_dirty_columns;
+ $self->discard_changes;
+
+ my $pos_col = $self->position_column;
+
+ # if any of our grouping columns have been changed
+ if (grep {$_} map {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) {
+ if (exists $changes{$col}) {
+ $new_group->{$col} = $changes{$col};
+ delete $changes{$col}; # don't want to pass this on to next::method
+ }
+ }
+
+ $self->move_to_group(
+ $new_group,
+ exists($changes{$pos_col}) ? delete($changes{$pos_col}) : $self->$pos_col
+ );
+ }
+ elsif (exists $changes{$pos_col}) {
+ $self->move_to(delete $changes{$pos_col});
+ }
+ return $self->next::method( \%changes );
+}
+
=head2 delete
Overrides the DBIC delete() method by first moving the object
=head2 _grouping_clause
-This method returns a name=>value pare for limiting a search
-by the collection column. If the collection column is not
+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
-
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
+sub _grouping_columns {
+ my( $self ) = @_;
my $col = $self->grouping_column();
- if ($col) {
- return ( $col => $self->get_column($col) );
+ if (ref $col eq 'ARRAY') {
+ return @$col;
+ } elsif ($col) {
+ return ( $col );
+ } else {
+ return ();
}
- return ();
}
+
+
+=head2 _is_in_group($other)
+
+ $item->_is_in_group( {user => 'fred', list => 'work'} )
+
+Returns true if the object is in the group represented by hashref $other
+=cut
+sub _is_in_group {
+ my ($self, $other) = @_;
+ my $current = {$self->_grouping_clause};
+ return 0 unless (ref $other eq 'HASH') and (keys %$current == keys %$other);
+ for my $key (keys %$current) {
+ return 0 unless exists $other->{$key};
+ return 0 if $current->{$key} ne $other->{$key};
+ }
+ return 1;
+}
+
+
1;
__END__
If a position is not specified for an insert than a position
will be chosen based on COUNT(*)+1. But, it first selects the
-count then inserts the record. The space of time between select
+count, and then inserts the record. The space of time between select
and insert introduces a race condition. To fix this we need the
ability to lock tables in DBIC. I've added an entry in the TODO
about this.
Re-selects the row from the database, losing any changes that had
been made.
+This method can also be used to refresh from storage, retrieving any
+changes made since the row was last read from storage.
+
=cut
sub discard_changes {
my ($self) = @_;
delete $self->{_dirty_columns};
return unless $self->in_storage; # Don't reload if we aren't real!
- my ($reload) = $self->result_source->resultset->find
- (map { $self->$_ } $self->primary_columns);
+
+ my $reload = $self->result_source->resultset->find(
+ map { $self->$_ } $self->primary_columns
+ );
unless ($reload) { # If we got deleted in the mean-time
$self->in_storage(0);
return $self;
}
- delete @{$self}{keys %$self};
- @{$self}{keys %$reload} = values %$reload;
+
+ %$self = %$reload;
+
+ # Avoid a possible infinite loop with
+ # sub DESTROY { $_[0]->discard_changes }
+ bless $reload, 'Do::Not::Exist';
+
return $self;
}
=head1 SYNOPSIS
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+__PACKAGE__->load_components(qw/Core/);
__PACKAGE__->set_primary_key('id');
=head1 DESCRIPTION
This class overrides the insert method to get automatically incremented primary
keys.
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->load_components(qw/Core/);
+
+PK::Auto is now part of Core.
-Note that C<PK::Auto> is specified as the left of the Core component.
See L<DBIx::Class::Manual::Component> for details of component interactions.
=head1 LOGIC
=head2 insert
-Overrides C<insert> so that it will get the value of autoincremented primary
-keys.
-
-=cut
-
-sub insert {
- my ($self, @rest) = @_;
- my $ret = $self->next::method(@rest);
-
- my ($pri, $too_many) = grep { !defined $self->get_column($_) ||
- ref($self->get_column($_)) eq 'SCALAR'} $self->primary_columns;
- return $ret unless defined $pri; # if all primaries are already populated, skip auto-inc
- $self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
- if defined $too_many;
-
- 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 $id = $storage->last_insert_id($self->result_source,$pri);
- $self->throw_exception( "Can't get last insert id" ) unless $id;
- $self->store_column($pri => $id);
-
- return $ret;
-}
+The code that was handled here is now in Row for efficiency.
=head2 sequence
=head1 SYNOPSIS
+ ## Creating relationships
MyDB::Schema::Actor->has_many('actorroles' => 'MyDB::Schema::ActorRole',
'actor');
MyDB::Schema::Role->has_many('actorroles' => 'MyDB::Schema::ActorRole',
MyDB::Schema::Role->many_to_many('actors' => 'actorroles', 'actor');
MyDB::Schema::Actor->many_to_many('roles' => 'actorroles', 'role');
+ ## Using relationships
$schema->resultset('Actor')->roles();
$schema->resultset('Role')->search_related('actors', { Name => 'Fred' });
$schema->resultset('ActorRole')->add_to_roles({ Name => 'Sherlock Holmes'});
my $fred = $schema->resultset('Author')->find({ Name => 'Fred' });
my $fredsbooks = $schema->resultset('Book')->search({ Author => $fred->ID });
+
With a has_many relationship called "books" on Author (see below for details),
we can do this instead:
=head1 METHODS
-All helper methods take the following arguments:
+All helper methods are called similar to the following template:
- __PACKAGE__>$method_name('relname', 'Foreign::Class', $cond, $attrs);
+ __PACKAGE__->$method_name('relname', 'Foreign::Class', $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>.
-See L<DBIx::Class::Relationship::Base> for a list of valid attributes and valid
-relationship attributes.
+See L<DBIx::Class::Relationship::Base> for documentation on the
+attrubutes that are allowed in the C<$attrs> argument.
+
=head2 belongs_to
=over 4
-=item Arguments: $accessor_name, $related_class, $foreign_key_column|$cond?, $attr?
+=item Arguments: $accessor_name, $related_class, $fk_column|\%cond|\@cond?, \%attr?
=back
- # in a Book class (where Author has many Books)
- My::DBIC::Schema::Book->belongs_to( author => 'My::DBIC::Schema::Author' );
+Creates a relationship where the calling class stores the foreign
+class's primary key in one (or more) of its columns. This relationship
+defaults to using C<$accessor_name> as the column in this class
+to resolve the join against the primary key from C<$related_class>,
+unless C<$fk_column> specifies the foreign key column in this class or
+C<cond> specifies a reference to a join condition hash.
+
+=over
+
+=item accessor_name
+
+This argument is the name of the method you can call on a
+L<DBIx::Class::Row> object to retrieve the instance of the foreign
+class matching this relationship. This is often called the
+C<relation(ship) name>.
- my $author_obj = $obj->author; # get author object
- $obj->author( $new_author_obj ); # set author object
+Use this accessor_name in L<DBIx::Class::ResultSet/join>
+or L<DBIx::Class::ResultSet/prefetch> to join to the foreign table
+indicated by this relationship.
-The above belongs_to relationship could also have been specified as,
+=item related_class
- My::DBIC::Schema::Book->belongs_to( author,
- 'My::DBIC::Schema::Author',
- { 'foreign.author' => 'self.author' } );
+This is the class name of the table referenced by the foreign key in
+this class.
+
+=item fk_column
+
+The column name on this class that contains the foreign key.
+
+OR
+
+=item cond
+
+A hashref where the keys are C<foreign.$column_on_related_table> and
+the values are C<self.$foreign_key_column>. This is useful for
+relations that are across multiple columns.
+
+=back
+
+
+ # in a Book class (where Author has many Books)
+ My::DBIC::Schema::Book->belongs_to(
+ author =>
+ 'My::DBIC::Schema::Author',
+ 'author_id'
+ );
+
+ # OR (same result)
+ My::DBIC::Schema::Book->belongs_to(
+ author =>
+ 'My::DBIC::Schema::Author',
+ { 'foreign.author_id' => 'self.author_id' }
+ );
+
+ # OR (similar result but uglier accessor name)
+ My::DBIC::Schema::Book->belongs_to(
+ author_id =>
+ 'My::DBIC::Schema::Author'
+ );
+
+ # Usage
+ my $author_obj = $book->author; # get author object
+ $book->author( $new_author_obj ); # set author object
+ $book->author_id(); # get the plain id
+
+ # To retrieve the plain id if you used the ugly version:
+ $book->get_column('author_id');
-Creates a relationship where the calling class stores the foreign class's
-primary key in one (or more) of its columns. This relationship defaults to
-using C<$accessor_name> as the foreign key in C<$related_class> to resolve the
-join, unless C<$foreign_key_column> specifies the foreign key column in
-C<$related_class> or C<$cond> specifies a reference to a join condition hash.
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
operations work correctly. The modified declaration is shown below:
# in a Book class (where Author has_many Books)
- __PACKAGE__->belongs_to(author => 'My::DBIC::Schema::Author',
- 'author', {join_type => 'left'});
+ __PACKAGE__->belongs_to(
+ author =>
+ 'My::DBIC::Schema::Author',
+ 'author',
+ { join_type => 'left' }
+ );
Cascading deletes are off by default on a C<belongs_to>
=over 4
-=item Arguments: $accessor_name, $related_class, $foreign_key_column|$cond?, $attr?
+=item Arguments: $accessor_name, $related_class, $foreign_key_column|\%cond|\@cond?, \%attr?
+
+=back
+
+Creates a one-to-many relationship, where the corresponding elements
+of the foreign class store the calling class's primary key in one (or
+more) of its columns. 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<$foreign_key_column> specifies the foreign
+key column in C<$related_class> or C<cond> specifies a reference to a
+join condition hash.
+
+=over
+
+=item accessor_name
+
+This argument is the name of the method you can call on a
+L<DBIx::Class::Row> object to retrieve a resultset of the related
+class restricted to the ones related to the row object. In list
+context it returns the row objects. This is often called the
+C<relation(ship) name>.
+
+Use this accessor_name in L<DBIx::Class::ResultSet/join>
+or L<DBIx::Class::ResultSet/prefetch> to join to the foreign table
+indicated by this relationship.
+
+=item related_class
+
+This is the class name of the table which contains a foreign key
+column containing PK values of this class.
+
+=item foreign_key_column
+
+The column name on the related class that contains the foreign key.
+
+OR
+
+=item cond
+
+A hashref where the keys are C<foreign.$foreign_key_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'} ]);
=back
# in an Author class (where Author has_many Books)
- My::DBIC::Schema::Author->has_many(books => 'My::DBIC::Schema::Book', 'author');
+ # assuming related class is storing our PK in "author_id"
+ My::DBIC::Schema::Author->has_many(
+ books =>
+ 'My::DBIC::Schema::Book',
+ 'author_id'
+ );
+
+ # OR (same result)
+ My::DBIC::Schema::Author->has_many(
+ 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',
+ );
- my $booklist = $obj->books;
- my $booklist = $obj->books({
+
+ # Usage
+ # resultset of Books belonging to author
+ my $booklist = $author->books;
+
+ # resultset of Books belonging to author, restricted by author name
+ my $booklist = $author->books({
name => { LIKE => '%macaroni%' },
{ prefetch => [qw/book/],
});
- my @book_objs = $obj->books;
- my $books_rs = $obj->books;
- ( $books_rs ) = $obj->books_rs;
- $obj->add_to_books(\%col_data);
+ # array of Book objects belonging to author
+ my @book_objs = $author->books;
-The above C<has_many> relationship could also have been specified with an
-explicit join condition:
+ # force resultset even in list context
+ my $books_rs = $author->books;
+ ( $books_rs ) = $obj->books_rs;
- My::DBIC::Schema::Author->has_many( books => 'My::DBIC::Schema::Book', {
- 'foreign.author' => 'self.author',
- });
+ # create a new book for this author, the relation fields are auto-filled
+ $author->create_related('books', \%col_data);
+ # alternative method for the above
+ $author->add_to_books(\%col_data);
-Creates a one-to-many relationship, where the corresponding elements of the
-foreign class store the calling class's primary key in one (or more) of its
-columns. This relationship defaults to using C<$accessor_name> as the foreign
-key in C<$related_class> to resolve the join, unless C<$foreign_key_column>
-specifies the foreign key column in C<$related_class> or C<$cond> specifies a
-reference to a join condition hash.
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 returns a resultset no matter what, even in list context. The third method,
+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
the related objects will be deleted as well. To turn this behaviour off,
-pass C<< cascade_delete => 0 >> in the C<$attr> hashref. However, any
+pass C<< cascade_delete => 0 >> in the C<attr> hashref. However, any
database-level cascade or restrict will take precedence over a
DBIx-Class-based cascading delete.
+If you copy an object in a class with a C<has_many> relationship, all
+the related objects will be copied as well. To turn this behaviour off,
+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.
=over 4
-=item Arguments: $accessor_name, $related_class, $foreign_key_column|$cond?, $attr?
+=item Arguments: $accessor_name, $related_class, $foreign_key_column|\%cond|\@cond?, \%attr?
=back
- My::DBIC::Schema::Author->might_have( pseudonym =>
- 'My::DBIC::Schema::Pseudonym' );
+Creates an optional one-to-one relationship with a class. This relationship
+defaults to using C<$accessor_name> as the foreign key in C<$related_class> to
+resolve the join, unless C<$foreign_key_column> specifies the foreign key
+column in C<$related_class> or C<cond> specifies a reference to a join
+condition hash.
- my $pname = $obj->pseudonym; # to get the Pseudonym object
+=over
-The above might_have relationship could have been specified as:
+=item accessor_name
- My::DBIC::Schema::Author->might_have( pseudonym =>
- 'My::DBIC::Schema::Pseudonym',
- 'author' );
+This argument is the name of the method you can call on a
+L<DBIx::Class::Row> object to retrieve the instance of the foreign
+class matching this relationship. This is often called the
+C<relation(ship) name>.
-Or even:
+Use this accessor_name in L<DBIx::Class::ResultSet/join>
+or L<DBIx::Class::ResultSet/prefetch> to join to the foreign table
+indicated by this relationship.
- My::DBIC::Schema::Author->might_have( pseudonym =>
- 'My::DBIC::Schema::Pseudonym',
- { 'foreign.author' => 'self.author' } );
+=item related_class
-Assuming the Pseudonym table has
+This is the class name of the table which contains a foreign key
+column containing PK values of this class.
-Creates an optional one-to-one relationship with a class. This relationship
-defaults to using C<$accessor_name> as the foreign key in C<$related_class> to
-resolve the join, unless C<$foreign_key_column> specifies the foreign key
-column in C<$related_class> or C<$cond> specifies a reference to a join
-condition hash.
+=item foreign_key_column
+
+The column name on the related class that contains the foreign key.
+
+OR
+
+=item cond
+
+A hashref where the keys are C<foreign.$column_on_related_table> and
+the values are C<self.$matching_column>. This is useful for
+relations that are across multiple columns.
+
+=back
+
+ # Author may have an entry in the pseudonym table
+ My::DBIC::Schema::Author->might_have(
+ pseudonym =>
+ 'My::DBIC::Schema::Pseudonym',
+ 'author_id',
+ );
+
+ # OR (same result, assuming the related_class stores our PK)
+ My::DBIC::Schema::Author->might_have(
+ pseudonym =>
+ 'My::DBIC::Schema::Pseudonym',
+ );
+
+ # OR (same result)
+ My::DBIC::Schema::Author->might_have(
+ pseudonym =>
+ 'My::DBIC::Schema::Pseudonym',
+ { 'foreign.author_id' => 'self.id' },
+ );
+
+ # Usage
+ my $pname = $author->pseudonym; # to get the Pseudonym object
If you update or delete an object in a class with a C<might_have>
relationship, the related object will be updated or deleted as well. To
=over 4
-=item Arguments: $accessor_name, $related_class_name, $join_condition?, $attr?
+=item Arguments: $accessor_name, $related_class, $foreign_key_column|\%cond|\@cond?, \%attr?
=back
- My::DBIC::Schema::Book->has_one(isbn => 'My::DBIC::Schema::ISBN');
+Creates a one-to-one relationship with a class. This relationship
+defaults to using C<$accessor_name> as the foreign key in C<$related_class> to
+resolve the join, unless C<$foreign_key_column> specifies the foreign key
+column in C<$related_class> or C<cond> specifies a reference to a join
+condition hash.
+
+=over
+
+=item accessor_name
+
+This argument is the name of the method you can call on a
+L<DBIx::Class::Row> object to retrieve the instance of the foreign
+class matching this relationship. This is often called the
+C<relation(ship) name>.
+
+Use this accessor_name in L<DBIx::Class::ResultSet/join>
+or L<DBIx::Class::ResultSet/prefetch> to join to the foreign table
+indicated by this relationship.
+
+=item related_class
+
+This is the class name of the table which contains a foreign key
+column containing PK values of this class.
+
+=item foreign_key_column
+
+The column name on the related class that contains the foreign key.
+
+OR
- my $isbn_obj = $obj->isbn; # to get the ISBN object
+=item cond
-Creates a one-to-one relationship with another class. This is just like
-C<might_have>, except the implication is that the other object is always
-present. The only difference between C<has_one> and C<might_have> is that
-C<has_one> uses an (ordinary) inner join, whereas C<might_have> uses a
-left join.
+A hashref where the keys are C<foreign.$column_on_related_table> and
+the values are C<self.$matching_column>. This is useful for
+relations that are across multiple columns.
+
+=back
+
+ # Every book has exactly one ISBN
+ My::DBIC::Schema::Book->has_one(
+ isbn =>
+ 'My::DBIC::Schema::ISBN',
+ 'book_id',
+ );
+
+ # OR (same result, assuming related_class stores our PK)
+ My::DBIC::Schema::Book->has_one(
+ isbn =>
+ 'My::DBIC::Schema::ISBN',
+ );
+
+ # OR (same result)
+ My::DBIC::Schema::Book->has_one(
+ isbn =>
+ 'My::DBIC::Schema::ISBN',
+ { 'foreign.book_id' => 'self.id' },
+ );
+
+ # Usage
+ my $isbn_obj = $book->isbn; # to get the ISBN object
+
+Creates a one-to-one relationship with another class. This is just
+like C<might_have>, except the implication is that the other object is
+always present. The only difference between C<has_one> and
+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
=over 4
-=item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, $attr?
+=item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, \%attr?
+
+=back
+
+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
+C<related_resultset> and similar methods which operate on true relationships.
+
+=over
+
+=item accessor_name
+
+This argument is the name of the method you can call on a
+L<DBIx::Class::Row> object to retrieve the rows matching this
+relationship.
+
+On a many_to_many, unlike other relationships, this cannot be used in
+L<DBIx::Class::ResultSet/search> to join tables. Use the relations
+bridged across instead.
+
+=item link_rel_name
+
+This is the accessor_name from the has_many relationship we are
+bridging from.
+
+=item foreign_rel_name
+
+This is the accessor_name of the belongs_to relationship in the link
+table that we are bridging across (which gives us the table we are
+bridging to).
=back
My::DBIC::Schema::Role->many_to_many( actors => 'actor_roles', 'actor' );
-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
-C<$related_resultset> and similar methods which operate on true relationships.
+To add a role for your actor, and fill in the year of the role in the
+actor_roles table:
+
+ $actor->add_to_roles($role, { year => 1995 });
In the above example, ActorRoles is the link table class, and Role is the
foreign class. The C<$link_rel_name> parameter is the name of the accessor for
relation names are then used in the many_to_many call.
In the above example, the Actor class will have 3 many_to_many accessor methods
-set: C<$roles>, C<$add_to_roles>, C<$set_roles>, and similarly named accessors
+set: C<roles>, C<add_to_roles>, C<set_roles>, and similarly named accessors
will be created for the Role class for the C<actors> many_to_many
relationship.
=head1 AUTHORS
-Matt S. Trout <mst@shadowcatsystems.co.uk>
+see L<DBIx::Class>
=head1 LICENSE
$class->inflate_column($rel,
{ inflate => sub {
my ($val, $self) = @_;
- return $self->find_or_create_related($rel, {}, {});
+ return $self->find_or_new_related($rel, {}, {});
},
deflate => sub {
my ($val, $self) = @_;
}
}
-sub new {
- my ($class, $attrs, @rest) = @_;
- my ($related, $info);
- foreach my $key (keys %{$attrs||{}}) {
- next unless $info = $class->relationship_info($key);
- $related->{$key} = delete $attrs->{$key}
- if ref $attrs->{$key}
- && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single';
- }
- my $obj = $class->next::method($attrs, @rest);
- if ($related) {
- $obj->{_relationship_data} = $related;
- foreach my $rel (keys %$related) {
- $obj->set_from_related($rel, $related->{$rel});
- }
- }
- return $obj;
-}
-
-sub update {
- my ($obj, $attrs, @rest) = @_;
- my $info;
- foreach my $key (keys %{$attrs||{}}) {
- next unless $info = $obj->relationship_info($key);
- if (ref $attrs->{$key} && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single') {
- my $rel = delete $attrs->{$key};
- $obj->set_from_related($key => $rel);
- $obj->{_relationship_data}{$key} = $rel;
- }
- }
- return $obj->next::method($attrs, @rest);
-}
-
1;
a column accessor). For C<multi> accessors, an add_to_* method is also
created, which calls C<create_related> 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
+should, set this attribute to a true or false value to override the detection
+of when to create constraints.
+
+=item is_deferrable
+
+Tells L<SQL::Translator> that the foreign key constraint it creates should be
+deferrable. In other words, the user may request that the constraint be ignored
+until the end of the transaction. Currently, only the PostgreSQL producer
+actually supports this.
+
+=item add_fk_index
+
+Tells L<SQL::Translator> to add an index for this constraint. Can also be
+specified globally in the args to L<DBIx::Class::Schema/deploy> or
+L<DBIx::Class::Schema/create_ddl_dir>. Default is on, set to 0 to disable.
+
=back
=head2 register_relationship
( $objects_rs ) = $rs->search_related_rs('relname', $cond, $attrs);
This method works exactly the same as search_related, except that
-it garauntees a restultset, even in list context.
+it guarantees a restultset, even in list context.
=cut
sub find_or_new_related {
my $self = shift;
- return $self->find_related(@_) || $self->new_related(@_);
+ my $obj = $self->find_related(@_);
+ return defined $obj ? $obj : $self->new_related(@_);
}
=head2 find_or_create_related
=head2 set_from_related
$book->set_from_related('author', $author_obj);
+ $book->author($author_obj); ## same thing
Set column values on the current object, using related values from the given
related object. This is used to associate previously separate objects, for
example, to set the correct author for a book, find the Author object, then
call set_from_related on the book.
+This is called internally when you pass existing objects as values to
+L<DBIx::Class::ResultSet/create>, or pass an object to a belongs_to acessor.
+
The columns are only set in the local copy of the object, call L</update> to
set them in the storage.
my $actor = $schema->resultset('Actor')->find(1);
my @roles = $schema->resultset('Role')->search({ role =>
- { '-in' -> ['Fred', 'Barney'] } } );
+ { '-in' => ['Fred', 'Barney'] } } );
$actor->set_roles(\@roles);
# Replaces all of $actor's previous roles with the two named
);
}
# explicit join condition
- elsif (ref $cond eq 'HASH') {
- my $cond_rel;
- for (keys %$cond) {
- if (m/\./) { # Explicit join condition
- $cond_rel = $cond;
- last;
+ elsif (ref $cond) {
+ if (ref $cond eq 'HASH') { # ARRAY is also valid
+ my $cond_rel;
+ for (keys %$cond) {
+ if (m/\./) { # Explicit join condition
+ $cond_rel = $cond;
+ last;
+ }
+ $cond_rel->{"foreign.$_"} = "self.".$cond->{$_};
}
- $cond_rel->{"foreign.$_"} = "self.".$cond->{$_};
+ $cond = $cond_rel;
}
- my $acc_type = (keys %$cond_rel == 1 and $class->has_column($rel))
- ? 'filter'
- : 'single';
+ my $acc_type = ((ref $cond eq 'HASH')
+ && keys %$cond == 1
+ && $class->has_column($rel))
+ ? 'filter'
+ : 'single';
$class->add_relationship($rel, $f_class,
- $cond_rel,
+ $cond,
{ accessor => $acc_type, %{$attrs || {}} }
);
}
"${class} has more"
) if $too_many;
+ $class->throw_exception(
+ "has_many needs a primary key to infer a join; ".
+ "${class} has none"
+ ) if !defined $pri && (!defined $cond || !length $cond);
+
my ($f_key,$guess);
if (defined $cond && length $cond) {
$f_key = $cond;
unless (ref $cond) {
$class->ensure_class_loaded($f_class);
my ($pri, $too_many) = $class->primary_columns;
+
$class->throw_exception(
"might_have/has_one can only infer join for a single primary key; ".
"${class} has more"
) if $too_many;
+
+ $class->throw_exception(
+ "might_have/has_one needs a primary key to infer a join; ".
+ "${class} has none"
+ ) if !defined $pri && (!defined $cond || !length $cond);
+
my $f_class_loaded = eval { $f_class->columns };
my ($f_key,$guess);
if (defined $cond && length $cond) {
sub many_to_many {
my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
+
+ $class->throw_exception(
+ "missing relation in many-to-many"
+ ) unless $rel;
+
+ $class->throw_exception(
+ "missing foreign relation in many-to-many"
+ ) unless $f_rel;
+
{
no strict 'refs';
no warnings 'redefine';
my $add_meth = "add_to_${meth}";
my $remove_meth = "remove_from_${meth}";
my $set_meth = "set_${meth}";
+ my $rs_meth = "${meth}_rs";
+
+ for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
+ warn "***************************************************************************\n".
+ "The many-to-many relationship $meth is trying to create a utility method called $_. This will overwrite the existing method on $class. You almost certainly want to rename your method or the many-to-many relationship, as your method will not be callable (it will use the one from the relationship instead.) YOU HAVE BEEN WARNED\n".
+ "***************************************************************************\n"
+ if $class->can($_);
+ }
$rel_attrs->{alias} ||= $f_rel;
- *{"${class}::${meth}"} = sub {
+ *{"${class}::${meth}_rs"} = sub {
my $self = shift;
my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
my @args = ($f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs });
- $self->search_related($rel)->search_related(
+ my $rs = $self->search_related($rel)->search_related(
$f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
);
+ return $rs;
};
+ *{"${class}::${meth}"} = sub {
+ my $self = shift;
+ my $rs = $self->$rs_meth( @_ );
+ return (wantarray ? $rs->all : $rs);
+ };
+
*{"${class}::${add_meth}"} = sub {
my $self = shift;
@_ > 0 or $self->throw_exception(
}
my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
- my $link = $self->search_related($rel)->new_result({});
+ my $link = $self->search_related($rel)->new_result($link_vals);
$link->set_from_related($f_rel, $obj);
- $link->set_columns($link_vals);
$link->insert();
+ return $obj;
};
*{"${class}::${set_meth}"} = sub {
--- /dev/null
+package DBIx::Class::ResultClass::HashRefInflator;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::ResultClass::HashRefInflator
+
+=head1 SYNOPSIS
+
+ my $rs = $schema->resultset('CD');
+
+ $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
+
+=head1 DESCRIPTION
+
+DBIx::Class is not built for speed: it's built for convenience and
+ease of use. But sometimes you just need to get the data, and skip the
+fancy objects. That is what this class provides.
+
+There are two ways of using this class.
+
+=over
+
+=item *
+
+Specify C<< $rs->result_class >> on a specific resultset to affect only that
+resultset (and any chained off of it); or
+
+=item *
+
+Specify C<< __PACKAGE__->result_class >> on your source object to force all
+uses of that result source to be inflated to hash-refs - this approach is not
+recommended.
+
+=back
+
+=head1 METHODS
+
+=head2 inflate_result
+
+Inflates the result and prefetched data into a hash-ref using L<mk_hash>.
+
+=cut
+
+sub inflate_result {
+ my ($self, $source, $me, $prefetch) = @_;
+
+ return mk_hash($me, $prefetch);
+}
+
+=head2 mk_hash
+
+This does all the work of inflating the (pre)fetched data.
+
+=cut
+
+sub mk_hash {
+ 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 mk_hash(@$_), @{$rest->{$_}} ]
+ : mk_hash( @{$rest->{$_}} )
+ )
+ } keys %$rest
+ };
+}
+
+=head1 CAVEAT
+
+This will not work for relationships that have been prefetched. Consider the
+following:
+
+ my $artist = $artitsts_rs->search({}, {prefetch => 'cds' })->first;
+
+ my $cds = $artist->cds;
+ $cds->result_class('DBIx::Class::ResultClass::HashRefInflator');
+ my $first = $cds->first;
+
+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.
+
+=cut
+
+1;
use strict;
use warnings;
use overload
- '0+' => \&count,
- 'bool' => sub { 1; },
+ '0+' => "count",
+ 'bool' => "_bool",
fallback => 1;
use Carp::Clan qw/^DBIx::Class/;
use Data::Page;
use Storable;
use DBIx::Class::ResultSetColumn;
+use DBIx::Class::ResultSourceHandle;
+use List::Util ();
use base qw/DBIx::Class/;
-__PACKAGE__->mk_group_accessors('simple' => qw/result_source result_class/);
+__PACKAGE__->mk_group_accessors('simple' => qw/result_class _source_handle/);
=head1 NAME
=head1 SYNOPSIS
- my $rs = $schema->resultset('User')->search(registered => 1);
- my @rows = $schema->resultset('CD')->search(year => 2005);
+ my $rs = $schema->resultset('User')->search({ registered => 1 });
+ my @rows = $schema->resultset('CD')->search({ year => 2005 })->all();
=head1 DESCRIPTION
__PACKAGE__->belongs_to(artist => 'MyApp::Schema::Artist');
1;
+=head1 OVERLOADING
+
+If a resultset is used in a numeric context it returns the L</count>.
+However, if it is used in a booleand 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) = @_;
- #weaken $source;
+ $source = $source->handle
+ unless $source->isa('DBIx::Class::ResultSourceHandle');
$attrs = { %{$attrs||{}} };
if ($attrs->{page}) {
$attrs->{rows} ||= 10;
- $attrs->{offset} ||= 0;
- $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1));
}
$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 = {
- result_source => $source,
- result_class => $attrs->{result_class} || $source->result_class,
+ _source_handle => $source,
+ result_class => $attrs->{result_class} || $source->resolve->result_class,
cond => $attrs->{where},
count => undef,
pager => undef,
columns => [qw/name artistid/],
});
-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 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>.
+
+For more help on using joins with search, see L<DBIx::Class::Manual::Joining>.
=cut
sub search_rs {
my $self = shift;
- my $rows;
-
- unless (@_) { # no search, effectively just a clone
- $rows = $self->get_cache;
- }
-
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 %safe = (alias => 1, cache => 1);
+
+ 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;
+ }
+
my $new_attrs = { %{$our_attrs}, %{$attrs} };
# merge new attrs into inherited
Pass a literal chunk of SQL to be added to the conditional part of the
resultset query.
+CAVEAT: C<search_literal> is provided for Class::DBI compatibility and should
+only be used in that context. There are known problems using C<search_literal>
+in chained queries; it can result in bind values in the wrong order. See
+L<DBIx::Class::Manual::Cookbook/Searching> and
+L<DBIx::Class::Manual::FAQ/Searching> for searching techniques that do not
+require C<search_literal>.
+
=cut
sub search_literal {
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, including the primary key.
+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.
+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>.
my (%related, $info);
- foreach my $key (keys %$input_query) {
+ 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}, delete $input_query->{$key}, $key
+ $info->{cond}, $val, $key
);
die "Can't handle OR join condition in find" if ref($rel_q) eq 'ARRAY';
@related{keys %$rel_q} = values %$rel_q;
@{$input_query}{@keys} = values %related;
}
- my @unique_queries = $self->_unique_queries($input_query, $attrs);
# 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 = @unique_queries
- ? [ map { $self->_add_alias($_, $alias) } @unique_queries ]
- : $self->_add_alias($input_query, $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);
+ }
+ 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);
+ }
# Run the query
if (keys %$attrs) {
my $rs = $self->search($query, $attrs);
- return keys %{$rs->_resolved_attrs->{collapse}} ? $rs->next : $rs->single;
+ if (keys %{$rs->_resolved_attrs->{collapse}}) {
+ my $row = $rs->next;
+ carp "Query returned more than one row" if $rs->next;
+ return $row;
+ }
+ else {
+ return $rs->single;
+ }
}
else {
- return keys %{$self->_resolved_attrs->{collapse}}
- ? $self->search($query)->next
- : $self->single($query);
+ if (keys %{$self->_resolved_attrs->{collapse}}) {
+ my $rs = $self->search($query);
+ my $row = $rs->next;
+ carp "Query returned more than one row" if $rs->next;
+ return $row;
+ }
+ else {
+ return $self->single($query);
+ }
}
}
? ($attrs->{key})
: $self->result_source->unique_constraint_names;
+ my $where = $self->_collapse_cond($self->{attrs}{where} || {});
+ my $num_where = scalar keys %$where;
+
my @unique_queries;
foreach my $name (@constraint_names) {
my @unique_cols = $self->result_source->unique_constraint_columns($name);
my $unique_query = $self->_build_unique_query($query, \@unique_cols);
+ my $num_cols = scalar @unique_cols;
my $num_query = scalar keys %$unique_query;
- next unless $num_query;
- # XXX: Assuming quite a bit about $self->{attrs}{where}
- my $num_cols = scalar @unique_cols;
- my $num_where = exists $self->{attrs}{where}
- ? scalar keys %{ $self->{attrs}{where} }
- : 0;
- push @unique_queries, $unique_query
- if $num_query + $num_where == $num_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;
+ }
}
return @unique_queries;
return shift->related_resultset(shift)->search(@_);
}
+=head2 search_related_rs
+
+This method works exactly the same as search_related, except that
+it guarantees a restultset, even in list context.
+
+=cut
+
+sub search_related_rs {
+ return shift->related_resultset(shift)->search_rs(@_);
+}
+
=head2 cursor
=over 4
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 an optimisation.
-Can optionally take an additional condition *only* - this is a fast-code-path
-method; if you need to add extra joins or similar call ->search and then
-->single without a condition on the $rs returned from that.
+Can optionally take an additional condition B<only> - this is a fast-code-path
+method; if you need to add extra joins or similar call L</search> and then
+L</single> without a condition on the L<DBIx::Class::ResultSet> returned from
+that.
+
+B<Note>: As of 0.08100, this method assumes that the query returns only one
+row. If more than one row is returned, you will receive a warning:
+
+ Query returned more than one row
+
+In this case, you should be using L</first> or L</find> instead.
=cut
$attrs->{where}, $attrs
);
- return (@data ? ($self->_construct_object(@data))[0] : ());
+ return (@data ? ($self->_construct_object(@data))[0] : undef);
}
# _is_unique_query
? @{delete $self->{stashed_row}}
: $self->cursor->next
);
- return unless (@row);
+ return undef unless (@row);
my ($row, @more) = $self->_construct_object(@row);
$self->{stashed_objects} = \@more if @more;
return $row;
}
sub _collapse_result {
- my ($self, $as, $row, $prefix) = @_;
+ my ($self, $as_proto, $row) = @_;
- my %const;
my @copy = @$row;
-
- foreach my $this_as (@$as) {
- my $val = shift @copy;
- if (defined $prefix) {
- if ($this_as =~ m/^\Q${prefix}.\E(.+)$/) {
- my $remain = $1;
- $remain =~ /^(?:(.*)\.)?([^.]+)$/;
- $const{$1||''}{$2} = $val;
- }
- } else {
- $this_as =~ /^(?:(.*)\.)?([^.]+)$/;
- $const{$1||''}{$2} = $val;
- }
- }
- my $alias = $self->{attrs}{alias};
- my $info = [ {}, {} ];
- foreach my $key (keys %const) {
- if (length $key && $key ne $alias) {
- my $target = $info;
- my @parts = split(/\./, $key);
- foreach my $p (@parts) {
- $target = $target->[1]->{$p} ||= [];
+ # 'foo' => [ undef, 'foo' ]
+ # 'foo.bar' => [ 'foo', 'bar' ]
+ # 'foo.bar.baz' => [ 'foo.bar', 'baz' ]
+
+ my @construct_as = map { [ (/^(?:(.*)\.)?([^.]+)$/) ] } @$as_proto;
+
+ my %collapse = %{$self->{_attrs}{collapse}||{}};
+
+ my @pri_index;
+
+ # if we're doing collapsing (has_many prefetch) we need to grab records
+ # until the PK changes, so fill @pri_index. if not, we leave it empty so
+ # we know we don't have to bother.
+
+ # the reason for not using the collapse stuff directly is because if you
+ # had for e.g. two artists in a row with no cds, the collapse info for
+ # both would be NULL (undef) so you'd lose the second artist
+
+ # store just the index so we can check the array positions from the row
+ # without having to contruct the full hash
+
+ if (keys %collapse) {
+ my %pri = map { ($_ => 1) } $self->result_source->primary_columns;
+ foreach my $i (0 .. $#construct_as) {
+ next if defined($construct_as[$i][0]); # only self table
+ if (delete $pri{$construct_as[$i][1]}) {
+ push(@pri_index, $i);
}
- $target->[0] = $const{$key};
- } else {
- $info->[0] = $const{$key};
+ last unless keys %pri; # short circuit (Johnny Five Is Alive!)
}
}
-
- my @collapse;
- if (defined $prefix) {
- @collapse = map {
- m/^\Q${prefix}.\E(.+)$/ ? ($1) : ()
- } keys %{$self->{_attrs}{collapse}}
- } else {
- @collapse = keys %{$self->{_attrs}{collapse}};
- };
- if (@collapse) {
- my ($c) = sort { length $a <=> length $b } @collapse;
- my $target = $info;
- foreach my $p (split(/\./, $c)) {
- $target = $target->[1]->{$p} ||= [];
+ # no need to do an if, it'll be empty if @pri_index is empty anyway
+
+ my %pri_vals = map { ($_ => $copy[$_]) } @pri_index;
+
+ my @const_rows;
+
+ do { # no need to check anything at the front, we always want the first row
+
+ my %const;
+
+ foreach my $this_as (@construct_as) {
+ $const{$this_as->[0]||''}{$this_as->[1]} = shift(@copy);
}
- my $c_prefix = (defined($prefix) ? "${prefix}.${c}" : $c);
- my @co_key = @{$self->{_attrs}{collapse}{$c_prefix}};
- my $tree = $self->_collapse_result($as, $row, $c_prefix);
- my %co_check = map { ($_, $tree->[0]->{$_}); } @co_key;
- my (@final, @raw);
-
- while (
- !(
+
+ push(@const_rows, \%const);
+
+ } until ( # no pri_index => no collapse => drop straight out
+ !@pri_index
+ or
+ do { # get another row, stash it, drop out if different PK
+
+ @copy = $self->cursor->next;
+ $self->{stashed_row} = \@copy;
+
+ # last thing in do block, counts as true if anything doesn't match
+
+ # check xor defined first for NULL vs. NOT NULL then if one is
+ # defined the other must be so check string equality
+
grep {
- !defined($tree->[0]->{$_}) || $co_check{$_} ne $tree->[0]->{$_}
- } @co_key
- )
- ) {
- push(@final, $tree);
- last unless (@raw = $self->cursor->next);
- $row = $self->{stashed_row} = \@raw;
- $tree = $self->_collapse_result($as, $row, $c_prefix);
+ (defined $pri_vals{$_} ^ defined $copy[$_])
+ || (defined $pri_vals{$_} && ($pri_vals{$_} ne $copy[$_]))
+ } @pri_index;
+ }
+ );
+
+ my $alias = $self->{attrs}{alias};
+ my $info = [];
+
+ my %collapse_pos;
+
+ my @const_keys;
+
+ foreach my $const (@const_rows) {
+ scalar @const_keys or do {
+ @const_keys = sort { length($a) <=> length($b) } keys %$const;
+ };
+ foreach my $key (@const_keys) {
+ if (length $key) {
+ my $target = $info;
+ my @parts = split(/\./, $key);
+ my $cur = '';
+ my $data = $const->{$key};
+ foreach my $p (@parts) {
+ $target = $target->[1]->{$p} ||= [];
+ $cur .= ".${p}";
+ if ($cur eq ".${key}" && (my @ckey = @{$collapse{$cur}||[]})) {
+ # collapsing at this point and on final part
+ my $pos = $collapse_pos{$cur};
+ CK: foreach my $ck (@ckey) {
+ if (!defined $pos->{$ck} || $pos->{$ck} ne $data->{$ck}) {
+ $collapse_pos{$cur} = $data;
+ delete @collapse_pos{ # clear all positioning for sub-entries
+ grep { m/^\Q${cur}.\E/ } keys %collapse_pos
+ };
+ push(@$target, []);
+ last CK;
+ }
+ }
+ }
+ if (exists $collapse{$cur}) {
+ $target = $target->[-1];
+ }
+ }
+ $target->[0] = $data;
+ } else {
+ $info->[0] = $const->{$key};
+ }
}
- @$target = (@final ? @final : [ {}, {} ]);
- # single empty result to indicate an empty prefetched has_many
}
- #print "final info: " . Dumper($info);
return $info;
}
with to find the number of elements. If passed arguments, does a search
on the resultset and counts the results of that.
-Note: When using C<count> with C<group_by>, L<DBIX::Class> emulates C<GROUP BY>
+Note: When using C<count> with C<group_by>, L<DBIx::Class> emulates C<GROUP BY>
using C<COUNT( DISTINCT( columns ) )>. Some databases (notably SQLite) do
not support C<DISTINCT> with multiple columns. If you are using such a
database, you should only use columns from the main table in your C<group_by>
my $count = $self->_count;
return 0 unless $count;
- $count -= $self->{attrs}{offset} if $self->{attrs}{offset};
+ # need to take offset from resolved attrs
+
+ $count -= $self->{_attrs}{offset} if $self->{_attrs}{offset};
$count = $self->{attrs}{rows} if
$self->{attrs}{rows} and $self->{attrs}{rows} < $count;
+ $count = 0 if ($count < 0);
return $count;
}
return $count;
}
+sub _bool {
+ return 1;
+}
+
=head2 count_literal
=over 4
unless ref $values eq 'HASH';
my $cond = $self->_cond_for_update_delete;
-
+
return $self->result_source->storage->update(
- $self->result_source->from, $values, $cond
+ $self->result_source, $values, $cond
);
}
my $cond = $self->_cond_for_update_delete;
- $self->result_source->storage->delete($self->result_source->from, $cond);
+ $self->result_source->storage->delete($self->result_source, $cond);
return 1;
}
return 1;
}
+=head2 populate
+
+=over 4
+
+=item Arguments: \@data;
+
+=back
+
+Pass an arrayref of hashrefs. Each hashref should be a structure suitable 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.
+
+Otherwise, each set of data is inserted into the database using
+L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
+objects is returned.
+
+Example: Assuming an Artist Class that has many CDs Classes relating:
+
+ my $Artist_rs = $schema->resultset("Artist");
+
+ ## Void Context Example
+ $Artist_rs->populate([
+ { artistid => 4, name => 'Manufactured Crap', cds => [
+ { title => 'My First CD', year => 2006 },
+ { title => 'Yet More Tweeny-Pop crap', year => 2007 },
+ ],
+ },
+ { artistid => 5, name => 'Angsty-Whiny Girl', cds => [
+ { title => 'My parents sold me to a record company' ,year => 2005 },
+ { title => 'Why Am I So Ugly?', year => 2006 },
+ { title => 'I Got Surgery and am now Popular', year => 2007 }
+ ],
+ },
+ ]);
+
+ ## Array Context Example
+ my ($ArtistOne, $ArtistTwo, $ArtistThree) = $Artist_rs->populate([
+ { name => "Artist One"},
+ { name => "Artist Two"},
+ { name => "Artist Three", cds=> [
+ { title => "First CD", year => 2007},
+ { title => "Second CD", year => 2008},
+ ]}
+ ]);
+
+ print $ArtistOne->name; ## response is 'Artist One'
+ print $ArtistThree->cds->count ## reponse is '2'
+
+Please note an important effect on your data when choosing between void and
+wantarray context. Since void context goes straight to C<insert_bulk> in
+L<DBIx::Class::Storage::DBI> this will skip any component that is overriding
+c<insert>. So if you are using something like L<DBIx-Class-UUIDColumns> to
+create primary keys for you, you will find that your PKs are empty. In this
+case you will have to use the wantarray context in order to create those
+values.
+
+=cut
+
+sub populate {
+ my ($self, $data) = @_;
+
+ if(defined wantarray) {
+ my @created;
+ foreach my $item (@$data) {
+ push(@created, $self->create($item));
+ }
+ return @created;
+ } else {
+ my ($first, @rest) = @$data;
+
+ my @names = grep {!ref $first->{$_}} keys %$first;
+ my @rels = grep { $self->result_source->has_relationship($_) } keys %$first;
+ my @pks = $self->result_source->primary_columns;
+
+ ## do the belongs_to relationships
+ foreach my $index (0..$#$data) {
+ if( grep { !defined $data->[$index]->{$_} } @pks ) {
+ my @ret = $self->populate($data);
+ return;
+ }
+
+ foreach my $rel (@rels) {
+ next unless $data->[$index]->{$rel} && 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 $related = $result->result_source->resolve_condition(
+ $result->result_source->relationship_info($reverse)->{cond},
+ $self,
+ $result,
+ );
+
+ delete $data->[$index]->{$rel};
+ $data->[$index] = {%{$data->[$index]}, %$related};
+
+ push @names, keys %$related if $index == 0;
+ }
+ }
+
+ ## do bulk insert on current row
+ my @values = map { [ @$_{@names} ] } @$data;
+
+ $self->result_source->storage->insert_bulk(
+ $self->result_source,
+ \@names,
+ \@values,
+ );
+
+ ## do the has_many relationships
+ foreach my $item (@$data) {
+
+ foreach my $rel (@rels) {
+ next unless $item->{$rel} && ref $item->{$rel} eq "ARRAY";
+
+ my $parent = $self->find(map {{$_=>$item->{$_}} } @pks)
+ || $self->throw_exception('Cannot find the relating object.');
+
+ my $child = $parent->$rel;
+
+ my $related = $child->result_source->resolve_condition(
+ $parent->result_source->relationship_info($rel)->{cond},
+ $child,
+ $parent,
+ );
+
+ my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
+ my @populate = map { {%$_, %$related} } @rows_to_add;
+
+ $child->populate( \@populate );
+ }
+ }
+ }
+}
+
=head2 pager
=over 4
=back
-Creates an object in the resultset's result class and returns it.
+Creates a new row object in the resultset's result class and returns
+it. The row is not inserted into the database at this point, call
+L<DBIx::Class::Row/insert> to do that. Calling L<DBIx::Class::Row/in_storage>
+will tell you whether the row object has been inserted or not.
+
+Passes the hashref of input on to L<DBIx::Class::Row/new>.
=cut
my $alias = $self->{attrs}{alias};
my $collapsed_cond = $self->{cond} ? $self->_collapse_cond($self->{cond}) : {};
+
+ # precendence must be given to passed values over values inherited from the cond,
+ # so the order here is important.
my %new = (
- %{ $self->_remove_alias($values, $alias) },
%{ $self->_remove_alias($collapsed_cond, $alias) },
- -result_source => $self->result_source,
+ %{ $self->_remove_alias($values, $alias) },
+ -source_handle => $self->_source_handle,
+ -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED
);
- my $obj = $self->result_class->new(\%new);
- return $obj;
+ return $self->result_class->new(\%new);
}
# _collapse_cond
=item Arguments: \%vals
-=item Return Value: $object
+=item Return Value: a L<DBIx::Class::Row> $object
=back
-Inserts a record into the resultset and returns the object representing it.
+Attempt to create a single new row or a row with multiple related rows
+in the table represented by the resultset (and related tables). This
+will not check for duplicate rows before inserting, use
+L</find_or_create> to do that.
+
+To create one row for this resultset, pass a hashref of key/value
+pairs representing the columns of the table and the values you wish to
+store. If the appropriate relationships are set up, foreign key fields
+can also be passed an object representing the foreign row, and the
+value will be set to it's primary key.
+
+To create related objects, pass a hashref for the value if the related
+item is a foreign key relationship (L<DBIx::Class::Relationship/belongs_to>),
+and use the name of the relationship as the key. (NOT the name of the field,
+necessarily). For C<has_many> and C<has_one> relationships, pass an arrayref
+of hashrefs containing the data for each of the rows to create in the foreign
+tables, again using the relationship name as the key.
+
+Instead of hashrefs of plain related data (key/value pairs), you may
+also pass new or inserted objects. New objects (not inserted yet, see
+L</new>), will be inserted into their appropriate tables.
Effectively a shortcut for C<< ->new_result(\%vals)->insert >>.
+Example of creating a new row.
+
+ $person_rs->create({
+ name=>"Some Person",
+ email=>"somebody@someplace.com"
+ });
+
+Example of creating a new row and also creating rows in a related C<has_many>
+or C<has_one> resultset. Note Arrayref.
+
+ $artist_rs->create(
+ { artistid => 4, name => 'Manufactured Crap', cds => [
+ { title => 'My First CD', year => 2006 },
+ { title => 'Yet More Tweeny-Pop crap', year => 2007 },
+ ],
+ },
+ );
+
+Example of creating a new row and also creating a row in a related
+C<belongs_to>resultset. Note Hashref.
+
+ $cd_rs->create({
+ title=>"Music for Silly Walks",
+ year=>2000,
+ artist => {
+ name=>"Silly Musician",
+ }
+ });
+
=cut
sub create {
Gets the contents of the cache for the resultset, if the cache is set.
+The cache is populated either by using the L</prefetch> attribute to
+L</search> or by calling L</set_cache>.
+
=cut
sub get_cache {
if the cache is set the resultset will return the cached objects rather
than re-querying the database even if the cache attr is not set.
+The contents of the cache can also be populated by using the
+L</prefetch> attribute to L</search>.
+
=cut
sub set_cache {
my $rel_obj = $self->result_source->relationship_info($rel);
$self->throw_exception(
- "search_related: result source '" . $self->result_source->name .
+ "search_related: result source '" . $self->result_source->source_name .
"' has no such relationship $rel")
unless $rel_obj;
my $join_count = $seen->{$rel};
my $alias = ($join_count > 1 ? join('_', $rel, $join_count) : $rel);
- $self->result_source->schema->resultset($rel_obj->{class})->search_rs(
- undef, {
- %{$self->{attrs}||{}},
- join => undef,
- prefetch => undef,
- select => undef,
- as => undef,
- alias => $alias,
- where => $self->{cond},
- seen_join => $seen,
- from => $from,
- });
+ #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi
+ my %attrs = %{$self->{attrs}||{}};
+ delete @attrs{qw(result_class alias)};
+
+ my $new_cache;
+
+ if (my $cache = $self->get_cache) {
+ if ($cache->[0] && $cache->[0]->related_resultset($rel)->get_cache) {
+ $new_cache = [ map { @{$_->related_resultset($rel)->get_cache} }
+ @$cache ];
+ }
+ }
+
+ my $rel_source = $self->result_source->related_source($rel);
+
+ my $new = do {
+
+ # The reason we do this now instead of passing the alias to the
+ # search_rs below is that if you wrap/overload resultset on the
+ # source you need to know what alias it's -going- to have for things
+ # to work sanely (e.g. RestrictWithObject wants to be able to add
+ # extra query restrictions, and these may need to be $alias.)
+
+ my $attrs = $rel_source->resultset_attributes;
+ local $attrs->{alias} = $alias;
+
+ $rel_source->resultset
+ ->search_rs(
+ undef, {
+ %attrs,
+ join => undef,
+ prefetch => undef,
+ select => undef,
+ as => undef,
+ where => $self->{cond},
+ seen_join => $seen,
+ from => $from,
+ });
+ };
+ $new->set_cache($new_cache) if $new_cache;
+ $new;
};
}
my $join = ($attrs->{join}
? [ $attrs->{join}, $extra_join ]
: $extra_join);
+
+ # we need to take the prefetch the attrs into account before we
+ # ->resolve_join as otherwise they get lost - captainL
+ my $merged = $self->_merge_attr( $join, $attrs->{prefetch} );
+
$from = [
@$from,
- ($join ? $source->resolve_join($join, $attrs->{alias}, $seen) : ()),
+ ($join ? $source->resolve_join($merged, $attrs->{alias}, $seen) : ()),
];
return ($from,$seen);
return $self->{_attrs} if $self->{_attrs};
my $attrs = { %{$self->{attrs}||{}} };
- my $source = $self->{result_source};
+ my $source = $self->result_source;
my $alias = $attrs->{alias};
$attrs->{columns} ||= delete $attrs->{cols} if exists $attrs->{cols};
$join = $self->_merge_attr(
$join, $attrs->{prefetch}
);
+
}
$attrs->{from} = # have to copy here to avoid corrupting the original
@{$attrs->{from}},
$source->resolve_join($join, $alias, { %{$attrs->{seen_join}||{}} })
];
+
}
$attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct};
}
$attrs->{collapse} = $collapse;
+ if ($attrs->{page}) {
+ $attrs->{offset} ||= 0;
+ $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1));
+ }
+
return $self->{_attrs} = $attrs;
}
+sub _rollout_attr {
+ my ($self, $attr) = @_;
+
+ if (ref $attr eq 'HASH') {
+ return $self->_rollout_hash($attr);
+ } elsif (ref $attr eq 'ARRAY') {
+ return $self->_rollout_array($attr);
+ } else {
+ return [$attr];
+ }
+}
+
+sub _rollout_array {
+ my ($self, $attr) = @_;
+
+ my @rolled_array;
+ foreach my $element (@{$attr}) {
+ if (ref $element eq 'HASH') {
+ push( @rolled_array, @{ $self->_rollout_hash( $element ) } );
+ } elsif (ref $element eq 'ARRAY') {
+ # XXX - should probably recurse here
+ push( @rolled_array, @{$self->_rollout_array($element)} );
+ } else {
+ push( @rolled_array, $element );
+ }
+ }
+ return \@rolled_array;
+}
+
+sub _rollout_hash {
+ my ($self, $attr) = @_;
+
+ my @rolled_array;
+ foreach my $key (keys %{$attr}) {
+ push( @rolled_array, { $key => $attr->{$key} } );
+ }
+ return \@rolled_array;
+}
+
+sub _calculate_score {
+ my ($self, $a, $b) = @_;
+
+ if (ref $b eq 'HASH') {
+ my ($b_key) = keys %{$b};
+ if (ref $a eq 'HASH') {
+ my ($a_key) = keys %{$a};
+ if ($a_key eq $b_key) {
+ return (1 + $self->_calculate_score( $a->{$a_key}, $b->{$b_key} ));
+ } else {
+ return 0;
+ }
+ } else {
+ return ($a eq $b_key) ? 1 : 0;
+ }
+ } else {
+ if (ref $a eq 'HASH') {
+ my ($a_key) = keys %{$a};
+ return ($b eq $a_key) ? 1 : 0;
+ } else {
+ return ($b eq $a) ? 1 : 0;
+ }
+ }
+}
+
sub _merge_attr {
my ($self, $a, $b) = @_;
+
return $b unless defined($a);
return $a unless defined($b);
- if (ref $b eq 'HASH' && ref $a eq 'HASH') {
- foreach my $key (keys %{$b}) {
- if (exists $a->{$key}) {
- $a->{$key} = $self->_merge_attr($a->{$key}, $b->{$key});
- } else {
- $a->{$key} = $b->{$key};
+ $a = $self->_rollout_attr($a);
+ $b = $self->_rollout_attr($b);
+
+ my $seen_keys;
+ foreach my $b_element ( @{$b} ) {
+ # find best candidate from $a to merge $b_element into
+ my $best_candidate = { position => undef, score => 0 }; my $position = 0;
+ foreach my $a_element ( @{$a} ) {
+ my $score = $self->_calculate_score( $a_element, $b_element );
+ if ($score > $best_candidate->{score}) {
+ $best_candidate->{position} = $position;
+ $best_candidate->{score} = $score;
}
+ $position++;
}
- return $a;
- } else {
- $a = [$a] unless ref $a eq 'ARRAY';
- $b = [$b] unless ref $b eq 'ARRAY';
-
- my $hash = {};
- my @array;
- foreach my $x ($a, $b) {
- foreach my $element (@{$x}) {
- if (ref $element eq 'HASH') {
- $hash = $self->_merge_attr($hash, $element);
- } elsif (ref $element eq 'ARRAY') {
- push(@array, @{$element});
- } else {
- push(@array, $element) unless $b == $x
- && grep { $_ eq $element } @array;
- }
+ my ($b_key) = ( ref $b_element eq 'HASH' ) ? keys %{$b_element} : ($b_element);
+
+ if ($best_candidate->{score} == 0 || exists $seen_keys->{$b_key}) {
+ push( @{$a}, $b_element );
+ } else {
+ my $a_best = $a->[$best_candidate->{position}];
+ # merge a_best and b_element together and replace original with merged
+ if (ref $a_best ne 'HASH') {
+ $a->[$best_candidate->{position}] = $b_element;
+ } elsif (ref $b_element eq 'HASH') {
+ my ($key) = keys %{$a_best};
+ $a->[$best_candidate->{position}] = { $key => $self->_merge_attr($a_best->{$key}, $b_element->{$key}) };
}
}
-
- @array = grep { !exists $hash->{$_} } @array;
-
- return keys %{$hash}
- ? ( scalar(@array)
- ? [$hash, @array]
- : $hash
- )
- : \@array;
+ $seen_keys->{$b_key} = 1; # don't merge the same key twice
}
+
+ return $a;
+}
+
+sub result_source {
+ my $self = shift;
+
+ if (@_) {
+ $self->_source_handle($_[0]->handle);
+ } else {
+ $self->_source_handle->resolve;
+ }
}
=head2 throw_exception
sub throw_exception {
my $self=shift;
- $self->result_source->schema->throw_exception(@_);
+ if (ref $self && $self->_source_handle->schema) {
+ $self->_source_handle->schema->throw_exception(@_)
+ } else {
+ croak(@_);
+ }
+
}
# XXX: FIXME: Attributes docs need clearing up
});
would return all CDs and include a 'name' column to the information
-passed to object inflation
+passed to object inflation. Note that the 'artist' is the name of the
+column (or relationship) accessor, and 'name' is the name of the column
+accessor in the related table.
=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 selection.
=back
=over 4
-Indicates additional column names for those added via L<+select>.
+Indicates additional column names for those added via L</+select>.
=back
=back
-Indicates column names for object inflation. This is used in conjunction with
-C<select>, usually when C<select> contains one or more function or stored
+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:
$rs = $schema->resultset('Employee')->search(undef, {
If you want to fetch related objects from other tables as well, see C<prefetch>
below.
+For more help on using joins with search, see L<DBIx::Class::Manual::Joining>.
+
=head2 prefetch
=over 4
=back
-Contains one or more relationships that should be fetched along with the main
-query (when they are accessed afterwards they will have already been
-"prefetched"). This is useful for when you know you will need the related
-objects, because it saves at least one query:
+Contains one or more relationships that should be fetched along with
+the main query (when they are accessed afterwards the data will
+already be available, without extra queries to the database). This is
+useful for when you know you will need the related objects, because it
+saves at least one query:
my $rs = $schema->resultset('Tag')->search(
undef,
case.
Simple prefetches will be joined automatically, so there is no need
-for a C<join> attribute in the above search. If you're prefetching to
-depth (e.g. { cd => { artist => 'label' } or similar), you'll need to
-specify the join as well.
+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').
+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 associted
+with that artist is given below (assuming many-to-many from artists to tags):
+
+ my $rs = $schema->resultset('Artist')->search(
+ undef,
+ {
+ prefetch => [
+ { cds => 'tracks' },
+ { artist_tags => 'tags' }
+ ]
+ }
+ );
+
+
+B<NOTE:> If you specify a C<prefetch> attribute, the C<join> and C<select>
+attributes will be ignored.
=head2 page
# SELECT child.* FROM person child
# INNER JOIN person father ON child.father_id = father.id
+=head2 for
+
+=over 4
+
+=item Value: ( 'update' | 'shared' )
+
+=back
+
+Set to 'update' for a SELECT ... FOR UPDATE or 'shared' for a SELECT
+... FOR SHARED.
+
=cut
1;
sub new {
my ($class, $rs, $column) = @_;
$class = ref $class if ref $class;
-
- my $object_ref = { _column => $column,
- _parent_resultset => $rs };
-
- my $new = bless $object_ref, $class;
- $new->throw_exception("column must be supplied") unless ($column);
+ my $new_parent_rs = $rs->search_rs; # we don't want to mess up the original, so clone it
+ $new_parent_rs->{attrs}->{prefetch} = undef; # prefetch causes additional columns to be fetched
+ my $new = bless { _column => $column, _parent_resultset => $new_parent_rs }, $class;
+ $new->throw_exception("column must be supplied") unless $column;
return $new;
}
sub next {
my $self = shift;
-
$self->{_resultset} = $self->{_parent_resultset}->search(undef, {select => [$self->{_column}], as => [$self->{_column}]}) unless ($self->{_resultset});
my ($row) = $self->{_resultset}->cursor->next;
return $row;
=cut
sub min {
- my $self = shift;
- return $self->func('MIN');
+ return shift->func('MIN');
}
=head2 max
=cut
sub max {
- my $self = shift;
- return $self->func('MAX');
+ return shift->func('MAX');
}
=head2 sum
=cut
sub sum {
- my $self = shift;
- return $self->func('SUM');
+ return shift->func('SUM');
}
=head2 func
=cut
sub func {
- my $self = shift;
- my $function = shift;
+ my ($self,$function) = @_;
+ my $cursor = $self->{_parent_resultset}->search(undef, {select => {$function => $self->{_column}}, as => [$self->{_column}]})->cursor;
+
+ if( wantarray ) {
+ return map { $_->[ 0 ] } $cursor->all;
+ }
- my ($row) = $self->{_parent_resultset}->search(undef, {select => {$function => $self->{_column}}, as => [$self->{_column}]})->cursor->next;
- return $row;
+ return ( $cursor->next )[ 0 ];
}
1;
use base 'DBIx::Class';
use Class::Inspector;
-=head1 NAME
-
-DBIx::Class::ResultSetManager - helpful methods for managing resultset
-classes (EXPERIMENTAL)
-
-=head1 SYNOPSIS
+warn "DBIx::Class::ResultSetManager never left experimental status and
+has now been DEPRECATED. This module will be deleted in 09000 so please
+migrate any and all code using it to explicit resultset classes using either
+__PACKAGE__->resultset_class(...) calls or by switching from using
+DBIx::Class::Schema->load_classes() to load_namespaces() and creating
+appropriate My::Schema::ResultSet::* classes for it to pick up.";
- # in a table class
- __PACKAGE__->load_components(qw/ResultSetManager Core/); # note order!
-
- # will be removed from the table class and inserted into a
- # table-specific resultset class
- sub search_by_year_desc : ResultSet {
- my $self = shift;
- my $cond = shift;
- my $attrs = shift || {};
- $attrs->{order_by} = 'year DESC';
- $self->search($cond, $attrs);
- }
+=head1 NAME
- $rs = $schema->resultset('CD')->search_by_year_desc({ artist => 'Tool' });
+DBIx::Class::ResultSetManager - scheduled for deletion in 09000
=head1 DESCRIPTION
-This package implements two useful features for customizing resultset
-classes. C<load_resultset_components> loads components in addition to
-C<DBIx::Class::ResultSet> (or whatever you set as
-C<base_resultset_class>). Any methods tagged with the C<ResultSet>
-attribute will be moved into a table-specific resultset class (by
-default called C<Class::_resultset>, but configurable via
-C<table_resultset_class_suffix>). Most of the magic is done when you
-call C<< __PACKAGE__->table >>.
+DBIx::Class::ResultSetManager never left experimental status and
+has now been DEPRECATED. This module will be deleted in 09000 so please
+migrate any and all code using it to explicit resultset classes using either
+__PACKAGE__->resultset_class(...) calls or by switching from using
+DBIx::Class::Schema->load_classes() to load_namespaces() and creating
+appropriate My::Schema::ResultSet::* classes for it to pick up.";
=cut
__PACKAGE__->base_resultset_class('DBIx::Class::ResultSet');
__PACKAGE__->table_resultset_class_suffix('::_resultset');
-=head2 table
-
-Stacks on top of the normal L<DBIx::Class> C<table> method. Any
-methods tagged with the C<ResultSet> attribute will be moved into a
-table-specific resultset class (by default called
-C<Class::_resultset>, but configurable via
-C<table_resultset_class_suffix>). The magic for this is done within
-this C<< __PACKAGE__->table >> call.
-
-=cut
-
sub table {
my ($self,@rest) = @_;
my $ret = $self->next::method(@rest);
return $ret;
}
-=head2 load_resultset_components
-
-C<load_resultset_components> loads components in addition to
-C<DBIx::Class::ResultSet> (or whatever you set as
-C<base_resultset_class>).
-
-=cut
-
sub load_resultset_components {
my ($self,@comp) = @_;
my $resultset_class = $self->_setup_resultset_class;
}
1;
-
-=head1 AUTHORS
-
-David Kamholz <dkamholz@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
use warnings;
use DBIx::Class::ResultSet;
+use DBIx::Class::ResultSourceHandle;
use Carp::Clan qw/^DBIx::Class/;
use Storable;
__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
_columns _primaries _unique_constraints name resultset_attributes
- schema from _relationships column_info_from_storage source_name
- source_info/);
+ schema from _relationships column_info_from_storage source_info
+ source_name/);
-__PACKAGE__->mk_group_accessors('inherited' => qw/resultset_class
+__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
result_class/);
=head1 NAME
my ($class, $attrs) = @_;
$class = ref $class if ref $class;
- my $new = { %{$attrs || {}}, _resultset => undef };
- bless $new, $class;
-
+ my $new = bless { %{$attrs || {}} }, $class;
$new->{resultset_class} ||= 'DBIx::Class::ResultSet';
$new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
$new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
the hashref as the column_info for that column. Repeated calls of this
method will add more columns, not replace them.
+The column names given will be created as accessor methods on your
+L<DBIx::Class::Row> objects, you can change the name of the accessor
+by supplying an L</accessor> in the column_info hash.
+
The contents of the column_info are not set in stone. The following
keys are currently recognised/used by DBIx::Class:
=item accessor
-Use this to set the name of the accessor for this column. If unset,
+Use this to set the name of the accessor method for this column. If unset,
the name of the column will be used.
=item data_type
will attempt to retrieve the name of the sequence from the database
automatically.
-=item extras
+=item auto_nextval
+
+Set this to a true value for a column whose value is retrieved
+automatically from an oracle sequence. If you do not use an oracle
+trigger to get the nextval, you have to set sequence as well.
+
+=item extra
This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
-to add extra non-generic data to the column. For example: C<< extras
+to add extra non-generic data to the column. For example: C<< extra
=> { unsigned => 1} >> is used by the MySQL producer to set an integer
column to unsigned. For more details, see
L<SQL::Translator::Producer::MySQL>.
return $self;
}
-*add_column = \&add_columns;
+sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
=head2 has_column
$self->_ordered_columns(\@remaining);
}
-*remove_column = \&remove_columns;
+sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
=head2 set_primary_key
unless $cond;
$attrs ||= {};
+ # Check foreign and self are right in cond
+ if ( (ref $cond ||'') eq 'HASH') {
+ for (keys %$cond) {
+ $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
+ if /\./ && !/^foreign\./;
+ }
+ }
+
my %rels = %{ $self->_relationships };
$rels{$rel} = { class => $f_source_name,
source => $f_source_name,
my $otherrel_info = $othertable->relationship_info($otherrel);
my $back = $othertable->related_source($otherrel);
- next unless $back->name eq $self->name;
+ next unless $back->source_name eq $self->source_name;
my @othertestconds;
=cut
sub resolve_join {
- my ($self, $join, $alias, $seen) = @_;
+ my ($self, $join, $alias, $seen, $force_left) = @_;
$seen ||= {};
+ $force_left ||= { force => 0 };
if (ref $join eq 'ARRAY') {
return map { $self->resolve_join($_, $alias, $seen) } @$join;
} elsif (ref $join eq 'HASH') {
return
map {
my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
- ($self->resolve_join($_, $alias, $seen),
- $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
+ local $force_left->{force};
+ (
+ $self->resolve_join($_, $alias, $seen, $force_left),
+ $self->related_source($_)->resolve_join(
+ $join->{$_}, $as, $seen, $force_left
+ )
+ );
} keys %$join;
} elsif (ref $join) {
$self->throw_exception("No idea how to resolve join reftype ".ref $join);
my $as = ($count > 1 ? "${join}_${count}" : $join);
my $rel_info = $self->relationship_info($join);
$self->throw_exception("No such relationship ${join}") unless $rel_info;
- my $type = $rel_info->{attrs}{join_type} || '';
+ my $type;
+ if ($force_left->{force}) {
+ $type = 'left';
+ } else {
+ $type = $rel_info->{attrs}{join_type} || '';
+ $force_left->{force} = 1 if lc($type) eq 'left';
+ }
return [ { $as => $self->related_source($join)->from,
-join_type => $type },
$self->resolve_condition($rel_info->{cond}, $as, $alias) ];
$self->throw_exception("Invalid rel cond val ${v}");
if (ref $for) { # Object
#warn "$self $k $for $v";
- $ret{$k} = $for->get_column($v);
+ $ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
#warn %ret;
} elsif (!defined $for) { # undef, i.e. "no object"
$ret{$k} = undef;
+ } elsif (ref $as eq 'HASH') { # reverse hashref
+ $ret{$v} = $as->{$k};
} elsif (ref $as) { # reverse object
$ret{$v} = $as->get_column($k);
} elsif (!defined $as) { # undef, i.e. "no reverse object"
$self->throw_exception(
"Can't prefetch has_many ${pre} (join cond too complex)")
unless ref($rel_info->{cond}) eq 'HASH';
+ my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
+ if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
+ keys %{$collapse}) {
+ my ($last) = ($fail =~ /([^\.]+)$/);
+ $self->throw_exception(
+ "Can't prefetch multiple has_many rels ${last} and ${pre}"
+ .(length($as_prefix) ? "at the same level (${as_prefix})"
+ : "at top level"
+ ));
+ }
+ #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
+ # values %{$rel_info->{cond}};
+ $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
+ # action at a distance. prepending the '.' allows simpler code
+ # in ResultSet->_collapse_result
my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
keys %{$rel_info->{cond}};
- $collapse->{"${as_prefix}${pre}"} = \@key;
my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
? @{$rel_info->{attrs}{order_by}}
: (defined $rel_info->{attrs}{order_by}
Set the class of the resultset, this is useful if you want to create your
own resultset methods. Create your own class derived from
-L<DBIx::Class::ResultSet>, and set it here.
+L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
+this method returns the name of the existing resultset class, if one
+exists.
=head2 resultset_attributes
$source->resultset_attributes({ order_by => [ 'id' ] });
-Specify here any attributes you wish to pass to your specialised resultset.
+Specify here any attributes you wish to pass to your specialised
+resultset. For a full list of these, please see
+L<DBIx::Class::ResultSet/ATTRIBUTES>.
=cut
'call it on the schema instead.'
) if scalar @_;
- # disabled until we can figure out a way to do it without consistency issues
- #
- #return $self->{_resultset}
- # if ref $self->{_resultset} eq $self->resultset_class;
- #return $self->{_resultset} =
-
return $self->resultset_class->new(
- $self, $self->{resultset_attributes}
+ $self,
+ {
+ %{$self->{resultset_attributes}},
+ %{$self->schema->default_resultset_attributes}
+ },
);
}
# from your schema...
$schema->resultset('Books')->find(1);
+=head2 handle
+
+Obtain a new handle to this source. Returns an instance of a
+L<DBIx::Class::ResultSourceHandle>.
+
+=cut
+
+sub handle {
+ return new DBIx::Class::ResultSourceHandle({
+ schema => $_[0]->schema,
+ source_moniker => $_[0]->source_name
+ });
+}
+
=head2 throw_exception
See L<DBIx::Class::Schema/"throw_exception">.
}
}
+=head2 sqlt_deploy_hook($sqlt_table)
+
+An optional sub which you can declare in your own Schema class that will get
+passed the L<SQL::Translator::Schema::Table> 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
+L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
+
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
=cut
+1;
--- /dev/null
+package DBIx::Class::ResultSourceHandle;
+
+use strict;
+use warnings;
+use Storable;
+use Carp;
+
+use base qw/DBIx::Class/;
+
+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/);
+
+# Schema to use when thawing.
+our $thaw_schema;
+
+=head1 NAME
+
+DBIx::Class::ResultSourceHandle
+
+=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
+
+=item *
+
+Closer to being able to do a Serialize::Storable that doesn't require class-based connections
+
+=back
+
+=head1 METHODS
+
+=head2 new
+
+=cut
+
+sub new {
+ my ($class, $data) = @_;
+
+ $class = ref $class if ref $class;
+
+ bless $data, $class;
+}
+
+=head2 resolve
+
+Resolve the moniker into the actual ResultSource object
+
+=cut
+
+sub resolve { return $_[0]->schema->source($_[0]->source_moniker) }
+
+=head2 STORABLE_freeze
+
+Freezes a handle.
+
+=cut
+
+sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+
+ my $to_serialize = { %$self };
+
+ my $class = $self->schema->class($self->source_moniker);
+ $to_serialize->{schema} = $class;
+ return (Storable::freeze($to_serialize));
+}
+
+=head2 STORABLE_thaw
+
+Thaws frozen handle. Resets the internal schema reference to the package
+variable C<$thaw_schema>. The recomened 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->{schema};
+ if( $thaw_schema ) {
+ $self->{schema} = $thaw_schema;
+ }
+ else {
+ my $rs = $class->result_source_instance;
+ $self->{schema} = $rs->schema if $rs;
+ }
+
+ carp "Unable to restore schema" unless $self->{schema};
+}
+
+=head1 AUTHOR
+
+Ash Berlin C<< <ash@cpan.org> >>
+
+=cut
+
+1;
use warnings;
use base qw/DBIx::Class/;
+use Scalar::Util qw/blessed/;
+use Carp::Clan qw/^DBIx::Class/;
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_name { shift->result_source_instance->source_name(@_) }
sub source_info { shift->result_source_instance->source_info(@_) }
+sub set_inherited_ro_instance {
+ my $self = shift;
+
+ croak "Cannot set @{[shift]} on an instance" if blessed $self;
+
+ return $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(@_);
}
__PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do
# anything yet!
+sub _init_result_source_instance {
+ my $class = shift;
+
+ $class->mk_classdata('result_source_instance')
+ unless $class->can('result_source_instance');
+
+ my $table = $class->result_source_instance;
+ my $class_has_table_instance = ($table and $table->result_class eq $class);
+ return $table if $class_has_table_instance;
+
+ if( $table ) {
+ $table = $class->table_class->new({
+ %$table,
+ result_class => $class,
+ source_name => undef,
+ schema => undef
+ });
+ }
+ else {
+ $table = $class->table_class->new({
+ name => undef,
+ result_class => $class,
+ source_name => undef,
+ });
+ }
+
+ $class->result_source_instance($table);
+
+ if ($class->can('schema_instance')) {
+ $class =~ m/([^:]+)$/;
+ $class->schema_instance->register_class($class, $class);
+ }
+
+ return $table;
+}
+
=head1 NAME
DBIx::Class::ResultSourceProxy::Table - provides a classdata table
unless (ref $table) {
$table = $class->table_class->new({
$class->can('result_source_instance') ?
- %{$class->result_source_instance} : (),
+ %{$class->result_source_instance||{}} : (),
name => $table,
result_class => $class,
source_name => undef,
});
}
- $class->mk_classdata('result_source_instance' => $table);
+
+ $class->mk_classdata('result_source_instance')
+ unless $class->can('result_source_instance');
+
+ $class->result_source_instance($table);
+
if ($class->can('schema_instance')) {
$class =~ m/([^:]+)$/;
$class->schema_instance->register_class($class, $class);
}
+ return $class->result_source_instance->name;
}
=head2 has_column
use base qw/DBIx::Class/;
use Carp::Clan qw/^DBIx::Class/;
+use Scalar::Util ();
+use Scope::Guard;
-__PACKAGE__->mk_group_accessors('simple' => 'result_source');
+__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
=head1 NAME
Creates a new row object from column => value mappings passed as a hash ref
+Passing an object, or an arrayref of objects as a value will call
+L<DBIx::Class::Relationship::Base/set_from_related> for you. When
+passed a hashref or an arrayref of hashrefs as the value, these will
+be turned into objects via new_related, and treated as if you had
+passed objects.
+
+For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
+
=cut
+## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
+## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
+## When doing the later insert, we need to make sure the PKs are set.
+## using _relationship_data in new and funky ways..
+## check Relationship::CascadeActions and Relationship::Accessor for compat
+## tests!
+
sub new {
my ($class, $attrs) = @_;
$class = ref $class if ref $class;
- my $new = { _column_data => {} };
+ my $new = {
+ _column_data => {},
+ };
bless $new, $class;
+ if (my $handle = delete $attrs->{-source_handle}) {
+ $new->_source_handle($handle);
+ }
+ if (my $source = delete $attrs->{-result_source}) {
+ $new->result_source($source);
+ }
+
if ($attrs) {
$new->throw_exception("attrs must be a hashref")
unless ref($attrs) eq 'HASH';
- if (my $source = delete $attrs->{-result_source}) {
- $new->result_source($source);
- }
- foreach my $k (keys %$attrs) {
- $new->throw_exception("No such column $k on $class")
- unless $class->has_column($k);
- $new->store_column($k => $attrs->{$k});
+
+ my ($related,$inflated);
+ ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
+ $new->{_rel_in_storage} = 1;
+
+ foreach my $key (keys %$attrs) {
+ if (ref $attrs->{$key}) {
+ ## Can we extract this lot to use with update(_or .. ) ?
+ my $info = $class->relationship_info($key);
+ if ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'single')
+ {
+ my $rel_obj = delete $attrs->{$key};
+ if(!Scalar::Util::blessed($rel_obj)) {
+ $rel_obj = $new->find_or_new_related($key, $rel_obj);
+ }
+
+ $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+
+ $new->set_from_related($key, $rel_obj);
+ $related->{$key} = $rel_obj;
+ next;
+ } elsif ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'multi'
+ && ref $attrs->{$key} eq 'ARRAY') {
+ my $others = delete $attrs->{$key};
+ foreach my $rel_obj (@$others) {
+ if(!Scalar::Util::blessed($rel_obj)) {
+ $rel_obj = $new->new_related($key, $rel_obj);
+ $new->{_rel_in_storage} = 0;
+ }
+
+ $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ }
+ $related->{$key} = $others;
+ next;
+ } elsif ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'filter')
+ {
+ ## 'filter' should disappear and get merged in with 'single' above!
+ my $rel_obj = delete $attrs->{$key};
+ if(!Scalar::Util::blessed($rel_obj)) {
+ $rel_obj = $new->find_or_new_related($key, $rel_obj);
+ $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ }
+ $inflated->{$key} = $rel_obj;
+ next;
+ } elsif ($class->has_column($key)
+ && $class->column_info($key)->{_inflate_info}) {
+ $inflated->{$key} = $attrs->{$key};
+ next;
+ }
+ }
+ $new->throw_exception("No such column $key on $class")
+ unless $class->has_column($key);
+ $new->store_column($key => $attrs->{$key});
}
+
+ $new->{_relationship_data} = $related if $related;
+ $new->{_inflated_column} = $inflated if $inflated;
}
return $new;
an entirely new object into the database, use C<create> (see
L<DBIx::Class::ResultSet/create>).
+To fetch an uninserted row object, call
+L<new|DBIx::Class::ResultSet/new> on a resultset.
+
+This will also insert any uninserted, related objects held inside this
+one, see L<DBIx::Class::ResultSet/create> for more details.
+
=cut
sub insert {
my ($self) = @_;
return $self if $self->in_storage;
- $self->{result_source} ||= $self->result_source_instance
+ my $source = $self->result_source;
+ $source ||= $self->result_source($self->result_source_instance)
if $self->can('result_source_instance');
- my $source = $self->{result_source};
$self->throw_exception("No result_source set on this object; can't insert")
unless $source;
- #use Data::Dumper; warn Dumper($self);
- $source->storage->insert($source->from, { $self->get_columns });
+
+ my $rollback_guard;
+
+ # Check if we stored uninserted relobjs here in new()
+ my %related_stuff = (%{$self->{_relationship_data} || {}},
+ %{$self->{_inflated_column} || {}});
+
+ if(!$self->{_rel_in_storage}) {
+
+ # The guard will save us if we blow out of this scope via die
+ $rollback_guard = $source->storage->txn_scope_guard;
+
+ ## Should all be in relationship_data, but we need to get rid of the
+ ## 'filter' reltype..
+ ## These are the FK rels, need their IDs for the insert.
+
+ my @pri = $self->primary_columns;
+
+ REL: foreach my $relname (keys %related_stuff) {
+
+ my $rel_obj = $related_stuff{$relname};
+
+ next REL unless (Scalar::Util::blessed($rel_obj)
+ && $rel_obj->isa('DBIx::Class::Row'));
+
+ my $cond = $source->relationship_info($relname)->{cond};
+
+ next REL unless ref($cond) eq 'HASH';
+
+ # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
+
+ my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
+
+ # assume anything that references our PK probably is dependent on us
+ # rather than vice versa, unless the far side is (a) defined or (b)
+ # auto-increment
+
+ foreach my $p (@pri) {
+ if (exists $keyhash->{$p}) {
+ unless (defined($rel_obj->get_column($keyhash->{$p}))
+ || $rel_obj->column_info($keyhash->{$p})
+ ->{is_auto_increment}) {
+ next REL;
+ }
+ }
+ }
+
+ $rel_obj->insert();
+ $self->set_from_related($relname, $rel_obj);
+ delete $related_stuff{$relname};
+ }
+ }
+
+ my $updated_cols = $source->storage->insert($source, { $self->get_columns });
+ $self->set_columns($updated_cols);
+
+ ## PK::Auto
+ my @auto_pri = grep {
+ !defined $self->get_column($_) ||
+ ref($self->get_column($_)) eq 'SCALAR'
+ } $self->primary_columns;
+
+ if (@auto_pri) {
+ #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
+ # if defined $too_many;
+
+ 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;
+ }
+
+ if(!$self->{_rel_in_storage}) {
+ ## Now do the has_many rels, that need $selfs ID.
+ foreach my $relname (keys %related_stuff) {
+ my $rel_obj = $related_stuff{$relname};
+ my @cands;
+ if (Scalar::Util::blessed($rel_obj)
+ && $rel_obj->isa('DBIx::Class::Row')) {
+ @cands = ($rel_obj);
+ } elsif (ref $rel_obj eq 'ARRAY') {
+ @cands = @$rel_obj;
+ }
+ if (@cands) {
+ my $reverse = $source->reverse_relationship_info($relname);
+ foreach my $obj (@cands) {
+ $obj->set_from_related($_, $self) for keys %$reverse;
+ $obj->insert() unless ($obj->in_storage || $obj->result_source->resultset->search({$obj->get_columns})->count);
+ }
+ }
+ }
+ $rollback_guard->commit;
+ }
+
$self->in_storage(1);
$self->{_dirty_columns} = {};
$self->{related_resultsets} = {};
+ undef $self->{_orig_ident};
return $self;
}
$obj->in_storage; # Get value
$obj->in_storage(1); # Set value
-Indicated whether the object exists as a row in the database or not
+Indicates whether the object exists as a row in the database or
+not. This is set to true when L<DBIx::Class::ResultSet/find>,
+L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
+are used.
+
+Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
+L</delete> on one, sets it to false.
=cut
=head2 update
- $obj->update;
+ $obj->update \%columns?;
Must be run on an object that is already in the database; issues an SQL
UPDATE query to commit any changes to the object to the database if
required.
+Also takes an options hashref of C<< column_name => value> pairs >> to update
+first. But be aware that the hashref will be passed to
+C<set_inflated_columns>, which might edit it in place, so dont rely on it being
+the same after a call to C<update>. If you need to preserve the hashref, it is
+sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
+
+If the values passed or any of the column values set on the object
+contain scalar references, eg:
+
+ $obj->last_modified(\'NOW()');
+ # OR
+ $obj->update({ last_modified => \'NOW()' });
+
+The update will pass the values verbatim into SQL. (See
+L<SQL::Abstract> docs). The values in your Row object will NOT change
+as a result of the update call, if you want the object to be updated
+with the actual values from the database, call L</discard_changes>
+after the update.
+
+ $obj->update()->discard_changes();
+
=cut
sub update {
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_columns($upd) if $upd;
+
+ $self->set_inflated_columns($upd) if $upd;
my %to_update = $self->get_dirty_columns;
return $self unless keys %to_update;
my $rows = $self->result_source->storage->update(
- $self->result_source->from, \%to_update, $ident_cond);
+ $self->result_source, \%to_update,
+ $self->{_orig_ident} || $ident_cond
+ );
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};
return $self;
}
$obj->delete
Deletes the object from the database. The object is still perfectly
-usable, but C<-E<gt>in_storage()> will now return 0 and the object must
-reinserted using C<-E<gt>insert()> before C<-E(<gt>update()> can be used
+usable, but C<< ->in_storage() >> will now return 0 and the object must
+reinserted using C<< ->insert() >> before C<< ->update() >> can be used
on it. If you delete an object in a class with a C<has_many>
relationship, all the related objects will be deleted as well. To turn
-this behavior off, pass C<cascade_delete => 0> in the C<$attr>
+this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
hashref. Any database-level cascade or restrict will take precedence
over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
unless exists $self->{_column_data}{$column};
}
$self->result_source->storage->delete(
- $self->result_source->from, $ident_cond);
+ $self->result_source, $ident_cond);
$self->in_storage(undef);
} else {
$self->throw_exception("Can't do class delete without a ResultSource instance")
my $val = $obj->get_column($col);
-Gets a column value from a row object. Currently, does not do
-any queries; the column must have already been fetched from
-the database and stored in the object.
+Returns a raw column value from the row object, if it has already
+been fetched from the database or set by an accessor.
+
+If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
+will be deflated and returned.
=cut
my ($self, $column) = @_;
$self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
+ if (exists $self->{_inflated_column}{$column}) {
+ return $self->store_column($column,
+ $self->_deflated_column($column, $self->{_inflated_column}{$column}));
+ }
$self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
return undef;
}
sub has_column_loaded {
my ($self, $column) = @_;
$self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
+ return 1 if exists $self->{_inflated_column}{$column};
return exists $self->{_column_data}{$column};
}
my %data = $obj->get_columns;
-Does C<get_column>, for all column values at once.
+Does C<get_column>, for all loaded column values at once.
=cut
sub get_columns {
my $self = shift;
+ if (exists $self->{_inflated_column}) {
+ foreach my $col (keys %{$self->{_inflated_column}}) {
+ $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
+ unless exists $self->{_column_data}{$col};
+ }
+ }
return %{$self->{_column_data}};
}
keys %{$self->{_dirty_columns}};
}
+=head2 make_column_dirty
+
+Marks a column dirty regardless if it has really changed. Throws an
+exception if the column does not exist.
+
+=cut
+sub make_column_dirty {
+ my ($self, $column) = @_;
+
+ $self->throw_exception( "No such column '${column}'" )
+ unless exists $self->{_column_data}{$column} || $self->has_column($column);
+ $self->{_dirty_columns}{$column} = 1;
+}
+
+=head2 get_inflated_columns
+
+ my %inflated_data = $obj->get_inflated_columns;
+
+Similar to get_columns but objects are returned for inflated columns
+instead of their raw non-inflated values.
+
+=cut
+
+sub get_inflated_columns {
+ my $self = shift;
+ return map {
+ my $accessor = $self->column_info($_)->{'accessor'} || $_;
+ ($_ => $self->$accessor);
+ } $self->columns;
+}
+
=head2 set_column
$obj->set_column($col => $val);
-Sets a column value. If the new value is different from the old one,
+Sets a raw column value. If the new value is different from the old one,
the column is marked as dirty for when you next call $obj->update.
+If passed an object or reference, this will happily attempt store the
+value, and a later insert/update will try and stringify/numify as
+appropriate.
+
=cut
sub set_column {
my $self = shift;
my ($column) = @_;
+ $self->{_orig_ident} ||= $self->ident_condition;
my $old = $self->get_column($column);
my $ret = $self->store_column(@_);
$self->{_dirty_columns}{$column} = 1
- if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
+ if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
+
+ # XXX clear out the relation cache for this column
+ delete $self->{related_resultsets}{$column};
+
return $ret;
}
return $self;
}
+=head2 set_inflated_columns
+
+ my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
+
+Sets more than one column value at once, taking care to respect inflations and
+relationships if relevant. Be aware that this hashref might be edited in place,
+so dont rely on it being the same after a call to C<set_inflated_columns>. If
+you need to preserve the hashref, it is sufficient to pass a shallow copy to
+C<set_inflated_columns>, e.g. ( { %{ $href } } )
+
+=cut
+
+sub set_inflated_columns {
+ my ( $self, $upd ) = @_;
+ foreach my $key (keys %$upd) {
+ if (ref $upd->{$key}) {
+ my $info = $self->relationship_info($key);
+ if ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'single')
+ {
+ my $rel = delete $upd->{$key};
+ $self->set_from_related($key => $rel);
+ $self->{_relationship_data}{$key} = $rel;
+ } elsif ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'multi'
+ && ref $upd->{$key} eq 'ARRAY') {
+ my $others = delete $upd->{$key};
+ foreach my $rel_obj (@$others) {
+ if(!Scalar::Util::blessed($rel_obj)) {
+ $rel_obj = $self->create_related($key, $rel_obj);
+ }
+ }
+ $self->{_relationship_data}{$key} = $others;
+# $related->{$key} = $others;
+ next;
+ }
+ elsif ($self->has_column($key)
+ && exists $self->column_info($key)->{_inflate_info})
+ {
+ $self->set_inflated_column($key, delete $upd->{$key});
+ }
+ }
+ }
+ $self->set_columns($upd);
+}
+
=head2 copy
my $copy = $orig->copy({ change => $to, ... });
-Inserts a new row with the specified changes.
+Inserts a new row with the specified changes. If the row has related
+objects in a C<has_many> then those objects may be copied too depending
+on the C<cascade_copy> relationship attribute.
=cut
bless $new, ref $self;
$new->result_source($self->result_source);
- $new->set_columns($changes);
+ $new->set_inflated_columns($changes);
$new->insert;
+
+ # Its possible we'll have 2 relations to the same Source. We need to make
+ # sure we don't try to insert the same row twice esle we'll violate unique
+ # constraints
+ my $rels_copied = {};
+
foreach my $rel ($self->result_source->relationships) {
my $rel_info = $self->result_source->relationship_info($rel);
- if ($rel_info->{attrs}{cascade_copy}) {
- my $resolved = $self->result_source->resolve_condition(
- $rel_info->{cond}, $rel, $new);
- foreach my $related ($self->search_related($rel)) {
- $related->copy($resolved);
- }
+
+ next unless $rel_info->{attrs}{cascade_copy};
+
+ my $resolved = $self->result_source->resolve_condition(
+ $rel_info->{cond}, $rel, $new
+ );
+
+ my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
+ foreach my $related ($self->search_related($rel)) {
+ my $id_str = join("\0", $related->id);
+ next if $copied->{$id_str};
+ $copied->{$id_str} = 1;
+ my $rel_copy = $related->copy($resolved);
}
+
}
return $new;
}
sub inflate_result {
my ($class, $source, $me, $prefetch) = @_;
- #use Data::Dumper; print Dumper(@_);
+
+ my ($source_handle) = $source;
+
+ if ($source->isa('DBIx::Class::ResultSourceHandle')) {
+ $source = $source_handle->resolve
+ } else {
+ $source_handle = $source->handle
+ }
+
my $new = {
- result_source => $source,
+ _source_handle => $source_handle,
_column_data => $me,
_in_storage => 1
};
$fetched = $pre_source->result_class->inflate_result(
$pre_source, @{$pre_val});
}
+ $new->related_resultset($pre)->set_cache([ $fetched ]);
my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
$class->throw_exception("No accessor for prefetched $pre")
unless defined $accessor;
$obj->update_or_insert
-Updates the object if it's already in the db, else inserts it.
+Updates the object if it's already in the database, according to
+L</in_storage>, else inserts it.
=head2 insert_or_update
Accessor to the ResultSource this object was created from
+=cut
+
+sub result_source {
+ my $self = shift;
+
+ if (@_) {
+ $self->_source_handle($_[0]->handle);
+ } else {
+ $self->_source_handle->resolve;
+ }
+}
+
=head2 register_column
$column_info = { .... };
sub throw_exception {
my $self=shift;
- if (ref $self && ref $self->result_source) {
+ if (ref $self && ref $self->result_source && $self->result_source->schema) {
$self->result_source->schema->throw_exception(@_);
} else {
croak(@_);
}
}
+=head2 id
+
+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
+
+Re-selects the row from the database, losing any changes that had
+been 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>
+
+=cut
+
1;
=head1 AUTHORS
use strict;
use warnings;
+use DBIx::Class::Exception;
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util qw/weaken/;
use File::Spec;
__PACKAGE__->mk_classdata('storage_type' => '::DBI');
__PACKAGE__->mk_classdata('storage');
__PACKAGE__->mk_classdata('exception_action');
+__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0);
+__PACKAGE__->mk_classdata('default_resultset_attributes' => {});
=head1 NAME
=head1 METHODS
+=head2 schema_version
+
+Returns the current schema class' $VERSION
+
+=cut
+
+sub schema_version {
+ my ($self) = @_;
+ my $class = ref($self)||$self;
+
+ # does -not- use $schema->VERSION
+ # since that varies in results depending on if version.pm is installed, and if
+ # so the perl or XS versions. If you want this to change, bug the version.pm
+ # author to make vpp and vxs behave the same.
+
+ my $version;
+ {
+ no strict 'refs';
+ $version = ${"${class}::VERSION"};
+ }
+ return $version;
+}
+
=head2 register_class
=over 4
sub register_source {
my ($self, $moniker, $source) = @_;
+
+ %$source = %{ $source->new( { %$source, source_name => $moniker }) };
+
my %reg = %{$self->source_registrations};
$reg{$moniker} = $source;
$self->source_registrations(\%reg);
+
$source->schema($self);
+
weaken($source->{schema}) if ref($self);
if ($source->result_class) {
my %map = %{$self->class_mappings};
}
}
+sub _unregister_source {
+ my ($self, $moniker) = @_;
+ my %reg = %{$self->source_registrations};
+
+ my $source = delete $reg{$moniker};
+ $self->source_registrations(\%reg);
+ if ($source->result_class) {
+ my %map = %{$self->class_mappings};
+ delete $map{$source->result_class};
+ $self->class_mappings(\%map);
+ }
+}
+
=head2 class
=over 4
}
}
$class->ensure_class_loaded($comp_class);
- $comp_class->source_name($comp) unless $comp_class->source_name;
- push(@to_register, [ $comp_class->source_name, $comp_class ]);
+ $comp = $comp_class->source_name || $comp;
+# $DB::single = 1;
+ push(@to_register, [ $comp, $comp_class ]);
}
}
}
Actually, you probably just wanted to call connect.
-=for hidden due to deprecation
+=begin hidden
+
+(hidden due to deprecation)
Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
more information.
+=end hidden
+
=cut
{
sub compose_connection {
my ($self, $target, @info) = @_;
- warn "compose_connection deprecated as of 0.08000" unless $warn++;
+ warn "compose_connection deprecated as of 0.08000"
+ unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
my $base = 'DBIx::Class::ResultSetProxy';
eval "require ${base};";
sub compose_namespace {
my ($self, $target, $base) = @_;
- my %reg = %{ $self->source_registrations };
- my %target;
- my %map;
my $schema = $self->clone;
{
no warnings qw/redefine/;
Class::C3->reinitialize();
{
no strict 'refs';
+ no warnings 'redefine';
foreach my $meth (qw/class source resultset/) {
*{"${target}::${meth}"} =
sub { shift->schema->$meth(@_) };
return $schema;
}
-=head2 setup_connection_class
-
-=over 4
-
-=item Arguments: $target, @info
-
-=back
-
-Sets up a database connection class to inject between the schema and the
-subclasses that the schema creates.
-
-=cut
-
sub setup_connection_class {
my ($class, $target, @info) = @_;
$class->inject_base($target => 'DBIx::Class::DB');
my $storage = $storage_class->new($self);
$storage->connect_info(\@info);
$self->storage($storage);
- $self->on_connect() if($self->can('on_connect'));
return $self;
}
$self->storage->txn_do(@_);
}
+=head2 txn_scope_guard
+
+Runs C<txn_scope_guard> on the schema's storage.
+
+=cut
+
+sub txn_scope_guard {
+ my $self = shift;
+
+ $self->storage or $self->throw_exception
+ ('txn_scope_guard called on $schema without storage');
+
+ $self->storage->txn_scope_guard(@_);
+}
+
=head2 txn_begin
Begins a transaction (does nothing if AutoCommit is off). Equivalent to
$self->storage->txn_rollback;
}
+=head2 svp_begin
+
+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.
+
+=cut
+
+sub svp_begin {
+ my ($self, $name) = @_;
+
+ $self->storage or $self->throw_exception
+ ('svp_begin called on $schema without storage');
+
+ $self->storage->svp_begin($name);
+}
+
+=head2 svp_release
+
+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.
+
+=cut
+
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->storage or $self->throw_exception
+ ('svp_release called on $schema without storage');
+
+ $self->storage->svp_release($name);
+}
+
+=head2 svp_rollback
+
+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.
+
+=cut
+
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->storage or $self->throw_exception
+ ('svp_rollback called on $schema without storage');
+
+ $self->storage->svp_rollback($name);
+}
+
=head2 clone
=over 4
[ 2, 'Indie Band' ],
...
]);
+
+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
+storages that support this method.
+
+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
+wantarray context if you want the PKs automatically created.
=cut
}
return @created;
}
- $self->storage->insert_bulk($self->source($name)->from, \@names, $data);
+ my @results_to_create;
+ foreach my $datum (@$data) {
+ my %result_to_create;
+ foreach my $index (0..$#names) {
+ $result_to_create{$names[$index]} = $$datum[$index];
+ }
+ push @results_to_create, \%result_to_create;
+ }
+ $rs->populate(\@results_to_create);
}
=head2 exception_action
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 its normal <croak> action.
+rather than its normal C<croak> or C<confess> action.
Your subroutine should probably just wrap the error in the exception
object/class of your choosing and rethrow. If, against all sage advice,
# suppress all exceptions, like a moron:
$schema_obj->exception_action(sub { 1 });
+=head2 stacktrace
+
+=over 4
+
+=item Arguments: boolean
+
+=back
+
+Whether L</throw_exception> should include stack trace information.
+Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
+is true.
+
=head2 throw_exception
=over 4
Throws an exception. Defaults to using L<Carp::Clan> to report errors from
user's perspective. See L</exception_action> for details on overriding
-this method's behavior.
+this method's behavior. If L</stacktrace> is turned on, C<throw_exception>'s
+default behavior will provide a detailed stack trace.
=cut
sub throw_exception {
my $self = shift;
- croak @_ if !$self->exception_action || !$self->exception_action->(@_);
+
+ DBIx::Class::Exception->throw($_[0], $self->stacktrace)
+ if !$self->exception_action || !$self->exception_action->(@_);
}
-=head2 deploy (EXPERIMENTAL)
+=head2 deploy
=over 4
Attempts to deploy the schema to the current storage using L<SQL::Translator>.
-Note that this feature is currently EXPERIMENTAL and may not work correctly
-across all databases, or fully handle complex relationships.
-
See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
produced include a DROP TABLE statement for each table created.
+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.
+
=cut
sub deploy {
$self->storage->deploy($self, undef, $sqltargs, $dir);
}
+=head2 deployment_statements
+
+=over 4
+
+=item Arguments: $rdbms_type
+
+=back
+
+Returns the SQL statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
+C<$rdbms_type> provides the DBI database driver name for which the SQL
+statements are produced. If not supplied, the type of the current schema storage
+will be used.
+
+=cut
+
+sub deployment_statements {
+ my ($self, $rdbms_type) = @_;
+
+ $self->throw_exception("Can't generate deployment statements without a storage")
+ if not $self->storage;
+
+ $self->storage->deployment_statements($self, $rdbms_type);
+}
+
=head2 create_ddl_dir (EXPERIMENTAL)
=over 4
name format. For the ALTER file, the same format is used, replacing
$version in the name with "$preversion-$version".
+See L<DBIx::Class::Schema/deploy> for details of $sqlt_args.
+
If no arguments are passed, then the following default values are used:
=over 4
=over 4
-=item Arguments: $directory, $database-type, $version, $preversion
+=item Arguments: $database-type, $version, $directory, $preversion
=back
- my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
+ my $filename = $table->ddl_filename($type, $version, $dir, $preversion)
This method is called by C<create_ddl_dir> to compose a file name out of
the supplied directory, database type and version number. The default file
=cut
sub ddl_filename {
- my ($self, $type, $dir, $version, $pversion) = @_;
+ 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);
+
+ return $filename;
+}
+
+=head2 sqlt_deploy_hook($sqlt_schema)
+
+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
+L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
+
+=head2 thaw
- my $filename = ref($self);
- $filename =~ s/::/-/;
- $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
- $filename =~ s/$version/$pversion-$version/ if($pversion);
+Provided as the recommened 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
+
+=cut
+
+sub thaw {
+ my ($self, $obj) = @_;
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+ return Storable::thaw($obj);
+}
+
+=head2 freeze
+
+This doesn't actualy do anything more than call L<Storable/freeze>, it is just
+provided here for symetry.
+
+=cut
+
+sub freeze {
+ return Storable::freeze($_[1]);
+}
+
+=head2 dclone
+
+Recommeneded way of dcloning objects. This is needed to properly maintain
+references to the schema object (which itself is B<not> cloned.)
+
+=cut
- return $filename;
+sub dclone {
+ my ($self, $obj) = @_;
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+ return Storable::dclone($obj);
}
1;
-package DBIx::Class::Version::Table;
+package # Hide from PAUSE
+ DBIx::Class::Version::Table;
use base 'DBIx::Class';
use strict;
use warnings;
__PACKAGE__->load_components(qw/ Core/);
-__PACKAGE__->table('SchemaVersions');
+__PACKAGE__->table('dbix_class_schema_versions');
__PACKAGE__->add_columns
- ( 'Version' => {
+ ( 'version' => {
'data_type' => 'VARCHAR',
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
- 'name' => 'Version',
+ 'name' => 'version',
'is_nullable' => 0,
'size' => '10'
},
- 'Installed' => {
+ 'installed' => {
'data_type' => 'VARCHAR',
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
- 'name' => 'Installed',
+ 'name' => 'installed',
'is_nullable' => 0,
'size' => '20'
},
);
+__PACKAGE__->set_primary_key('version');
+
+package # Hide from PAUSE
+ DBIx::Class::Version::TableCompat;
+use base 'DBIx::Class';
+__PACKAGE__->load_components(qw/ Core/);
+__PACKAGE__->table('SchemaVersions');
+
+__PACKAGE__->add_columns
+ ( 'Version' => {
+ 'data_type' => 'VARCHAR',
+ },
+ 'Installed' => {
+ 'data_type' => 'VARCHAR',
+ },
+ );
__PACKAGE__->set_primary_key('Version');
-package DBIx::Class::Version;
+package # Hide from PAUSE
+ DBIx::Class::Version;
use base 'DBIx::Class::Schema';
use strict;
use warnings;
__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
+package # Hide from PAUSE
+ DBIx::Class::VersionCompat;
+use base 'DBIx::Class::Schema';
+use strict;
+use warnings;
+
+__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
+
# ---------------------------------------------------------------------------
+
+=head1 NAME
+
+DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+
+=head1 SYNOPSIS
+
+ package Library::Schema;
+ use base qw/DBIx::Class::Schema/;
+ # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
+ __PACKAGE__->load_classes(qw/CD Book DVD/);
+
+ __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
+ __PACKAGE__->upgrade_directory('/path/to/upgrades/');
+ __PACKAGE__->backup_directory('/path/to/backups/');
+
+
+=head1 DESCRIPTION
+
+This module is a component designed to extend L<DBIx::Class::Schema>
+classes, to enable them to upgrade to newer schema layouts. To use this
+module, you need to have called C<create_ddl_dir> on your Schema to
+create your upgrade files to include with your delivery.
+
+A table called I<dbix_class_schema_versions> is created and maintained by the
+module. This contains two fields, 'Version' and 'Installed', which
+contain each VERSION of your Schema, and the date+time it was installed.
+
+The actual upgrade is called manually by calling C<upgrade> on your
+schema object. Code is run at connect time to determine whether an
+upgrade is needed, if so, a warning "Versions out of sync" is
+produced.
+
+So you'll probably want to write a script which generates your DDLs and diffs
+and another which executes the upgrade.
+
+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
+them.
+
+=head1 METHODS
+
+=head2 upgrade_directory
+
+Use this to set the directory your upgrade files are stored in.
+
+=head2 backup_directory
+
+Use this to set the directory you want your backups stored in.
+
+=cut
+
package DBIx::Class::Schema::Versioned;
use strict;
__PACKAGE__->mk_classdata('_filedata');
__PACKAGE__->mk_classdata('upgrade_directory');
+__PACKAGE__->mk_classdata('backup_directory');
+__PACKAGE__->mk_classdata('do_backup');
+__PACKAGE__->mk_classdata('do_diff_on_init');
-sub on_connect
-{
- my ($self) = @_;
- my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
- my $vtable = $vschema->resultset('Table');
- my $pversion;
+=head2 get_db_version
- if(!$self->exists($vtable))
- {
-# $vschema->storage->debug(1);
- $vschema->storage->ensure_connected();
- $vschema->deploy();
- $pversion = 0;
- }
- else
- {
- my $psearch = $vtable->search(undef,
- { select => [
- { 'max' => 'Installed' },
- ],
- as => ['maxinstall'],
- })->first;
- $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
- })->first;
- $pversion = $pversion->Version if($pversion);
- }
-# warn("Previous version: $pversion\n");
- if($pversion eq $self->VERSION)
- {
- warn "This version is already installed\n";
- return 1;
- }
-
-## use IC::DT?
-
- if(!$pversion)
- {
- $vtable->create({ Version => $self->VERSION,
- Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
- });
- ## If we let the user do this, where does the Version table get updated?
- warn "No previous version found, calling deploy to install this version.\n";
- $self->deploy();
- return 1;
- }
+Returns the version that your database is currently at. This is determined by the values in the
+dbix_class_schema_versions table that $self->upgrade writes to.
- my $file = $self->ddl_filename(
- $self->storage->sqlt_type,
- $self->upgrade_directory,
- $self->VERSION
- );
- if(!$file)
- {
- # No upgrade path between these two versions
- return 1;
- }
+=cut
- $file = $self->ddl_filename(
- $self->storage->sqlt_type,
- $self->upgrade_directory,
- $self->VERSION,
- $pversion,
- );
-# $file =~ s/@{[ $self->VERSION ]}/"${pversion}-" . $self->VERSION/e;
- if(!-f $file)
- {
- warn "Upgrade not possible, no upgrade file found ($file)\n";
- return;
- }
-
- my $fh;
- open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
- my @data = split(/;\n/, join('', <$fh>));
- close($fh);
- @data = grep { $_ && $_ !~ /^-- / } @data;
- @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
-
- $self->_filedata(\@data);
+sub get_db_version
+{
+ my ($self, $rs) = @_;
- ## Don't do this yet, do only on command?
- ## If we do this later, where does the Version table get updated??
- warn "Versions out of sync. This is " . $self->VERSION .
- ", your database contains version $pversion, please call upgrade on your Schema.\n";
-# $self->upgrade($pversion, $self->VERSION);
+ my $vtable = $self->{vschema}->resultset('Table');
+ my $version = 0;
+ eval {
+ my $stamp = $vtable->get_column('installed')->max;
+ $version = $vtable->search({ installed => $stamp })->first->version;
+ };
+ return $version;
}
-sub exists
+sub _source_exists
{
my ($self, $rs) = @_;
return 1;
}
+=head2 backup
+
+This is an overwritable method which is called just before the upgrade, to
+allow you to make a backup of the database. Per default this method attempts
+to call C<< $self->storage->backup >>, to run the standard backup on each
+database type.
+
+This method should return the name of the backup file, if appropriate..
+
+This method is disabled by default. Set $schema->do_backup(1) to enable it.
+
+=cut
+
sub backup
{
my ($self) = @_;
## Make each ::DBI::Foo do this
- $self->storage->backup();
+ $self->storage->backup($self->backup_directory());
}
-sub upgrade
-{
- my ($self) = @_;
-
- ## overridable sub, per default just run all the commands.
-
- $self->backup();
+# is this just a waste of time? if not then merge with DBI.pm
+sub _create_db_to_schema_diff {
+ my $self = shift;
- $self->run_upgrade(qr/create/i);
- $self->run_upgrade(qr/alter table .*? add/i);
- $self->run_upgrade(qr/alter table .*? (?!drop)/i);
- $self->run_upgrade(qr/alter table .*? drop/i);
- $self->run_upgrade(qr/drop/i);
-# $self->run_upgrade(qr//i);
+ my %driver_to_db_map = (
+ 'mysql' => 'MySQL'
+ );
- my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
- my $vtable = $vschema->resultset('Table');
- $vtable->create({ Version => $self->VERSION,
- Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
- });
-}
+ my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
+ unless ($db) {
+ print "Sorry, this is an unsupported DB\n";
+ return;
+ }
+ eval 'require SQL::Translator "0.09"';
+ if ($@) {
+ $self->throw_exception("SQL::Translator 0.09 required");
+ }
-sub run_upgrade
-{
- my ($self, $stm) = @_;
-# print "Reg: $stm\n";
- my @statements = grep { $_ =~ $stm } @{$self->_filedata};
-# print "Statements: ", join("\n", @statements), "\n";
- $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
+ my $db_tr = SQL::Translator->new({
+ add_drop_table => 1,
+ parser => 'DBI',
+ parser_args => { dbh => $self->storage->dbh }
+ });
+
+ $db_tr->producer($db);
+ my $dbic_tr = SQL::Translator->new;
+ $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
+ $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
+ $dbic_tr->data($self);
+ $dbic_tr->producer($db);
+
+ $db_tr->schema->name('db_schema');
+ $dbic_tr->schema->name('dbic_schema');
+
+ # is this really necessary?
+ foreach my $tr ($db_tr, $dbic_tr) {
+ my $data = $tr->data;
+ $tr->parser->($tr, $$data);
+ }
- for (@statements)
+ my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
+ $dbic_tr->schema, $db,
+ { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
+
+ my $filename = $self->ddl_filename(
+ $db,
+ $self->schema_version,
+ $self->upgrade_directory,
+ 'PRE',
+ );
+ my $file;
+ if(!open($file, ">$filename"))
{
- $self->storage->debugfh->print("$_\n") if $self->storage->debug;
-# print "Running \n>>$_<<\n";
- $self->storage->dbh->do($_) or warn "SQL was:\n $_";
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
}
+ print $file $diff;
+ close($file);
- return 1;
+ print "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";
}
-1;
-
-=head1 NAME
-
-DBIx::Class::Versioning - DBIx::Class::Schema plugin for Schema upgrades
+=head2 upgrade
-=head1 SYNOPSIS
+Call this to attempt to upgrade your database from the version it is at to the version
+this DBIC schema is at.
- package Library::Schema;
- use base qw/DBIx::Class::Schema/;
- # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
- __PACKAGE__->load_classes(qw/CD Book DVD/);
+It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
+have created this using $schema->create_ddl_dir.
- __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
- __PACKAGE__->upgrade_directory('/path/to/upgrades/');
+=cut
- sub backup
- {
- my ($self) = @_;
- # my special backup process
+sub upgrade
+{
+ my ($self) = @_;
+ my $db_version = $self->get_db_version();
+
+ # db unversioned
+ unless ($db_version) {
+ # set version in dbix_class_schema_versions table, can't actually upgrade as we don 't know what version the DB is at
+ $self->_create_db_to_schema_diff() if ($self->do_diff_on_init);
+
+ # create versions table and version row
+ $self->{vschema}->deploy;
+ $self->_set_db_version;
+ return;
}
- sub upgrade
- {
- my ($self) = @_;
-
- ## overridable sub, per default just runs all the commands.
-
- $self->run_upgrade(qr/create/i);
- $self->run_upgrade(qr/alter table .*? add/i);
- $self->run_upgrade(qr/alter table .*? (?!drop)/i);
- $self->run_upgrade(qr/alter table .*? drop/i);
- $self->run_upgrade(qr/drop/i);
- $self->run_upgrade(qr//i);
+ # db and schema at same version. do nothing
+ if ($db_version eq $self->schema_version) {
+ print "Upgrade not necessary\n";
+ return;
}
-=head1 DESCRIPTION
-
-This module is a component designed to extend L<DBIx::Class::Schema>
-classes, to enable them to upgrade to newer schema layouts. To use this
-module, you need to have called C<create_ddl_dir> on your Schema to
-create your upgrade files to include with your delivery.
-
-A table called I<SchemaVersions> is created and maintained by the
-module. This contains two fields, 'Version' and 'Installed', which
-contain each VERSION of your Schema, and the date+time it was installed.
-
-If you would like to influence which levels of version change need
-upgrades in your Schema, you can override the method C<ddl_filename>
-in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
-path between the two versions supplied. By default, every change in
-your VERSION is regarded as needing an upgrade.
-
-NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
-returns SQL statements that SQLite does not support.
+ # strangely the first time this is called can
+ # differ to subsequent times. so we call it
+ # here to be sure.
+ # XXX - just fix it
+ $self->storage->sqlt_type;
+
+ my $upgrade_file = $self->ddl_filename(
+ $self->storage->sqlt_type,
+ $self->schema_version,
+ $self->upgrade_directory,
+ $db_version,
+ );
+
+ unless (-f $upgrade_file) {
+ warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
+ return;
+ }
+ # backup if necessary then apply upgrade
+ $self->_filedata($self->_read_sql_file($upgrade_file));
+ $self->backup() if($self->do_backup);
+ $self->txn_do(sub { $self->do_upgrade() });
-=head1 METHODS
+ # set row in dbix_class_schema_versions table
+ $self->_set_db_version;
+}
-=head2 backup
+sub _set_db_version {
+ my $self = shift;
-This is an overwritable method which is called just before the upgrade, to
-allow you to make a backup of the database. Per default this method attempts
-to call C<< $self->storage->backup >>, to run the standard backup on each
-database type.
+ my $vtable = $self->{vschema}->resultset('Table');
+ $vtable->create({ version => $self->schema_version,
+ installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
+ });
-This method should return the name of the backup file, if appropriate.
+}
-C<backup> is called from C<upgrade>, make sure you call it, if you write your
-own <upgrade> method.
+sub _read_sql_file {
+ my $self = shift;
+ my $file = shift || return;
+
+ my $fh;
+ open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
+ my @data = split(/\n/, join('', <$fh>));
+ @data = grep(!/^--/, @data);
+ @data = split(/;/, join('', @data));
+ close($fh);
+ @data = grep { $_ && $_ !~ /^-- / } @data;
+ @data = grep { $_ !~ /^(BEGIN|BEGIN TRANSACTION|COMMIT)/m } @data;
+ return \@data;
+}
-=head2 upgrade
+=head2 do_upgrade
This is an overwritable method used to run your upgrade. The freeform method
allows you to run your upgrade any way you please, you can call C<run_upgrade>
any number of times to run the actual SQL commands, and in between you can
sandwich your data upgrading. For example, first run all the B<CREATE>
commands, then migrate your data from old to new tables/formats, then
-issue the DROP commands when you are finished.
+issue the DROP commands when you are finished. Will run the whole file as it is by default.
+
+=cut
+
+sub do_upgrade
+{
+ my ($self) = @_;
+
+ # just run all the commands (including inserts) in order
+ $self->run_upgrade(qr/.*?/);
+}
=head2 run_upgrade
Runs a set of SQL statements matching a passed in regular expression. The
idea is that this method can be called any number of times from your
C<upgrade> method, running whichever commands you specify via the
-regex in the parameter.
+regex in the parameter. Probably won't work unless called from the overridable
+do_upgrade method.
+
+=cut
+
+sub run_upgrade
+{
+ my ($self, $stm) = @_;
+
+ return unless ($self->_filedata);
+ my @statements = grep { $_ =~ $stm } @{$self->_filedata};
+ $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
+
+ for (@statements)
+ {
+ $self->storage->debugobj->query_start($_) if $self->storage->debug;
+ $self->storage->dbh->do($_) or warn "SQL was:\n $_";
+ $self->storage->debugobj->query_end($_) if $self->storage->debug;
+ }
+
+ return 1;
+}
+
+=head2 connection
+
+Overloaded method. This checks the DBIC schema version against the DB version and
+warns if they are not the same or if the DB is unversioned. It also provides
+compatibility between the old versions table (SchemaVersions) and the new one
+(dbix_class_schema_versions).
+
+To avoid the checks on connect, set the env var DBIC_NO_VERSION_CHECK or alternatively you can set the ignore_version attr in the forth arg like so:
-=head1 AUTHOR
+ my $schema = MyApp::Schema->connect(
+ $dsn,
+ $user,
+ $password,
+ { ignore_version => 1 },
+ );
+
+=cut
+
+sub connection {
+ my $self = shift;
+ $self->next::method(@_);
+ $self->_on_connect($_[3]);
+ return $self;
+}
+
+sub _on_connect
+{
+ my ($self, $args) = @_;
+
+ $args = {} unless $args;
+ $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
+ my $vtable = $self->{vschema}->resultset('Table');
+
+ # 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');
+ 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);
+ }
+ }
+
+ # useful when connecting from scripts etc
+ return if ($args->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $args->{ignore_version}));
+ my $pversion = $self->get_db_version();
+
+ if($pversion eq $self->schema_version)
+ {
+# warn "This version is already installed\n";
+ return 1;
+ }
+
+ if(!$pversion)
+ {
+ warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
+ return 1;
+ }
+
+ warn "Versions out of sync. This is " . $self->schema_version .
+ ", your database contains version $pversion, please call upgrade on your Schema.\n";
+}
+
+1;
+
+
+=head1 AUTHORS
Jess Robinson <castaway@desert-island.demon.co.uk>
+Luke Saunders <luke@shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
use Storable;
sub STORABLE_freeze {
- my ($self,$cloning) = @_;
+ my ($self, $cloning) = @_;
my $to_serialize = { %$self };
+
delete $to_serialize->{result_source};
+ delete $to_serialize->{related_resultsets};
+ delete $to_serialize->{_inflated_column};
+
return (Storable::freeze($to_serialize));
}
sub STORABLE_thaw {
- my ($self,$cloning,$serialized) = @_;
+ my ($self, $cloning, $serialized) = @_;
+
%$self = %{ Storable::thaw($serialized) };
$self->result_source($self->result_source_instance)
if $self->can('result_source_instance');
--- /dev/null
+package DBIx::Class::StartupCheck;
+
+BEGIN {
+
+ { package # don't want this in PAUSE
+ TestRHBug; use overload bool => sub { 0 } }
+
+ sub _has_bug_34925 {
+ my %thing;
+ my $r1 = \%thing;
+ my $r2 = \%thing;
+ bless $r1 => 'TestRHBug';
+ return !!$r2;
+ }
+
+ sub _possibly_has_bad_overload_performance {
+ return $] < 5.008009 && ! _has_bug_34925();
+ }
+
+ unless ($ENV{DBIC_NO_WARN_BAD_PERL}) {
+ if (_possibly_has_bad_overload_performance()) {
+ print STDERR "\n\nWARNING: " . __PACKAGE__ . ": This version of Perl is likely to exhibit\n" .
+ "extremely slow performance for certain critical operations.\n" .
+ "Please consider recompiling Perl. For more information, see\n" .
+ "https://bugzilla.redhat.com/show_bug.cgi?id=196836 and/or\n" .
+ "http://lists.scsys.co.uk/pipermail/dbix-class/2007-October/005119.html.\n" .
+ "You can suppress this message by setting DBIC_NO_WARN_BAD_PERL=1 in your\n" .
+ "environment.\n\n";
+ }
+ }
+}
+
+=head1 NAME
+
+DBIx::Class::StartupCheck - Run environment checks on startup
+
+=head1 SYNOPSIS
+
+ use DBIx::Class::StartupCheck;
+
+=head1 DESCRIPTION
+
+Currently this module checks for, and if necessary issues a warning for, a
+particular bug found on RedHat systems from perl-5.8.8-10 and up. Other checks
+may be added from time to time.
+
+Any checks herein can be disabled by setting an appropriate environment
+variable. If your system suffers from a particular bug, you will get a warning
+message on startup sent to STDERR, explaining what to do about it and how to
+suppress the message. If you don't see any messages, you have nothing to worry
+about.
+
+=head1 CONTRIBUTORS
+
+Nigel Metheringham
+
+Brandon Black
+
+Matt S. Trout
+
+=head1 AUTHOR
+
+Jon Schutz
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
use Scalar::Util qw/weaken/;
use Carp::Clan qw/^DBIx::Class/;
+use IO::File;
+use DBIx::Class::Storage::TxnScopeGuard;
__PACKAGE__->mk_group_accessors('simple' => qw/debug debugobj schema/);
+__PACKAGE__->mk_group_accessors('inherited' => 'cursor_class');
+
+__PACKAGE__->cursor_class('DBIx::Class::Cursor');
+
+sub cursor { shift->cursor_class(@_); }
package # Hide from PAUSE
DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
$new->set_schema($schema);
$new->debugobj(new DBIx::Class::Storage::Statistics());
- my $fh;
+ #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')
- or $new->throw_exception("Cannot open trace file $1");
- } else {
- $fh = IO::File->new('>&STDERR');
- }
-
- $new->debugfh($fh);
$new->debug(1) if $debug_env;
$new;
the outermost transaction will issue a L</txn_commit>, and txn_do() can be
called in void, scalar and list context and it will behave as expected.
+Please note that all of the code in your coderef, including non-DBIx::Class
+code, is part of a transaction. This transaction may fail out halfway, or
+it may get partially double-executed (in the case that our DB connection
+failed halfway through the transaction, in which case we reconnect and
+restart the txn). Therefore it is best that any side-effects in your coderef
+are idempotent (that is, can be re-executed multiple times and get the
+same result), and that you check up on your side-effects in the case of
+transaction failure.
+
=cut
sub txn_do {
sub txn_rollback { die "Virtual method!" }
+=head2 svp_begin
+
+Arguments: $savepoint_name?
+
+Created a new savepoint using the name provided as argument. If no name
+is provided, a random name will be used.
+
+=cut
+
+sub svp_begin { die "Virtual method!" }
+
+=head2 svp_release
+
+Arguments: $savepoint_name?
+
+Release the savepoint provided as argument. If none is provided,
+release the savepoint created most recently. This will implicitly
+release all savepoints created after the one explicitly released as well.
+
+=cut
+
+sub svp_release { die "Virtual method!" }
+
+=head2 svp_rollback
+
+Arguments: $savepoint_name?
+
+Rollback to the savepoint provided as argument. If none is provided,
+rollback to the savepoint created most recently. This will implicitly
+release all savepoints created after the savepoint we rollback to.
+
+=cut
+
+sub svp_rollback { die "Virtual method!" }
+
+=for comment
+
+=head2 txn_scope_guard
+
+Return an object that does stuff.
+
+=cut
+
+sub txn_scope_guard {
+ return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
+}
+
=head2 sql_maker
Returns a C<sql_maker> object - normally an object of class
}
}
-=head2 cursor
+=head2 cursor_class
The cursor class for this Storage object.
=cut
-sub cursor { die "Virtual method!" }
-
=head2 deploy
Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
Old name for DBIC_TRACE
+=head1 SEE ALSO
+
+L<DBIx::Class::Storage::DBI> - reference storage implementation using
+SQL::Abstract and DBI.
+
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
use base 'DBIx::Class::Storage';
-use strict;
+use strict;
use warnings;
+use Carp::Clan qw/^DBIx::Class/;
use DBI;
use SQL::Abstract::Limit;
use DBIx::Class::Storage::DBI::Cursor;
use DBIx::Class::Storage::Statistics;
-use IO::File;
+use Scalar::Util qw/blessed weaken/;
-__PACKAGE__->mk_group_accessors(
- 'simple' =>
- qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
- disable_sth_caching cursor on_connect_do transaction_depth/
+__PACKAGE__->mk_group_accessors('simple' =>
+ qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
+ _conn_pid _conn_tid disable_sth_caching on_connect_do
+ on_disconnect_do transaction_depth unsafe _dbh_autocommit
+ auto_savepoint savepoints/
);
+__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
+
+__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
+__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
+
BEGIN {
-package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
+package # Hide from PAUSE
+ DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
use base qw/SQL::Abstract::Limit/;
my ($sql, @ret) = $self->SUPER::select(
$table, $self->_recurse_fields($fields), $where, $order, @rest
);
+ $sql .=
+ $self->{for} ?
+ (
+ $self->{for} eq 'update' ? ' FOR UPDATE' :
+ $self->{for} eq 'shared' ? ' FOR SHARE' :
+ ''
+ ) :
+ ''
+ ;
return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
}
}
sub _recurse_fields {
- my ($self, $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}
- ? ' AS col'.$self->{rownum_hack_count}++
- : '')
- } @$fields);
+ .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
+ ? ' AS col'.$self->{rownum_hack_count}++
+ : '')
+ } @$fields);
} elsif ($ref eq 'HASH') {
foreach my $func (keys %$fields) {
return $self->_sqlcase($func)
if (ref $_[0] eq 'HASH') {
if (defined $_[0]->{group_by}) {
$ret = $self->_sqlcase(' group by ')
- .$self->_recurse_fields($_[0]->{group_by});
+ .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
}
if (defined $_[0]->{having}) {
my $frag;
if (ref $cond eq 'HASH') {
my %j;
for (keys %$cond) {
- my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
+ my $v = $cond->{$_};
+ if (ref $v) {
+ # XXX no throw_exception() in this package and croak() fails with strange results
+ Carp::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 $self->_recurse_where(\%j);
+ return scalar($self->_recurse_where(\%j));
} elsif (ref $cond eq 'ARRAY') {
return join(' OR ', map { $self->_join_condition($_) } @$cond);
} else {
sub new {
my $new = shift->next::method(@_);
- $new->cursor("DBIx::Class::Storage::DBI::Cursor");
$new->transaction_depth(0);
$new->_sql_maker_opts({});
+ $new->{savepoints} = [];
$new->{_in_dbh_do} = 0;
$new->{_dbh_gen} = 0;
The arrayref can either contain the same set of arguments one would
normally pass to L<DBI/connect>, or a lone code reference which returns
-a connected database handle.
+a connected database handle. Please note that the L<DBI> docs
+recommend that you always explicitly set C<AutoCommit> to either
+C<0> or C<1>. L<DBIx::Class> further recommends that it be set
+to C<1>, and that you perform transactions via our L</txn_do>
+method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
+set it to zero. This is the default for most DBDs. See below for more
+details.
In either case, if the final argument in your connect_info happens
to be a hashref, C<connect_info> will look there for several
=item on_connect_do
-This can be set to an arrayref of literal sql statements, which will
-be executed immediately after making the connection to the database
-every time we [re-]connect.
+Specifies things to do immediately after connecting or re-connecting to
+the database. Its value may contain:
+
+=over
+
+=item an array reference
+
+This contains SQL statements to execute in order. Each element contains
+a string or a code reference that returns a string.
+
+=item a code reference
+
+This contains some code to execute. Unlike code references within an
+array reference, its return value is ignored.
+
+=back
+
+=item on_disconnect_do
+
+Takes arguments in the same form as L<on_connect_do> and executes them
+immediately before disconnecting from the database.
+
+Note, this only runs if you explicitly call L<disconnect> on the
+storage object.
=item disable_sth_caching
specify the charecter that seperates elements (schemas, tables, columns) from
each other. In most cases this is simply a C<.>.
+=item unsafe
+
+This Storage driver normally installs its own C<HandleError>, sets
+C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
+all database handles, including those supplied by a coderef. It does this
+so that it can have consistent and useful error behavior.
+
+If you set this option to a true value, Storage will not do its usual
+modifications to the database handle's attributes, and instead relies on
+the settings in your connect_info DBI options (or the values you set in
+your connection coderef, in the case that you are connecting via coderef).
+
+Note that your custom settings can cause Storage to malfunction,
+especially if you set a C<HandleError> handler that suppresses exceptions
+and/or disable C<RaiseError>.
+
+=item auto_savepoint
+
+If this option is true, L<DBIx::Class> will use savepoints when nesting
+transactions, making it possible to recover from failure in the inner
+transaction without having to abort all outer transactions.
+
=back
These options can be mixed in with your other L<DBI> connection attributes,
these options will be cleared before setting the new ones, regardless of
whether any options are specified in the new C<connect_info>.
-Important note: DBIC expects the returned database handle provided by
-a subref argument to have RaiseError set on it. If it doesn't, things
-might not work very well, YMMV. If you don't use a subref, DBIC will
-force this setting for you anyways. Setting HandleError to anything
-other than simple exception object wrapper might cause problems too.
+Another Important Note:
+
+DBIC can do some wonderful magic with handling exceptions,
+disconnections, and transactions when you use C<< AutoCommit => 1 >>
+combined with C<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
+like to manage that manually. A lot of DBIC's magic protections
+go away. We can't protect you from exceptions due to database
+disconnects because we don't know anything about how to restart your
+transactions. You're on your own for handling all sorts of exceptional
+cases if you choose the C<< AutoCommit => 0 >> path, just as you would
+be with raw DBI.
Examples:
'dbi:Pg:dbname=foo',
'postgres',
'my_pg_password',
- { AutoCommit => 0 },
+ { AutoCommit => 1 },
{ quote_char => q{"}, name_sep => q{.} },
]
);
'dbi:Pg:dbname=foo',
'postgres',
'my_pg_password',
- { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
+ { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
]
);
# the new set of options
$self->_sql_maker(undef);
$self->_sql_maker_opts({});
+ $self->_connect_info([@$info_arg]); # copy for _connect_info
- my $info = [ @$info_arg ]; # copy because we can alter it
- my $last_info = $info->[-1];
+ my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
+
+ my $last_info = $dbi_info->[-1];
if(ref $last_info eq 'HASH') {
- for my $storage_opt (qw/on_connect_do disable_sth_caching/) {
+ $last_info = { %$last_info }; # so delete is non-destructive
+ my @storage_option = qw(
+ on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
+ auto_savepoint
+ );
+ for my $storage_opt (@storage_option) {
if(my $value = delete $last_info->{$storage_opt}) {
$self->$storage_opt($value);
}
$self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
}
}
+ # re-insert modified hashref
+ $dbi_info->[-1] = $last_info;
# Get rid of any trailing empty hashref
- pop(@$info) if !keys %$last_info;
+ pop(@$dbi_info) if !keys %$last_info;
}
+ $self->_dbi_connect_info($dbi_info);
- $self->_connect_info($info);
+ $self->_connect_info;
}
=head2 on_connect_do
=head2 dbh_do
-Arguments: $subref, @extra_coderef_args?
+Arguments: ($subref | $method_name), @extra_coderef_args?
-Execute the given subref using the new exception-based connection management.
+Execute the given $subref or $method_name using the new exception-based
+connection management.
The first two arguments will be the storage object that C<dbh_do> was called
on and a database handle to use. Any additional arguments will be passed
sub dbh_do {
my $self = shift;
- my $coderef = shift;
+ my $code = shift;
- ref $coderef eq 'CODE' or $self->throw_exception
- ('$coderef must be a CODE reference');
+ my $dbh = $self->_dbh;
+
+ return $self->$code($dbh, @_) if $self->{_in_dbh_do}
+ || $self->{transaction_depth};
- return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
local $self->{_in_dbh_do} = 1;
my @result;
my $want_array = wantarray;
eval {
- $self->_verify_pid if $self->_dbh;
- $self->_populate_dbh if !$self->_dbh;
+ $self->_verify_pid if $dbh;
+ if(!$self->_dbh) {
+ $self->_populate_dbh;
+ $dbh = $self->_dbh;
+ }
+
if($want_array) {
- @result = $coderef->($self, $self->_dbh, @_);
+ @result = $self->$code($dbh, @_);
}
elsif(defined $want_array) {
- $result[0] = $coderef->($self, $self->_dbh, @_);
+ $result[0] = $self->$code($dbh, @_);
}
else {
- $coderef->($self, $self->_dbh, @_);
+ $self->$code($dbh, @_);
}
};
# We were not connected - reconnect and retry, but let any
# exception fall right through this time
$self->_populate_dbh;
- $coderef->($self, $self->_dbh, @_);
+ $self->$code($self->_dbh, @_);
}
# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
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 ($self) = @_;
if( $self->connected ) {
- $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
+ my $connection_do = $self->on_disconnect_do;
+ $self->_do_connection_actions($connection_do) if ref($connection_do);
+
+ $self->_dbh->rollback unless $self->_dbh_autocommit;
$self->_dbh->disconnect;
$self->_dbh(undef);
$self->{_dbh_gen}++;
}
else {
$self->_verify_pid;
+ return 0 if !$self->_dbh;
}
return ($dbh->FETCH('Active') && $dbh->ping);
}
sub _verify_pid {
my ($self) = @_;
- return if $self->_conn_pid == $$;
+ return if defined $self->_conn_pid && $self->_conn_pid == $$;
$self->_dbh->{InactiveDestroy} = 1;
$self->_dbh(undef);
sub _sql_maker_args {
my ($self) = @_;
- return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
+ return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
}
sub sql_maker {
my ($self) = @_;
unless ($self->_sql_maker) {
- $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
+ my $sql_maker_class = $self->sql_maker_class;
+ $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
}
return $self->_sql_maker;
}
+sub _rebless {}
+
sub _populate_dbh {
my ($self) = @_;
- my @info = @{$self->_connect_info || []};
+ my @info = @{$self->_dbi_connect_info || []};
$self->_dbh($self->_connect(@info));
+ # Always set the transaction depth on connect, since
+ # there is no transaction in progress by definition
+ $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
+
if(ref $self eq 'DBIx::Class::Storage::DBI') {
my $driver = $self->_dbh->{Driver}->{Name};
if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
bless $self, "DBIx::Class::Storage::DBI::${driver}";
- $self->_rebless() if $self->can('_rebless');
+ $self->_rebless();
}
}
- # if on-connect sql statements are given execute them
- foreach my $sql_statement (@{$self->on_connect_do || []}) {
- $self->debugobj->query_start($sql_statement) if $self->debug();
- $self->_dbh->do($sql_statement);
- $self->debugobj->query_end($sql_statement) if $self->debug();
- }
+ my $connection_do = $self->on_connect_do;
+ $self->_do_connection_actions($connection_do) if ref($connection_do);
$self->_conn_pid($$);
$self->_conn_tid(threads->tid) if $INC{'threads.pm'};
}
+sub _do_connection_actions {
+ my $self = shift;
+ my $connection_do = shift;
+
+ if (ref $connection_do eq 'ARRAY') {
+ $self->_do_query($_) foreach @$connection_do;
+ }
+ elsif (ref $connection_do eq 'CODE') {
+ $connection_do->();
+ }
+
+ return $self;
+}
+
+sub _do_query {
+ my ($self, $action) = @_;
+
+ if (ref $action eq 'CODE') {
+ $action = $action->($self);
+ $self->_do_query($_) foreach @$action;
+ }
+ else {
+ my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
+ $self->_query_start(@to_run);
+ $self->_dbh->do(@to_run);
+ $self->_query_end(@to_run);
+ }
+
+ return $self;
+}
+
sub _connect {
my ($self, @info) = @_;
$self->throw_exception("You failed to provide any connection info")
- if !@info;
+ if !@info;
my ($old_connect_via, $dbh);
if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
- $old_connect_via = $DBI::connect_via;
- $DBI::connect_via = 'connect';
+ $old_connect_via = $DBI::connect_via;
+ $DBI::connect_via = 'connect';
}
eval {
}
else {
$dbh = DBI->connect(@info);
- $dbh->{RaiseError} = 1;
- $dbh->{PrintError} = 0;
- $dbh->{PrintWarn} = 0;
+ }
+
+ if($dbh && !$self->unsafe) {
+ my $weak_self = $self;
+ weaken($weak_self);
+ $dbh->{HandleError} = sub {
+ $weak_self->throw_exception("DBI Exception: $_[0]")
+ };
+ $dbh->{ShowErrorStatement} = 1;
+ $dbh->{RaiseError} = 1;
+ $dbh->{PrintError} = 0;
}
};
$DBI::connect_via = $old_connect_via if $old_connect_via;
- if (!$dbh || $@) {
- $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
- }
+ $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
+ if !$dbh || $@;
+
+ $self->_dbh_autocommit($dbh->{AutoCommit});
$dbh;
}
-sub _dbh_txn_begin {
- my ($self, $dbh) = @_;
- if ($dbh->{AutoCommit}) {
- $self->debugobj->txn_begin()
- if ($self->debug);
- $dbh->begin_work;
- }
+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 txn_begin {
- my $self = shift;
- $self->dbh_do($self->can('_dbh_txn_begin'))
- if $self->{transaction_depth}++ == 0;
+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 _dbh_txn_commit {
- my ($self, $dbh) = @_;
- if ($self->{transaction_depth} == 0) {
- unless ($dbh->{AutoCommit}) {
- $self->debugobj->txn_commit()
- if ($self->debug);
- $dbh->commit;
- }
+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];
}
- else {
- if (--$self->{transaction_depth} == 0) {
- $self->debugobj->txn_commit()
- if ($self->debug);
- $dbh->commit;
- }
+
+ $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;
+ $self->ensure_connected();
+ if($self->{transaction_depth} == 0) {
+ $self->debugobj->txn_begin()
+ if $self->debug;
+ # this isn't ->_dbh-> because
+ # we should reconnect on begin_work
+ # for AutoCommit users
+ $self->dbh->begin_work;
+ } elsif ($self->auto_savepoint) {
+ $self->svp_begin;
}
+ $self->{transaction_depth}++;
}
sub txn_commit {
my $self = shift;
- $self->dbh_do($self->can('_dbh_txn_commit'));
+ if ($self->{transaction_depth} == 1) {
+ my $dbh = $self->_dbh;
+ $self->debugobj->txn_commit()
+ if ($self->debug);
+ $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;
+ }
}
-sub _dbh_txn_rollback {
- my ($self, $dbh) = @_;
- if ($self->{transaction_depth} == 0) {
- unless ($dbh->{AutoCommit}) {
+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;
$dbh->rollback;
}
- }
- else {
- if (--$self->{transaction_depth} == 0) {
- $self->debugobj->txn_rollback()
- if ($self->debug);
- $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;
}
- }
-}
-
-sub txn_rollback {
- my $self = shift;
-
- eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
+ };
if ($@) {
my $error = $@;
my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
$error =~ /$exception_class/ and $self->throw_exception($error);
- $self->{transaction_depth} = 0; # ensure that a failed rollback
- $self->throw_exception($error); # resets the transaction depth
+ # ensure that a failed rollback resets the transaction depth
+ $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
+ $self->throw_exception($error);
}
}
# 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, $extra_bind, $ident, $args) = @_;
- my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
- unshift(@bind, @$extra_bind) if $extra_bind;
- @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
+ my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
+ unshift(@bind,
+ map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
+ if $extra_bind;
- return ($sql, @bind);
+ return ($sql, \@bind);
}
-sub _execute {
- my $self = shift;
+sub _fix_bind_params {
+ my ($self, @bind) = @_;
+
+ ### 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 ($sql, @bind) = $self->_prep_for_execute(@_);
+sub _query_start {
+ my ( $self, $sql, @bind ) = @_;
+
+ if ( $self->debug ) {
+ @bind = $self->_fix_bind_params(@bind);
+ $self->debugobj->query_start( $sql, @bind );
+ }
+}
- if ($self->debug) {
- my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
- $self->debugobj->query_start($sql, @debug_bind);
+sub _query_end {
+ my ( $self, $sql, @bind ) = @_;
+
+ if ( $self->debug ) {
+ @bind = $self->_fix_bind_params(@bind);
+ $self->debugobj->query_end( $sql, @bind );
+ }
+}
+
+sub _dbh_execute {
+ my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
+
+ if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
+ $ident = $ident->from();
}
- my $sth = $self->sth($sql);
+ my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
+
+ $self->_query_start( $sql, @$bind );
+
+ my $sth = $self->sth($sql,$op);
+
+ my $placeholder_index = 1;
- my $rv;
- if ($sth) {
- my $time = time();
- $rv = eval { $sth->execute(@bind) };
+ foreach my $bound (@$bind) {
+ my $attributes = {};
+ my($column_name, @data) = @$bound;
- if ($@ || !$rv) {
- $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
+ if ($bind_attributes) {
+ $attributes = $bind_attributes->{$column_name}
+ if defined $bind_attributes->{$column_name};
+ }
+
+ foreach my $data (@data) {
+ $data = ref $data ? ''.$data : $data; # stringify args
+
+ $sth->bind_param($placeholder_index, $data, $attributes);
+ $placeholder_index++;
}
- } else {
- $self->throw_exception("'$sql' did not generate a statement.");
- }
- if ($self->debug) {
- my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
- $self->debugobj->query_end($sql, @debug_bind);
}
- return (wantarray ? ($rv, $sth, @bind) : $rv);
+
+ # Can this fail without throwing an exception anyways???
+ my $rv = $sth->execute();
+ $self->throw_exception($sth->errstr) if !$rv;
+
+ $self->_query_end( $sql, @$bind );
+
+ return (wantarray ? ($rv, $sth, @$bind) : $rv);
+}
+
+sub _execute {
+ my $self = shift;
+ $self->dbh_do('_dbh_execute', @_)
}
sub insert {
- my ($self, $ident, $to_insert) = @_;
- $self->throw_exception(
- "Couldn't insert ".join(', ',
- map "$_ => $to_insert->{$_}", keys %$to_insert
- )." into ${ident}"
- ) unless ($self->_execute('insert' => [], $ident, $to_insert));
+ my ($self, $source, $to_insert) = @_;
+
+ my $ident = $source->from;
+ my $bind_attributes = $self->source_bind_attributes($source);
+
+ foreach my $col ( $source->columns ) {
+ if ( !defined $to_insert->{$col} ) {
+ my $col_info = $source->column_info($col);
+
+ if ( $col_info->{auto_nextval} ) {
+ $self->ensure_connected;
+ $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
+ }
+ }
+ }
+
+ $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
+
return $to_insert;
}
## scalar refs, or at least, all the same type as the first set, the statement is
## only prepped once.
sub insert_bulk {
- my ($self, $table, $cols, $data) = @_;
+ my ($self, $source, $cols, $data) = @_;
my %colvalues;
+ my $table = $source->from;
@colvalues{@$cols} = (0..$#$cols);
my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
-# print STDERR "BIND".Dumper(\@bind);
-
- if ($self->debug) {
- my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
- $self->debugobj->query_start($sql, @debug_bind);
- }
+
+ $self->_query_start( $sql, @bind );
my $sth = $self->sth($sql);
# @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
- my $rv;
## This must be an arrayref, else nothing works!
+
my $tuple_status = [];
-# use Data::Dumper;
-# print STDERR Dumper($data);
- if ($sth) {
- my $time = time();
- $rv = eval { $sth->execute_array({ ArrayTupleFetch => sub { my $values = shift @$data; return if !$values; return [ @{$values}[@bind] ]},
- ArrayTupleStatus => $tuple_status }) };
-# print STDERR Dumper($tuple_status);
-# print STDERR "RV: $rv\n";
- if ($@ || !defined $rv) {
- my $errors = '';
- foreach my $tuple (@$tuple_status)
- {
- $errors .= "\n" . $tuple->[1] if(ref $tuple);
- }
- $self->throw_exception("Error executing '$sql': ".($@ || $errors));
+
+ ##use Data::Dumper;
+ ##print STDERR Dumper( $data, $sql, [@bind] );
+
+ my $time = time();
+
+ ## Get the bind_attributes, if any exist
+ my $bind_attributes = $self->source_bind_attributes($source);
+
+ ## Bind the values and execute
+ my $placeholder_index = 1;
+
+ foreach my $bound (@bind) {
+
+ my $attributes = {};
+ my ($column_name, $data_index) = @$bound;
+
+ if( $bind_attributes ) {
+ $attributes = $bind_attributes->{$column_name}
+ if defined $bind_attributes->{$column_name};
}
- } else {
- $self->throw_exception("'$sql' did not generate a statement.");
- }
- if ($self->debug) {
- my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
- $self->debugobj->query_end($sql, @debug_bind);
+
+ my @data = map { $_->[$data_index] } @$data;
+
+ $sth->bind_param_array( $placeholder_index, [@data], $attributes );
+ $placeholder_index++;
}
+ my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
+ $self->throw_exception($sth->errstr) if !$rv;
+
+ $self->_query_end( $sql, @bind );
return (wantarray ? ($rv, $sth, @bind) : $rv);
}
sub update {
- return shift->_execute('update' => [], @_);
+ my $self = shift @_;
+ my $source = shift @_;
+ my $bind_attributes = $self->source_bind_attributes($source);
+
+ return $self->_execute('update' => [], $source, $bind_attributes, @_);
}
+
sub delete {
- return shift->_execute('delete' => [], @_);
+ my $self = shift @_;
+ my $source = shift @_;
+
+ my $bind_attrs = {}; ## If ever it's needed...
+
+ return $self->_execute('delete' => [], $source, $bind_attrs, @_);
}
sub _select {
my ($self, $ident, $select, $condition, $attrs) = @_;
my $order = $attrs->{order_by};
+
if (ref $condition eq 'SCALAR') {
$order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
}
+
+ my $for = delete $attrs->{for};
+ my $sql_maker = $self->sql_maker;
+ local $sql_maker->{for} = $for;
+
if (exists $attrs->{group_by} || $attrs->{having}) {
$order = {
group_by => $attrs->{group_by},
($order ? (order_by => $order) : ())
};
}
- my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
+ my $bind_attrs = {}; ## Future support
+ my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
if ($attrs->{software_limit} ||
$self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
$attrs->{software_limit} = 1;
} else {
$self->throw_exception("rows attribute must be positive if present")
if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
+
+ # MySQL actually recommends this approach. I cringe.
+ $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
push @args, $attrs->{rows}, $attrs->{offset};
}
+
return $self->_execute(@args);
}
+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;
+}
+
=head2 select
=over 4
sub select {
my $self = shift;
my ($ident, $select, $condition, $attrs) = @_;
- return $self->cursor->new($self, \@_, $attrs);
+ return $self->cursor_class->new($self, \@_, $attrs);
}
sub select_single {
my $self = shift;
my ($rv, $sth, @bind) = $self->_select(@_);
my @row = $sth->fetchrow_array;
+ if(@row && $sth->fetchrow_array) {
+ carp "Query returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single";
+ }
# Need to call finish() to work round broken DBDs
$sth->finish();
return @row;
? $dbh->prepare($sql)
: $dbh->prepare_cached($sql, {}, 3);
- $self->throw_exception(
- 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
- ) if !$sth;
+ # XXX You would think RaiseError would make this impossible,
+ # but apparently that's not true :(
+ $self->throw_exception($dbh->errstr) if !$sth;
$sth;
}
sub sth {
my ($self, $sql) = @_;
- $self->dbh_do($self->can('_dbh_sth'), $sql);
+ $self->dbh_do('_dbh_sth', $sql);
}
sub _dbh_columns_info_for {
}
my %result;
- my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
+ my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
$sth->execute;
my @columns = @{$sth->{NAME_lc}};
for my $i ( 0 .. $#columns ){
my %column_info;
- my $type_num = $sth->{TYPE}->[$i];
- my $type_name;
- if(defined $type_num && $dbh->can('type_info')) {
- my $type_info = $dbh->type_info($type_num);
- $type_name = $type_info->{TYPE_NAME} if $type_info;
- }
- $column_info{data_type} = $type_name ? $type_name : $type_num;
+ $column_info{data_type} = $sth->{TYPE}->[$i];
$column_info{size} = $sth->{PRECISION}->[$i];
$column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
$result{$columns[$i]} = \%column_info;
}
+ $sth->finish;
+
+ foreach my $col (keys %result) {
+ my $colinfo = $result{$col};
+ my $type_num = $colinfo->{data_type};
+ my $type_name;
+ if(defined $type_num && $dbh->can('type_info')) {
+ my $type_info = $dbh->type_info($type_num);
+ $type_name = $type_info->{TYPE_NAME} if $type_info;
+ $colinfo->{data_type} = $type_name if $type_name;
+ }
+ }
return \%result;
}
sub columns_info_for {
my ($self, $table) = @_;
- $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
+ $self->dbh_do('_dbh_columns_info_for', $table);
}
=head2 last_insert_id
sub last_insert_id {
my $self = shift;
- $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
+ $self->dbh_do('_dbh_last_insert_id', @_);
}
=head2 sqlt_type
sub sqlt_type { shift->dbh->{Driver}->{Name} }
-=head2 create_ddl_dir (EXPERIMENTAL)
+=head2 bind_attribute_by_data_type
+
+Given a datatype from column info, returns a database specific bind attribute for
+$dbh->bind_param($val,$attribute) or nothing if we will let the database planner
+just handle it.
+
+Generally only needed for special case column types, like bytea in postgres.
+
+=cut
+
+sub bind_attribute_by_data_type {
+ return;
+}
+
+=head2 create_ddl_dir
=over 4
-=item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
+=item Arguments: $schema \@databases, $version, $directory, $preversion, \%sqlt_args
=back
Creates a SQL file based on the Schema, for each of the specified
database types, in the given directory.
-Note that this feature is currently EXPERIMENTAL and may not work correctly
-across all databases, or fully handle complex relationships.
+By default, C<\%sqlt_args> will have
+
+ { add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1 }
+
+merged with the hash passed in. To disable any of those features, pass in a
+hashref like the following
+
+ { ignore_constraint_names => 0, # ... other options }
=cut
-sub create_ddl_dir
-{
+sub create_ddl_dir {
my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
- if(!$dir || !-d $dir)
- {
+ if(!$dir || !-d $dir) {
warn "No directory given, using ./\n";
$dir = "./";
}
$databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
$databases = [ $databases ] if(ref($databases) ne 'ARRAY');
$version ||= $schema->VERSION || '1.x';
- $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
+ $sqltargs = {
+ add_drop_table => 1,
+ ignore_constraint_names => 1,
+ ignore_index_names => 1,
+ %{$sqltargs || {}}
+ };
- eval "use SQL::Translator";
- $self->throw_exception("Can't create a ddl file without SQL::Translator: $@") if $@;
+ $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
+ . $self->_check_sqlt_message . q{'})
+ if !$self->_check_sqlt_version;
- my $sqlt = SQL::Translator->new({
-# debug => 1,
- add_drop_table => 1,
- });
- foreach my $db (@$databases)
- {
+ my $sqlt = SQL::Translator->new( $sqltargs );
+
+ $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
+ my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
+
+ foreach my $db (@$databases) {
$sqlt->reset();
- $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
-# $sqlt->parser_args({'DBIx::Class' => $schema);
$sqlt = $self->configure_sqlt($sqlt, $db);
- $sqlt->data($schema);
+ $sqlt->{schema} = $sqlt_schema;
$sqlt->producer($db);
my $file;
- my $filename = $schema->ddl_filename($db, $dir, $version);
- if(-e $filename)
- {
- warn("$filename already exists, skipping $db");
- next;
+ my $filename = $schema->ddl_filename($db, $version, $dir);
+ if (-e $filename && (!$version || ($version == $schema->schema_version()))) {
+ # if we are dumping the current version, overwrite the DDL
+ warn "Overwriting existing DDL file - $filename";
+ unlink($filename);
}
my $output = $sqlt->translate;
- if(!$output)
- {
+ if(!$output) {
warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
next;
}
- if(!open($file, ">$filename"))
- {
- $self->throw_exception("Can't open $filename for writing ($!)");
- next;
+ if(!open($file, ">$filename")) {
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
}
print $file $output;
close($file);
+
+ next unless ($preversion);
+
+ require SQL::Translator::Diff;
+
+ my $prefilename = $schema->ddl_filename($db, $preversion, $dir);
+ if(!-e $prefilename) {
+ warn("No previous schema file found ($prefilename)");
+ next;
+ }
- if($preversion)
+ my $difffile = $schema->ddl_filename($db, $version, $dir, $preversion);
+ if(-e $difffile) {
+ warn("Overwriting existing diff file - $difffile");
+ unlink($difffile);
+ }
+
+ my $source_schema;
{
- eval "use SQL::Translator::Diff";
- if($@)
- {
- warn("Can't diff versions without SQL::Translator::Diff: $@");
- next;
+ my $t = SQL::Translator->new($sqltargs);
+ $t->debug( 0 );
+ $t->trace( 0 );
+ $t->parser( $db ) or die $t->error;
+ $t = $self->configure_sqlt($t, $db);
+ my $out = $t->translate( $prefilename ) or die $t->error;
+ $source_schema = $t->schema;
+ unless ( $source_schema->name ) {
+ $source_schema->name( $prefilename );
}
+ }
- my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
-# print "Previous version $prefilename\n";
- if(!-e $prefilename)
- {
- warn("No previous schema file found ($prefilename)");
- next;
- }
- #### We need to reparse the SQLite file we just wrote, so that
- ## Diff doesnt get all confoosed, and Diff is *very* confused.
- ## FIXME: rip Diff to pieces!
-# my $target_schema = $sqlt->schema;
-# unless ( $target_schema->name ) {
-# $target_schema->name( $filename );
-# }
- my @input;
- push @input, {file => $prefilename, parser => $db};
- push @input, {file => $filename, parser => $db};
- my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
- my $file = $_->{'file'};
- my $parser = $_->{'parser'};
-
- my $t = SQL::Translator->new;
- $t->debug( 0 );
- $t->trace( 0 );
- $t->parser( $parser ) or die $t->error;
- my $out = $t->translate( $file ) or die $t->error;
- my $schema = $t->schema;
- unless ( $schema->name ) {
- $schema->name( $file );
- }
- ($schema, $parser);
- } @input;
-
- my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
- $target_schema, $db,
- {}
- );
- my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
- print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
- if(-e $difffile)
- {
- warn("$difffile already exists, skipping");
- next;
- }
- if(!open $file, ">$difffile")
- {
- $self->throw_exception("Can't write to $difffile ($!)");
- next;
- }
- print $file $diff;
- close($file);
+ # The "new" style of producers have sane normalization and can support
+ # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
+ # And we have to diff parsed SQL against parsed SQL.
+ my $dest_schema = $sqlt_schema;
+
+ unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
+ my $t = SQL::Translator->new($sqltargs);
+ $t->debug( 0 );
+ $t->trace( 0 );
+ $t->parser( $db ) or die $t->error;
+ $t = $self->configure_sqlt($t, $db);
+ my $out = $t->translate( $filename ) or die $t->error;
+ $dest_schema = $t->schema;
+ $dest_schema->name( $filename )
+ unless $dest_schema->name;
+ }
+
+ my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
+ $dest_schema, $db,
+ $sqltargs
+ );
+ if(!open $file, ">$difffile") {
+ $self->throw_exception("Can't write to $difffile ($!)");
+ next;
}
+ print $file $diff;
+ close($file);
}
}
return join('', @rows);
}
- eval "use SQL::Translator";
- if(!$@)
- {
- eval "use SQL::Translator::Parser::DBIx::Class;";
- $self->throw_exception($@) if $@;
- eval "use SQL::Translator::Producer::${type};";
- $self->throw_exception($@) if $@;
- my $tr = SQL::Translator->new(%$sqltargs);
- SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
- return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
- }
+ $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
+ . $self->_check_sqlt_message . q{'})
+ if !$self->_check_sqlt_version;
+
+ require SQL::Translator::Parser::DBIx::Class;
+ eval qq{use SQL::Translator::Producer::${type}};
+ $self->throw_exception($@) if $@;
+
+ # sources needs to be a parser arg, but for simplicty allow at top level
+ # coming in
+ $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
+ if exists $sqltargs->{sources};
+
+ my $tr = SQL::Translator->new(%$sqltargs);
+ SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
+ return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
- $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
return;
}
sub deploy {
my ($self, $schema, $type, $sqltargs, $dir) = @_;
foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
- for ( split(";\n", $statement)) {
- next if($_ =~ /^--/);
- next if(!$_);
-# next if($_ =~ /^DROP/m);
- next if($_ =~ /^BEGIN TRANSACTION/m);
- next if($_ =~ /^COMMIT/m);
- next if $_ =~ /^\s+$/; # skip whitespace only
- $self->debugobj->query_start($_) if $self->debug;
- $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
- $self->debugobj->query_end($_) if $self->debug;
+ foreach my $line ( split(";\n", $statement)) {
+ next if($line =~ /^--/);
+ next if(!$line);
+# next if($line =~ /^DROP/m);
+ next if($line =~ /^BEGIN TRANSACTION/m);
+ next if($line =~ /^COMMIT/m);
+ next if $line =~ /^\s+$/; # skip whitespace only
+ $self->_query_start($line);
+ eval {
+ $self->dbh->do($line); # shouldn't be using ->dbh ?
+ };
+ if ($@) {
+ warn qq{$@ (running "${line}")};
+ }
+ $self->_query_end($line);
}
}
}
sub datetime_parser {
my $self = shift;
- return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
+ return $self->{datetime_parser} ||= do {
+ $self->ensure_connected;
+ $self->build_datetime_parser(@_);
+ };
}
=head2 datetime_parser_type
return $type;
}
+{
+ my $_check_sqlt_version; # private
+ my $_check_sqlt_message; # private
+ sub _check_sqlt_version {
+ return $_check_sqlt_version if defined $_check_sqlt_version;
+ eval 'use SQL::Translator "0.09"';
+ $_check_sqlt_message = $@ || '';
+ $_check_sqlt_version = !$@;
+ }
+
+ sub _check_sqlt_message {
+ _check_sqlt_version if !defined $_check_sqlt_message;
+ $_check_sqlt_message;
+ }
+}
+
sub DESTROY {
my $self = shift;
return if !$self->_dbh;
=back
-Advances the cursor to the next row and returns an arrayref of column values.
+Advances the cursor to the next row and returns an array of column
+values (the result of L<DBI/fetchrow_array> method).
=cut
sub all {
my ($self) = @_;
- return $self->SUPER::all if $self->{attrs}{rows};
+ if ($self->{attrs}{software_limit}
+ && ($self->{attrs}{offset} || $self->{attrs}{rows})) {
+ return $self->SUPER::all;
+ }
$self->{storage}->dbh_do($self->can('_dbh_all'), $self);
}
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} };
}
sub connect_info {
my $self = shift;
- my $retval = shift->next::method(@_);
+ my $retval = $self->next::method(@_);
$self->disable_sth_caching(1);
$retval;
}
sub _prep_for_execute {
my $self = shift;
- my ($sql, @bind) = $self->next::method(@_);
+ my ($sql, $bind) = $self->next::method(@_);
- $sql =~ s/\?/$self->_dbh->quote(shift(@bind))/eg;
+ # stringify args, quote via $dbh, and manually insert
- return ($sql);
+ my @sql_part = split /\?/, $sql;
+ my $new_sql;
+
+ foreach my $bound (@$bind) {
+ shift @$bound;
+ foreach my $data (@$bound) {
+ if(ref $data) {
+ $data = ''.$data;
+ }
+ $new_sql .= shift(@sql_part) . $self->_dbh->quote($data);
+ }
+ }
+ $new_sql .= join '', @sql_part;
+
+ return ($new_sql);
}
=head1 AUTHORS
=head1 AUTHORS
-Marc Mims C<< <marc@sssonline.com> >>
+Marc Mims C<< <marc@questright.com> >>
=head1 LICENSE
--- /dev/null
+package DBIx::Class::Storage::DBI::ODBC::ACCESS;\r
+use strict;\r
+use warnings;\r
+\r
+use Data::Dump qw( dump );\r
+\r
+use DBI;\r
+use base qw/DBIx::Class::Storage::DBI/;\r
+\r
+my $ERR_MSG_START = __PACKAGE__ . ' failed: ';\r
+\r
+sub insert {\r
+ my $self = shift;\r
+ my ( $source, $to_insert ) = @_;\r
+\r
+ my $bind_attributes = $self->source_bind_attributes( $source );\r
+ my ( undef, $sth ) = $self->_execute( 'insert' => [], $source, $bind_attributes, $to_insert );\r
+\r
+ #store the identity here since @@IDENTITY is connection global and this prevents\r
+ #possibility that another insert to a different table overwrites it for this resultsource\r
+ my $identity = 'SELECT @@IDENTITY';\r
+ my $max_sth = $self->{ _dbh }->prepare( $identity )\r
+ or $self->throw_exception( $ERR_MSG_START . $self->{ _dbh }->errstr() );\r
+ $max_sth->execute() or $self->throw_exception( $ERR_MSG_START . $max_sth->errstr );\r
+\r
+ my $row = $max_sth->fetchrow_arrayref()\r
+ or $self->throw_exception( $ERR_MSG_START . "$identity did not return any result." );\r
+\r
+ $self->{ last_pk }->{ $source->name() } = $row;\r
+\r
+ return $to_insert;\r
+}\r
+\r
+sub last_insert_id {\r
+ my $self = shift;\r
+ my ( $result_source ) = @_;\r
+\r
+ return @{ $self->{ last_pk }->{ $result_source->name() } };\r
+}\r
+\r
+sub bind_attribute_by_data_type {\r
+ my $self = shift;\r
+ \r
+ my ( $data_type ) = @_;\r
+ \r
+ return { TYPE => $data_type } if $data_type == DBI::SQL_LONGVARCHAR;\r
+ \r
+ return;\r
+}\r
+\r
+sub sqlt_type { 'ACCESS' }\r
+\r
+1;\r
+\r
+=head1 NAME\r
+\r
+DBIx::Class::Storage::ODBC::ACCESS - Support specific to MS Access over ODBC\r
+\r
+=head1 WARNING\r
+\r
+I am not a DBI, DBIx::Class or MS Access guru. Use this module with that in\r
+mind.\r
+\r
+This module is currently considered alpha software and can change without notice.\r
+\r
+=head1 DESCRIPTION\r
+\r
+This class implements support specific to Microsoft Access over ODBC.\r
+\r
+It is loaded automatically by by DBIx::Class::Storage::DBI::ODBC when it\r
+detects a MS Access back-end.\r
+\r
+=head1 SUPPORTED VERSIONS\r
+\r
+This module have currently only been tested on MS Access 2003 using the Jet 4.0 engine.\r
+\r
+As far as my knowledge it should work on MS Access 2000 or later, but that have not been tested.\r
+Information about support for different version of MS Access is welcome.\r
+\r
+=head1 IMPLEMENTATION NOTES\r
+\r
+MS Access supports the @@IDENTITY function for retriving the id of the latest inserted row.\r
+@@IDENTITY is global to the connection, so to support the possibility of getting the last inserted\r
+id for different tables, the insert() function stores the inserted id on a per table basis.\r
+last_insert_id() then just returns the stored value.\r
+\r
+=head1 KNOWN ACCESS PROBLEMS\r
+\r
+=over\r
+\r
+=item Invalid precision value\r
+\r
+This error message is received when trying to store more than 255 characters in a MEMO field.\r
+The problem is (to my knowledge) an error in the MS Access ODBC driver. The problem is fixed\r
+by setting the C<data_type> of the column to C<SQL_LONGVARCHAR> in C<add_columns>. \r
+C<SQL_LONGVARCHAR> is a constant in the C<DBI> module.\r
+\r
+=back\r
+\r
+=head1 IMPLEMENTED FUNCTIONS\r
+\r
+=head2 bind_attribute_by_data_type\r
+\r
+This function currently supports the SQL_LONGVARCHAR column type.\r
+\r
+=head2 insert\r
+\r
+=head2 last_insert_id\r
+\r
+=head2 sqlt_type\r
+\r
+=head1 BUGS\r
+\r
+Most likely. Bug reports are welcome.\r
+\r
+=head1 AUTHORS\r
+\r
+Øystein Torget C<< <oystein.torget@dnv.com> >>\r
+\r
+=head1 COPYRIGHT\r
+\r
+You may distribute this code under the same terms as Perl itself.\r
+\r
+Det Norske Veritas AS (DNV)\r
+\r
+http://www.dnv.com\r
+\r
+=cut\r
+\r
=head1 AUTHORS
-Marc Mims C<< <marc@sssonline.com> >>
+Marc Mims C<< <marc@questright.com> >>
Based on DBIx::Class::Storage::DBI::DB2 by Jess Robinson.
--- /dev/null
+package DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server;
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+sub _prep_for_execute {
+ my $self = shift;
+ my ($op, $extra_bind, $ident, $args) = @_;
+
+ my ($sql, $bind) = $self->SUPER::_prep_for_execute(@_);
+ $sql .= ';SELECT SCOPE_IDENTITY()' if $op eq 'insert';
+
+ return ($sql, $bind);
+}
+
+sub insert {
+ my ($self, $source, $to_insert) = @_;
+
+ my $bind_attributes = $self->source_bind_attributes($source);
+ my (undef, $sth) = $self->_execute( 'insert' => [], $source, $bind_attributes, $to_insert);
+ $self->{_scope_identity} = $sth->fetchrow_array;
+
+ return $to_insert;
+}
+
+sub last_insert_id { shift->{_scope_identity} }
+
+sub sqlt_type { 'SQLServer' }
+
+sub _sql_maker_opts {
+ my ( $self, $opts ) = @_;
+
+ if ( $opts ) {
+ $self->{_sql_maker_opts} = { %$opts };
+ }
+
+ return { limit_dialect => 'Top', %{$self->{_sql_maker_opts}||{}} };
+}
+
+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 => '%F %T' );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server - Support specific
+to Microsoft SQL Server over ODBC
+
+=head1 DESCRIPTION
+
+This class implements support specific to Microsoft SQL Server over ODBC,
+including auto-increment primary keys and SQL::Abstract::Limit dialect. It
+is loaded automatically by by DBIx::Class::Storage::DBI::ODBC when it
+detects a MSSQL back-end.
+
+=head1 IMPLEMENTATION NOTES
+
+Microsoft SQL Server supports three methods of retrieving the IDENTITY
+value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
+SCOPE_IDENTITY is used here because it is the safest. However, it must
+be called is the same execute statement, not just the same connection.
+
+So, this implementation appends a SELECT SCOPE_IDENTITY() statement
+onto each INSERT to accommodate that requirement.
+
+=head1 METHODS
+
+=head2 insert
+
+=head2 last_insert_id
+
+=head2 sqlt_type
+
+=head2 build_datetime_parser
+
+The resulting parser handles the MSSQL C<DATETIME> type, but is almost
+certainly not sufficient for the other MSSQL 2008 date/time types.
+
+=head1 AUTHORS
+
+Marc Mims C<< <marc@questright.com> >>
+
+=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 base qw/DBIx::Class::Storage::DBI/;
-use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
+sub _rebless {
+ my ($self) = @_;
-# __PACKAGE__->load_components(qw/PK::Auto/);
+ my $version = eval { $self->_dbh->get_info(18); };
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
- my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
- my $sql = 'SELECT ' . $seq . '.currval FROM DUAL';
- my ($id) = $dbh->selectrow_array($sql);
- return $id;
-}
+ 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';
+
+ # Load and rebless
+ eval "require $class";
-sub _dbh_get_autoinc_seq {
- my ($self, $dbh, $source, $col) = @_;
-
- # look up the correct sequence automatically
- my $sql = q{
- SELECT trigger_body FROM ALL_TRIGGERS t
- WHERE t.table_name = ?
- AND t.triggering_event = 'INSERT'
- AND t.status = 'ENABLED'
- };
-
- # trigger_body is a LONG
- $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
-
- my $sth = $dbh->prepare($sql);
- $sth->execute( uc($source->name) );
- while (my ($insert_trigger) = $sth->fetchrow_array) {
- return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
- }
- croak "Unable to find a sequence INSERT trigger on table '" . $source->name . "'.";
+ bless $self, $class unless $@;
+ }
}
-sub get_autoinc_seq {
- my ($self, $source, $col) = @_;
-
- $self->dbh_do($self->can('_dbh_get_autoinc_seq'), $source, $col);
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("SAVEPOINT $name");
}
-sub columns_info_for {
- my ($self, $table) = @_;
+# Would've implemented _svp_release here, but Oracle doesn't support it.
- $self->next::method(uc($table));
-}
+sub _svp_rollback {
+ my ($self, $name) = @_;
+ $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
1;
=head1 NAME
-DBIx::Class::Storage::DBI::Oracle - Automatic primary key class for Oracle
+DBIx::Class::Storage::DBI::Oracle - Base class for Oracle driver
=head1 SYNOPSIS
# In your table classes
- __PACKAGE__->load_components(qw/PK::Auto Core/);
- __PACKAGE__->set_primary_key('id');
- __PACKAGE__->sequence('mysequence');
+ __PACKAGE__->load_components(qw/Core/);
=head1 DESCRIPTION
-This class implements autoincrements for Oracle.
+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.
-=head1 AUTHORS
+For Oracle major versions <= 8 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
+
+ __PACKAGE__->storage_type('::DBI::Oracle::WhereJoins');
-Andy Grundman <andy@hybridized.org>
+to your Schema class.
+
+=head1 AUTHORS
-Scott Connelly <scottsweep@yahoo.com>
+David Jack Olrik C<< <djo@cpan.org> >>
=head1 LICENSE
--- /dev/null
+package DBIx::Class::Storage::DBI::Oracle::Generic;
+# -*- mode: cperl; cperl-indent-level: 2 -*-
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Oracle - Automatic primary key class for Oracle
+
+=head1 SYNOPSIS
+
+ # In your table classes
+ __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->sequence('mysequence');
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for Oracle.
+
+=head1 METHODS
+
+=cut
+
+use Carp::Clan qw/^DBIx::Class/;
+
+use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
+
+# __PACKAGE__->load_components(qw/PK::Auto/);
+
+sub _dbh_last_insert_id {
+ my ($self, $dbh, $source, @columns) = @_;
+ 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 );
+ push @ids, $id;
+ }
+ return @ids;
+}
+
+sub _dbh_get_autoinc_seq {
+ my ($self, $dbh, $source, $col) = @_;
+
+ # look up the correct sequence automatically
+ my $sql = q{
+ SELECT trigger_body FROM ALL_TRIGGERS t
+ WHERE t.table_name = ?
+ AND t.triggering_event = 'INSERT'
+ AND t.status = 'ENABLED'
+ };
+
+ # trigger_body is a LONG
+ $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
+
+ my $sth = $dbh->prepare($sql);
+ $sth->execute( uc($source->name) );
+ while (my ($insert_trigger) = $sth->fetchrow_array) {
+ return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
+ }
+ $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
+}
+
+sub _sequence_fetch {
+ my ( $self, $type, $seq ) = @_;
+ my ($id) = $self->dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
+ return $id;
+}
+
+=head2 get_autoinc_seq
+
+Returns the sequence name for an autoincrement column
+
+=cut
+
+sub get_autoinc_seq {
+ my ($self, $source, $col) = @_;
+
+ $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(uc($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"; }
+
+=head1 AUTHORS
+
+Andy Grundman <andy@hybridized.org>
+
+Scott Connelly <scottsweep@yahoo.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+package DBIx::Class::Storage::DBI::Oracle::WhereJoins;
+
+use base qw( DBIx::Class::Storage::DBI::Oracle::Generic );
+
+use strict;
+use warnings;
+
+__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract::Oracle');
+
+BEGIN {
+ package # Hide from PAUSE
+ DBIC::SQL::Abstract::Oracle;
+
+ use base qw( DBIC::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.
+ die "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";
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Oracle::WhereJoins - Oracle joins in WHERE syntax
+support (instead of ANSI).
+
+=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. (See:
+http://scsys.co.uk:8001/7495)
+
+=head1 SYNOPSIS
+
+DBIx::Class should automagically detect Oracle and use this module with no
+work from you.
+
+=head1 DESCRIPTION
+
+This class implements Oracle's WhereJoin support. 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
+
+This module replaces a subroutine contained in DBIC::SQL::Abstract:
+
+=over
+
+=item sql_maker
+
+=back
+
+It also creates a new module in its BEGIN { } block called
+DBIC::SQL::Abstract::Oracle which has the following methods:
+
+=over
+
+=item select ($\@$;$$@)
+
+Replaces DBIC::SQL::Abstract'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<DBIC::SQL::Abstract>
+
+=item L<DBIx::Class::Storage::DBI::Oracle::Generic>
+
+=item L<DBIx::Class>
+
+=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
use strict;
use warnings;
-use DBD::Pg;
+use DBD::Pg qw(:pg_types);
use base qw/DBIx::Class::Storage::DBI/;
sub last_insert_id {
my ($self,$source,$col) = @_;
my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
- $self->dbh_do($self->can('_dbh_last_insert_id'), $seq);
+ $self->throw_exception("could not fetch primary key for " . $source->name . ", could not "
+ . "get autoinc sequence for $col (check that table and column specifications are correct "
+ . "and in the correct case)") unless defined $seq;
+ $self->dbh_do('_dbh_last_insert_id', $seq);
}
sub _dbh_get_autoinc_seq {
my ($schema,$table) = $source->name =~ /^(.+)\.(.+)$/ ? ($1,$2)
: (undef,$source->name);
- $self->dbh_do($self->can('_dbh_get_autoinc_seq'), $schema, $table, @pri);
+ $self->dbh_do('_dbh_get_autoinc_seq', $schema, $table, @pri);
}
sub sqlt_type {
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 },
+ };
+
+ if( defined $bind_attributes->{$data_type} ) {
+ return $bind_attributes->{$data_type};
+ }
+ else {
+ return;
+ }
+}
+
+sub _sequence_fetch {
+ my ( $self, $type, $seq ) = @_;
+ my ($id) = $self->dbh->selectrow_array("SELECT nextval('${seq}')");
+ return $id;
+}
+
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->dbh->pg_savepoint($name);
+}
+
+sub _svp_release {
+ my ($self, $name) = @_;
+
+ $self->dbh->pg_release($name);
+}
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->dbh->pg_rollback_to($name);
+}
+
1;
=head1 NAME
--- /dev/null
+package DBIx::Class::Storage::DBI::Replicated;
+
+use strict;
+use warnings;
+
+use DBIx::Class::Storage::DBI;
+use DBD::Multi;
+
+use base qw/Class::Accessor::Fast/;
+
+__PACKAGE__->mk_accessors( qw/read_source write_source/ );
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Replicated - ALPHA Replicated database support
+
+=head1 SYNOPSIS
+
+The Following example shows how to change an existing $schema to a replicated
+storage type and update it's connection information to contain a master DSN and
+an array of slaves.
+
+ ## Change storage_type in your schema class
+ $schema->storage_type( '::DBI::Replicated' );
+
+ ## Set your connection.
+ $schema->connect(
+ $dsn, $user, $password, {
+ AutoCommit => 1,
+ ## Other standard DBI connection or DBD custom attributes added as
+ ## usual. Additionally, we have two custom attributes for defining
+ ## slave information and controlling how the underlying DBD::Multi
+ slaves_connect_info => [
+ ## Define each slave like a 'normal' DBI connection, but you add
+ ## in a DBD::Multi custom attribute to define how the slave is
+ ## prioritized. Please see DBD::Multi for more.
+ [$slave1dsn, $user, $password, {%slave1opts, priority=>10}],
+ [$slave2dsn, $user, $password, {%slave2opts, priority=>10}],
+ [$slave3dsn, $user, $password, {%slave3opts, priority=>20}],
+ ## add in a preexisting database handle
+ [$dbh, '','', {priority=>30}],
+ ## DBD::Multi will call this coderef for connects
+ [sub { DBI->connect(< DSN info >) }, '', '', {priority=>40}],
+ ## If the last item is hashref, we use that for DBD::Multi's
+ ## configuration information. Again, see DBD::Multi for more.
+ {timeout=>25, failed_max=>2},
+ ],
+ },
+ );
+
+ ## Now, just use the schema as normal
+ $schema->resultset('Table')->find(< unique >); ## Reads will use slaves
+ $schema->resultset('Table')->create(\%info); ## Writes will use master
+
+=head1 DESCRIPTION
+
+Warning: This class is marked ALPHA. We are using this in development and have
+some basic test coverage but the code hasn't yet been stressed by a variety
+of databases. Individual DB's may have quirks we are not aware of. Please
+use this in development and pass along your experiences/bug fixes.
+
+This class implements replicated data store for DBI. Currently you can define
+one master and numerous slave database connections. All write-type queries
+(INSERT, UPDATE, DELETE and even LAST_INSERT_ID) are routed to master
+database, all read-type queries (SELECTs) go to the slave database.
+
+For every slave database you can define a priority value, which controls data
+source usage pattern. It uses L<DBD::Multi>, so first the lower priority data
+sources used (if they have the same priority, the are used randomized), than
+if all low priority data sources fail, higher ones tried in order.
+
+=head1 CONFIGURATION
+
+Please see L<DBD::Multi> for most configuration information.
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref( $proto ) || $proto;
+ my $self = {};
+
+ bless( $self, $class );
+
+ $self->write_source( DBIx::Class::Storage::DBI->new );
+ $self->read_source( DBIx::Class::Storage::DBI->new );
+
+ return $self;
+}
+
+sub all_sources {
+ my $self = shift;
+
+ my @sources = ($self->read_source, $self->write_source);
+
+ return wantarray ? @sources : \@sources;
+}
+
+sub _connect_info {
+ my $self = shift;
+ my $master = $self->write_source->_connect_info;
+ $master->[-1]->{slave_connect_info} = $self->read_source->_connect_info;
+ return $master;
+}
+
+sub connect_info {
+ my ($self, $source_info) = @_;
+
+ ## if there is no $source_info, treat this sub like an accessor
+ return $self->_connect_info
+ if !$source_info;
+
+ ## Alright, let's conect the master
+ $self->write_source->connect_info($source_info);
+
+ ## Now, build and then connect the Slaves
+ my @slaves_connect_info = @{$source_info->[-1]->{slaves_connect_info}};
+ my $dbd_multi_config = ref $slaves_connect_info[-1] eq 'HASH'
+ ? pop @slaves_connect_info : {};
+
+ ## We need to do this since SQL::Abstract::Limit can't guess what DBD::Multi is
+ $dbd_multi_config->{limit_dialect} = $self->write_source->sql_maker->limit_dialect
+ unless defined $dbd_multi_config->{limit_dialect};
+
+ @slaves_connect_info = map {
+ ## if the first element in the arrayhash is a ref, make that the value
+ my $db = ref $_->[0] ? $_->[0] : $_;
+ my $priority = $_->[-1]->{priority} || 10; ## default priority is 10
+ $priority => $db;
+ } @slaves_connect_info;
+
+ $self->read_source->connect_info([
+ 'dbi:Multi:', undef, undef, {
+ dsns => [@slaves_connect_info],
+ %$dbd_multi_config,
+ },
+ ]);
+
+ ## Return the formated connection information
+ return $self->_connect_info;
+}
+
+sub select {
+ shift->read_source->select( @_ );
+}
+sub select_single {
+ shift->read_source->select_single( @_ );
+}
+sub throw_exception {
+ shift->read_source->throw_exception( @_ );
+}
+sub sql_maker {
+ shift->read_source->sql_maker( @_ );
+}
+sub columns_info_for {
+ shift->read_source->columns_info_for( @_ );
+}
+sub sqlt_type {
+ shift->read_source->sqlt_type( @_ );
+}
+sub create_ddl_dir {
+ shift->read_source->create_ddl_dir( @_ );
+}
+sub deployment_statements {
+ shift->read_source->deployment_statements( @_ );
+}
+sub datetime_parser {
+ shift->read_source->datetime_parser( @_ );
+}
+sub datetime_parser_type {
+ shift->read_source->datetime_parser_type( @_ );
+}
+sub build_datetime_parser {
+ shift->read_source->build_datetime_parser( @_ );
+}
+
+sub limit_dialect { $_->limit_dialect( @_ ) for( shift->all_sources ) }
+sub quote_char { $_->quote_char( @_ ) for( shift->all_sources ) }
+sub name_sep { $_->quote_char( @_ ) for( shift->all_sources ) }
+sub disconnect { $_->disconnect( @_ ) for( shift->all_sources ) }
+sub set_schema { $_->set_schema( @_ ) for( shift->all_sources ) }
+
+sub DESTROY {
+ my $self = shift;
+
+ undef $self->{write_source};
+ undef $self->{read_sources};
+}
+
+sub last_insert_id {
+ shift->write_source->last_insert_id( @_ );
+}
+sub insert {
+ shift->write_source->insert( @_ );
+}
+sub update {
+ shift->write_source->update( @_ );
+}
+sub update_all {
+ shift->write_source->update_all( @_ );
+}
+sub delete {
+ shift->write_source->delete( @_ );
+}
+sub delete_all {
+ shift->write_source->delete_all( @_ );
+}
+sub create {
+ shift->write_source->create( @_ );
+}
+sub find_or_create {
+ shift->write_source->find_or_create( @_ );
+}
+sub update_or_create {
+ shift->write_source->update_or_create( @_ );
+}
+sub connected {
+ shift->write_source->connected( @_ );
+}
+sub ensure_connected {
+ shift->write_source->ensure_connected( @_ );
+}
+sub dbh {
+ shift->write_source->dbh( @_ );
+}
+sub txn_do {
+ shift->write_source->txn_do( @_ );
+}
+sub txn_commit {
+ shift->write_source->txn_commit( @_ );
+}
+sub txn_rollback {
+ shift->write_source->txn_rollback( @_ );
+}
+sub sth {
+ shift->write_source->sth( @_ );
+}
+sub deploy {
+ shift->write_source->deploy( @_ );
+}
+sub _prep_for_execute {
+ shift->write_source->_prep_for_execute(@_);
+}
+
+sub debugobj {
+ shift->write_source->debugobj(@_);
+}
+sub debug {
+ shift->write_source->debug(@_);
+}
+
+sub debugfh { shift->_not_supported( 'debugfh' ) };
+sub debugcb { shift->_not_supported( 'debugcb' ) };
+
+sub _not_supported {
+ my( $self, $method ) = @_;
+
+ die "This Storage does not support $method method.";
+}
+
+=head1 SEE ALSO
+
+L<DBI::Class::Storage::DBI>, L<DBD::Multi>, L<DBI>
+
+=head1 AUTHOR
+
+Norbert Csongrádi <bert@cpan.org>
+
+Peter Siklósi <einon@einon.hu>
+
+John Napiorkowski <john.napiorkowski@takkle.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
--- /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;
\ No newline at end of file
sub backup
{
- my ($self) = @_;
+ my ($self, $dir) = @_;
+ $dir ||= './';
## Where is the db file?
my $dsn = $self->connect_info()->[0];
# print "Found database: $dbname\n";
# my $dbfile = file($dbname);
- my ($vol, $dir, $file) = File::Spec->splitpath($dbname);
+ my ($vol, $dbdir, $file) = File::Spec->splitpath($dbname);
# my $file = $dbfile->basename();
- $file = strftime("%y%m%d%h%M%s", localtime()) . $file;
+ $file = strftime("%Y-%m-%d-%H_%M_%S", localtime()) . $file;
$file = "B$file" while(-f $file);
-
- my $res = copy($dbname, $file);
+
+ mkdir($dir) unless -f $dir;
+ my $backupfile = File::Spec->catfile($dir, $file);
+
+ my $res = copy($dbname, $backupfile);
$self->throw_exception("Backup failed! ($!)") if(!$res);
- return $file;
+ return $backupfile;
}
+
1;
=head1 NAME
-DBIx::Class::PK::Auto::SQLite - Automatic primary key class for SQLite
+DBIx::Class::Storage::DBI::SQLite - Automatic primary key class for SQLite
=head1 SYNOPSIS
use strict;
use warnings;
+use Class::C3;
use base qw/DBIx::Class::Storage::DBI::MSSQL DBIx::Class::Storage::DBI::Sybase/;
1;
$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>
return 'MySQL';
}
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("SAVEPOINT $name");
+}
+
+sub _svp_release {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("RELEASE SAVEPOINT $name");
+}
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
1;
=head1 NAME
use warnings;
use base qw/Class::Accessor::Grouped/;
+use IO::File;
__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh/);
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.
+
+=cut
+sub print {
+ my ($self, $msg) = @_;
+
+ if(!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')
+ or die("Cannot open trace file $1");
+ } else {
+ $fh = IO::File->new('>&STDERR')
+ or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)');
+ }
+
+ $fh->autoflush();
+ $self->debugfh($fh);
+ }
+
+ $self->debugfh->print($msg);
+}
+
=head2 txn_begin
Called when a transaction begins.
sub txn_begin {
my $self = shift;
- $self->debugfh->print("BEGIN WORK\n");
+ $self->print("BEGIN WORK\n");
}
=head2 txn_rollback
sub txn_rollback {
my $self = shift;
- $self->debugfh->print("ROLLBACK\n");
+ $self->print("ROLLBACK\n");
}
=head2 txn_commit
sub txn_commit {
my $self = shift;
- $self->debugfh->print("COMMIT\n");
+ $self->print("COMMIT\n");
+}
+
+=head2 svp_begin
+
+Called when a savepoint is created.
+
+=cut
+sub svp_begin {
+ my ($self, $name) = @_;
+
+ $self->print("SAVEPOINT $name\n");
+}
+
+=head2 svp_release
+
+Called when a savepoint is released.
+
+=cut
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->print("RELEASE SAVEPOINT $name\n");
+}
+
+=head2 svp_rollback
+
+Called when rolling back to a savepoint.
+
+=cut
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->print("ROLLBACK TO SAVEPOINT $name\n");
}
=head2 query_start
return;
}
- $self->debugfh->print($message);
+ $self->print($message);
}
=head2 query_end
--- /dev/null
+package # Hide from pause for now - till we get it working
+ DBIx::Class::Storage::TxnScopeGuard;
+
+use strict;
+use warnings;
+
+sub new {
+ my ($class, $storage) = @_;
+
+ $storage->txn_begin;
+ bless [ 0, $storage ], ref $class || $class;
+}
+
+sub commit {
+ my $self = shift;
+
+ $self->[1]->txn_commit;
+ $self->[0] = 1;
+}
+
+sub DESTROY {
+ my ($dismiss, $storage) = @{$_[0]};
+
+ return if $dismiss;
+
+ my $exception = $@;
+ Carp::cluck("A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or an error - bad")
+ unless $exception;
+ {
+ local $@;
+ eval { $storage->txn_rollback };
+ my $rollback_exception = $@;
+ if($rollback_exception) {
+ my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
+
+ $storage->throw_exception(
+ "Transaction aborted: ${exception}. "
+ . "Rollback failed: ${rollback_exception}"
+ ) unless $rollback_exception =~ /$exception_class/;
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBIx::Class::Storage::TxnScopeGuard - Experimental
+
+=head1 SYNOPSIS
+
+ sub foo {
+ my ($self, $schema) = @_;
+
+ my $guard = $schema->txn_scope_guard;
+
+ # Multiple database operations here
+
+ $guard->commit;
+ }
+
+=head1 DESCRIPTION
+
+An object that behaves much like L<Scope::Guard>, but hardcoded to do the
+right thing with transactions in DBIx::Class.
+
+=head1 METHODS
+
+=head2 new
+
+Creating an instance of this class will start a new transaction. Expects a
+L<DBIx::Class::Storage> object as its only argument.
+
+=head2 commit
+
+Commit the transaction, and stop guarding the scope. If this method is not
+called (i.e. an exception is thrown) and this object goes out of scope then
+the transaction is rolled back.
+
+=cut
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema/txn_scope_guard>.
+
+=head1 AUTHOR
+
+Ash Berlin, 2008.
+
+Insipred by L<Scope::Guard> by chocolateboy.
+
+This module is free software. It may be used, redistributed and/or modified
+under the same terms as Perl itself.
+
+=cut
# Some mistakes the fault of Matt S Trout
+# Others the fault of Ash Berlin
+
use strict;
use warnings;
-use vars qw($DEBUG $VERSION @EXPORT_OK);
+use vars qw($DEBUG @EXPORT_OK);
$DEBUG = 0 unless defined $DEBUG;
-$VERSION = sprintf "%d.%02d", q$Revision 1.0$ =~ /(\d+)\.(\d+)/;
use Exporter;
use Data::Dumper;
# -------------------------------------------------------------------
# parse($tr, $data)
#
+# setting parser_args => { add_fk_index => 0 } will prevent
+# the auto-generation of an index for each FK.
+#
# Note that $data, in the case of this parser, is not useful.
# We're working with DBIx::Class Schemas, not data streams.
# -------------------------------------------------------------------
sub parse {
- my ($tr, $data) = @_;
- my $args = $tr->parser_args;
- my $dbixschema = $args->{'DBIx::Schema'} || $data;
- $dbixschema ||= $args->{'package'};
+ 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'};
- die 'No DBIx::Schema' unless ($dbixschema);
- if (!ref $dbixschema) {
- eval "use $dbixschema;";
- die "Can't load $dbixschema ($@)" if($@);
+ die 'No DBIx::Class::Schema' unless ($dbicschema);
+ if (!ref $dbicschema) {
+ eval "use $dbicschema;";
+ die "Can't load $dbicschema ($@)" if($@);
}
my $schema = $tr->schema;
my $table_no = 0;
-# print Dumper($dbixschema->registered_classes);
-
- #foreach my $tableclass ($dbixschema->registered_classes)
+ $schema->name( ref($dbicschema) . " v" . ($dbicschema->VERSION || '1.x'))
+ unless ($schema->name);
my %seen_tables;
- foreach my $moniker ($dbixschema->sources)
+ my @monikers = sort $dbicschema->sources;
+ if ($limit_sources) {
+ my $ref = ref $limit_sources || '';
+ die "'sources' parameter must be an array or hash ref" unless $ref eq 'ARRAY' || ref eq 'HASH';
+
+ # limit monikers to those specified in
+ my $sources;
+ if ($ref eq 'ARRAY') {
+ $sources->{$_} = 1 for (@$limit_sources);
+ } else {
+ $sources = $limit_sources;
+ }
+ @monikers = grep { $sources->{$_} } @monikers;
+ }
+
+
+ foreach my $moniker (sort @monikers)
{
- #eval "use $tableclass";
- #print("Can't load $tableclass"), next if($@);
- my $source = $dbixschema->source($moniker);
+ my $source = $dbicschema->source($moniker);
+ # Its possible to have multiple DBIC source using same table
next if $seen_tables{$source->name}++;
my $table = $schema->add_table(
my $colcount = 0;
foreach my $col ($source->columns)
{
- # assuming column_info in dbix is the same as DBI (?)
+ # assuming column_info in dbic is the same as DBI (?)
# data_type is a number, column_type is text?
my %colinfo = (
name => $col,
my @primary = $source->primary_columns;
my %unique_constraints = $source->unique_constraints;
- foreach my $uniq (keys %unique_constraints) {
+ foreach my $uniq (sort keys %unique_constraints) {
if (!$source->compare_relationship_keys($unique_constraints{$uniq}, \@primary)) {
$table->add_constraint(
type => 'unique',
- name => "$uniq",
+ name => $uniq,
fields => $unique_constraints{$uniq}
);
}
}
my @rels = $source->relationships();
- foreach my $rel (@rels)
+
+ my %created_FK_rels;
+
+ # global add_fk_index set in parser_args
+ my $add_fk_index = (exists $args->{add_fk_index} && ($args->{add_fk_index} == 0)) ? 0 : 1;
+
+ foreach my $rel (sort @rels)
{
my $rel_info = $source->relationship_info($rel);
if($rel_table)
{
-
my $reverse_rels = $source->reverse_relationship_info($rel);
my ($otherrelname, $otherrelationship) = each %{$reverse_rels};
$on_update = $otherrelationship->{'attrs'}->{cascade_copy} ? 'CASCADE' : '';
}
+ my $is_deferrable = $rel_info->{attrs}{is_deferrable};
+
+ # global parser_args add_fk_index param can be overridden on the rel def
+ my $add_fk_index_rel = (exists $rel_info->{attrs}{add_fk_index}) ? $rel_info->{attrs}{add_fk_index} : $add_fk_index;
+
+ # Make sure we dont create the same foreign key constraint twice
+ my $key_test = join("\x00", @keys);
+
#Decide if this is a foreign key based on whether the self
#items are our primary columns.
# If the sets are different, then we assume it's a foreign key from
# us to another table.
- if (!$source->compare_relationship_keys(\@keys, \@primary)) {
- $table->add_constraint(
- type => 'foreign_key',
- name => "fk_$keys[0]",
- fields => \@keys,
- reference_fields => \@refkeys,
- reference_table => $rel_table,
- on_delete => $on_delete,
- on_update => $on_update
- );
+ # OR: If is_foreign_key_constraint attr is explicity set (or set to false) on the relation
+ next if ( exists $created_FK_rels{$rel_table}->{$key_test} );
+ if ( exists $rel_info->{attrs}{is_foreign_key_constraint}) {
+ # not is this attr set to 0 but definitely if set to 1
+ next unless ($rel_info->{attrs}{is_foreign_key_constraint});
+ } else {
+ # not if might have
+ # next if ($rel_info->{attrs}{accessor} eq 'single' && exists $rel_info->{attrs}{join_type} && uc($rel_info->{attrs}{join_type}) eq 'LEFT');
+ # not sure about this one
+ next if $source->compare_relationship_keys(\@keys, \@primary);
}
+
+ $created_FK_rels{$rel_table}->{$key_test} = 1;
+ if (scalar(@keys)) {
+ $table->add_constraint(
+ type => 'foreign_key',
+ name => join('_', $table->name, 'fk', @keys),
+ fields => \@keys,
+ reference_fields => \@refkeys,
+ reference_table => $rel_table,
+ on_delete => $on_delete,
+ on_update => $on_update,
+ (defined $is_deferrable ? ( deferrable => $is_deferrable ) : ()),
+ );
+
+ if ($add_fk_index_rel) {
+ my $index = $table->add_index(
+ name => join('_', $table->name, 'idx', @keys),
+ fields => \@keys,
+ type => 'NORMAL',
+ );
+ }
+ }
}
}
+
+ if ($source->result_class->can('sqlt_deploy_hook')) {
+ $source->result_class->sqlt_deploy_hook($table);
+ }
}
+
+ if ($dbicschema->can('sqlt_deploy_hook')) {
+ $dbicschema->sqlt_deploy_hook($schema);
+ }
+
return 1;
}
1;
-
use Getopt::Long;
use Pod::Usage;
-use JSON qw( jsonToObj );
+use JSON::Any;
-$JSON::BareKey = 1;
-$JSON::QuotApos = 1;
+
+my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1);
GetOptions(
'schema=s' => \my $schema_class,
die('No schema specified') if(!$schema_class);
eval("require $schema_class");
die('Unable to load schema') if ($@);
-$connect = jsonToObj( $connect ) if ($connect);
+$connect = $json->jsonToObj( $connect ) if ($connect);
my $schema = $schema_class->connect(
( $connect ? @$connect : () )
);
my $resultset = eval{ $schema->resultset($resultset_class) };
die('Unable to load the class with the schema') if ($@);
-$set = jsonToObj( $set ) if ($set);
-$where = jsonToObj( $where ) if ($where);
-$attrs = jsonToObj( $attrs ) if ($attrs);
+$set = $json->jsonToObj( $set ) if ($set);
+$where = $json->jsonToObj( $where ) if ($where);
+$attrs = $json->jsonToObj( $attrs ) if ($attrs);
if ($op eq 'insert') {
die('Do not use the where option with the insert op') if ($where);
die('Do not use the attrs option with the insert op') if ($attrs);
my $obj = $resultset->create( $set );
- print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n";
+ print ''.ref($resultset).' ID: '.join(',',$obj->id())."\n" if (!$quiet);
}
elsif ($op eq 'update') {
$resultset = $resultset->search( ($where||{}) );
eval "use Test::Pod::Coverage 1.04";
plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
-plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
+plan skip_all => 'set TEST_POD to enable this test'
+ unless ($ENV{TEST_POD} || -e 'MANIFEST.SKIP');
my @modules = sort { $a cmp $b } (Test::Pod::Coverage::all_modules());
plan tests => scalar(@modules);
ignore => [
qw/MODIFY_CODE_ATTRIBUTES
component_base_class
- mk_classdata/
+ mk_classdata
+ mk_classaccessor/
+ ]
+ },
+ 'DBIx::Class::Storage' => {
+ ignore => [
+ qw(cursor)
+ ]
+ },
+ 'DBIx::Class::Schema' => {
+ ignore => [
+ qw(setup_connection_class)
]
},
'DBIx::Class::CDBICompat::AccessorMapping' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::AbstractSearch' => {
+ ignore => [qw(search_where)]
+ },
'DBIx::Class::CDBICompat::AttributeAPI' => { skip => 1 },
'DBIx::Class::CDBICompat::AutoUpdate' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::ColumnsAsHash' => {
+ ignore => [qw(inflate_result new update)]
+ },
'DBIx::Class::CDBICompat::ColumnCase' => { skip => 1 },
'DBIx::Class::CDBICompat::ColumnGroups' => { skip => 1 },
'DBIx::Class::CDBICompat::Constraints' => { skip => 1 },
'DBIx::Class::CDBICompat::Constructor' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::Copy' => {
+ ignore => [qw(copy)]
+ },
'DBIx::Class::CDBICompat::DestroyWarning' => { skip => 1 },
'DBIx::Class::CDBICompat::GetSet' => { skip => 1 },
'DBIx::Class::CDBICompat::HasA' => { skip => 1 },
'DBIx::Class::CDBICompat::LazyLoading' => { skip => 1 },
'DBIx::Class::CDBICompat::LiveObjectIndex' => { skip => 1 },
'DBIx::Class::CDBICompat::MightHave' => { skip => 1 },
- 'DBIx::Class::CDBICompat::ObjIndexStubs' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::NoObjectIndex' => { skip => 1 },
'DBIx::Class::CDBICompat::Pager' => { skip => 1 },
'DBIx::Class::CDBICompat::ReadOnly' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::Relationship' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::Relationships' => { skip => 1 },
'DBIx::Class::CDBICompat::Retrieve' => { skip => 1 },
+ 'DBIx::Class::CDBICompat::SQLTransformer' => { skip => 1 },
'DBIx::Class::CDBICompat::Stringify' => { skip => 1 },
'DBIx::Class::CDBICompat::TempColumns' => { skip => 1 },
'DBIx::Class::CDBICompat::Triggers' => { skip => 1 },
'DBIx::Class::Relationship::ManyToMany' => { skip => 1 },
'DBIx::Class::Relationship::ProxyMethods' => { skip => 1 },
'DBIx::Class::ResultSetProxy' => { skip => 1 },
+ 'DBIx::Class::ResultSetManager' => { skip => 1 },
'DBIx::Class::ResultSourceProxy' => { skip => 1 },
'DBIx::Class::Storage::DBI' => { skip => 1 },
'DBIx::Class::Storage::DBI::DB2' => { skip => 1 },
'DBIx::Class::Storage::DBI::mysql' => { skip => 1 },
'SQL::Translator::Parser::DBIx::Class' => { skip => 1 },
'SQL::Translator::Producer::DBIx::Class::File' => { skip => 1 },
+
+# skipped because the synopsis covers it clearly
+
+ 'DBIx::Class::InflateColumn::File' => { skip => 1 },
+
+# skip connection since it's just an override
+
+ 'DBIx::Class::Schema::Versioned' => { ignore => [ qw(connection) ] },
+
+# must kill authors.
+
+ 'DBIx::Class::Storage::DBI::Replicated' => { skip => 1 },
};
foreach my $module (@modules) {
use lib qw(t/lib);
use DBICTest::ForeignComponent;
-plan tests => 5;
+plan tests => 6;
# Tests if foreign component was loaded by calling foreign's method
ok( DBICTest::ForeignComponent->foreign_test_method, 'foreign component' );
}
is( scalar @warnings, 0,
'warning not issued for correct order in load_components()' );
+
+use_ok('DBIx::Class::AccessorGroup');
--- /dev/null
+## ----------------------------------------------------------------------------
+## Tests for the $resultset->populate method.
+##
+## 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
+##
+## Also need to test some stuff that should generate errors.
+## ----------------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+plan tests => 134;
+
+
+## ----------------------------------------------------------------------------
+## Get a Schema and some ResultSets we can play with.
+## ----------------------------------------------------------------------------
+
+my $schema = DBICTest->init_schema();
+my $art_rs = $schema->resultset('Artist');
+my $cd_rs = $schema->resultset('CD');
+
+ok( $schema, 'Got a Schema object');
+ok( $art_rs, 'Got Good Artist Resultset');
+ok( $cd_rs, 'Got Good CD Resultset');
+
+
+## ----------------------------------------------------------------------------
+## Schema populate Tests
+## ----------------------------------------------------------------------------
+
+SCHEMA_POPULATE1: {
+
+ ## Test to make sure that the old $schema->populate is using the new method
+ ## for $resultset->populate when in void context and with sub objects.
+
+ $schema->populate('Artist', [
+
+ [qw/name cds/],
+ ["001First Artist", [
+ {title=>"001Title1", year=>2000},
+ {title=>"001Title2", year=>2001},
+ {title=>"001Title3", year=>2002},
+ ]],
+ ["002Second Artist", []],
+ ["003Third Artist", [
+ {title=>"003Title1", year=>2005},
+ ]],
+ [undef, [
+ {title=>"004Title1", year=>2010}
+ ]],
+ ]);
+
+ isa_ok $schema, 'DBIx::Class::Schema';
+
+ my ($undef, $artist1, $artist2, $artist3 ) = $schema->resultset('Artist')->search({
+ name=>["001First Artist","002Second Artist","003Third Artist", undef]},
+ {order_by=>'name ASC'})->all;
+
+ isa_ok $artist1, 'DBICTest::Artist';
+ isa_ok $artist2, 'DBICTest::Artist';
+ isa_ok $artist3, '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 $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";
+
+ ARTIST1CDS: {
+
+ my ($cd1, $cd2, $cd3) = $artist1->cds->search(undef, {order_by=>'year ASC'});
+
+ isa_ok $cd1, 'DBICTest::CD';
+ isa_ok $cd2, 'DBICTest::CD';
+ isa_ok $cd3, 'DBICTest::CD';
+
+ ok $cd1->year == 2000;
+ ok $cd2->year == 2001;
+ ok $cd3->year == 2002;
+
+ ok $cd1->title eq '001Title1';
+ ok $cd2->title eq '001Title2';
+ ok $cd3->title eq '001Title3';
+ }
+
+ ARTIST3CDS: {
+
+ my ($cd1) = $artist3->cds->search(undef, {order_by=>'year ASC'});
+
+ isa_ok $cd1, 'DBICTest::CD';
+
+ ok $cd1->year == 2005;
+ ok $cd1->title eq '003Title1';
+ }
+
+ ARTIST4CDS: {
+
+ my ($cd1) = $undef->cds->search(undef, {order_by=>'year ASC'});
+
+ isa_ok $cd1, 'DBICTest::CD';
+
+ ok $cd1->year == 2010;
+ ok $cd1->title eq '004Title1';
+ }
+
+ ## Need to do some cleanup so that later tests don't get borked
+
+ $undef->delete;
+}
+
+
+## ----------------------------------------------------------------------------
+## Array context tests
+## ----------------------------------------------------------------------------
+
+ARRAY_CONTEXT: {
+
+ ## These first set of tests are cake because array context just delegates
+ ## all it's processing to $resultset->create
+
+ HAS_MANY_NO_PKS: {
+
+ ## This first group of tests checks to make sure we can call populate
+ ## with the parent having many children and let the keys be automatic
+
+ my $artists = [
+ {
+ name => 'Angsty-Whiny Girl',
+ cds => [
+ { title => 'My First CD', year => 2006 },
+ { title => 'Yet More Tweeny-Pop crap', year => 2007 },
+ ],
+ },
+ {
+ name => 'Manufactured Crap',
+ },
+ {
+ name => 'Like I Give a Damn',
+ cds => [
+ { title => 'My parents sold me to a record company' ,year => 2005 },
+ { title => 'Why Am I So Ugly?', year => 2006 },
+ { title => 'I Got Surgery and am now Popular', year => 2007 }
+ ],
+ },
+ {
+ name => 'Formerly Named',
+ cds => [
+ { title => 'One Hit Wonder', year => 2006 },
+ ],
+ },
+ ];
+
+ ## Get the result row objects.
+
+ my ($girl, $crap, $damn, $formerly) = $art_rs->populate($artists);
+
+ ## Do we have the right object?
+
+ 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'");
+
+ ## Find the expected information?
+
+ ok( $crap->name eq 'Manufactured Crap', "Got Correct name for result object");
+ ok( $girl->name eq 'Angsty-Whiny Girl', "Got Correct name for result object");
+ ok( $damn->name eq 'Like I Give a Damn', "Got Correct name for result object");
+ ok( $formerly->name eq 'Formerly Named', "Got Correct name for result object");
+
+ ## 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( $damn->cds->count == 3, "got Expected Number of Cds");
+ ok( $formerly->cds->count == 1, "got Expected Number of Cds");
+
+ ## Did the cds get expected information?
+
+ my ($cd1, $cd2) = $girl->cds->search({},{order_by=>'year ASC'});
+
+ ok( $cd1->title eq "My First CD", "Got Expected CD Title");
+ ok( $cd2->title eq "Yet More Tweeny-Pop crap", "Got Expected CD Title");
+ }
+
+ HAS_MANY_WITH_PKS: {
+
+ ## This group tests the ability to specify the PK in the parent and let
+ ## DBIC transparently pass the PK down to the Child and also let's the
+ ## child create any other needed PK's for itself.
+
+ my $aid = $art_rs->get_column('artistid')->max || 0;
+
+ my $first_aid = ++$aid;
+
+ my $artists = [
+ {
+ artistid => $first_aid,
+ name => 'PK_Angsty-Whiny Girl',
+ cds => [
+ { artist => $first_aid, title => 'PK_My First CD', year => 2006 },
+ { artist => $first_aid, title => 'PK_Yet More Tweeny-Pop crap', year => 2007 },
+ ],
+ },
+ {
+ artistid => ++$aid,
+ name => 'PK_Manufactured Crap',
+ },
+ {
+ artistid => ++$aid,
+ name => 'PK_Like I Give a Damn',
+ cds => [
+ { title => 'PK_My parents sold me to a record company' ,year => 2005 },
+ { title => 'PK_Why Am I So Ugly?', year => 2006 },
+ { title => 'PK_I Got Surgery and am now Popular', year => 2007 }
+ ],
+ },
+ {
+ artistid => ++$aid,
+ name => 'PK_Formerly Named',
+ cds => [
+ { title => 'PK_One Hit Wonder', year => 2006 },
+ ],
+ },
+ ];
+
+ ## Get the result row objects.
+
+ my ($girl, $crap, $damn, $formerly) = $art_rs->populate($artists);
+
+ ## Do we have the right object?
+
+ 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'");
+
+ ## Find the expected information?
+
+ ok( $crap->name eq 'PK_Manufactured Crap', "Got Correct name for result object");
+ ok( $girl->name eq 'PK_Angsty-Whiny Girl', "Got Correct name for result object");
+ ok( $girl->artistid == $first_aid, "Got Correct artist PK for result object");
+ ok( $damn->name eq 'PK_Like I Give a Damn', "Got Correct name for result object");
+ ok( $formerly->name eq 'PK_Formerly Named', "Got Correct name for result object");
+
+ ## 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( $damn->cds->count == 3, "got Expected Number of Cds");
+ ok( $formerly->cds->count == 1, "got Expected Number of Cds");
+
+ ## Did the cds get expected information?
+
+ my ($cd1, $cd2) = $girl->cds->search({},{order_by=>'year ASC'});
+
+ ok( $cd1->title eq "PK_My First CD", "Got Expected CD Title");
+ ok( $cd2->title eq "PK_Yet More Tweeny-Pop crap", "Got Expected CD Title");
+ }
+
+ BELONGS_TO_NO_PKs: {
+
+ ## 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.
+
+ my $cds = [
+ {
+ title => 'Some CD3',
+ year => '1997',
+ artist => { name => 'Fred BloggsC'},
+ },
+ {
+ title => 'Some CD4',
+ year => '1997',
+ artist => { name => 'Fred BloggsD'},
+ },
+ ];
+
+ 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');
+
+
+ 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');
+ }
+
+ BELONGS_TO_WITH_PKs: {
+
+ ## 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;
+
+ my $cds = [
+ {
+ title => 'Some CD3',
+ year => '1997',
+ artist => { artistid=> ++$aid, name => 'Fred BloggsC'},
+ },
+ {
+ title => 'Some CD4',
+ year => '1997',
+ artist => { artistid=> ++$aid, name => 'Fred BloggsD'},
+ },
+ ];
+
+ 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');
+
+ 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');
+ ok($cdB->artist->artistid == $aid, "Got Expected Artist ID");
+ }
+}
+
+
+## ----------------------------------------------------------------------------
+## Void context tests
+## ----------------------------------------------------------------------------
+
+VOID_CONTEXT: {
+
+ ## 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.
+
+ HAS_MANY_WITH_PKS: {
+
+ ## This first group of tests checks to make sure we can call populate
+ ## with the parent having many children and the parent PK is set
+
+ my $aid = $art_rs->get_column('artistid')->max || 0;
+
+ my $first_aid = ++$aid;
+
+ my $artists = [
+ {
+ artistid => $first_aid,
+ name => 'VOID_PK_Angsty-Whiny Girl',
+ cds => [
+ { artist => $first_aid, title => 'VOID_PK_My First CD', year => 2006 },
+ { artist => $first_aid, title => 'VOID_PK_Yet More Tweeny-Pop crap', year => 2007 },
+ ],
+ },
+ {
+ artistid => ++$aid,
+ name => 'VOID_PK_Manufactured Crap',
+ },
+ {
+ artistid => ++$aid,
+ name => 'VOID_PK_Like I Give a Damn',
+ 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 }
+ ],
+ },
+ {
+ artistid => ++$aid,
+ name => 'VOID_PK_Formerly Named',
+ cds => [
+ { title => 'VOID_PK_One Hit Wonder', year => 2006 },
+ ],
+ },
+ {
+ artistid => ++$aid,
+ name => undef,
+ cds => [
+ { title => 'VOID_PK_Zundef test', year => 2006 },
+ ],
+ },
+ ];
+
+ ## Get the result row objects.
+
+ $art_rs->populate($artists);
+
+ my ($undef, $girl, $formerly, $damn, $crap) = $art_rs->search(
+
+ {name=>[ map { $_->{name} } @$artists]},
+ {order_by=>'name ASC'},
+ );
+
+ ## Do we have the right object?
+
+ 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'");
+
+ ## 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( $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");
+
+ ## 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( $crap->cds->count == 0, "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");
+
+ ## Did the cds get expected information?
+
+ my ($cd1, $cd2) = $girl->cds->search({},{order_by=>'year ASC'});
+
+ ok( $cd1->title eq "VOID_PK_My First CD", "Got Expected CD Title");
+ ok( $cd2->title eq "VOID_PK_Yet More Tweeny-Pop crap", "Got Expected CD Title");
+ }
+
+
+ BELONGS_TO_WITH_PKs: {
+
+ ## 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;
+
+ my $cds = [
+ {
+ title => 'Some CD3B',
+ year => '1997',
+ artist => { artistid=> ++$aid, name => 'Fred BloggsCB'},
+ },
+ {
+ title => 'Some CD4B',
+ year => '1997',
+ artist => { artistid=> ++$aid, name => 'Fred BloggsDB'},
+ },
+ ];
+
+ $cd_rs->populate($cds);
+
+ my ($cdA, $cdB) = $cd_rs->search(
+ {title=>[sort map {$_->{title}} @$cds]},
+ {order_by=>'title ASC'},
+ );
+
+ isa_ok($cdA, 'DBICTest::CD', 'Created CD');
+ isa_ok($cdA->artist, 'DBICTest::Artist', 'Set Artist');
+ is($cdA->artist->name, 'Fred BloggsCB', 'Set Artist to FredCB');
+
+ isa_ok($cdB, 'DBICTest::CD', 'Created CD');
+ isa_ok($cdB->artist, 'DBICTest::Artist', 'Set Artist');
+ is($cdB->artist->name, 'Fred BloggsDB', 'Set Artist to FredDB');
+ ok($cdB->artist->artistid == $aid, "Got Expected Artist ID");
+ }
+
+ BELONGS_TO_NO_PKs: {
+
+ ## Test from a belongs_to perspective, should create artist first,
+ ## then CD with artistid.
+
+ my $cds = [
+ {
+ title => 'Some CD3BB',
+ year => '1997',
+ artist => { name => 'Fred BloggsCBB'},
+ },
+ {
+ title => 'Some CD4BB',
+ year => '1997',
+ artist => { name => 'Fred BloggsDBB'},
+ },
+ {
+ title => 'Some CD5BB',
+ year => '1997',
+ artist => { name => undef},
+ },
+ ];
+
+ $cd_rs->populate($cds);
+
+ my ($cdA, $cdB, $cdC) = $cd_rs->search(
+ {title=>[sort map {$_->{title}} @$cds]},
+ {order_by=>'title ASC'},
+ );
+
+ isa_ok($cdA, 'DBICTest::CD', 'Created CD');
+ isa_ok($cdA->artist, 'DBICTest::Artist', 'Set Artist');
+ is($cdA->title, 'Some CD3BB', 'Found Expected title');
+ is($cdA->artist->name, 'Fred BloggsCBB', 'Set Artist to FredCBB');
+
+ isa_ok($cdB, 'DBICTest::CD', 'Created CD');
+ isa_ok($cdB->artist, 'DBICTest::Artist', 'Set Artist');
+ is($cdB->title, 'Some CD4BB', 'Found Expected title');
+ is($cdB->artist->name, 'Fred BloggsDBB', 'Set Artist to FredDBB');
+
+ isa_ok($cdC, 'DBICTest::CD', 'Created CD');
+ isa_ok($cdC->artist, 'DBICTest::Artist', 'Set Artist');
+ is($cdC->title, 'Some CD5BB', 'Found Expected title');
+ is( $cdC->artist->name, undef, 'Set Artist to something undefined');
+ }
+
+
+ HAS_MANY_NO_PKS: {
+
+ ## This first group of tests checks to make sure we can call populate
+ ## 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',
+ },
+ {
+ name => 'VOID_Like I Give a Damn',
+ 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 }
+ ],
+ },
+ {
+ name => 'VOID_Formerly Named',
+ cds => [
+ { title => 'VOID_One Hit Wonder', year => 2006 },
+ ],
+ },
+ ];
+
+ ## Get the result row objects.
+
+ $art_rs->populate($artists);
+
+ my ($girl, $formerly, $damn, $crap) = $art_rs->search(
+ {name=>[sort map {$_->{name}} @$artists]},
+ {order_by=>'name ASC'},
+ );
+
+ ## Do we have the right object?
+
+ 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'");
+
+ ## 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( $formerly->name eq 'VOID_Formerly Named', "Got Correct name 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( $crap->cds->count == 0, "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 the cds get expected information?
+
+ my ($cd1, $cd2) = $girl->cds->search({},{order_by=>'year ASC'});
+
+ ok($cd1, "Got a got CD");
+ ok($cd2, "Got a got CD");
+ ok( $cd1->title eq "VOID_My First CD", "Got Expected CD Title");
+ ok( $cd2->title eq "VOID_Yet More Tweeny-Pop crap", "Got Expected CD Title");
+ }
+
+}
\ No newline at end of file
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 3 );
+ : ( tests => 4 );
}
use lib qw(t/lib);
use_ok( 'DBICTest' );
-
use_ok( 'DBICTest::Schema' );
+my $schema = DBICTest->init_schema;
{
my $warnings;
local $SIG{__WARN__} = sub { $warnings .= $_[0] };
- eval { DBICTest::CD->create({ title => 'vacation in antarctica' }) };
+ eval {
+ $schema->resultset('CD')
+ ->create({ title => 'vacation in antarctica' })
+ };
+ like $@, qr/NULL/; # as opposed to some other error
ok( $warnings !~ /uninitialized value/, "No warning from Storage" );
}
diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
my $dsn = $schema->storage->connect_info->[0];
-$schema->connection($dsn, { quote_char => '`', name_sep => '.' });
+$schema->connection(
+ $dsn,
+ undef,
+ undef,
+ { AutoCommit => 1 },
+ { quote_char => '`', name_sep => '.' },
+);
my $sql = '';
$schema->storage->debugcb(sub { $sql = $_[1] });
eval { $rs->first };
like($sql, qr/ORDER BY \Q${order}\E/, 'did not quote ORDER BY with scalarref');
-$schema->connection($dsn, { quote_char => [qw/[ ]/], name_sep => '.' });
+$schema->connection(
+ $dsn,
+ undef,
+ undef,
+ { AutoCommit => 1, quote_char => [qw/[ ]/], name_sep => '.' }
+);
$schema->storage->debugcb(sub { $sql = $_[1] });
$schema->storage->debug(1);
order => '12'
);
-$schema->connection($dsn, { quote_char => '`', name_sep => '.' });
+$schema->connection(
+ $dsn,
+ undef,
+ undef,
+ { AutoCommit => 1, quote_char => '`', name_sep => '.' }
+);
is($schema->storage->sql_maker->update('group', \%data), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE');
use Test::More;
use lib qw(t/lib);
-use DBICTest::Plain;
-plan tests => 1;
+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');
use strict;
use warnings;
+use FindBin;
+use File::Copy;
use Test::More;
use lib qw(t/lib);
use DBICTest;
-plan tests => 2;
+plan tests => 5;
+
+my $db_orig = "$FindBin::Bin/var/DBIxClass.db";
+my $db_tmp = "$db_orig.tmp";
# Set up the "usual" sqlite for DBICTest
my $schema = DBICTest->init_schema;
# 4. Success!
my @art_two = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
cmp_ok(@art_two, '==', 3, "Three artists returned");
+
+### 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 );
+open DBFILE, '>', $db_orig;
+print DBFILE 'THIS IS NOT A REAL DATABASE';
+close DBFILE;
+chmod 0000, $db_orig;
+
+### Try the operation again... it should fail, since there's no db
+eval {
+ my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
+};
+ok( $@, 'The operation failed' );
+
+### 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" );
+}
use lib qw(t/lib);
use DBICTest;
-plan tests => 6;
+plan tests => 8;
# Set up the "usual" sqlite for DBICTest
my $schema = DBICTest->init_schema;
# Basic check, normal exception
eval { throwex };
+my $e = $@; # like() seems to stringify $@
+like($@, $ex_regex);
+
+# Re-throw the exception with rethrow()
+eval { $e->rethrow };
+isa_ok( $@, 'DBIx::Class::Exception' );
like($@, $ex_regex);
# Now lets rethrow via exception_action
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+eval { require DateTime::Format::MySQL };
+
+plan $@ ? ( skip_all => 'Requires DateTime::Format::MySQL' )
+ : ( tests => 3 );
+
+my $schema = DBICTest->init_schema(
+ no_deploy => 1, # Deploying would cause an early rebless
+);
+
+is(
+ ref $schema->storage, 'DBIx::Class::Storage::DBI',
+ 'Starting with generic storage'
+);
+
+# Calling date_time_parser should cause the storage to be reblessed,
+# so that we can pick up datetime_parser_type from subclasses
+
+my $parser = $schema->storage->datetime_parser();
+
+# We're currently expecting a MySQL parser. May change in future.
+is($parser, 'DateTime::Format::MySQL', 'Got expected datetime_parser');
+
+isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::SQLite', 'storage');
+
}
}
+BEGIN {
+ local $SIG{__WARN__} = sub {};
+ require DBIx::Class::ResultSetManager;
+}
+
use DBICTest::ResultSetManager; # uses Class::Inspector
my $schema = DBICTest::ResultSetManager->compose_namespace('DB');
use warnings;
use Test::More;
-use DBIx::Class::Storage::DBI;
+#use DBIx::Class::Storage::DBI;
+use DBIx::Class::Storage::DBI::Oracle::WhereJoins;
-plan tests => 1;
+plan tests => 4;
-my $sa = new DBIC::SQL::Abstract;
+my $sa = new DBIC::SQL::Abstract::Oracle;
$sa->limit_dialect('RowNum');
) B
WHERE r >= 4
', 'Munged stuff to make Oracle not explode');
+
+# test WhereJoins
+# search with undefined or empty $cond
+
+# my ($self, $table, $fields, $where, $order, @rest) = @_;
+is($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),
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( artist.artistid(+) = me.artist )', 'WhereJoins search with empty where clause');
+
+is($sa->select([
+ { me => "cd" },
+ [
+ { "-join_type" => "", artist => "artist" },
+ { "artist.artistid" => "me.artist" },
+ ],
+ ],
+ [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
+ { 'artist.artistid' => 3 },
+ undef),
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist ) AND ( artist.artistid = ? ) ) )', 'WhereJoins search with where clause');
+
+is($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' ],
+ [{ 'artist.artistid' => 3 }, { 'me.cdid' => 5 }],
+ undef),
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid(+) = me.artist ) AND ( ( ( artist.artistid = ? ) OR ( me.cdid = ? ) ) ) ) )', 'WhereJoins search with or in where clause');
+
+
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 7 );
+}
+
+### $schema->storage->debug(1);
+
+my $where_bind = {
+ where => \'name like ?',
+ bind => [ 'Cat%' ],
+};
+
+my $rs;
+
+TODO: {
+ local $TODO = 'bind args order needs fixing (semifor)';
+
+ # First, the simple cases...
+ $rs = $schema->resultset('Artist')->search(
+ { artistid => 1 },
+ $where_bind,
+ );
+
+ is ( $rs->count, 1, 'where/bind combined' );
+
+ $rs= $schema->resultset('Artist')->search({}, $where_bind)
+ ->search({ artistid => 1});
+
+ is ( $rs->count, 1, 'where/bind first' );
+
+ $rs = $schema->resultset('Artist')->search({ artistid => 1})
+ ->search({}, $where_bind);
+
+ is ( $rs->count, 1, 'where/bind last' );
+}
+
+# More complex cases, based primarily on the Cookbook
+# "Arbitrary SQL through a custom ResultSource" technique,
+# which seems to be the only place the bind attribute is
+# documented. Breaking this technique probably breaks existing
+# application code.
+my $source = DBICTest::Artist->result_source_instance;
+my $new_source = $source->new($source);
+$new_source->source_name('Complex');
+
+$new_source->name(\<<'');
+( 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=?)
+
+$schema->register_source('Complex' => $new_source);
+
+$rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] });
+is ( $rs->count, 1, 'cookbook arbitrary sql example' );
+
+$rs = $schema->resultset('Complex')->search({ 'artistid' => 1 }, { bind => [ 1999 ] });
+is ( $rs->count, 1, '...coobook + search condition' );
+
+$rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] })
+ ->search({ 'artistid' => 1 });
+is ( $rs->count, 1, '...cookbook (bind first) + chained search' );
+
+TODO: {
+ local $TODO = 'bind args order needs fixing (semifor)';
+ $rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] })
+ ->search({ 'artistid' => 1 }, {
+ where => \'title like ?',
+ bind => [ 'Spoon%' ] });
+ is ( $rs->count, 1, '...cookbook + chained search with extra bind' );
+}
$num_children = 10;
}
-plan tests => $num_children + 5;
+plan tests => $num_children + 6;
use lib qw(t/lib);
};
ok(!$@) or diag "Creation eval failed: $@";
+{
+ my $pid = fork;
+ if(!defined $pid) {
+ die "fork failed: $!";
+ }
+
+ if (!$pid) {
+ exit $schema->storage->connected ? 1 : 0;
+ }
+
+ if (waitpid($pid, 0) == $pid) {
+ my $ex = $? >> 8;
+ ok($ex == 0, "storage->connected() returns false in child");
+ exit $ex if $ex; # skip remaining tests
+ }
+}
+
my @pids;
while(@pids < $num_children) {
my $newthread = async {
my $tid = threads->tid;
- my $dbh = $schema->storage->dbh;
my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
my $row = $parent_rs->next;
--- /dev/null
+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
+
+BEGIN {
+ plan skip_all => 'Your perl does not support ithreads'
+ if !$Config{useithreads} || $] < 5.008;
+}
+
+use threads;
+
+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';
+
+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 $parent_rs;
+
+eval {
+ my $dbh = $schema->storage->dbh;
+
+ {
+ local $SIG{__WARN__} = sub {};
+ eval { $dbh->do("DROP TABLE cd") };
+ $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(255) NOT NULL UNIQUE, year VARCHAR(255));");
+ }
+
+ $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
+ $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 });
+
+ $parent_rs = $schema->resultset('CD')->search({ year => 1901 });
+ $parent_rs->next;
+};
+ok(!$@) or diag "Creation eval failed: $@";
+
+my @children;
+while(@children < $num_children) {
+
+ my $newthread = async {
+ my $tid = threads->tid;
+ # my $dbh = $schema->storage->dbh;
+
+ $schema->txn_do(sub {
+ 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 $tid", artist => $tid, year => scalar(@children) });
+ }
+ });
+ sleep(3);
+ };
+ die "Thread creation failed: $! $@" if !defined $newthread;
+ push(@children, $newthread);
+}
+
+ok(1, "past spawning");
+
+{
+ $_->join for(@children);
+}
+
+ok(1, "past joining");
+
+while(@children) {
+ my $child = pop(@children);
+ my $tid = $child->tid;
+ my $rs = $schema->resultset('CD')->search({ title => "test success $tid", artist => $tid, year => scalar(@children) });
+ is($rs->next->get_column('artist'), $tid, "Child $tid successful");
+}
+
+ok(1, "Made it to the end");
+
+$schema->storage->dbh->do("DROP TABLE cd");
my $schema = DBICTest->init_schema();
-plan tests => 64;
+plan tests => 84;
+
+eval { require DateTime::Format::MySQL };
+my $NO_DTFM = $@ ? 1 : 0;
# figure out if we've got a version of sqlite that is older than 3.2.6, in
# which case COUNT(DISTINCT()) doesn't work
is($art->name, 'We Are In Rehab', "Accessor update ok");
+my %dirty = $art->get_dirty_columns();
+cmp_ok(scalar(keys(%dirty)), '==', 1, '1 dirty column');
+ok(grep($_ eq 'name', keys(%dirty)), 'name is dirty');
+
is($art->get_column("name"), 'We Are In Rehab', 'And via get_column');
ok($art->update, 'Update run');
+my %not_dirty = $art->get_dirty_columns();
+cmp_ok(scalar(keys(%not_dirty)), '==', 0, 'Nothing is dirty');
+
+eval {
+ my $ret = $art->make_column_dirty('name2');
+};
+ok(defined($@), 'Failed to make non-existent column dirty');
+$art->make_column_dirty('name');
+my %fake_dirty = $art->get_dirty_columns();
+cmp_ok(scalar(keys(%fake_dirty)), '==', 1, '1 fake dirty column');
+ok(grep($_ eq 'name', keys(%fake_dirty)), 'name is fake dirty');
+
my $record_jp = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search(undef, { prefetch => 'cds' })->next;
ok($record_jp, "prefetch on same rel okay");
cd => 1,
position => 4,
title => 'Insert or Update',
+ last_updated_on => '1973-07-19 12:01:02'
} );
$new->update_or_insert;
ok($new->in_storage, 'update_or_insert insert ok');
$new->update_or_insert;
is( $schema->resultset("Track")->find(100)->pos, 5, 'update_or_insert update ok');
+# get_inflated_columns w/relation and accessor alias
+SKIP: {
+ skip "This test requires DateTime::Format::MySQL", 8 if $NO_DTFM;
+
+ isa_ok($new->updated_date, 'DateTime', 'have inflated object via accessor');
+ my %tdata = $new->get_inflated_columns;
+ is($tdata{'trackid'}, 100, 'got id');
+ isa_ok($tdata{'cd'}, 'DBICTest::CD', 'cd is CD object');
+ is($tdata{'cd'}->id, 1, 'cd object is id 1');
+ is($tdata{'position'}, 5, 'got position from pos');
+ is($tdata{'title'}, 'Insert or Update');
+ is($tdata{'last_updated_on'}, '1973-07-19T12:01:02');
+ isa_ok($tdata{'last_updated_on'}, 'DateTime', 'inflated accessored column');
+}
+
eval { $schema->class("Track")->load_components('DoesNotExist'); };
ok $@, $@;
cmp_ok(@artsn, '==', 4, "Four artists returned");
# make sure subclasses that don't set source_name are ok
- ok($schema->source('ArtistSubclass', 'ArtistSubclass exists'));
+ ok($schema->source('ArtistSubclass'), 'ArtistSubclass exists');
}
my $newbook = $schema->resultset( 'Bookmark' )->find(1);
ok(! exists $schema->source('CD')->_columns->{'year'}, 'year still exists in _columns');
}
+# test get_inflated_columns with objects
+SKIP: {
+ skip "This test requires DateTime::Format::MySQL", 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');
+ diag $class;
+ my $table = $class->table($class->table);
+ is($table, $class->table, '->table($table) returns $table');
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+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);
+cmp_ok(@cd, '==', 1, 'Return something even in array context');
+ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
+
+$art = $schema->resultset("Artist")->find({artistid => '4'});
+ok(!defined($art), 'Find on unique constraint: artist not found');
+@cd = $schema->resultset("CD")->find({artist => '2', title => 'Lada-Di Lada-Da'});
+cmp_ok(@cd, '==', 1, 'Return something even in array context');
+ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
+
+$art = $schema->resultset("Artist")->search({name => 'The Jesus And Mary Chain'});
+isa_ok($art, 'DBIx::Class::ResultSet', 'get a DBIx::Class::ResultSet object');
+my $next = $art->next;
+ok(!defined($next), 'Nothing next in ResultSet');
+my $cd = $schema->resultset("CD")->search({title => 'Rubbersoul'});
+@cd = $cd->next;
+cmp_ok(@cd, '==', 1, 'Return something even in array context');
+ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
+
+$art = $schema->resultset("Artist")->single({name => 'Bikini Bottom Boys'});
+ok(!defined($art), 'Find on primary id: artist not found');
+@cd = $schema->resultset("CD")->single({title => 'The Singles 1962-2006'});
+cmp_ok(@cd, '==', 1, 'Return something even in array context');
+ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
+
+$art = $schema->resultset("Artist")->search({name => 'Random Girl Band'});
+isa_ok($art, 'DBIx::Class::ResultSet', 'get a DBIx::Class::ResultSet object');
+$next = $art->single;
+ok(!defined($next), 'Nothing next in ResultSet');
+$cd = $schema->resultset("CD")->search({title => 'Call of the West'});
+@cd = $cd->single;
+cmp_ok(@cd, '==', 1, 'Return something even in array context');
+ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
+
+$cd = $schema->resultset("CD")->first;
+my $artist_rs = $schema->resultset("Artist")->search({ artistid => $cd->artist->artistid });
+$art = $artist_rs->find({ name => 'some other name' }, { key => 'primary' });
+ok($art, 'Artist found by key in the resultset');
+
+$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"
+ => "Non-unique find generated a cursor inexhaustion warning";
+
+$artist_rs = $schema->resultset("Artist")->search({}, { prefetch => 'cds' });
+warning_is {
+ $artist_rs->find({}, { key => 'primary' })
+} "DBIx::Class::ResultSet::find(): Query returned more than one row", "Non-unique find generated a cursor inexhaustion warning";
my $schema = DBICTest->init_schema();
-plan tests => 56;
+plan tests => 63;
# has_a test
my $cd = $schema->resultset("CD")->find(4);
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' );
+};
# update_from_related, the same as set_from_related, but it calls update afterwards
$track = $schema->resultset("Track")->create( {
year => 2006,
} );
is( $cd->title, 'Greatest Hits', 'find_or_create_related new record ok' );
+
@cds = $artist->search_related('cds');
is( ($artist->search_related('cds'))[4]->title, 'Greatest Hits', 'find_or_create_related new record search ok' );
is( $cd->title, 'Greatest Hits 2: Louder Than Ever', 'find_or_new_related new record ok' );
ok( ! $cd->in_storage, 'find_or_new_related on a new record: not in_storage' );
+# print STDERR Data::Dumper::Dumper($cd->get_columns);
+# $cd->result_source->schema->storage->debug(1);
+$cd->artist(undef);
+my $newartist = $cd->find_or_new_related( 'artist', {
+ name => 'Random Boy Band Two',
+ artistid => 200,
+} );
+# $cd->result_source->schema->storage->debug(0);
+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');
+
SKIP: {
skip "relationship checking needs fixing", 1;
# try to add a bogus relationship using the wrong cols
is( $twokey->fourkeys_to_twokeys->count, 0,
'twokey has no links to fourkey' );
+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, 3, 'open search on undef FK');
+
+my $def_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007, artist => undef });
+is($def_artist_cd->has_column_loaded('artist'), 1, 'FK loaded');
+is($def_artist_cd->search_related('artist')->count, 0, 'closed search on null FK');
# test undirected many-to-many relationship (e.g. "related artists")
my $undir_maps = $schema->resultset("Artist")->find(1)->artist_undirected_maps;
use strict;
use warnings;
-use Test::More;
+use Test::More qw(no_plan);
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 12;
-
# first page
my $it = $schema->resultset("CD")->search(
{},
is( $it->next->title, "Generic Manufactured Singles", "software iterator->next ok" );
+# test paging with chained searches
+$it = $schema->resultset("CD")->search(
+ {},
+ { rows => 2,
+ page => 2 }
+)->search( undef, { order_by => 'title' } );
+
+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');
use lib qw(t/lib);
use DBICTest;
-DBICTest::Schema::CD->add_column('year');
my $schema = DBICTest->init_schema();
eval { require DateTime };
plan skip_all => "Need DateTime for inflation tests" if $@;
-plan tests => 4;
+plan tests => 21;
-DBICTest::Schema::CD->inflate_column( 'year',
+$schema->class('CD')
+#DBICTest::Schema::CD
+->inflate_column( 'year',
{ inflate => sub { DateTime->new( year => shift ) },
deflate => sub { shift->year } }
);
is( $cd->year->month, 1, 'inflated month ok' );
+eval { $cd->year(\'year +1'); };
+ok(!$@, 'updated year using a scalarref');
+$cd->update();
+$cd->discard_changes();
+
+is( ref($cd->year), 'DateTime', 'year is still a DateTime, ok' );
+
+is( $cd->year->year, 1998, 'updated year, bypassing inflation' );
+
+is( $cd->year->month, 1, 'month is still 1' );
+
+# get_inflated_column test
+
+is( ref($cd->get_inflated_column('year')), 'DateTime', 'get_inflated_column produces a DateTime');
+
# deflate test
my $now = DateTime->now;
$cd->year( $now );
$cd->update;
-($cd) = $schema->resultset("CD")->search( year => $now->year );
+$cd = $schema->resultset("CD")->find(3);
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');
+$cd->update;
+
+$cd = $schema->resultset("CD")->find(3);
+is( $cd->year->year, $now->year, 'deflate ok' );
+
+$cd = $schema->resultset("CD")->find(3);
+my $before_year = $cd->year->year;
+eval { $cd->set_inflated_column('year', \'year + 1') };
+ok(!$@, 'set_inflated_column to "year + 1"');
+$cd->update;
+
+$cd = $schema->resultset("CD")->find(3);
+is( $cd->year->year, $before_year+1, 'deflate ok' );
+
+# store_inflated_column test
+$cd = $schema->resultset("CD")->find(3);
+eval { $cd->store_inflated_column('year', $now) };
+ok(!$@, 'store_inflated_column with DateTime object');
+$cd->update;
+
+is( $cd->year->year, $now->year, 'deflate ok' );
+
+# update tests
+$cd = $schema->resultset("CD")->find(3);
+eval { $cd->update({'year' => $now}) };
+ok(!$@, 'update using DateTime object ok');
+is($cd->year->year, $now->year, 'deflate ok');
+
+$cd = $schema->resultset("CD")->find(3);
+$before_year = $cd->year->year;
+eval { $cd->update({'year' => \'year + 1'}) };
+ok(!$@, 'update using scalarref ok');
+
+$cd = $schema->resultset("CD")->find(3);
+is($cd->year->year, $before_year + 1, 'deflate ok');
+
+# discard_changes test
+$cd = $schema->resultset("CD")->find(3);
+# inflate the year
+$before_year = $cd->year->year;
+$cd->update({ year => \'year + 1'});
+$cd->discard_changes;
+
+is($cd->year->year, $before_year + 1, 'discard_changes clears the inflated value');
+
+my $copy = $cd->copy({ year => $now, title => "zemoose" });
+
+isnt( $copy->year->year, $before_year, "copy" );
+
+# eval { $cd->store_inflated_column('year', \'year + 1') };
+# print STDERR "ERROR: $@" if($@);
+# ok(!$@, 'store_inflated_column to "year + 1"');
+
+# is_deeply( $cd->year, \'year + 1', 'deflate ok' );
+
plan tests => 6;
-DBICTest::Schema::CD->load_components(qw/CDBICompat::HasA/);
+DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
DBICTest::Schema::CD->has_a( 'year', 'DateTime',
inflate => sub { DateTime->new( year => shift ) },
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More qw(no_plan);
+use lib qw(t/lib);
+use DBICTest;
+use DBIx::Class::ResultClass::HashRefInflator;
+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');
+
+ # 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' );
+}
+
+
+sub check_cols_of {
+ my ($dbic_obj, $datahashref) = @_;
+
+ foreach my $col (keys %$datahashref) {
+ # plain column
+ if (not ref ($datahashref->{$col}) ) {
+ is ($datahashref->{$col}, $dbic_obj->get_column($col), 'same value');
+ }
+ # related table entry (belongs_to)
+ elsif (ref ($datahashref->{$col}) eq 'HASH') {
+ check_cols_of($dbic_obj->$col, $datahashref->{$col});
+ }
+ # multiple related entries (has_many)
+ elsif (ref ($datahashref->{$col}) eq 'ARRAY') {
+ my @dbic_reltable = $dbic_obj->$col;
+ my @hashref_reltable = @{$datahashref->{$col}};
+
+ is (scalar @hashref_reltable, scalar @dbic_reltable, 'number of related entries');
+
+ # for my $index (0..scalar @hashref_reltable) {
+ for my $index (0..scalar @dbic_reltable) {
+ my $dbic_reltable_obj = $dbic_reltable[$index];
+ my $hashref_reltable_entry = $hashref_reltable[$index];
+
+ check_cols_of($dbic_reltable_obj, $hashref_reltable_entry);
+ }
+ }
+ }
+}
+
+# create a cd without tracks for testing empty has_many relationship
+$schema->resultset('CD')->create({ title => 'Silence is golden', artist => 3, year => 2006 });
+
+# order_by to ensure both resultsets have the rows in the same order
+my $rs_dbic = $schema->resultset('CD')->search(undef,
+ {
+ prefetch => [ qw/ artist tracks / ],
+ order_by => [ 'me.cdid', 'tracks.position' ],
+ }
+);
+my $rs_hashrefinf = $schema->resultset('CD')->search(undef,
+ {
+ prefetch => [ qw/ artist tracks / ],
+ order_by => [ 'me.cdid', 'tracks.position' ],
+ }
+);
+$rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator');
+
+my @dbic = $rs_dbic->all;
+my @hashrefinf = $rs_hashrefinf->all;
+
+for my $index (0..scalar @hashrefinf) {
+ my $dbic_obj = $dbic[$index];
+ my $datahashref = $hashrefinf[$index];
+
+ check_cols_of($dbic_obj, $datahashref);
+}
plan (skip_all => "No suitable serializer found") unless $selected;
-plan (tests => 6);
+plan (tests => 8);
DBICTest::Schema::Serialized->inflate_column( 'serialized',
{ inflate => $selected->{inflater},
deflate => $selected->{deflater},
);
Class::C3->reinitialize;
-my $complex1 = {
- id => 1,
- serialized => {
- a => 1,
- b => [
- { c => 2 },
- ],
- d => 3,
- },
+my $struct_hash = {
+ a => 1,
+ b => [
+ { c => 2 },
+ ],
+ d => 3,
};
-my $complex2 = {
- id => 1,
- serialized => [
- 'a',
- { b => 1, c => 2},
- 'd',
- ],
-};
+my $struct_array = [
+ 'a',
+ {
+ b => 1,
+ c => 2
+ },
+ 'd',
+];
my $rs = $schema->resultset('Serialized');
-my $entry = $rs->create({ id => 1, serialized => ''});
-
my $inflated;
-ok($entry->update ({ %{$complex1} }), 'hashref deflation ok');
-ok($inflated = $entry->serialized, 'hashref inflation ok');
-is_deeply($inflated, $complex1->{serialized}, 'inflated hash matches original');
+#======= testing hashref serialization
+
+my $object = $rs->create( {
+ id => 1,
+ 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( {
+ id => 2,
+ serialized => '',
+} );
+eval { $object->set_inflated_column('serialized', $struct_hash) };
+ok(!$@, 'set_inflated_column to a hashref');
+is_deeply($object->serialized, $struct_hash, 'inflated hash matches original');
+
-ok($entry->update ({ %{$complex2} }), 'arrayref deflation ok');
-ok($inflated = $entry->serialized, 'arrayref inflation ok');
-is_deeply($inflated, $complex2->{serialized}, 'inflated array matches original');
+#====== testing arrayref serialization
+ok($object->update( { serialized => $struct_array } ), 'arrayref deflation');
+ok($inflated = $object->serialized, 'arrayref inflation');
+is_deeply($inflated, $struct_array, 'inflated array matches original');
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
}
my $art = $schema->resultset("Artist")->find(1);
ok($art->update({ artistid => 100 }), 'update allows pk mutation');
is($art->artistid, 100, 'pk mutation applied');
+
+my $art_100 = $schema->resultset("Artist")->find(100);
+$art_100->artistid(101);
+ok($art_100->update(), 'update allows pk mutation via column accessor');
plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
unless ($dsn && $user);
-plan tests => 5;
+plan tests => 10;
-DBICTest::Schema->compose_namespace('MySQLTest' => $dsn, $user, $pass);
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
-my $dbh = MySQLTest->schema->storage->dbh;
+my $dbh = $schema->storage->dbh;
$dbh->do("DROP TABLE IF EXISTS artist;");
#'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', '');
-MySQLTest::Artist->load_components('PK::Auto');
+# This is in Core now, but it's here just to test that it doesn't break
+$schema->class('Artist')->load_components('PK::Auto');
# test primary key handling
-my $new = MySQLTest::Artist->create({ name => 'foo' });
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
ok($new->artistid, "Auto-PK worked");
# test LIMIT support
for (1..6) {
- MySQLTest::Artist->create({ name => 'Artist ' . $_ });
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
}
-my $it = MySQLTest::Artist->search( {},
+my $it = $schema->resultset('Artist')->search( {},
{ rows => 3,
offset => 2,
order_by => 'artistid' }
$test_type_info->{charfield}->{data_type} = 'VARCHAR';
}
- my $type_info = MySQLTest->schema->storage->columns_info_for('artist');
+ my $type_info = $schema->storage->columns_info_for('artist');
is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
}
+## Can we properly deal with the null search problem?
+##
+## Only way is to do a SET SQL_AUTO_IS_NULL = 0; on connect
+## But I'm not sure if we should do this or not (Ash, 2008/06/03)
+
+NULLINSEARCH: {
+
+ ok my $artist1_rs = $schema->resultset('Artist')->search({artistid=>6666})
+ => 'Created an artist resultset of 6666';
+
+ is $artist1_rs->count, 0
+ => 'Got no returned rows';
+
+ ok my $artist2_rs = $schema->resultset('Artist')->search({artistid=>undef})
+ => 'Created an artist resultset of undef';
+
+ TODO: {
+ $TODO = "need to fix the row count =1 when select * from table where pk IS NULL problem";
+ is $artist2_rs->count, 0
+ => 'got no rows';
+ }
+
+ my $artist = $artist2_rs->single;
+
+ is $artist => undef
+ => 'Nothing Found!';
+}
+
+
# clean up our mess
-$dbh->do("DROP TABLE artist");
+END {
+ $dbh->do("DROP TABLE artist") if $dbh;
+}
use warnings;
use base 'DBIx::Class';
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('casecheck');
__PACKAGE__->add_columns(qw/id name NAME uc_name/);
__PACKAGE__->column_info_from_storage(1);
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
. ' (note: creates and drops tables named artist and casecheck!)' unless ($dsn && $user);
-plan tests => 8;
+plan tests => 32;
DBICTest::Schema->load_classes( 'Casecheck' );
-DBICTest::Schema->compose_namespace('PgTest' => $dsn, $user, $pass);
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
-my $dbh = PgTest->schema->storage->dbh;
-PgTest->schema->source("Artist")->name("testschema.artist");
+# Check that datetime_parser returns correctly before we explicitly connect.
+SKIP: {
+ eval { require DateTime::Format::Pg };
+ skip "DateTime::Format::Pg required", 2 if $@;
+
+ my $store = ref $schema->storage;
+ is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
+
+ my $parser = $schema->storage->datetime_parser;
+ is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
+}
+
+my $dbh = $schema->storage->dbh;
+$schema->source("Artist")->name("testschema.artist");
+$schema->source("SequenceTest")->name("testschema.sequence_test");
$dbh->do("CREATE SCHEMA testschema;");
$dbh->do("CREATE TABLE testschema.artist (artistid serial PRIMARY KEY, name VARCHAR(100), charfield CHAR(10));");
+$dbh->do("CREATE TABLE testschema.sequence_test (pkid1 integer, pkid2 integer, nonpkid integer, name VARCHAR(100), CONSTRAINT pk PRIMARY KEY(pkid1, pkid2));");
+$dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0");
+$dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0");
+$dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0");
ok ( $dbh->do('CREATE TABLE testschema.casecheck (id serial PRIMARY KEY, "name" VARCHAR(1), "NAME" VARCHAR(2), "UC_NAME" VARCHAR(3));'), 'Creation of casecheck table');
-PgTest::Artist->load_components('PK::Auto');
+# This is in Core now, but it's here just to test that it doesn't break
+$schema->class('Artist')->load_components('PK::Auto');
-my $new = PgTest::Artist->create({ name => 'foo' });
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
is($new->artistid, 1, "Auto-PK worked");
-$new = PgTest::Artist->create({ name => 'bar' });
+$new = $schema->resultset('Artist')->create({ name => 'bar' });
is($new->artistid, 2, "Auto-PK worked");
};
-my $type_info = PgTest->schema->storage->columns_info_for('testschema.artist');
+my $type_info = $schema->storage->columns_info_for('testschema.artist');
my $artistid_defval = delete $type_info->{artistid}->{default_value};
like($artistid_defval,
qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
is_deeply($type_info, $test_type_info,
'columns_info_for - column data types');
-my $name_info = PgTest::Casecheck->column_info( 'name' );
+my $name_info = $schema->source('Casecheck')->column_info( 'name' );
is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
-my $NAME_info = PgTest::Casecheck->column_info( '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 = PgTest::Casecheck->column_info( 'uc_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'" );
-$dbh->do("DROP TABLE testschema.artist;");
-$dbh->do("DROP TABLE testschema.casecheck;");
-$dbh->do("DROP SCHEMA testschema;");
+# Test SELECT ... FOR UPDATE
+my $HaveSysSigAction = eval "require Sys::SigAction" && !$@;
+if ($HaveSysSigAction) {
+ Sys::SigAction->import( 'set_sig_handler' );
+}
+
+SKIP: {
+ skip "Sys::SigAction is not available", 3 unless $HaveSysSigAction;
+ # create a new schema
+ my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema2->source("Artist")->name("testschema.artist");
+
+ $schema->txn_do( sub {
+ my $artist = $schema->resultset('Artist')->search(
+ {
+ artistid => 1
+ },
+ {
+ for => 'update'
+ }
+ )->first;
+ is($artist->artistid, 1, "select for update returns artistid = 1");
+
+ my $artist_from_schema2;
+ my $error_ok = 0;
+ eval {
+ my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
+ alarm(2);
+ $artist_from_schema2 = $schema2->resultset('Artist')->find(1);
+ $artist_from_schema2->name('fooey');
+ $artist_from_schema2->update;
+ alarm(0);
+ };
+ if (my $e = $@) {
+ $error_ok = $e =~ /DBICTestTimeout/;
+ }
+
+ # Make sure that an error was raised, and that the update failed
+ ok($error_ok, "update from second schema times out");
+ ok($artist_from_schema2->is_column_changed('name'), "'name' column is still dirty from second schema");
+ });
+}
+
+SKIP: {
+ skip "Sys::SigAction is not available", 3 unless $HaveSysSigAction;
+ # create a new schema
+ my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema2->source("Artist")->name("testschema.artist");
+
+ $schema->txn_do( sub {
+ my $artist = $schema->resultset('Artist')->search(
+ {
+ artistid => 1
+ },
+ )->first;
+ is($artist->artistid, 1, "select for update returns artistid = 1");
+
+ my $artist_from_schema2;
+ my $error_ok = 0;
+ eval {
+ my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
+ alarm(2);
+ $artist_from_schema2 = $schema2->resultset('Artist')->find(1);
+ $artist_from_schema2->name('fooey');
+ $artist_from_schema2->update;
+ alarm(0);
+ };
+ if (my $e = $@) {
+ $error_ok = $e =~ /DBICTestTimeout/;
+ }
+
+ # Make sure that an error was NOT raised, and that the update succeeded
+ ok(! $error_ok, "update from second schema DOES NOT timeout");
+ ok(! $artist_from_schema2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
+ });
+}
+
+SKIP: {
+ skip "Oracle Auto-PK tests are broken", 16;
+
+ # test auto increment using sequences WITHOUT triggers
+ 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");
+}
+
+END {
+ if($dbh) {
+ $dbh->do("DROP TABLE testschema.artist;");
+ $dbh->do("DROP TABLE testschema.casecheck;");
+ $dbh->do("DROP TABLE testschema.sequence_test;");
+ $dbh->do("DROP SEQUENCE pkid1_seq");
+ $dbh->do("DROP SEQUENCE pkid2_seq");
+ $dbh->do("DROP SEQUENCE nonpkid_seq");
+ $dbh->do("DROP SCHEMA testschema;");
+ }
+}
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. ' .
- 'Warning: This test drops and creates tables called \'artist\', \'cd\' and \'track\''
+ '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);
-plan tests => 6;
+plan tests => 23;
-DBICTest::Schema->compose_namespace('OraTest' => $dsn, $user, $pass);
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
-my $dbh = OraTest->schema->storage->dbh;
+my $dbh = $schema->storage->dbh;
eval {
$dbh->do("DROP SEQUENCE artist_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 cd");
$dbh->do("DROP TABLE track");
};
$dbh->do("CREATE SEQUENCE artist_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))");
+$dbh->do("CREATE TABLE sequence_test (pkid1 NUMBER(12), pkid2 NUMBER(12), nonpkid NUMBER(12), name VARCHAR(255))");
$dbh->do("CREATE TABLE cd (cdid NUMBER(12), artist NUMBER(12), title VARCHAR(255), year VARCHAR(4))");
-$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255))");
+$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE)");
$dbh->do("ALTER TABLE artist ADD (CONSTRAINT artist_pk PRIMARY KEY (artistid))");
+$dbh->do("ALTER TABLE sequence_test ADD (CONSTRAINT sequence_test_constraint PRIMARY KEY (pkid1, pkid2))");
$dbh->do(qq{
CREATE OR REPLACE TRIGGER artist_insert_trg
BEFORE INSERT ON artist
END;
});
-OraTest::Artist->load_components('PK::Auto');
-OraTest::CD->load_components('PK::Auto::Oracle');
-OraTest::Track->load_components('PK::Auto::Oracle');
+# 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');
# test primary key handling
-my $new = OraTest::Artist->create({ name => 'foo' });
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
is($new->artistid, 1, "Oracle Auto-PK worked");
# test join with row count ambiguity
-my $cd = OraTest::CD->create({ cdid => 1, artist => 1, title => 'EP C', year => '2003' });
-my $track = OraTest::Track->create({ trackid => 1, cd => 1, position => 1, title => 'Track1' });
-my $tjoin = OraTest::Track->search({ 'me.title' => 'Track1'},
+my $cd = $schema->resultset('CD')->create({ cdid => 1, artist => 1, title => 'EP C', year => '2003' });
+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 }
);
is($tjoin->next->title, 'Track1', "ambiguous column ok");
# check count distinct with multiple columns
-my $other_track = OraTest::Track->create({ trackid => 2, cd => 1, position => 1, title => 'Track2' });
-my $tcount = OraTest::Track->search(
+my $other_track = $schema->resultset('Track')->create({ trackid => 2, cd => 1, position => 1, title => 'Track2' });
+my $tcount = $schema->resultset('Track')->search(
{},
{
select => [{count => {distinct => ['position', 'title']}}],
# test LIMIT support
for (1..6) {
- OraTest::Artist->create({ name => 'Artist ' . $_ });
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
}
-my $it = OraTest::Artist->search( {},
+my $it = $schema->resultset('Artist')->search( {},
{ rows => 3,
offset => 2,
order_by => 'artistid' }
$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 auto increment using sequences WITHOUT triggers
+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");
+
# clean up our mess
-$dbh->do("DROP SEQUENCE artist_seq");
-$dbh->do("DROP TABLE artist");
-$dbh->do("DROP TABLE cd");
-$dbh->do("DROP TABLE track");
+END {
+ if($dbh) {
+ $dbh->do("DROP SEQUENCE artist_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 cd");
+ $dbh->do("DROP TABLE track");
+ }
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
+
+eval "use DateTime; use DateTime::Format::Oracle;";
+if ($@) {
+ plan skip_all => 'needs DateTime and DateTime::Format::Oracle for testing';
+}
+elsif (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 {
+ plan tests => 4;
+}
+
+# DateTime::Format::Oracle needs this set
+$ENV{NLS_DATE_FORMAT} = 'DD-MON-YY';
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+
+# 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' });
+
+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)");
+
+# 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' });
+is($new->trackid, 1, "insert sucessful");
+
+my $track = $schema->resultset('Track')->find( 1 );
+
+is( ref($track->last_updated_on), 'DateTime', "last_updated_on inflated ok");
+
+is( $track->last_updated_on->month, 5, "DateTime methods work on inflated column");
+
+my $dt = DateTime->now();
+$track->last_updated_on($dt);
+$track->update;
+
+is( $track->last_updated_on->month, $dt->month, "deflate ok");
+
+# clean up our mess
+END {
+ if($dbh) {
+ $dbh->do("DROP TABLE track");
+ }
+}
+
plan tests => 6;
-DBICTest::Schema->compose_namespace('DB2Test' => $dsn, $user, $pass);
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
-my $dbh = DB2Test->schema->storage->dbh;
+my $dbh = $schema->storage->dbh;
-$dbh->do("DROP TABLE artist", { RaiseError => 0, PrintError => 0 });
+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));");
-#'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', '');
-
-DB2Test::Artist->load_components('PK::Auto');
+# This is in core, just testing that it still loads ok
+$schema->class('Artist')->load_components('PK::Auto');
# test primary key handling
-my $new = DB2Test::Artist->create({ name => 'foo' });
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
ok($new->artistid, "Auto-PK worked");
# test LIMIT support
for (1..6) {
- DB2Test::Artist->create({ name => 'Artist ' . $_ });
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
}
-my $it = DB2Test::Artist->search( {},
+my $it = $schema->resultset('Artist')->search( {},
{ rows => 3,
order_by => 'artistid'
}
};
-my $type_info = DB2Test->schema->storage->columns_info_for('artist');
+my $type_info = $schema->storage->columns_info_for('artist');
is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
-
-
# clean up our mess
-$dbh->do("DROP TABLE artist");
-
+END {
+ $dbh->do("DROP TABLE artist") if $dbh;
+}
plan tests => 6;
-DBICTest::Schema->compose_namespace('DB2Test' => $dsn, $user, $pass);
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
-my $dbh = DB2Test->schema->storage->dbh;
+my $dbh = $schema->storage->dbh;
-$dbh->do("DROP TABLE artist", { RaiseError => 0, PrintError => 0 });
+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))");
-DB2Test::Artist->load_components('PK::Auto');
+# Just to test loading, already in Core
+$schema->class('Artist')->load_components('PK::Auto');
# test primary key handling
-my $new = DB2Test::Artist->create({ name => 'foo' });
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
ok($new->artistid, "Auto-PK worked");
# test LIMIT support
for (1..6) {
- DB2Test::Artist->create({ name => 'Artist ' . $_ });
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
}
-my $it = DB2Test::Artist->search( {},
+my $it = $schema->resultset('Artist')->search( {},
{ rows => 3,
order_by => 'artistid'
}
};
-my $type_info = DB2Test->schema->storage->columns_info_for('artist');
+my $type_info = $schema->storage->columns_info_for('artist');
is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
-
-
# clean up our mess
-$dbh->do("DROP TABLE artist");
+END {
+ $dbh->do("DROP TABLE artist") if $dbh;
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+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);
+
+plan tests => 12;
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1});
+
+$schema->storage->ensure_connected;
+isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' );
+
+my $dbh = $schema->storage->dbh;
+
+eval { $dbh->do("DROP TABLE artist") };
+
+ $dbh->do(<<'');
+CREATE TABLE artist (
+ artistid INT IDENTITY NOT NULL,
+ name VARCHAR(255),
+ charfield CHAR(10),
+ primary key(artistid)
+)
+
+my %seen_id;
+
+# test primary key handling
+my $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" );
+
+
+# clean up our mess
+END {
+ $dbh->do('DROP TABLE artist') if $dbh;
+}
+
plan skip_all => 'Set $ENV{DBICTEST_MSSQL_DSN}, _USER and _PASS to run this test'
unless ($dsn);
-plan tests => 4;
+plan tests => 5;
my $storage_type = '::DBI::MSSQL';
$storage_type = '::DBI::Sybase::MSSQL' if $dsn =~ /^dbi:Sybase:/;
# Add more for others in the future when they exist (ODBC? ADO? JDBC?)
-DBICTest::Schema->storage_type($storage_type);
-DBICTest::Schema->compose_namespace( 'MSSQLTest' => $dsn, $user, $pass );
+my $schema = DBICTest::Schema->clone;
+$schema->storage_type($storage_type);
+$schema->connection($dsn, $user, $pass);
-my $dbh = MSSQLTest->schema->storage->dbh;
+my $dbh = $schema->storage->dbh;
$dbh->do("IF OBJECT_ID('artist', 'U') IS NOT NULL
DROP TABLE artist");
$dbh->do("CREATE TABLE artist (artistid INT IDENTITY PRIMARY KEY, name VARCHAR(255));");
+$dbh->do("CREATE TABLE cd (cdid INT IDENTITY PRIMARY KEY, artist INT, title VARCHAR(100), year VARCHAR(100));");
-MSSQLTest::Artist->load_components('PK::Auto::MSSQL');
+# Just to test compat shim, Auto is in Core
+$schema->class('Artist')->load_components('PK::Auto::MSSQL');
# Test PK
-my $new = MSSQLTest::Artist->create( { name => 'foo' } );
+my $new = $schema->resultset('Artist')->create( { name => 'foo' } );
ok($new->artistid, "Auto-PK worked");
# Test LIMIT
for (1..6) {
- MSSQLTest::Artist->create( { name => 'Artist ' . $_ } );
+ $schema->resultset('Artist')->create( { name => 'Artist ' . $_ } );
}
-my $it = MSSQLTest::Artist->search( { },
+my $it = $schema->resultset('Artist')->search( { },
{ rows => 3,
offset => 2,
order_by => 'artistid'
}
);
+# Test ? in data don't get treated as placeholders
+my $cd = $schema->resultset('CD')->create( {
+ artist => 1,
+ title => 'Does this break things?',
+ year => 2007,
+} );
+ok($cd->id, 'Not treating ? in data as placeholders');
+
is( $it->count, 3, "LIMIT count ok" );
ok( $it->next->name, "iterator->next ok" );
$it->next;
$it->next;
is( $it->next, undef, "next past end of resultset ok" );
+# clean up our mess
+END {
+ $dbh->do("IF OBJECT_ID('artist', 'U') IS NOT NULL DROP TABLE artist")
+ if $dbh;
+ $dbh->do("IF OBJECT_ID('cd', 'U') IS NOT NULL DROP TABLE cd")
+ if $dbh;
+}
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 9);
-}
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
+}
# test LIMIT
my $it = $schema->resultset("CD")->search( {},
);
is( $cds[0]->title, "Spoonful of bees", "software offset ok" );
+
+@cds = $schema->resultset("CD")->search( {},
+ {
+ offset => 2,
+ order_by => 'year' }
+);
+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(
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 49 );
+ : ( tests => 16 );
}
# figure out if we've got a version of sqlite that is older than 3.2.6, in
;
is( $sa->_recurse_from(@j4), $match, 'join 4 (nested joins + join types) ok');
+my @j5 = (
+ { child => 'person' },
+ [ { father => 'person' }, { 'father.person_id' => \'!= child.father_id' }, ],
+ [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
+);
+$match = 'person child JOIN person father ON ( father.person_id != '
+ . 'child.father_id ) JOIN person mother ON ( mother.person_id '
+ . '= child.mother_id )'
+ ;
+is( $sa->_recurse_from(@j5), $match, '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 - try using "\.\.\." instead/;
+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' },
);
cmp_ok( scalar $rs->all, '==', scalar $rs->slice(0, $rs->count - 1), 'slice() with join has same count as all()' );
+ok(!$rs->slice($rs->count+1000, $rs->count+1002)->count,
+ 'Slicing beyond end of rs returns a zero count');
+
$rs = $schema->resultset("Artist")->search(
{ 'liner_notes.notes' => 'Kill Yourself!' },
{ join => { 'cds' => 'liner_notes' } });
is($rs->first->name, 'We Are Goth', 'Correct record returned');
-# bug in 0.07000 caused attr (join/prefetch) to be modifed by search
-# so we check the search & attr arrays are not modified
-my $search = { 'artist.name' => 'Caterwauler McCrae' };
-my $attr = { prefetch => [ qw/artist liner_notes/ ],
- order_by => 'me.cdid' };
-my $search_str = Dumper($search);
-my $attr_str = Dumper($attr);
-
-$rs = $schema->resultset("CD")->search($search, $attr);
-
-is(Dumper($search), $search_str, 'Search hash untouched after search()');
-is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()');
-cmp_ok($rs + 0, '==', 3, 'Correct number of records returned');
-
-my $queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my @cd = $rs->all;
-
-is($cd[0]->title, 'Spoonful of bees', 'First record returned ok');
-
-ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join');
-
-is($cd[1]->{_relationship_data}{liner_notes}->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN');
-
-is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class');
-
-is($cd[2]->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'Prefetch on parent object ok');
-
-is($queries, 1, 'prefetch ran only 1 select statement');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-# test for partial prefetch via columns attr
-my $cd = $schema->resultset('CD')->find(1,
- {
- columns => [qw/title artist.name/],
- join => { 'artist' => {} }
- }
-);
-ok(eval { $cd->artist->name eq 'Caterwauler McCrae' }, 'single related column prefetched');
-
-# start test for nested prefetch SELECT count
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-$rs = $schema->resultset('Tag')->search(
- {},
- {
- prefetch => { cd => 'artist' }
- }
-);
-
-my $tag = $rs->first;
-
-is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' );
-
-is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch');
-
-# count the SELECTs
-#$selects++ if /SELECT(?!.*WHERE 1=0.*)/;
-is($queries, 1, 'nested prefetch ran exactly 1 select statement (excluding column_info)');
-
-$queries = 0;
-
-$cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' });
-
-is($cd->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'artist prefetched correctly on find');
-
-is($queries, 1, 'find with prefetch ran exactly 1 select statement (excluding column_info)');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-$rs = $schema->resultset('Tag')->search(
- {},
- {
- join => { cd => 'artist' },
- prefetch => { cd => 'artist' }
- }
-);
-
-cmp_ok( $rs->count, '>=', 0, 'nested prefetch does not duplicate joins' );
-
-my ($artist) = $schema->resultset("Artist")->search({ 'cds.year' => 2001 },
- { order_by => 'artistid DESC', join => 'cds' });
-
-is($artist->name, 'Random Boy Band', "Join search by object ok");
-
-my @cds = $schema->resultset("CD")->search({ 'liner_notes.notes' => 'Buy Merch!' },
- { join => 'liner_notes' });
-
-cmp_ok(scalar @cds, '==', 1, "Single CD retrieved via might_have");
-
-is($cds[0]->title, "Generic Manufactured Singles", "Correct CD retrieved");
-
-my @artists = $schema->resultset("Artist")->search({ 'tags.tag' => 'Shiny' },
- { join => { 'cds' => 'tags' } });
-
-cmp_ok( @artists, '==', 2, "two-join search ok" );
-
-$rs = $schema->resultset("CD")->search(
- {},
- { group_by => [qw/ title me.cdid /] }
-);
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- cmp_ok( $rs->count, '==', 5, "count() ok after group_by on main pk" );
-}
-
-cmp_ok( scalar $rs->all, '==', 5, "all() returns same count as count() after group_by on main pk" );
-
-$rs = $schema->resultset("CD")->search(
- {},
- { join => [qw/ artist /], group_by => [qw/ artist.name /] }
-);
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- 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' } }
-);
-
-cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" );
-
-$rs = $rs->search( undef, { having =>{ 'count(*)'=> \'> 2' }});
-
-cmp_ok( $rs->all, '==', 1, "count() ok after group_by on related column with a having" );
-
-$rs = $schema->resultset("Artist")->search(
- { 'cds.title' => 'Spoonful of bees',
- 'cds_2.title' => 'Forkful of bees' },
- { join => [ 'cds', 'cds' ] });
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- cmp_ok($rs->count, '==', 1, "single artist returned from multi-join");
-}
-
-is($rs->next->name, 'Caterwauler McCrae', "Correct artist returned");
-
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my $tree_like =
- $schema->resultset('TreeLike')->find(4,
- { join => { parent => { parent => 'parent' } },
- prefetch => { parent => { parent => 'parent' } } });
-
-is($tree_like->name, 'quux', 'Bottom of tree ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'baz', 'First level up ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'bar', 'Second level up ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'foo', 'Third level up ok');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-cmp_ok($queries, '==', 1, 'Only one query run');
-
-$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 1});
-$tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first;
-is($tree_like->name, 'quux', 'Tree search_related ok');
-
-$tree_like = $schema->resultset('TreeLike')->search_related('children',
- { 'children.id' => 2, 'children_2.id' => 3 },
- { prefetch => { children => 'children' } }
- )->first;
-is(eval { $tree_like->children->first->children->first->name }, 'quux',
- 'Tree search_related with prefetch ok');
-
-$tree_like = eval { $schema->resultset('TreeLike')->search(
- { 'children.id' => 2, 'children_2.id' => 5 },
- { join => [qw/children children/] }
- )->search_related('children', { 'children_4.id' => 6 }, { prefetch => 'children' }
- )->first->children->first; };
-is(eval { $tree_like->name }, 'fong', 'Tree with multiple has_many joins ok');
-
-# test that collapsed joins don't get a _2 appended to the alias
-
-my $sql = '';
-$schema->storage->debugcb(sub { $sql = $_[1] });
-$schema->storage->debug(1);
-
-eval {
- my $row = $schema->resultset('Artist')->search_related('cds', undef, {
- join => 'tracks',
- prefetch => 'tracks',
- })->search_related('tracks')->first;
-};
-
-like( $sql, qr/^SELECT tracks_2\.trackid/, "join not collapsed for search_related" );
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use Data::Dumper;
+
+my $schema = DBICTest->init_schema();
+
+my $orig_debug = $schema->storage->debug;
+
+use IO::File;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 58 );
+}
+
+# figure out if we've got a version of sqlite that is older than 3.2.6, in
+# which case COUNT(DISTINCT()) doesn't work
+my $is_broken_sqlite = 0;
+my ($sqlite_major_ver,$sqlite_minor_ver,$sqlite_patch_ver) =
+ split /\./, $schema->storage->dbh->get_info(18);
+if( $schema->storage->dbh->get_info(17) eq 'SQLite' &&
+ ( ($sqlite_major_ver < 3) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver < 2) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver == 2 && $sqlite_patch_ver < 6) ) ) {
+ $is_broken_sqlite = 1;
+}
+
+# bug in 0.07000 caused attr (join/prefetch) to be modifed by search
+# so we check the search & attr arrays are not modified
+my $search = { 'artist.name' => 'Caterwauler McCrae' };
+my $attr = { prefetch => [ qw/artist liner_notes/ ],
+ order_by => 'me.cdid' };
+my $search_str = Dumper($search);
+my $attr_str = Dumper($attr);
+
+my $rs = $schema->resultset("CD")->search($search, $attr);
+
+is(Dumper($search), $search_str, 'Search hash untouched after search()');
+is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()');
+cmp_ok($rs + 0, '==', 3, 'Correct number of records returned');
+
+my $queries = 0;
+$schema->storage->debugcb(sub { $queries++; });
+$schema->storage->debug(1);
+
+my @cd = $rs->all;
+
+is($cd[0]->title, 'Spoonful of bees', 'First record returned ok');
+
+ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join');
+
+is($cd[1]->{_relationship_data}{liner_notes}->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN');
+
+is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class');
+
+is($cd[2]->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'Prefetch on parent object ok');
+
+is($queries, 1, 'prefetch ran only 1 select statement');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+# test for partial prefetch via columns attr
+my $cd = $schema->resultset('CD')->find(1,
+ {
+ columns => [qw/title artist.name/],
+ join => { 'artist' => {} }
+ }
+);
+ok(eval { $cd->artist->name eq 'Caterwauler McCrae' }, 'single related column prefetched');
+
+# start test for nested prefetch SELECT count
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+$rs = $schema->resultset('Tag')->search(
+ {},
+ {
+ prefetch => { cd => 'artist' }
+ }
+);
+
+my $tag = $rs->first;
+
+is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' );
+
+is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch');
+
+# count the SELECTs
+#$selects++ if /SELECT(?!.*WHERE 1=0.*)/;
+is($queries, 1, 'nested prefetch ran exactly 1 select statement (excluding column_info)');
+
+$queries = 0;
+
+is($tag->search_related('cd')->search_related('artist')->first->name,
+ 'Caterwauler McCrae',
+ 'chained belongs_to->belongs_to search_related ok');
+
+is($queries, 0, 'chained search_related after belontgs_to->belongs_to prefetch ran no queries');
+
+$queries = 0;
+
+$cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' });
+
+is($cd->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'artist prefetched correctly on find');
+
+is($queries, 1, 'find with prefetch ran exactly 1 select statement (excluding column_info)');
+
+$queries = 0;
+
+$schema->storage->debugcb(sub { $queries++; });
+
+$cd = $schema->resultset('CD')->find(1, { prefetch => { cd_to_producer => 'producer' } });
+
+is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok');
+
+is($queries, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
+
+$queries = 0;
+
+my $producers = $cd->search_related('cd_to_producer')->search_related('producer');
+
+is($producers->first->name, 'Matt S Trout', 'chained many_to_many search_related ok');
+
+is($queries, 0, 'chained search_related after many_to_many prefetch ran no queries');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+$rs = $schema->resultset('Tag')->search(
+ {},
+ {
+ join => { cd => 'artist' },
+ prefetch => { cd => 'artist' }
+ }
+);
+
+cmp_ok( $rs->count, '>=', 0, 'nested prefetch does not duplicate joins' );
+
+my ($artist) = $schema->resultset("Artist")->search({ 'cds.year' => 2001 },
+ { order_by => 'artistid DESC', join => 'cds' });
+
+is($artist->name, 'Random Boy Band', "Join search by object ok");
+
+my @cds = $schema->resultset("CD")->search({ 'liner_notes.notes' => 'Buy Merch!' },
+ { join => 'liner_notes' });
+
+cmp_ok(scalar @cds, '==', 1, "Single CD retrieved via might_have");
+
+is($cds[0]->title, "Generic Manufactured Singles", "Correct CD retrieved");
+
+my @artists = $schema->resultset("Artist")->search({ 'tags.tag' => 'Shiny' },
+ { join => { 'cds' => 'tags' } });
+
+cmp_ok( @artists, '==', 2, "two-join search ok" );
+
+$rs = $schema->resultset("CD")->search(
+ {},
+ { group_by => [qw/ title me.cdid /] }
+);
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ cmp_ok( $rs->count, '==', 5, "count() ok after group_by on main pk" );
+}
+
+cmp_ok( scalar $rs->all, '==', 5, "all() returns same count as count() after group_by on main pk" );
+
+$rs = $schema->resultset("CD")->search(
+ {},
+ { join => [qw/ artist /], group_by => [qw/ artist.name /] }
+);
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ 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' } }
+);
+
+cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" );
+
+$rs = $rs->search( undef, { having =>{ 'count(*)'=> \'> 2' }});
+
+cmp_ok( $rs->all, '==', 1, "count() ok after group_by on related column with a having" );
+
+$rs = $schema->resultset("Artist")->search(
+ { 'cds.title' => 'Spoonful of bees',
+ 'cds_2.title' => 'Forkful of bees' },
+ { join => [ 'cds', 'cds' ] });
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ cmp_ok($rs->count, '==', 1, "single artist returned from multi-join");
+}
+
+is($rs->next->name, 'Caterwauler McCrae', "Correct artist returned");
+
+$cd = $schema->resultset('Artist')->first->create_related('cds',
+ {
+ title => 'Unproduced Single',
+ year => 2007
+});
+
+my $left_join = $schema->resultset('CD')->search(
+ { 'me.cdid' => $cd->cdid },
+ { prefetch => { cd_to_producer => 'producer' } }
+);
+
+cmp_ok($left_join, '==', 1, 'prefetch with no join record present');
+
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+my $tree_like =
+ $schema->resultset('TreeLike')->find(4,
+ { join => { parent => { parent => 'parent' } },
+ prefetch => { parent => { parent => 'parent' } } });
+
+is($tree_like->name, 'quux', 'Bottom of tree ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'baz', 'First level up ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'bar', 'Second level up ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'foo', 'Third level up ok');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+cmp_ok($queries, '==', 1, 'Only one query run');
+
+$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 1});
+$tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first;
+is($tree_like->name, 'quux', 'Tree search_related ok');
+
+$tree_like = $schema->resultset('TreeLike')->search_related('children',
+ { 'children.id' => 2, 'children_2.id' => 3 },
+ { prefetch => { children => 'children' } }
+ )->first;
+is(eval { $tree_like->children->first->children->first->name }, 'quux',
+ 'Tree search_related with prefetch ok');
+
+$tree_like = eval { $schema->resultset('TreeLike')->search(
+ { 'children.id' => 2, 'children_2.id' => 5 },
+ { join => [qw/children children/] }
+ )->search_related('children', { 'children_4.id' => 6 }, { prefetch => 'children' }
+ )->first->children->first; };
+is(eval { $tree_like->name }, 'fong', 'Tree with multiple has_many joins ok');
+
+# test that collapsed joins don't get a _2 appended to the alias
+
+my $sql = '';
+$schema->storage->debugcb(sub { $sql = $_[1] });
+$schema->storage->debug(1);
+
+eval {
+ my $row = $schema->resultset('Artist')->search_related('cds', undef, {
+ join => 'tracks',
+ prefetch => 'tracks',
+ })->search_related('tracks')->first;
+};
+
+like( $sql, qr/^SELECT tracks_2\.trackid/, "join not collapsed for search_related" );
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+$rs = $schema->resultset('Artist');
+$rs->create({ artistid => 4, name => 'Unknown singer-songwriter' });
+$rs->create({ artistid => 5, name => 'Emo 4ever' });
+@artists = $rs->search(undef, { prefetch => 'cds', order_by => 'artistid' });
+is(scalar @artists, 5, 'has_many prefetch with adjacent empty rows ok');
+
+# -------------
+#
+# Tests for multilevel has_many prefetch
+
+# artist resultsets - with and without prefetch
+my $art_rs = $schema->resultset('Artist');
+my $art_rs_pr = $art_rs->search(
+ {},
+ {
+ join => [ { cds => ['tracks'] } ],
+ prefetch => [ { cds => ['tracks'] } ],
+ cache => 1 # last test needs this
+ }
+);
+
+# This test does the same operation twice - once on a
+# set of items fetched from the db with no prefetch of has_many rels
+# The second prefetches 2 levels of has_many
+# We check things are the same by comparing the name or title
+# we build everything into a hash structure and compare the one
+# from each rs to see what differs
+
+sub make_hash_struc {
+ my $rs = shift;
+
+ my $struc = {};
+ foreach my $art ( $rs->all ) {
+ foreach my $cd ( $art->cds ) {
+ foreach my $track ( $cd->tracks ) {
+ $struc->{ $art->name }{ $cd->title }{ $track->title }++;
+ }
+ }
+ }
+ return $struc;
+}
+
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+my $prefetch_result = make_hash_struc($art_rs_pr);
+
+is($queries, 1, 'nested prefetch across has_many->has_many ran exactly 1 query');
+
+my $nonpre_result = make_hash_struc($art_rs);
+
+is_deeply( $prefetch_result, $nonpre_result,
+ 'Compare 2 level prefetch result to non-prefetch result' );
+
+$queries = 0;
+
+is($art_rs_pr->search_related('cds')->search_related('tracks')->first->title,
+ 'Fowlin',
+ 'chained has_many->has_many search_related ok'
+ );
+
+is($queries, 0, 'chained search_related after has_many->has_many prefetch ran no queries');
+
+# once the following TODO is complete, remove the 2 stop-gap tests immediately after the TODO block
+# (the TODO block itself contains tests ensuring that the stop-gaps are removed)
+TODO: {
+ local $TODO = 'Prefetch of multiple has_many rels at the same level (currently must die to protect the clueless git)';
+ use DBIx::Class::ResultClass::HashRefInflator;
+
+ #( 1 -> M + M )
+ my $cd_rs = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' });
+ my $pr_cd_rs = $cd_rs->search ({}, {
+ prefetch => [qw/tracks tags/],
+ });
+
+ my $tracks_rs = $cd_rs->first->tracks;
+ my $tracks_count = $tracks_rs->count;
+
+ my ($pr_tracks_rs, $pr_tracks_count);
+
+ $queries = 0;
+ $schema->storage->debugcb(sub { $queries++ });
+ $schema->storage->debug(1);
+ eval {
+ $pr_tracks_rs = $pr_cd_rs->first->tracks;
+ $pr_tracks_count = $pr_tracks_rs->count;
+ };
+
+ my $o_mm_exc = $@;
+ ok(! $o_mm_exc, 'exception on attempt to prefetch several same level has_many\'s (1 -> M + M)');
+
+ SKIP: {
+ skip "1 -> M + M prefetch died", 3 if $o_mm_exc;
+
+ is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
+ is($pr_tracks_count, $tracks_count, 'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)');
+
+ for ($pr_tracks_rs, $tracks_rs) {
+ $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
+ }
+
+ is_deeply ([$pr_tracks_rs->all], [$tracks_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (1 -> M + M)');
+ };
+
+ #( M -> 1 -> M + M )
+ my $note_rs = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' });
+ my $pr_note_rs = $note_rs->search ({}, {
+ prefetch => {
+ cd => [qw/tags tracks/]
+ },
+ });
+
+ my $tags_rs = $note_rs->first->cd->tags;
+ my $tags_count = $tags_rs->count;
+
+ my ($pr_tags_rs, $pr_tags_count);
+
+ $queries = 0;
+ $schema->storage->debugcb(sub { $queries++ });
+ $schema->storage->debug(1);
+ eval {
+ $pr_tags_rs = $pr_note_rs->first->cd->tags;
+ $pr_tags_count = $pr_tags_rs->count;
+ };
+
+ my $m_o_mm_exc = $@;
+ ok(! $m_o_mm_exc, 'exception on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
+
+ SKIP: {
+ skip "M -> 1 -> M + M prefetch died", 3 if $m_o_mm_exc;
+
+ is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
+
+ is($pr_tags_count, $tags_count, 'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)');
+
+ for ($pr_tags_rs, $tags_rs) {
+ $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
+ }
+
+ is_deeply ([$pr_tags_rs->all], [$tags_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)');
+ };
+};
+
+eval { my $track = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' }, { prefetch => [qw/tracks tags/] })->first->tracks->first };
+ok ($@, 'exception on attempt to prefetch several same level has_many\'s (1 -> M + M)');
+eval { my $tag = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' }, { prefetch => { cd => [qw/tags tracks/] } })->first->cd->tags->first };
+ok ($@, 'exception on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
my $schema = DBICTest->init_schema();
-plan tests => 43;
+plan tests => 45;
# Check the defined unique constraints
is_deeply(
is($cd8->title, $cd1->title, 'title is correct');
is($cd8->year, $cd1->year, 'year is correct');
-my $cd9 = $artist->update_or_create_related('cds',
+my $cd9 = $artist->cds->update_or_create(
{
+ cdid => $cd1->cdid,
title => $title,
year => 2021,
},
},
{ key => 'foo_bar' }
);
+
ok(! $row->is_changed, 'update_or_create on table without primary key: row is clean');
is($row->foo, 1, 'foo is correct');
is($row->bar, 2, 'bar is correct');
is($row->baz, 3, 'baz is correct');
+
+# Test a unique condition with extra information in the where attr
+{
+ my $artist = $schema->resultset('Artist')->find({ artistid => 1 });
+ my $cd = $artist->cds->find_or_new(
+ {
+ cdid => 1,
+ title => 'Not The Real Title',
+ year => 3000,
+ },
+ { key => 'primary' }
+ );
+
+ ok($cd->in_storage, 'find correctly grepped the key across a relationship');
+ is($cd->cdid, 1, 'cdid is correct');
+}
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 39;
+plan tests => 63;
my $code = sub {
my ($artist, @cd_titles) = @_;
# 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;
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;
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) = @_;
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 {
# Test failed txn_do()
{
+
+ is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+
my $artist = $schema->resultset('Artist')->find(3);
eval {
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);
+
+ eval {
+ $schema->txn_do($fail_code, $artist);
+ };
+
+ my $error = $@;
+
+ like($error, 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';
- local *{"DBIx::Class::Storage::DBI::SQLite::txn_rollback"} = sub{die 'FAILED'};
+
+ # 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';
+ };
eval {
$schema->txn_do($fail_code, $artist);
year => 2005,
})->first;
ok(!defined($cd), q{deleted the failed txn's cd});
- $schema->storage->{transaction_depth} = 0; # Must reset this or further tests
- # will fail
+ $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) = @_;
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);
+ eval {
+ $schema2->txn_begin();
+ $schema2->txn_begin();
+ };
+ my $err = $@;
+ ok(($err eq ''), 'Pre-connection nested transactions.');
+ $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+/, "Error propogated okay";
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ my $inner_exception;
+ eval {
+ outer($schema, 1);
+ };
+ is($@, $inner_exception, "Nested exceptions propogated");
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+
+ eval {
+ # The 0 arg says done die, just let the scope guard go out of scope
+ # forcing a txn_rollback to happen
+ outer($schema, 0);
+ };
+ local $TODO = "Work out how this should work";
+ is($@, "Not sure what we want here, but something", "Rollback okay");
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ sub outer {
+ my ($schema) = @_;
+
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset('Artist')->create({
+ name => 'Death Cab for Cutie',
+ });
+ inner(@_);
+ $guard->commit;
+ }
+
+ sub inner {
+ my ($schema, $fatal) = @_;
+ my $guard = $schema->txn_scope_guard;
+
+ my $artist = $artist_rs->find({ name => 'Death Cab for Cutie' });
+
+ is($schema->storage->transaction_depth, 2, "Correct transaction depth");
+ undef $@;
+ 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 $@;
+ }
+
+ # See what happens if we dont $guard->commit;
+ }
+}
eval "use DBD::SQLite";
plan skip_all => 'needs DBD::SQLite for testing' if $@;
-plan tests => 22;
+plan tests => 23;
my $rs = $schema->resultset("Artist")->search(
{ artistid => 1 }
push @objs, $tag->id; #warn "tag: ", $tag->ID;
}
-is_deeply( \@objs, [ 2, 5, 8 ], 'second cd has correct tags' );
+is_deeply( \@objs, [ 1 ], 'second cd has correct tags' );
+
+$tags = $cds->next->tags;
+@objs = ();
+while( my $tag = $tags->next ) {
+ push @objs, $tag->id; #warn "tag: ", $tag->ID;
+}
+
+is_deeply( \@objs, [ 2, 5, 8 ], 'third cd has correct tags' );
is( $queries, 0, 'no additional SQL statements while checking nested data' );
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use Storable;
+use Storable qw(dclone freeze thaw);
my $schema = DBICTest->init_schema();
-plan tests => 1;
+my %stores = (
+ dclone_method => sub { return $schema->dclone($_[0]) },
+ dclone_func => sub { return dclone($_[0]) },
+ "freeze/thaw_method" => sub {
+ my $ice = $schema->freeze($_[0]);
+ return $schema->thaw($ice);
+ },
+ "freeze/thaw_func" => sub {
+ thaw(freeze($_[0]));
+ },
+);
-my $artist = $schema->resultset('Artist')->find(1);
-my $copy = eval { Storable::dclone($artist) };
-is_deeply($copy, $artist, 'serialize row object works');
+plan tests => (7 * keys %stores);
+for my $name (keys %stores) {
+ my $store = $stores{$name};
+
+ 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);
+ }
+
+ my $copy = eval { $store->($artist) };
+ is_deeply($copy, $artist, "serialize row object works: $name");
+
+ # Test that an object with a related_resultset can be serialized.
+ my @cds = $artist->related_resultset("cds");
+
+ ok $artist->{related_resultsets}, 'has key: related_resultsets';
+
+ $copy = eval { $store->($artist) };
+ for my $key (keys %$artist) {
+ next if $key eq 'related_resultsets';
+ next if $key eq '_inflated_column';
+ is_deeply($copy->{$key}, $artist->{$key},
+ qq[serialize with related_resultset "$key"]);
+ }
+
+ ok eval { $copy->discard_changes; 1 } or diag $@;
+ is($copy->id, $artist->id, "IDs still match ");
+}
my $schema = DBICTest->init_schema;
-plan tests => 53;
+plan tests => 130;
my $translator = SQL::Translator->new(
parser_args => {
my $output = $translator->translate();
+
+ok($output, "SQLT produced someoutput")
+ or diag($translator->error);
+
# Note that the constraints listed here are the only ones that are tested -- if
# more exist in the Schema than are listed here and all listed constraints are
# correct, the test will still pass. If you add a class with UNIQUE or FOREIGN
twokeys => [
{
'display' => 'twokeys->cd',
+ 'name' => 'twokeys_fk_cd', 'index_name' => 'twokeys_idx_cd',
'selftable' => 'twokeys', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => '', on_update => '',
+ 'noindex' => 1,
+ on_delete => '', on_update => '', deferrable => 0,
},
{
'display' => 'twokeys->artist',
+ 'name' => 'twokeys_fk_artist', 'index_name' => 'twokeys_idx_artist',
'selftable' => 'twokeys', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
fourkeys_to_twokeys => [
{
'display' => 'fourkeys_to_twokeys->twokeys',
+ 'name' => 'fourkeys_to_twokeys_fk_t_cd_t_artist', 'index_name' => 'fourkeys_to_twokeys_idx_t_cd_t_artist',
'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'twokeys',
'selfcols' => ['t_artist', 't_cd'], 'foreigncols' => ['artist', 'cd'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
- 'display' => 'fourkeys_to_twokeys->fourkeys',
+ 'display' => 'fourkeys_to_twokeys->fourkeys', 'index_name' => 'fourkeys_to_twokeys_idx_f_foo_f_goodbye_f_hello_f_bar',
+ 'name' => 'fourkeys_to_twokeys_fk_f_foo_f_goodbye_f_hello_f_bar',
'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'fourkeys',
'selfcols' => [qw(f_foo f_bar f_hello f_goodbye)],
'foreigncols' => [qw(foo bar hello goodbye)],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
cd_to_producer => [
{
'display' => 'cd_to_producer->cd',
+ 'name' => 'cd_to_producer_fk_cd', 'index_name' => 'cd_to_producer_idx_cd',
'selftable' => 'cd_to_producer', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ 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',
'selfcols' => ['producer'], 'foreigncols' => ['producerid'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
self_ref_alias => [
{
'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',
'selfcols' => ['self_ref'], 'foreigncols' => ['id'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ 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',
'selfcols' => ['alias'], 'foreigncols' => ['id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
cd => [
{
'display' => 'cd->artist',
+ 'name' => 'cd_fk_artist', 'index_name' => 'cd_idx_artist',
'selftable' => 'cd', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
artist_undirected_map => [
{
'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',
'selfcols' => ['id1'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => '',
+ on_delete => 'CASCADE', on_update => '', 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',
'selfcols' => ['id2'], 'foreigncols' => ['artistid'],
- on_delete => 'CASCADE', on_update => '',
+ on_delete => 'CASCADE', on_update => '', deferrable => 1,
},
],
track => [
{
'display' => 'track->cd',
+ 'name' => 'track_fk_cd', 'index_name' => 'track_idx_cd',
'selftable' => 'track', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
treelike => [
{
'display' => 'treelike->treelike for parent',
+ 'name' => 'treelike_fk_parent', 'index_name' => 'treelike_idx_parent',
'selftable' => 'treelike', 'foreigntable' => 'treelike',
'selfcols' => ['parent'], 'foreigncols' => ['id'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
twokeytreelike => [
{
'display' => 'twokeytreelike->twokeytreelike for parent1,parent2',
+ 'name' => 'twokeytreelike_fk_parent1_parent2', 'index_name' => 'twokeytreelike_idx_parent1_parent2',
'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike',
'selfcols' => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
},
],
tags => [
{
'display' => 'tags->cd',
+ 'name' => 'tags_fk_cd', 'index_name' => 'tags_idx_cd',
'selftable' => 'tags', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- on_delete => 'CASCADE', on_update => 'CASCADE',
+ on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
bookmark => [
{
'display' => 'bookmark->link',
+ 'name' => 'bookmark_fk_link', 'index_name' => 'bookmark_idx_link',
'selftable' => 'bookmark', 'foreigntable' => 'link',
'selfcols' => ['link'], 'foreigncols' => ['id'],
- on_delete => '', on_update => '',
+ on_delete => '', on_update => '', deferrable => 1,
+ },
+ ],
+ # ForceForeign
+ forceforeign => [
+ {
+ 'display' => 'forceforeign->artist',
+ 'name' => 'forceforeign_fk_artist', 'index_name' => 'forceforeign_idx_artist',
+ 'selftable' => 'forceforeign', 'foreigntable' => 'artist',
+ 'selfcols' => ['artist'], 'foreigncols' => ['artist_id'],
+ on_delete => '', on_update => '', deferrable => 1,
},
],
+
);
my %unique_constraints = (
cd => [
{
'display' => 'cd artist and title unique',
+ 'name' => 'cd_artist_title',
'table' => 'cd', 'cols' => ['artist', 'title'],
},
],
producer => [
{
'display' => 'producer name unique',
+ 'name' => 'prod_name', # explicit name
'table' => 'producer', 'cols' => ['name'],
},
],
twokeytreelike => [
{
'display' => 'twokeytreelike name unique',
+ 'name' => 'tktlnameunique', # explicit name
'table' => 'twokeytreelike', 'cols' => ['name'],
},
],
# employee => [
# {
# 'display' => 'employee position and group_id unique',
+# 'name' => 'position_group',
# 'table' => 'employee', cols => ['position', 'group_id'],
# },
# ],
);
+my %indexes = (
+ artist => [
+ {
+ 'fields' => ['name']
+ },
+ ]
+);
+
my $tschema = $translator->schema();
+# Test that the $schema->sqlt_deploy_hook was called okay and that it removed
+# the 'dummy' table
+ok( !defined($tschema->get_table('dummy')), "Dummy table was removed by hook");
# Test that nonexistent constraints are not found
my $constraint = get_constraint('FOREIGN KEY', 'cd', ['title'], 'cd', ['year']);
ok( !defined($constraint), 'nonexistent FOREIGN KEY constraint not found' );
$constraint = get_constraint('UNIQUE', 'cd', ['artist']);
ok( !defined($constraint), 'nonexistent UNIQUE constraint not found' );
+$constraint = get_constraint('FOREIGN KEY', 'forceforeign', ['cd'], 'cd', ['cdid']);
+ok( !defined($constraint), 'forced nonexistent FOREIGN KEY constraint not found' );
for my $expected_constraints (keys %fk_constraints) {
for my $expected_constraint (@{ $fk_constraints{$expected_constraints} }) {
'UNIQUE', $expected_constraint->{table}, $expected_constraint->{cols},
);
ok( defined($constraint), "UNIQUE constraint matching `$desc' found" );
+ test_unique($expected_constraint, $constraint);
+ }
+}
+
+for my $table_index (keys %indexes) {
+ for my $expected_index ( @{ $indexes{$table_index} } ) {
+
+ ok ( get_index($table_index, $expected_index), "Got a matching index on $table_index table");
}
}
my %fields = map { $_ => 1 } @$cols;
my %f_fields = map { $_ => 1 } @$f_cols;
+ die "No $table_name" unless $table;
CONSTRAINT:
for my $constraint ( $table->get_constraints ) {
next unless $constraint->type eq $type;
return undef; # didn't find a matching constraint
}
+sub get_index {
+ my ($table_name, $index) = @_;
+
+ my $table = $tschema->get_table($table_name);
+
+ 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};
+
+ my %idx_fields = map { $_ => 1 } $cand_index->fields;
+
+ for my $field ( @{ $index->{fields} } ) {
+ next CAND_INDEX unless $idx_fields{$field};
+ }
+
+ %idx_fields = map { $_ => 1 } @{$index->{fields}};
+ for my $field ( $cand_index->fields) {
+ next CAND_INDEX unless $idx_fields{$field};
+ }
+
+ return $cand_index;
+ }
+
+ return undef; # No matching idx
+}
+
# Test parameters in a FOREIGN KEY constraint other than columns
sub test_fk {
my ($expected, $got) = @_;
my $desc = $expected->{display};
+ is( $got->name, $expected->{name},
+ "name parameter correct for `$desc'" );
is( $got->on_delete, $expected->{on_delete},
"on_delete parameter correct for `$desc'" );
is( $got->on_update, $expected->{on_update},
"on_update parameter correct for `$desc'" );
+ is( $got->deferrable, $expected->{deferrable},
+ "is_deferrable parameter correct for `$desc'" );
+
+ my $index = get_index( $got->table, { fields => $expected->{selfcols} } );
+
+ if ($expected->{noindex}) {
+ ok( !defined $index, "index doesn't for `$desc'" );
+ } else {
+ ok( defined $index, "index exists for `$desc'" );
+ is( $index->name, $expected->{index_name}, "index has correct name for `$desc'" );
+ }
+}
+
+sub test_unique {
+ my ($expected, $got) = @_;
+ my $desc = $expected->{display};
+ is( $got->name, $expected->{name},
+ "name parameter correct for `$desc'" );
}
use lib qw(t/lib);
use DBICTest;
+use POSIX qw(ceil);
+
my $schema = DBICTest->init_schema();
-plan tests => 321;
+plan tests => 879;
my $employees = $schema->resultset('Employee');
$employees->delete();
DBICTest::Employee->grouping_column('group_id');
$employees->delete();
-foreach my $group_id (1..3) {
+foreach my $group_id (1..4) {
foreach (1..6) {
$employees->create({ name=>'temp', group_id=>$group_id });
}
}
$employees = $employees->search(undef,{order_by=>'group_id,position'});
-foreach my $group_id (1..3) {
+foreach my $group_id (1..4) {
my $group_employees = $employees->search({group_id=>$group_id});
$group_employees->all();
ok( check_rs($group_employees), "group intial positions" );
hammer_rs( $group_employees );
}
+my $group_3 = $employees->search({group_id=>3});
+my $to_group = 1;
+my $to_pos = undef;
+while (my $employee = $group_3->next) {
+ $employee->move_to_group($to_group, $to_pos);
+ $to_pos++;
+ $to_group = $to_group==1 ? 2 : 1;
+}
+foreach my $group_id (1..4) {
+ my $group_employees = $employees->search({group_id=>$group_id});
+ $group_employees->all();
+ ok( check_rs($group_employees), "group positions after move_to_group" );
+}
+
+my $employee = $employees->search({group_id=>4})->first;
+$employee->position(2);
+$employee->update;
+ok( check_rs($employees->search_rs({group_id=>4})), "overloaded update 1" );
+$employee = $employees->search({group_id=>4})->first;
+$employee->update({position=>3});
+ok( check_rs($employees->search_rs({group_id=>4})), "overloaded update 2" );
+$employee = $employees->search({group_id=>4})->first;
+$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"
+);
+$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"
+);
+$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"
+);
+$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"
+);
+$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"
+);
+
+# multicol tests begin here
+DBICTest::Employee->grouping_column(['group_id', 'group_id_2']);
+$employees->delete();
+foreach my $group_id (1..4) {
+ foreach my $group_id_2 (1..4) {
+ foreach (1..4) {
+ $employees->create({ name=>'temp', group_id=>$group_id, group_id_2=>$group_id_2 });
+ }
+ }
+}
+$employees = $employees->search(undef,{order_by=>'group_id,group_id_2,position'});
+
+foreach my $group_id (1..3) {
+ foreach my $group_id_2 (1..3) {
+ my $group_employees = $employees->search({group_id=>$group_id, group_id_2=>$group_id_2});
+ $group_employees->all();
+ ok( check_rs($group_employees), "group intial positions" );
+ hammer_rs( $group_employees );
+ }
+}
+
+# move_to_group, specifying group by hash
+my $group_4 = $employees->search({group_id=>4});
+$to_group = 1;
+my $to_group_2_base = 7;
+my $to_group_2 = 1;
+$to_pos = undef;
+while (my $employee = $group_4->next) {
+ $employee->move_to_group({group_id=>$to_group, group_id_2=>$to_group_2}, $to_pos);
+ $to_pos++;
+ $to_group = ($to_group % 3) + 1;
+ $to_group_2_base++;
+ $to_group_2 = (ceil($to_group_2_base/3.0) %3) +1
+}
+foreach my $group_id (1..4) {
+ foreach my $group_id_2 (1..4) {
+ my $group_employees = $employees->search({group_id=>$group_id,group_id_2=>$group_id_2});
+ $group_employees->all();
+ ok( check_rs($group_employees), "group positions after move_to_group" );
+ }
+}
+
+$employees->delete();
+foreach my $group_id (1..4) {
+ foreach my $group_id_2 (1..4) {
+ foreach (1..4) {
+ $employees->create({ name=>'temp', group_id=>$group_id, group_id_2=>$group_id_2 });
+ }
+ }
+}
+$employees = $employees->search(undef,{order_by=>'group_id,group_id_2,position'});
+
+$employee = $employees->search({group_id=>4, group_id_2=>1})->first;
+$employee->group_id(1);
+$employee->update;
+ok(
+ check_rs($employees->search_rs({group_id=>4, group_id_2=>1}))
+ && check_rs($employees->search_rs({group_id=>1, group_id_2=>1})),
+ "overloaded multicol update 1"
+);
+
+$employee = $employees->search({group_id=>4, group_id_2=>1})->first;
+$employee->update({group_id=>2});
+ok( check_rs($employees->search_rs({group_id=>4, group_id_2=>1}))
+ && check_rs($employees->search_rs({group_id=>2, group_id_2=>1})),
+ "overloaded multicol update 2"
+);
+
+$employee = $employees->search({group_id=>3, group_id_2=>1})->first;
+$employee->group_id(1);
+$employee->group_id_2(3);
+$employee->update();
+ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>1}))
+ && check_rs($employees->search_rs({group_id=>1, group_id_2=>3})),
+ "overloaded multicol update 3"
+);
+
+$employee = $employees->search({group_id=>3, group_id_2=>1})->first;
+$employee->update({group_id=>2, group_id_2=>3});
+ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>1}))
+ && check_rs($employees->search_rs({group_id=>2, group_id_2=>3})),
+ "overloaded multicol update 4"
+);
+
+$employee = $employees->search({group_id=>3, group_id_2=>2})->first;
+$employee->update({group_id=>2, group_id_2=>4, position=>2});
+ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>2}))
+ && check_rs($employees->search_rs({group_id=>2, group_id_2=>4})),
+ "overloaded multicol update 5"
+);
+
sub hammer_rs {
my $rs = shift;
my $employee;
my $schema = DBICTest->init_schema();
-plan tests => 8;
+plan tests => 10;
my $cd;
my $rs = $cd = $schema->resultset("CD")->search({});
is($rs_title->next, 'Spoonful of bees', "next okay");
+is_deeply( [ sort $rs_year->func('DISTINCT') ], [ 1997, 1998, 1999, 2001 ], "wantarray context okay");
+
my @all = $rs_title->all;
cmp_ok(scalar @all, '==', 5, "five titles returned");
ok(defined($psrs->get_column('count')), '+select/+as arrayref count');
ok(defined($psrs->get_column('addedtitle')), '+select/+as title');
+{
+ my $rs = $schema->resultset("CD")->search({}, { prefetch => 'artist' });
+ my $rsc = $rs->get_column('year');
+ is( $rsc->{_parent_resultset}->{attrs}->{prefetch}, undef, 'prefetch wiped' );
+}
my $schema = DBICTest->init_schema();
-eval 'require JSON';
-plan skip_all => 'Install JSON to run this test' if ($@);
+eval 'require JSON::Any';
+plan skip_all => 'Install JSON::Any to run this test' if ($@);
eval 'require Text::CSV_XS';
if ($@) {
plan tests => 5;
-# double quotes round the arguments and single-quote within to make sure the
-# tests run on windows as well
+# the script supports double quotes round the arguments and single-quote within
+# to make sure it runs on windows as well, but only if JSON::Any picks the right module
+
+
my $employees = $schema->resultset('Employee');
-my $cmd = qq|$^X script/dbicadmin --schema=DBICTest::Schema --class=Employee --tlibs --connect="['dbi:SQLite:dbname=t/var/DBIxClass.db','','']" --force --tlibs|;
+my @cmd = ($^X, qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee --tlibs|, q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|, qw|--force --tlibs|);
-`$cmd --op=insert --set="{name:'Matt'}"`;
+system(@cmd, qw|--op=insert --set={"name":"Matt"}|);
ok( ($employees->count()==1), 'insert count' );
my $employee = $employees->find(1);
ok( ($employee->name() eq 'Matt'), 'insert valid' );
-`$cmd --op=update --set="{name:'Trout'}"`;
+system(@cmd, qw|--op=update --set={"name":"Trout"}|);
$employee = $employees->find(1);
ok( ($employee->name() eq 'Trout'), 'update' );
-`$cmd --op=insert --set="{name:'Aran'}"`;
-my $data = `$cmd --op=select --attrs="{order_by:'name'}"`;
+system(@cmd, qw|--op=insert --set={"name":"Aran"}|);
+
+open(my $fh, "-|", @cmd, qw|--op=select --attrs={"order_by":"name"}|) or die $!;
+my $data = do { local $/; <$fh> };
+close($fh);
ok( ($data=~/Aran.*Trout/s), 'select with attrs' );
-`$cmd --op=delete --where="{name:'Trout'}"`;
+system(@cmd, qw|--op=delete --where={"name":"Trout"}|);
ok( ($employees->count()==1), 'delete' );
eval { require DateTime::Format::MySQL };
plan skip_all => "Need DateTime::Format::MySQL for inflation tests" if $@;
-plan tests => 8;
+plan tests => 17;
# inflation test
my $event = $schema->resultset("Event")->find(1);
isa_ok($created->created_on, 'DateTime', 'DateTime returned');
is("$created_cron", '2006-06-23T00:00:00', 'Correct date/time');
+
+
+# Test "timezone" parameter
+my $event_tz = $schema->resultset('EventTZ')->create({
+ starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ),
+ created_on => DateTime->new(year=>2006, month=>1, day=>31,
+ hour => 13, minute => 34, second => 56, time_zone => "America/New_York" ),
+});
+
+my $starts_at = $event_tz->starts_at;
+is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone');
+
+my $created_on = $event_tz->created_on;
+is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using timezone');
+is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct timezone");
+
+my $loaded_event = $schema->resultset('EventTZ')->find( $event_tz->id );
+
+isa_ok($loaded_event->starts_at, 'DateTime', 'DateTime returned');
+$starts_at = $loaded_event->starts_at;
+is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using timezone');
+is($starts_at->time_zone->name, 'America/Chicago', 'Correct timezone');
+
+isa_ok($loaded_event->created_on, 'DateTime', 'DateTime returned');
+$created_on = $loaded_event->created_on;
+is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone');
+is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone');
+
my $schema = DBICTest->init_schema();
-plan tests => 19;
+plan tests => 20;
# Test ensure_class_found
ok( $schema->ensure_class_found('DBIx::Class::Schema'),
'load_optional_class(DBICTest::SyntaxErrorComponent2) threw ok' );
}
+
+eval {
+ package Fake::ResultSet;
+
+ use base 'DBIx::Class::ResultSet';
+
+ __PACKAGE__->load_components('+DBICTest::SyntaxErrorComponent3');
+};
+
+# Make sure the errors in components of resultset classes are reported right.
+like($@, qr!\Qsyntax error at t/lib/DBICTest/SyntaxErrorComponent3.pm!, "Errors from RS components reported right");
+
1;
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use Data::Dumper;
my $schema = DBICTest->init_schema();
-plan tests => 19;
+plan tests => 22;
+
+ {
+ my $rs = $schema->resultset( 'CD' )->search(
+ {
+ 'producer.name' => 'blah',
+ 'producer_2.name' => 'foo',
+ },
+ {
+ 'join' => [
+ { cd_to_producer => 'producer' },
+ { cd_to_producer => 'producer' },
+ ],
+ 'prefetch' => [
+ 'artist',
+ { cd_to_producer => 'producer' },
+ ],
+ }
+ );
+
+ eval {
+ my @rows = $rs->all();
+ };
+ is( $@, '' );
+ }
+
my @rs1a_results = $schema->resultset("Artist")->search_related('cds', {title => 'Forkful of bees'}, {order_by => 'title'});
is($rs1a_results[0]->title, 'Forkful of bees', "bare field conditions okay after search related");
my $rs1 = $schema->resultset("Artist")->search({ 'tags.tag' => 'Blue' }, { join => {'cds' => 'tracks'}, prefetch => {'cds' => 'tags'} });
my @artists = $rs1->all;
-cmp_ok(@artists, '==', 1, "Two artists returned");
+cmp_ok(@artists, '==', 2, "Two artists returned");
my $rs2 = $rs1->search({ artistid => '1' }, { join => {'cds' => {'cd_to_producer' => 'producer'} } });
-
my @artists2 = $rs2->search({ 'producer.name' => 'Matt S Trout' });
my @cds = $artists2[0]->cds;
cmp_ok(scalar @cds, '==', 1, "condition based on inherited join okay");
-#this is wrong, should accept me.title really
my $rs3 = $rs2->search_related('cds');
-cmp_ok(scalar($rs3->all), '==', 27, "All cds for artist returned");
-cmp_ok($rs3->count, '==', 27, "All cds for artist returned via count");
+cmp_ok(scalar($rs3->all), '==', 45, "All cds for artist returned");
+
+
+cmp_ok($rs3->count, '==', 45, "All cds for artist returned via count");
my $rs4 = $schema->resultset("CD")->search({ 'artist.artistid' => '1' }, { join => ['tracks', 'artist'], prefetch => 'artist' });
my @rs4_results = $rs4->all;
ok(!$@, "pathological prefetch ok");
+my $rs = $schema->resultset("Artist")->search({}, { join => 'twokeys' });
+my $second_search_rs = $rs->search({ 'cds_2.cdid' => '2' }, { join =>
+['cds', 'cds'] });
+is(scalar(@{$second_search_rs->{attrs}->{join}}), 3, 'both joins kept');
+ok($second_search_rs->next, 'query on double joined rel runs okay');
+
1;
my $schema = DBICTest->init_schema();
-plan tests => 2;
+plan tests => 6;
ok ( $schema->storage->debug(1), 'debug' );
ok ( defined(
'debugfh'
);
+$schema->storage->debugfh->autoflush(1);
+my $rs = $schema->resultset('CD')->search({});
+$rs->count();
+
+my $log = new IO::File('t/var/sql.log', 'r') or die($!);
+my $line = <$log>;
+$log->close();
+ok($line =~ /^SELECT COUNT/, 'Log success');
+
+$schema->storage->debugfh(undef);
+$ENV{'DBIC_TRACE'} = '=t/var/foo.log';
+$rs = $schema->resultset('CD')->search({});
+$rs->count();
+$log = new IO::File('t/var/foo.log', 'r') or die($!);
+$line = <$log>;
+$log->close();
+ok($line =~ /^SELECT COUNT/, 'Log success');
+$schema->storage->debugobj->debugfh(undef);
+delete($ENV{'DBIC_TRACE'});
+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');
+open(STDERR, '>&STDERRCOPY');
+
+# test trace output correctness for bind params
+{
+ my $sql = '';
+ $schema->storage->debugcb( sub { $sql = $_[1] } );
+
+ my @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
+ like(
+ $sql,
+ qr/\QSELECT me.cdid, me.artist, me.title, me.year FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? ): '1', '1', '3'\E/,
+ 'got correct SQL with all bind parameters'
+ );
+}
+
1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use Test::More;
+
+plan tests => 15;
+
+my $schema = DBICTest->init_schema();
+my $rs = $schema->resultset( 'CD' );
+
+{
+ my $a = 'artist';
+ my $b = 'cd';
+ my $expected = [ 'artist', 'cd' ];
+ my $result = $rs->_merge_attr($a, $b);
+ is_deeply( $result, $expected );
+}
+
+{
+ my $a = [ 'artist' ];
+ my $b = [ 'cd' ];
+ my $expected = [ 'artist', 'cd' ];
+ my $result = $rs->_merge_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);
+ is_deeply( $result, $expected );
+}
+
+{
+ my $a = [ 'artist', 'artist' ];
+ my $b = [ 'artist', 'cd' ];
+ my $expected = [ 'artist', 'artist', 'cd' ];
+ my $result = $rs->_merge_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);
+ is_deeply( $result, $expected );
+}
+
+{
+ my $a = [ 'twokeys' ];
+ my $b = [ 'cds', 'cds' ];
+ my $expected = [ 'twokeys', 'cds', 'cds' ];
+ my $result = $rs->_merge_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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ is_deeply( $result, $expected );
+}
+
+
+1;
use lib qw(t/lib);
use DBICTest;
-plan tests => 1;
+{
+ package DBICTest::ExplodingStorage::Sth;
+ use strict;
+ use warnings;
+
+ sub execute { die "Kablammo!" }
+
+ sub bind_param {}
+
+ package DBICTest::ExplodingStorage;
+ use strict;
+ use warnings;
+ use base 'DBIx::Class::Storage::DBI::SQLite';
+
+ my $count = 0;
+ sub sth {
+ my ($self, $sql) = @_;
+ return bless {}, "DBICTest::ExplodingStorage::Sth" unless $count++;
+ return $self->next::method($sql);
+ }
+
+ sub connected {
+ return 0 if $count == 1;
+ return shift->next::method(@_);
+ }
+}
+
+plan tests => 6;
my $schema = DBICTest->init_schema();
is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' );
+my $storage = $schema->storage;
+$storage->ensure_connected;
+
+eval {
+ $schema->storage->throw_exception('test_exception_42');
+};
+like($@, qr/\btest_exception_42\b/, 'basic exception');
+
+eval {
+ $schema->resultset('CD')->search_literal('broken +%$#$1')->all;
+};
+like($@, qr/prepare_cached failed/, 'exception via DBI->HandleError, etc');
+
+bless $storage, "DBICTest::ExplodingStorage";
+$schema->storage($storage);
+
+eval {
+ $schema->resultset('Artist')->create({ name => "Exploding Sheep" });
+};
+
+is($@, "", "Exploding \$sth->execute was caught");
+
+is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count,
+ "And the STH was retired");
+
+my $info = { on_connect_do => [] };
+
+$storage->connect_info(['foo','bar','baz',$info]);
+
+ok(exists($info->{on_connect_do}), q{Didn't kill key passed to storage});
+
1;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+
+use lib qw(t/lib);
+use base 'DBICTest';
+
+
+my $schema = DBICTest->init_schema(
+ no_connect => 1,
+ no_deploy => 1,
+);
+ok $schema->connection(
+ DBICTest->_database,
+ {
+ on_connect_do => [
+ 'CREATE TABLE TEST_empty (id INTEGER)',
+ [ 'INSERT INTO TEST_empty VALUES (?)', {}, 2 ],
+ \&insert_from_subref,
+ ],
+ on_disconnect_do =>
+ [\&check_exists, 'DROP TABLE TEST_empty', \&check_dropped],
+ },
+), 'connection()';
+
+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';
+
+$schema->storage->disconnect();
+
+my($connected, $disconnected);
+ok $schema->connection(
+ DBICTest->_database,
+ {
+ on_connect_do => sub { $connected = 1 },
+ on_disconnect_do => sub { $disconnected = 1 },
+ },
+), 'second connection()';
+$schema->storage->dbh->do('SELECT 1');
+ok $connected, 'on_connect_do() called after connect()';
+ok ! $disconnected, 'on_disconnect_do() not called after connect()';
+$schema->storage->disconnect();
+ok $disconnected, 'on_disconnect_do() called after disconnect()';
+
+
+sub check_exists {
+ my $storage = shift;
+ ok $storage->dbh->do('SELECT 1 FROM TEST_empty'), 'Table still exists';
+ return;
+}
+
+sub check_dropped {
+ my $storage = shift;
+ eval { $storage->dbh->do('SELECT 1 FROM TEST_empty'); };
+ ok $@, 'Reading from dropped table fails';
+ return;
+}
+
+sub insert_from_subref {
+ my $storage = shift;
+ return [
+ [ 'INSERT INTO TEST_empty VALUES (?)', {}, 3 ],
+ 'INSERT INTO TEST_empty VALUES (7)',
+ ];
+}
{ # Fake storage driver for mysql + no bind variables
package DBIx::Class::Storage::DBI::MySQLNoBindVars;
+ use Class::C3;
use base qw/
- DBIx::Class::Storage::DBI::mysql
DBIx::Class::Storage::DBI::NoBindVars
+ DBIx::Class::Storage::DBI::mysql
/;
$INC{'DBIx/Class/Storage/DBI/MySQLNoBindVars.pm'} = 1;
}
-DBICTest::Schema->storage(undef); # just in case?
-DBICTest::Schema->storage_type('::DBI::MySQLNoBindVars');
-DBICTest::Schema->compose_namespace('MySQLTest' => $dsn, $user, $pass);
+# 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 = MySQLTest->schema->storage->dbh;
+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(255), charfield CHAR(10));");
-#'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', '');
-
-MySQLTest::Artist->load_components('PK::Auto');
+$schema->class('Artist')->load_components('PK::Auto');
# test primary key handling
-my $new = MySQLTest::Artist->create({ name => 'foo' });
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
ok($new->artistid, "Auto-PK worked");
# test LIMIT support
for (1..6) {
- MySQLTest::Artist->create({ name => 'Artist ' . $_ });
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
}
-my $it = MySQLTest::Artist->search( {},
+my $it = $schema->resultset('Artist')->search( {},
{ rows => 3,
offset => 2,
order_by => 'artistid' }
is( $it->next, undef, "next past end of resultset ok" );
# clean up our mess
-$dbh->do("DROP TABLE artist");
+END {
+ $dbh->do("DROP TABLE artist") if $dbh;
+}
--- /dev/null
+use strict;
+use warnings;
+use lib qw(t/lib);
+use Test::More;
+
+BEGIN {
+ eval "use DBD::Multi";
+ plan $@
+ ? ( skip_all => 'needs DBD::Multi for testing' )
+ : ( tests => 20 );
+}
+
+## ----------------------------------------------------------------------------
+## Build a class to hold all our required testing data and methods.
+## ----------------------------------------------------------------------------
+
+TESTSCHEMACLASS: {
+
+ package DBIx::Class::DBI::Replicated::TestReplication;
+
+ use DBI;
+ use DBICTest;
+ use File::Copy;
+
+ ## Create a constructor
+
+ sub new {
+ my $class = shift @_;
+ my %params = @_;
+
+ my $self = bless {
+ db_paths => $params{db_paths},
+ dsns => $class->init_dsns(%params),
+ schema=>$class->init_schema,
+ }, $class;
+
+ $self->connect;
+ return $self;
+ }
+
+ ## get the DSNs. We build this up from the list of file paths
+
+ sub init_dsns {
+ my $class = shift @_;
+ my %params = @_;
+ my $db_paths = $params{db_paths};
+
+ my @dsn = map {
+ "dbi:SQLite:${_}";
+ } @$db_paths;
+
+ return \@dsn;
+ }
+
+ ## get the Schema and set the replication storage type
+
+ sub init_schema {
+ my $class = shift @_;
+ my $schema = DBICTest->init_schema();
+ $schema->storage_type( '::DBI::Replicated' );
+
+ return $schema;
+ }
+
+ ## connect the Schema
+
+ sub connect {
+ my $self = shift @_;
+ my ($master, @slaves) = @{$self->{dsns}};
+ my $master_connect_info = [$master, '','', {AutoCommit=>1, PrintError=>0}];
+
+ my @slavesob;
+ foreach my $slave (@slaves)
+ {
+ my $dbh = shift @{$self->{slaves}}
+ || DBI->connect($slave,"","",{PrintError=>0, PrintWarn=>0});
+
+ push @{$master_connect_info->[-1]->{slaves_connect_info}},
+ [$dbh, '','',{priority=>10}];
+
+ push @slavesob,
+ $dbh;
+ }
+
+ ## Keep track of the created slave databases
+ $self->{slaves} = \@slavesob;
+
+ $self
+ ->{schema}
+ ->connect(@$master_connect_info);
+ }
+
+ ## replication
+
+ sub replicate {
+ my $self = shift @_;
+ my ($master, @slaves) = @{$self->{db_paths}};
+
+ foreach my $slave (@slaves) {
+ copy($master, $slave);
+ }
+ }
+
+ ## Cleanup afer ourselves.
+
+ sub cleanup {
+ my $self = shift @_;
+ my ($master, @slaves) = @{$self->{db_paths}};
+
+ foreach my $slave (@slaves) {
+ unlink $slave;
+ }
+ }
+
+ ## Force a reconnection
+
+ sub reconnect {
+ my $self = shift @_;
+ my $schema = $self->connect;
+ $self->{schema} = $schema;
+ return $schema;
+ }
+}
+
+## ----------------------------------------------------------------------------
+## Create an object and run some tests
+## ----------------------------------------------------------------------------
+
+my %params = (
+ db_paths => [
+ "t/var/DBIxClass.db",
+ "t/var/DBIxClass_slave1.db",
+ "t/var/DBIxClass_slave2.db",
+ ],
+);
+
+ok my $replicate = DBIx::Class::DBI::Replicated::TestReplication->new(%params)
+ => 'Created a replication object';
+
+isa_ok $replicate->{schema}
+ => 'DBIx::Class::Schema';
+
+## Add some info to the database
+
+$replicate
+ ->{schema}
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 4, "Ozric Tentacles"],
+ ]);
+
+## Make sure all the slaves have the table definitions
+
+$replicate->replicate;
+
+## Make sure we can read the data.
+
+ok my $artist1 = $replicate->{schema}->resultset('Artist')->find(4)
+ => 'Created Result';
+
+isa_ok $artist1
+ => 'DBICTest::Artist';
+
+is $artist1->name, 'Ozric Tentacles'
+ => 'Found expected name for first result';
+
+## Add some new rows that only the master will have This is because
+## we overload any type of write operation so that is must hit the master
+## database.
+
+$replicate
+ ->{schema}
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 5, "Doom's Children"],
+ [ 6, "Dead On Arrival"],
+ [ 7, "Watergate"],
+ ]);
+
+## Reconnect the database
+$replicate->reconnect;
+
+## Alright, the database 'cluster' is not in a consistent state. When we do
+## a read now we expect bad news
+
+is $replicate->{schema}->resultset('Artist')->find(5), undef
+ => 'read after disconnect fails because it uses slave 1 which we have neglected to "replicate" yet';
+
+## Make sure all the slaves have the table definitions
+$replicate->replicate;
+
+## Should find some data now
+
+ok my $artist2 = $replicate->{schema}->resultset('Artist')->find(5)
+ => 'Sync succeed';
+
+isa_ok $artist2
+ => 'DBICTest::Artist';
+
+is $artist2->name, "Doom's Children"
+ => 'Found expected name for first result';
+
+## What happens when we delete one of the slaves?
+
+ok my $slave1 = @{$replicate->{slaves}}[0]
+ => 'Got Slave1';
+
+ok $slave1->disconnect
+ => 'disconnected slave1';
+
+$replicate->reconnect;
+
+ok my $artist3 = $replicate->{schema}->resultset('Artist')->find(6)
+ => 'Still finding stuff.';
+
+isa_ok $artist3
+ => 'DBICTest::Artist';
+
+is $artist3->name, "Dead On Arrival"
+ => 'Found expected name for first result';
+
+## Let's delete all the slaves
+
+ok my $slave2 = @{$replicate->{slaves}}[1]
+ => 'Got Slave2';
+
+ok $slave2->disconnect
+ => 'Disconnected slave2';
+
+$replicate->reconnect;
+
+## We expect an error now, since all the slaves are dead
+
+eval {
+ $replicate->{schema}->resultset('Artist')->find(4)->name;
+};
+
+ok $@ => 'Got error when trying to find artistid 4';
+
+## This should also be an error
+
+eval {
+ my $artist4 = $replicate->{schema}->resultset('Artist')->find(7);
+};
+
+ok $@ => 'Got read errors after everything failed';
+
+## make sure ->connect_info returns something sane
+
+ok $replicate->{schema}->storage->connect_info
+ => 'got something out of ->connect_info';
+
+## Force a connection to the write source for testing.
+
+$replicate->{schema}->storage($replicate->{schema}->storage->write_source);
+
+## What happens when we do a find for something that doesn't exist?
+
+ok ! $replicate->{schema}->resultset('Artist')->find(666)
+ => 'Correctly did not find a bad artist id';
+
+## Delete the old database files
+$replicate->cleanup;
+
+
+
+
+
+
my $schema = DBICTest->init_schema();
-plan tests => 5;
+plan tests => 10;
my $old_artistid = 1;
my $new_artistid = $schema->resultset("Artist")->get_column('artistid')->max + 1;
ok(defined $artist, 'found an artist with the new PK');
is($artist->artistid, $new_artistid, 'artist ID matches');
}
+
+# Do it all over again, using a different methodology:
+$old_artistid = $new_artistid;
+$new_artistid++;
+
+# Update the PK
+{
+ my $artist = $schema->resultset("Artist")->find($old_artistid);
+ ok(defined $artist, 'found an artist with the new PK');
+
+ $artist->artistid($new_artistid);
+ $artist->update;
+ is($artist->artistid, $new_artistid, 'artist ID matches');
+}
+
+# Look for the old PK
+{
+ my $artist = $schema->resultset("Artist")->find($old_artistid);
+ ok(!defined $artist, 'no artist found with the old PK');
+}
+
+# Look for the new PK
+{
+ my $artist = $schema->resultset("Artist")->find($new_artistid);
+ ok(defined $artist, 'found an artist with the new PK');
+ is($artist->artistid, $new_artistid, 'artist ID matches');
+}
use strict;
use warnings;
use Test::More;
+use File::Spec;
+use File::Copy;
+
+#warn "$dsn $user $pass";
+my ($dsn, $user, $pass);
BEGIN {
- eval "use DBD::SQLite; use SQL::Translator;";
+ ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
+
+ plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
+ unless ($dsn);
+
+
+ eval "use DBD::mysql; use SQL::Translator 0.09;";
plan $@
- ? ( skip_all => 'needs DBD::SQLite and SQL::Translator for testing' )
- : ( tests => 6 );
+ ? ( skip_all => 'needs DBD::mysql and SQL::Translator 0.09 for testing' )
+ : ( tests => 17 );
}
-use lib qw(t/lib);
+my $version_table_name = 'dbix_class_schema_versions';
+my $old_table_name = 'SchemaVersions';
+use lib qw(t/lib);
use_ok('DBICVersionOrig');
-my $db_file = "t/var/versioning.db";
-unlink($db_file) if -e $db_file;
-unlink($db_file . "-journal") if -e $db_file . "-journal";
-mkdir("t/var") unless -d "t/var";
-unlink('t/var/DBICVersion-Schema-1.0-SQLite.sql');
+my $schema_orig = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
+eval { $schema_orig->storage->dbh->do('drop table ' . $version_table_name) };
+eval { $schema_orig->storage->dbh->do('drop table ' . $old_table_name) };
-my $schema_orig = DBICVersion::Schema->connect("dbi:SQLite:$db_file");
-# $schema->storage->ensure_connected();
+is($schema_orig->ddl_filename('MySQL', '1.0', 't/var'), File::Spec->catfile('t', 'var', 'DBICVersion-Schema-1.0-MySQL.sql'), 'Filename creation working');
+unlink('t/var/DBICVersion-Schema-1.0-MySQL.sql') if (-e 't/var/DBICVersion-Schema-1.0-MySQL.sql');
+$schema_orig->create_ddl_dir('MySQL', undef, 't/var');
-is($schema_orig->ddl_filename('SQLite', 't/var', '1.0'), 't/var/DBICVersion-Schema-1.0-SQLite.sql', 'Filename creation working');
-$schema_orig->create_ddl_dir('SQLite', undef, 't/var');
+ok(-f 't/var/DBICVersion-Schema-1.0-MySQL.sql', 'Created DDL file');
+$schema_orig->deploy({ add_drop_table => 1 });
+$schema_orig->upgrade();
-ok(-f 't/var/DBICVersion-Schema-1.0-SQLite.sql', 'Created DDL file');
-## do this here or let Versioned.pm do it?
-# $schema->deploy();
-
-my $tvrs = $schema_orig->resultset('Table');
-is($schema_orig->exists($tvrs), 1, 'Created schema from DDL file');
+my $tvrs = $schema_orig->{vschema}->resultset('Table');
+is($schema_orig->_source_exists($tvrs), 1, 'Created schema from DDL file');
eval "use DBICVersionNew";
-my $schema_new = DBICVersion::Schema->connect("dbi:SQLite:$db_file");
+{
+ unlink('t/var/DBICVersion-Schema-2.0-MySQL.sql');
+ unlink('t/var/DBICVersion-Schema-1.0-2.0-MySQL.sql');
+
+ my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
+ is($schema_upgrade->get_db_version(), '1.0', 'get_db_version ok');
+ is($schema_upgrade->schema_version, '2.0', 'schema version ok');
+ $schema_upgrade->create_ddl_dir('MySQL', '2.0', 't/var', '1.0');
+ ok(-f 't/var/DBICVersion-Schema-1.0-2.0-MySQL.sql', 'Created DDL file');
+ $schema_upgrade->upgrade();
+ is($schema_upgrade->get_db_version(), '2.0', 'db version number upgraded');
+
+ eval {
+ $schema_upgrade->storage->dbh->do('select NewVersionName from TestVersion');
+ };
+ is($@, '', 'new column created');
+
+ # should overwrite files
+ $schema_upgrade->create_ddl_dir('MySQL', '2.0', 't/var', '1.0');
+}
-unlink('t/var/DBICVersion-Schema-2.0-SQLite.sql');
-unlink('t/var/DBICVersion-Schema-1.0-2.0-SQLite.sql');
-$schema_new->create_ddl_dir('SQLite', undef, 't/var', '1.0');
-ok(-f 't/var/DBICVersion-Schema-1.0-2.0-SQLite.sql', 'Created DDL upgrade file');
+{
+ my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ eval {
+ $schema_version->storage->dbh->do('select * from ' . $version_table_name);
+ };
+ is($@, '', 'version table exists');
-## create new to pick up filedata for upgrade files we just made (on_connect)
-my $schema_upgrade = DBICVersion::Schema->connect("dbi:SQLite:$db_file");
+ eval {
+ $schema_version->storage->dbh->do("DROP TABLE IF EXISTS $old_table_name");
+ $schema_version->storage->dbh->do("RENAME TABLE $version_table_name TO $old_table_name");
+ };
+ is($@, '', 'versions table renamed to old style table');
-## do this here or let Versioned.pm do it?
-$schema_upgrade->upgrade();
-$tvrs = $schema_upgrade->resultset('Table');
-is($schema_upgrade->exists($tvrs), 1, 'Upgraded schema from DDL file');
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ is($schema_version->get_db_version, '2.0', 'transition from old table name to new okay');
+
+ eval {
+ $schema_version->storage->dbh->do('select * from ' . $old_table_name);
+ };
+ ok($@, 'old version table gone');
+
+}
+
+# check behaviour of DBIC_NO_VERSION_CHECK env var and ignore_version connect attr
+{
+ my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ eval {
+ $schema_version->storage->dbh->do("DELETE from $version_table_name");
+ };
+
+
+ my $warn = '';
+ $SIG{__WARN__} = sub { $warn = shift };
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ like($warn, qr/Your DB is currently unversioned/, 'warning detected without env var or attr');
+
+
+ # should warn
+ $warn = '';
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
+ is($warn, '', 'warning not detected with attr set');
+ # should not warn
+
+ $ENV{DBIC_NO_VERSION_CHECK} = 1;
+ $warn = '';
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ is($warn, '', 'warning not detected with env var set');
+ # should not warn
+
+ $warn = '';
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 0 });
+ like($warn, qr/Your DB is currently unversioned/, 'warning detected without env var or attr');
+ # should warn
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use IO::File;
+use File::Compare;
+use Path::Class qw/file/;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 9;
+
+my $rs = $schema->resultset('FileColumn');
+my $fname = '96file_column.t';
+my $source_file = file('t', $fname);
+my $fh = $source_file->open('r') or die "failed to open $source_file: $!\n";
+my $fc = eval {
+ $rs->create({ file => { handle => $fh, filename => $fname } })
+};
+is ( $@, '', 'created' );
+
+$fh->close;
+
+my $storage = file(
+ $fc->column_info('file')->{file_column_path},
+ $fc->id,
+ $fc->file->{filename},
+);
+ok ( -e $storage, 'storage exists' );
+
+# read it back
+$fc = $rs->find({ id => $fc->id });
+
+is ( $fc->file->{filename}, $fname, 'filename matches' );
+ok ( compare($storage, $source_file) == 0, 'file contents matches' );
+
+# update
+my $new_fname = 'File.pm';
+my $new_source_file = file(qw/lib DBIx Class InflateColumn File.pm/);
+my $new_storage = file(
+ $fc->column_info('file')->{file_column_path},
+ $fc->id,
+ $new_fname,
+);
+$fh = $new_source_file->open('r') or die "failed to open $new_source_file: $!\n";
+
+$fc->file({ handle => $fh, filename => $new_fname });
+$fc->update;
+
+TODO: {
+ local $TODO = 'design change required';
+ ok ( ! -e $storage, 'old storage does not exist' );
+};
+
+ok ( -e $new_storage, 'new storage exists' );
+
+# read it back
+$fc = $rs->find({ id => $fc->id });
+
+is ( $fc->file->{filename}, $new_fname, 'new filname matches' );
+ok ( compare($new_storage, $new_source_file) == 0, 'new content matches' );
+
+$fc->delete;
+
+ok ( ! -e $storage, 'storage deleted' );
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More qw(no_plan);
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $cd2 = $schema->resultset('CD')->create({ artist =>
+ { name => 'Fred Bloggs' },
+ title => 'Some CD',
+ year => 1996
+ });
+
+is(ref $cd2->artist, 'DBICTest::Artist', 'Created CD and Artist object');
+is($cd2->artist->name, 'Fred Bloggs', 'Artist created correctly');
+
+my $artist = $schema->resultset('Artist')->create({ name => 'Fred 2',
+ cds => [
+ { title => 'Music to code by',
+ year => 2007,
+ },
+ ],
+ });
+is(ref $artist->cds->first, 'DBICTest::CD', 'Created Artist with CDs');
+is($artist->cds->first->title, 'Music to code by', 'CD created correctly');
+
+# Add a new CD
+$artist->update({cds => [ $artist->cds,
+ { title => 'Yet another CD',
+ year => 2006,
+ },
+ ],
+ });
+is(($artist->cds->search({}, { order_by => 'year' }))[0]->title, 'Yet another CD', 'Updated and added another CD');
+
+my $newartist = $schema->resultset('Artist')->find_or_create({ name => 'Fred 2'});
+
+is($newartist->name, 'Fred 2', 'Retrieved the artist');
+
+
+my $newartist2 = $schema->resultset('Artist')->find_or_create({ name => 'Fred 3',
+ cds => [
+ { title => 'Noah Act',
+ year => 2007,
+ },
+ ],
+
+ });
+
+is($newartist2->name, 'Fred 3', 'Created new artist with cds via find_or_create');
+
+my $artist2 = $schema->resultset('Artist')->create({ artistid => 1000,
+ name => 'Fred 3',
+ cds => [
+ { artist => 1000,
+ title => 'Music to code by',
+ year => 2007,
+ },
+ ],
+ cds_unordered => [
+ { artist => 1000,
+ title => 'Music to code by',
+ year => 2007,
+ },
+ ]
+ });
+
+is($artist2->in_storage, 1, 'artist with duplicate rels inserted okay');
+
+CREATE_RELATED1 :{
+
+ my $artist = $schema->resultset('Artist')->first;
+
+ my $cd_result = $artist->create_related('cds', {
+
+ title => 'TestOneCD1',
+ year => 2007,
+ tracks => [
+
+ { position=>111,
+ title => 'TrackOne',
+ },
+ { position=>112,
+ title => 'TrackTwo',
+ }
+ ],
+
+ });
+
+ ok( $cd_result && ref $cd_result eq 'DBICTest::CD', "Got Good CD Class");
+ ok( $cd_result->title eq "TestOneCD1", "Got Expected Title");
+
+ my $tracks = $cd_result->tracks;
+
+ ok( ref $tracks eq "DBIx::Class::ResultSet", "Got Expected Tracks ResultSet");
+
+ foreach my $track ($tracks->all)
+ {
+ ok( $track && ref $track eq 'DBICTest::Track', 'Got Expected Track Class');
+ }
+}
+
+CREATE_RELATED2 :{
+
+ my $artist = $schema->resultset('Artist')->first;
+
+ my $cd_result = $artist->create_related('cds', {
+
+ title => 'TestOneCD2',
+ year => 2007,
+ tracks => [
+
+ { position=>111,
+ title => 'TrackOne',
+ },
+ { position=>112,
+ title => 'TrackTwo',
+ }
+ ],
+
+ liner_notes => { notes => 'I can haz liner notes?' },
+
+ });
+
+ ok( $cd_result && ref $cd_result eq '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;
+
+ ok( ref $tracks eq "DBIx::Class::ResultSet", "Got Expected Tracks ResultSet");
+
+ foreach my $track ($tracks->all)
+ {
+ ok( $track && ref $track eq 'DBICTest::Track', 'Got Expected Track Class');
+ }
+}
+
+my $cdp = $schema->resultset('CD_to_Producer')->create({
+ cd => { artist => 1, title => 'foo', year => 2000 },
+ producer => { name => 'jorge' }
+ });
+
+ok($cdp, 'join table record created ok');
+
+SPECIAL_CASE: {
+ my $kurt_cobain = { name => 'Kurt Cobain' };
+
+ my $in_utero = $schema->resultset('CD')->new({
+ title => 'In Utero',
+ year => 1993
+ });
+
+ $kurt_cobain->{cds} = [ $in_utero ];
+
+
+ $schema->resultset('Artist')->populate([ $kurt_cobain ]); # %)
+ $a = $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,
+ 'In Utero', 'CD insertion ok');
+}
+
+SPECIAL_CASE2: {
+ my $pink_floyd = { name => 'Pink Floyd' };
+
+ my $the_wall = { title => 'The Wall', year => 1979 };
+
+ $pink_floyd->{cds} = [ $the_wall ];
+
+
+ $schema->resultset('Artist')->populate([ $pink_floyd ]); # %)
+ $a = $schema->resultset('Artist')->find({name => 'Pink Floyd'});
+
+ is($a->name, 'Pink Floyd', 'Artist insertion ok');
+ is($a->cds && $a->cds->first->title, 'The Wall', 'CD insertion ok');
+}
+
+## Create foreign key col obj including PK
+## See test 20 in 66relationships.t
+my $new_cd_hashref = {
+ cdid => 27,
+ title => 'Boogie Woogie',
+ year => '2007',
+ artist => { artistid => 17, name => 'king luke' }
+ };
+
+my $cd = $schema->resultset("CD")->find(1);
+
+is($cd->artist->id, 1, 'rel okay');
+
+my $new_cd = $schema->resultset("CD")->create($new_cd_hashref);
+is($new_cd->artist->id, 17, 'new id retained okay');
+
+
+# Test find or create related functionality
+my $new_artist = $schema->resultset("Artist")->create({ artistid => 18, name => 'larry' });
+
+eval {
+ $schema->resultset("CD")->create({
+ cdid => 28,
+ title => 'Boogie Wiggle',
+ year => '2007',
+ artist => { artistid => 18, name => 'larry' }
+ });
+};
+is($@, '', 'new cd created without clash on related artist');
+
+# Make sure exceptions from errors in created rels propogate
+eval {
+ my $t = $schema->resultset("Track")->new({});
+ $t->cd($t->new_related('cd', { artist => undef } ) );
+ $t->{_rel_in_storage} = 0;
+ $t->insert;
+};
+like($@, qr/cd.artist may not be NULL/, "Exception propogated properly");
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 9;
+
+{
+ my $cd_rc = $schema->resultset("CD")->result_class;
+
+ my $artist_rs = $schema->resultset("Artist")
+ ->search_rs({}, {result_class => "IWillExplode"});
+ 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');
+
+ my $cd_rs2 = $schema->resultset("Artist")->search_rs({})->related_resultset('cds');
+ is($cd_rs->result_class, $cd_rc, 'Correct cd2 result_class');
+
+ 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->search({ cdid => 1 })->first }, $cd_rc, 'Inflated into correct cd result_class');
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::Stats;
+
+my ($create_sql, $dsn, $user, $pass);
+
+if (exists $ENV{DBICTEST_PG_DSN}) {
+ ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
+
+ $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), charfield CHAR(10))";
+} elsif (exists $ENV{DBICTEST_MYSQL_DSN}) {
+ ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
+
+ $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255), charfield CHAR(10)) ENGINE=InnoDB";
+} else {
+ plan skip_all => 'Set DBICTEST_(PG|MYSQL)_DSN _USER and _PASS if you want to run savepoint tests';
+}
+
+plan tests => 16;
+
+my $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 });
+
+my $stats = DBICTest::Stats->new;
+
+$schema->storage->debugobj($stats);
+
+$schema->storage->debug(1);
+
+$schema->storage->dbh->do ($create_sql);
+
+$schema->resultset('Artist')->create({ name => 'foo' });
+
+$schema->txn_begin;
+
+my $arty = $schema->resultset('Artist')->find(1);
+
+my $name = $arty->name;
+
+# First off, test a generated savepoint name
+$schema->svp_begin;
+
+cmp_ok($stats->{'SVP_BEGIN'}, '==', 1, 'Statistics svp_begin tickled');
+
+$arty->update({ name => 'Jheephizzy' });
+
+$arty->discard_changes;
+
+cmp_ok($arty->name, 'eq', 'Jheephizzy', 'Name changed');
+
+# Rollback the generated name
+# Active: 0
+$schema->svp_rollback;
+
+cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled');
+
+$arty->discard_changes;
+
+cmp_ok($arty->name, 'eq', $name, 'Name rolled back');
+
+$arty->update({ name => 'Jheephizzy'});
+
+# Active: 0 1
+$schema->svp_begin('testing1');
+
+$arty->update({ name => 'yourmom' });
+
+# 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');
+
+# 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');
+
+# 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;
+
+# And now to see if txn_do will behave correctly
+
+$schema->txn_do (sub {
+ $schema->txn_do (sub {
+ $arty->name ('Muff');
+
+ $arty->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");
+ });
+ };
+
+ ok ($@,'Nested transaction failed (good)');
+
+ $arty->discard_changes;
+
+ is($arty->name,'Muff','auto_savepoint rollback worked');
+
+ $arty->name ('Miff');
+
+ $arty->update;
+ });
+
+$arty->discard_changes;
+
+is($arty->name,'Miff','auto_savepoint worked');
+
+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_ROLLBACK'},'==',5,'Correct number of savepoint rollbacks');
+
+END { $schema->storage->dbh->do ("DROP TABLE artist") if defined $schema }
+
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+BEGIN {
+ eval "use DBD::mysql; use SQL::Translator 0.09;";
+ plan $@
+ ? ( skip_all => 'needs SQL::Translator 0.09 for testing' )
+ : ( tests => 99 );
+}
+
+my $schema = DBICTest->init_schema();
+
+{
+ my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { } } });
+
+ foreach my $source ($schema->sources) {
+ my $table = $sqlt_schema->get_table($schema->source($source)->from);
+
+ my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
+ my @indices = $table->get_indices;
+ my $index_count = scalar(@indices);
+ $index_count++ if ($source eq 'TwoKeys'); # TwoKeys has the index turned off on the rel def
+ is($index_count, $fk_count, "correct number of indices for $source with no args");
+ }
+}
+
+{
+ my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 1 } } });
+
+ foreach my $source ($schema->sources) {
+ my $table = $sqlt_schema->get_table($schema->source($source)->from);
+
+ my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
+ my @indices = $table->get_indices;
+ my $index_count = scalar(@indices);
+ $index_count++ if ($source eq 'TwoKeys'); # TwoKeys has the index turned off on the rel def
+ is($index_count, $fk_count, "correct number of indices for $source with add_fk_index => 1");
+ }
+}
+
+{
+ my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 0 } } });
+
+ foreach my $source ($schema->sources) {
+ my $table = $sqlt_schema->get_table($schema->source($source)->from);
+
+ my @indices = $table->get_indices;
+ my $index_count = scalar(@indices);
+ is($index_count, 0, "correct number of indices for $source with add_fk_index => 0");
+ }
+}
+
+sub create_schema {
+ my $args = shift;
+
+ my $schema = $args->{schema};
+ my $additional_sqltargs = $args->{args} || {};
+
+ my $sqltargs = {
+ add_drop_table => 1,
+ ignore_constraint_names => 1,
+ ignore_index_names => 1,
+ %{$additional_sqltargs}
+ };
+
+ my $sqlt = SQL::Translator->new( $sqltargs );
+
+ $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
+ return $sqlt->translate({ data => $schema }) or die $sqlt->error;
+}
--- /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 => 3;
+
+my $schema = DBICTest::Schema->connection($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
+
+my $dbh = $schema->storage->dbh;
+
+$dbh->do(qq[
+
+ CREATE TABLE artist
+ (
+ artistid serial NOT NULL PRIMARY KEY,
+ media bytea NOT NULL,
+ name varchar NULL
+ );
+],{ RaiseError => 1, PrintError => 1 });
+
+
+$schema->class('Artist')->load_components(qw/
+
+ PK::Auto
+ Core
+/);
+
+$schema->class('Artist')->add_columns(
+
+ "media", {
+
+ data_type => "bytea",
+ is_nullable => 0,
+ },
+);
+
+# test primary key handling
+my $big_long_string = 'abcd' x 250000;
+
+my $new = $schema->resultset('Artist')->create({ media => $big_long_string });
+
+ok($new->artistid, "Created a blob row");
+is($new->media, $big_long_string, "Set the blob correctly.");
+
+my $rs = $schema->resultset('Artist')->find({artistid=>$new->artistid});
+
+is($rs->get_column('media'), $big_long_string, "Created the blob correctly.");
+
+$dbh->do("DROP TABLE artist");
+
+
+
--- /dev/null
+use strict;
+use Test::More;
+
+BEGIN {
+ 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;
+}
+
+my $DB = "t/testdb";
+unlink $DB if -e $DB;
+
+my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 });
+
+package Music::DBI;
+use base qw(DBIx::Class::CDBICompat);
+use Class::DBI::Plugin::DeepAbstractSearch;
+__PACKAGE__->connection(@DSN);
+
+my $sql = <<'SQL_END';
+
+---------------------------------------
+-- Artists
+---------------------------------------
+CREATE TABLE artists (
+ id INTEGER NOT NULL PRIMARY KEY,
+ name VARCHAR(32)
+);
+
+INSERT INTO artists VALUES (1, "Willie Nelson");
+INSERT INTO artists VALUES (2, "Patsy Cline");
+
+---------------------------------------
+-- Labels
+---------------------------------------
+CREATE TABLE labels (
+ id INTEGER NOT NULL PRIMARY KEY,
+ name VARCHAR(32)
+);
+
+INSERT INTO labels VALUES (1, "Columbia");
+INSERT INTO labels VALUES (2, "Sony");
+INSERT INTO labels VALUES (3, "Supraphon");
+
+---------------------------------------
+-- CDs
+---------------------------------------
+CREATE TABLE cds (
+ id INTEGER NOT NULL PRIMARY KEY,
+ label INTEGER,
+ artist INTEGER,
+ title VARCHAR(32),
+ year INTEGER
+);
+INSERT INTO cds VALUES (1, 1, 1, "Songs", 2005);
+INSERT INTO cds VALUES (2, 2, 1, "Read Headed Stanger", 2000);
+INSERT INTO cds VALUES (3, 1, 1, "Wanted! The Outlaws", 2004);
+INSERT INTO cds VALUES (4, 2, 1, "The Very Best of Willie Nelson", 1999);
+
+INSERT INTO cds VALUES (5, 1, 2, "12 Greates Hits", 1999);
+INSERT INTO cds VALUES (6, 2, 2, "Sweet Dreams", 1995);
+INSERT INTO cds VALUES (7, 3, 2, "The Best of Patsy Cline", 1991);
+
+---------------------------------------
+-- Tracks
+---------------------------------------
+CREATE TABLE tracks (
+ id INTEGER NOT NULL PRIMARY KEY,
+ cd INTEGER,
+ position INTEGER,
+ title VARCHAR(32)
+);
+INSERT INTO tracks VALUES (1, 1, 1, "Songs: Track 1");
+INSERT INTO tracks VALUES (2, 1, 2, "Songs: Track 2");
+INSERT INTO tracks VALUES (3, 1, 3, "Songs: Track 3");
+INSERT INTO tracks VALUES (4, 1, 4, "Songs: Track 4");
+
+INSERT INTO tracks VALUES (5, 2, 1, "Read Headed Stanger: Track 1");
+INSERT INTO tracks VALUES (6, 2, 2, "Read Headed Stanger: Track 2");
+INSERT INTO tracks VALUES (7, 2, 3, "Read Headed Stanger: Track 3");
+INSERT INTO tracks VALUES (8, 2, 4, "Read Headed Stanger: Track 4");
+
+INSERT INTO tracks VALUES (9, 3, 1, "Wanted! The Outlaws: Track 1");
+INSERT INTO tracks VALUES (10, 3, 2, "Wanted! The Outlaws: Track 2");
+
+INSERT INTO tracks VALUES (11, 4, 1, "The Very Best of Willie Nelson: Track 1");
+INSERT INTO tracks VALUES (12, 4, 2, "The Very Best of Willie Nelson: Track 2");
+INSERT INTO tracks VALUES (13, 4, 3, "The Very Best of Willie Nelson: Track 3");
+INSERT INTO tracks VALUES (14, 4, 4, "The Very Best of Willie Nelson: Track 4");
+INSERT INTO tracks VALUES (15, 4, 5, "The Very Best of Willie Nelson: Track 5");
+INSERT INTO tracks VALUES (16, 4, 6, "The Very Best of Willie Nelson: Track 6");
+
+INSERT INTO tracks VALUES (17, 5, 1, "12 Greates Hits: Track 1");
+INSERT INTO tracks VALUES (18, 5, 2, "12 Greates Hits: Track 2");
+INSERT INTO tracks VALUES (19, 5, 3, "12 Greates Hits: Track 3");
+INSERT INTO tracks VALUES (20, 5, 4, "12 Greates Hits: Track 4");
+
+INSERT INTO tracks VALUES (21, 6, 1, "Sweet Dreams: Track 1");
+INSERT INTO tracks VALUES (22, 6, 2, "Sweet Dreams: Track 2");
+INSERT INTO tracks VALUES (23, 6, 3, "Sweet Dreams: Track 3");
+INSERT INTO tracks VALUES (24, 6, 4, "Sweet Dreams: Track 4");
+
+INSERT INTO tracks VALUES (25, 7, 1, "The Best of Patsy Cline: Track 1");
+INSERT INTO tracks VALUES (26, 7, 2, "The Best of Patsy Cline: Track 2");
+
+SQL_END
+
+foreach my $statement (split /;/, $sql) {
+ $statement =~ s/^\s*//gs;
+ $statement =~ s/\s*$//gs;
+ next unless $statement;
+ Music::DBI->db_Main->do($statement) or die "$@ $!";
+}
+
+Music::DBI->dbi_commit;
+
+package Music::Artist;
+use base 'Music::DBI';
+Music::Artist->table('artists');
+Music::Artist->columns(All => qw/id name/);
+
+
+package Music::Label;
+use base 'Music::DBI';
+Music::Label->table('labels');
+Music::Label->columns(All => qw/id name/);
+
+package Music::CD;
+use base 'Music::DBI';
+Music::CD->table('cds');
+Music::CD->columns(All => qw/id label artist title year/);
+
+
+package Music::Track;
+use base 'Music::DBI';
+Music::Track->table('tracks');
+Music::Track->columns(All => qw/id cd position title/);
+
+Music::Artist->has_many(cds => 'Music::CD');
+Music::Label->has_many(cds => 'Music::CD');
+Music::CD->has_many(tracks => 'Music::Track');
+Music::CD->has_a(artist => 'Music::Artist');
+Music::CD->has_a(label => 'Music::Label');
+Music::Track->has_a(cd => 'Music::CD');
+
+package main;
+
+{
+ my $where = { };
+ my $attr;
+ my @artists = Music::Artist->deep_search_where($where, $attr);
+ is_deeply [ sort @artists ], [ 1, 2 ], "all without order";
+}
+
+{
+ my $where = { };
+ my $attr = { order_by => 'name' };
+ my @artists = Music::Artist->deep_search_where($where, $attr);
+ is_deeply \@artists, [ 2, 1 ], "all with ORDER BY name";
+}
+
+{
+ my $where = { };
+ my $attr = { order_by => 'name DESC' };
+ my @artists = Music::Artist->deep_search_where($where, $attr);
+ is_deeply \@artists, [ 1, 2 ], "all with ORDER BY name DESC";
+}
+
+{
+ my $where = { name => { -like => 'Patsy Cline' }, };
+ my $attr;
+ my @artists = Music::Artist->deep_search_where($where, $attr);
+ is_deeply \@artists, [ 2 ], "simple search";
+}
+
+{
+ my $where = { 'artist.name' => 'Patsy Cline' };
+ my $attr = { } ;
+ my @cds = Music::CD->deep_search_where($where, $attr);
+ is_deeply [ sort @cds ], [ 5, 6, 7 ], "Patsy's CDs";
+}
+
+{
+ my $where = { 'artist.name' => 'Patsy Cline' };
+ my $attr = { order_by => "title" } ;
+ my @cds = Music::CD->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 5, 6, 7 ], "Patsy's CDs by title";
+
+ my $count = Music::CD->count_deep_search_where($where);
+ is_deeply $count, 3, "count Patsy's CDs by title";
+}
+
+{
+ my $where = { 'cd.title' => { -like => 'S%' }, };
+ my $attr = { order_by => "cd.title, title" } ;
+ my @cds = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [1, 2, 3, 4, 21, 22, 23, 24 ], "Tracks from CDs whose name starts with 'S'";
+}
+
+{
+ my $where = {
+ 'cd.artist.name' => { -like => 'W%' },
+ 'cd.year' => { '>' => 2000 },
+ 'position' => { '<' => 3 }
+ };
+ my $attr = { order_by => "cd.title DESC, title" } ;
+ my @cds = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000 ";
+
+ my $count = Music::Track->count_deep_search_where($where);
+ is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000";
+}
+
+{
+ my $where = {
+ 'cd.artist.name' => { -like => 'W%' },
+ 'cd.year' => { '>' => 2000 },
+ 'position' => { '<' => 3 }
+ };
+ my $attr = { order_by => [ 'cd.title DESC' , 'title' ] } ;
+ my @cds = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000, array ref order ";
+
+ my $count = Music::Track->count_deep_search_where($where);
+ is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000, array ref order";
+}
+
+{
+ my $where = { 'cd.title' => [ -and => { -like => '%o%' }, { -like => '%W%' } ] };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 3, 3, 4, 4, 4, 4, 4, 4 ], "Tracks from CD titles containing 'o' AND 'W'";
+}
+
+{
+ my $where = { 'cd.year' => [ 1995, 1999 ] };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ],
+ "Tracks from CDs from 1995, 1999";
+}
+
+{
+ my $where = { 'cd.year' => { -in => [ 1995, 1999 ] } };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ],
+ "Tracks from CDs in 1995, 1999";
+}
+
+{
+ my $where = { -and => [ 'cd.year' => [ 1995, 1999 ], position => { '<=', 2 } ] };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ],
+ "First 2 tracks Tracks from CDs from 1995, 1999";
+}
+
+{
+ my $where = { -and => [ 'cd.year' => { -in => [ 1995, 1999 ] }, position => { '<=', 2 } ] };
+ my $attr = { order_by => [ 'cd.id' ] } ;
+
+ my @tracks = Music::Track->deep_search_where($where, $attr);
+ is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ],
+ "First 2 tracks Tracks from CDs in 1995, 1999";
+}
+
+{
+ my $where = { 'label.name' => { -in => [ 'Sony', 'Supraphon', 'Bogus' ] } };
+ my $attr = { order_by => [ 'id' ] } ;
+
+ my @cds = Music::CD->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 2, 4, 6, 7 ],
+ "CDs from Sony or Supraphon";
+}
+
+{
+ my $where = { 'label.name' => [ 'Sony', 'Supraphon', 'Bogus' ] };
+ my $attr = { order_by => [ 'id' ] } ;
+
+ my @cds = Music::CD->deep_search_where($where, $attr);
+ is_deeply [ @cds ], [ 2, 4, 6, 7 ],
+ "CDs from Sony or Supraphon";
+}
+
+END { unlink $DB if -e $DB }
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use Test::More;
+
+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/testlib';
+ use Film;
+}
+
+
+Film->create({ Title => $_, Rating => "PG" }) for ("Superman", "Super Fuzz");
+Film->create({ Title => "Batman", Rating => "PG13" });
+
+my $superman = Film->search_where( Title => "Superman" );
+is $superman->next->Title, "Superman", "search_where() as iterator";
+is $superman->next, undef;
+
+{
+ my @supers = Film->search_where({ title => { 'like' => 'Super%' } });
+ 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],
+ "order_by ASC";
+
+@all = Film->search_where({}, { order_by => "Title DESC" });
+is_deeply ["Superman", "Super Fuzz", "Batman"],
+ [map $_->Title, @all],
+ "order_by DESC";
+
+@all = Film->search_where({ Rating => "PG" }, { limit => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz"],
+ [map $_->Title, @all],
+ "where, limit";
+
+@all = Film->search_where({}, { limit => 2, order_by => "Title ASC" });
+is_deeply ["Batman", "Super Fuzz"],
+ [map $_->Title, @all],
+ "limit";
+
+@all = Film->search_where({}, { offset => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz", "Superman"],
+ [map $_->Title, @all],
+ "offset";
+
+@all = Film->search_where({}, { limit => 1, offset => 1, order_by => "Title ASC" });
+is_deeply ["Super Fuzz"],
+ [map $_->Title, @all],
+ "limit + offset";
+
+@all = Film->search_where({}, { limit => 2, offset => 1,
+ limit_dialect => "Top", order_by => "Title ASC"
+ });
+is_deeply ["Super Fuzz", "Superman"],
+ [map $_->Title, @all],
+ "limit_dialect ignored";
+
use lib 't/lib';
use_ok('DBICTest');
-my $schema = DBICTest->init_schema();
-DBICTest::CD->load_components(qw/CDBICompat CDBICompat::Pager/);
+DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/);
-DBICTest::CD->result_source_instance->schema($schema);
+my $schema = DBICTest->init_schema(compose_connection => 1);
+
+DBICTest::CD->result_source_instance->schema->storage($schema->storage);
my ( $pager, $it ) = DBICTest::CD->page(
{},
BEGIN {
eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') : (tests=> 24);
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") : (tests=> 24);
}
State->columns(Other => qw/Capital Population/);
#State->has_many(cities => "City");
-sub accessor_name {
+sub accessor_name_for {
my ($class, $column) = @_;
my $return = $column eq "Rain" ? "Rainfall" : $column;
return $return;
}
-sub mutator_name {
+sub mutator_name_for {
my ($class, $column) = @_;
my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column";
return $return;
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 96);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 98);
}
INIT {
ok $@, "Can't get title with no object";
}
-eval { my $duh = Film->create; };
+eval { my $duh = Film->insert; };
like $@, qr/create needs a hashref/, "needs a hashref";
ok +Film->create_test_film;
{
Film->add_constructor(title_asc => "title LIKE ? ORDER BY title");
Film->add_constructor(title_desc => "title LIKE ? ORDER BY title DESC");
+ Film->add_constructor(title_asc_nl => q{
+ title LIKE ?
+ ORDER BY title
+ LIMIT 1
+ });
{
my @films = Film->title_asc("Bladerunner%");
is @films, 2, "We have 2 Bladerunners";
is $films[0]->Title, $blrunner_dc->Title, "Ordered correctly";
}
+ {
+ my @films = Film->title_asc_nl("Bladerunner%");
+ is @films, 1, "We have 2 Bladerunners";
+ is $films[0]->Title, $blrunner->Title, "Ordered correctly";
+ }
}
# Multi-column search
}
eval {
- my $ishtar = Film->create({ Title => 'Ishtar', Director => 'Elaine May' });
+ my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' });
my $mandn =
- Film->create({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
+ Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
my $new_leaf =
- Film->create({ Title => 'A New Leaf', Director => 'Elaine May' });
+ Film->insert({ Title => 'A New Leaf', Director => 'Elaine May' });
#use Data::Dumper; die Dumper(Film->search( Director => 'Elaine May' ));
cmp_ok(Film->search(Director => 'Elaine May'), '==', 3,
{ # update deleted object
my $rt = "Royal Tenenbaums";
- my $ten = Film->create({ title => $rt, Rating => "R" });
+ my $ten = Film->insert({ title => $rt, Rating => "R" });
$ten->rating(18);
Film->set_sql(drt => "DELETE FROM __TABLE__ WHERE title = ?");
Film->sql_drt->execute($rt);
# Primary key of 0
{
- my $zero = Film->create({ Title => 0, Rating => "U" });
+ my $zero = Film->insert({ Title => 0, Rating => "U" });
ok defined $zero, "Create 0";
ok my $ret = Film->retrieve(0), "Retrieve 0";
is $ret->Title, 0, "Title OK";
{
{
- ok my $byebye = DeletingFilm->create(
+ ok my $byebye = DeletingFilm->insert(
{
Title => 'Goodbye Norma Jean',
Rating => 'PG',
}
SKIP: {
- #skip "DBIx::Class doesn't yet have a live objects index", 3;
- #skip "Scalar::Util::weaken not available", 3
- #if !$Class::DBI::Weaken_Is_Available;
+ skip "Caching has been removed", 5
+ if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
# my bad taste is your bad taste
my $btaste = Film->retrieve('Bad Taste');
isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4),
"Clearing cache and retrieving again gives new object";
- $btaste=Film->create({
+ $btaste=Film->insert({
Title => 'Bad Taste 2',
Director => 'Peter Jackson',
Rating => 'R',
+#!/usr/bin/perl -w
+
use strict;
use Test::More;
-
+use Test::Warn;
#----------------------------------------------------------------------
# Test lazy loading
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 25);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 36);
}
INIT {
};
ok($@, $@);
+
+warning_is {
+ Lazy->columns( TEMP => qw(that) );
+} "Declaring column that as TEMP but it already exists";
+
+# Test that create() and update() throws out columns that changed
+{
+ my $l = Lazy->create({
+ this => 99,
+ that => 2,
+ oop => 3,
+ opop => 4,
+ });
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET oop = ?
+ WHERE this = ?
+ }, undef, 87, $l->this);
+
+ is $l->oop, 87;
+
+ $l->oop(32);
+ $l->update;
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ SET oop = ?
+ WHERE this = ?
+ }, undef, 23, $l->this);
+
+ is $l->oop, 23;
+
+ $l->delete;
+}
+
+
+# Now again for inflated values
+SKIP: {
+ skip "Requires Date::Simple", 5 unless eval "use Date::Simple; 1; ";
+ Lazy->has_a(
+ orp => 'Date::Simple',
+ inflate => sub { Date::Simple->new($_[0] . '-01-01') },
+ deflate => 'format'
+ );
+
+ my $l = Lazy->create({
+ this => 89,
+ that => 2,
+ orp => 1998,
+ });
+
+ ok $l->db_Main->do(qq{
+ UPDATE @{[ $l->table ]}
+ 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 = ?
+ WHERE this = ?
+ }, undef, 1942, $l->this);
+
+ is $l->orp, '1942-01-01';
+
+ $l->delete;
+}
+
+
+# Test that a deleted object works
+{
+ Lazy->search()->delete_all;
+ my $l = Lazy->create({
+ this => 99,
+ that => 2,
+ 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};
+}
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
next;
}
eval "use DBD::SQLite";
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
+ : (tests=> 3);
+}
+
+package A;
+@A::ISA = qw(DBIx::Class::CDBICompat);
+__PACKAGE__->columns(Primary => 'id');
+
+package A::B;
+@A::B::ISA = 'A';
+__PACKAGE__->columns(All => qw(id b1));
+
+package A::C;
+@A::C::ISA = 'A';
+__PACKAGE__->columns(All => qw(id c1 c2 c3));
+
+package main;
+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";
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 => 30);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 31);
}
use lib 't/testlib';
use Film;
use Actor;
-Film->has_many(actors => Actor => 'Film', { order_by => 'name' });
Actor->has_a(Film => 'Film');
+Film->has_many(actors => 'Actor', { order_by => 'name' });
is(Actor->primary_column, 'id', "Actor primary OK");
ok(Actor->can('Salary'), "Actor table set-up OK");
is($as->Name, 'Arnold Schwarzenegger', "Arnie's still Arnie");
+
+# Test infering of the foreign key of a has_many from an existing has_a
+{
+ use Thing;
+ use OtherThing;
+
+ Thing->has_a(that_thing => "OtherThing");
+ OtherThing->has_many(things => "Thing");
+
+ my $other_thing = OtherThing->create({ id => 1 });
+ Thing->create({ id => 1, that_thing => $other_thing });
+ Thing->create({ id => 2, that_thing => $other_thing });
+
+ is_deeply [sort map { $_->id } $other_thing->things], [1,2];
+}
sub default_rating { $_[0]->Rating(15); }
-Film->add_trigger(
- before_create => \&default_rating,
- after_create => \&create_trigger2,
- after_delete => \&delete_trigger,
- before_update => \&pre_up_trigger,
- after_update => \&pst_up_trigger,
-);
+Film->add_trigger(before_create => \&default_rating);
+Film->add_trigger(after_create => \&create_trigger2);
+Film->add_trigger(after_delete => \&delete_trigger);
+Film->add_trigger(before_update => \&pre_up_trigger);
+Film->add_trigger(after_update => \&pst_up_trigger);
ok(
my $ver = Film->create({
use Film;
sub valid_rating {
- my $value = shift;
- my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/;
- return $ok;
+ my $value = shift;
+ my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/;
+ return $ok;
}
Film->add_constraint('valid rating', Rating => \&valid_rating);
my %info = (
- Title => 'La Double Vie De Veronique',
- Director => 'Kryzstof Kieslowski',
- Rating => '18',
+ Title => 'La Double Vie De Veronique',
+ Director => 'Kryzstof Kieslowski',
+ Rating => '18',
);
{
- local $info{Title} = "nonsense";
- local $info{Rating} = 19;
- eval { Film->create({%info}) };
- ok $@, $@;
- ok !Film->retrieve($info{Title}), "No film created";
- is(Film->retrieve_all, 0, "So no films");
+ local $info{Title} = "nonsense";
+ local $info{Rating} = 19;
+ eval { Film->create({%info}) };
+ ok $@, $@;
+ ok !Film->retrieve($info{Title}), "No film created";
+ is(Film->retrieve_all, 0, "So no films");
}
ok(my $ver = Film->create({%info}), "Can create with valid rating");
is $ver->Rating, 12, "Rating now 12";
eval {
- $ver->Rating(13);
- $ver->update;
+ $ver->Rating(13);
+ $ver->update;
};
ok $@, $@;
is $ver->Rating, 12, "Rating still 12";
ok $fred, "Got fred";
{
- ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]),
- "constraint_column";
- my $narrower = eval { Film->create({ Rating => 'Uc' }) };
- like $@, qr/fails.*constraint/, "Fails listref constraint";
- my $ok = eval { Film->create({ Rating => 'U' }) };
- is $@, '', "Can create with rating U";
+ ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]),
+ "constraint_column";
+ my $narrower = eval { Film->create({ Rating => 'Uc' }) };
+ like $@, qr/fails.*constraint/, "Fails listref constraint";
+ my $ok = eval { Film->create({ Rating => 'U' }) };
+ is $@, '', "Can create with rating U";
SKIP: {
skip "No column objects", 2;
- ok +Film->find_column('rating')->is_constrained, "Rating is constrained";
- ok +Film->find_column('director')->is_constrained, "Director is not";
+ ok +Film->find_column('rating')->is_constrained, "Rating is constrained";
+ ok +Film->find_column('director')->is_constrained, "Director is not";
}
}
{
- ok +Film->constrain_column(title => qr/The/), "constraint_column";
- my $inferno = eval { Film->create({ Title => 'Towering Infero' }) };
- like $@, qr/fails.*constraint/, "Can't create towering inferno";
- my $the_inferno = eval { Film->create({ Title => 'The Towering Infero' }) };
- is $@, '', "But can create THE towering inferno";
+ ok +Film->constrain_column(title => qr/The/), "constraint_column";
+ my $inferno = eval { Film->create({ Title => 'Towering Infero' }) };
+ like $@, qr/fails.*constraint/, "Can't create towering inferno";
+ my $the_inferno = eval { Film->create({ Title => 'The Towering Infero' }) };
+ is $@, '', "But can create THE towering inferno";
}
{
- sub Film::_constrain_by_untaint {
- my ($class, $col, $string, $type) = @_;
- $class->add_constraint(
- untaint => $col => sub {
- my ($value, $self, $column_name, $changing) = @_;
- $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0;
- }
- );
- }
- eval { Film->constrain_column(codirector => Untaint => 'date') };
- is $@, '', 'Can constrain with untaint';
- my $freeaa =
- eval { Film->create({ title => "The Freaa", codirector => 'today' }) };
- is $@, '', "Can create codirector";
- is $freeaa->codirector, '2001-03-03', "Set the codirector";
+ sub Film::_constrain_by_untaint {
+ my ($class, $col, $string, $type) = @_;
+ $class->add_constraint(
+ untaint => $col => sub {
+ my ($value, $self, $column_name, $changing) = @_;
+ $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0;
+ }
+ );
+ }
+ eval { Film->constrain_column(codirector => Untaint => 'date') };
+ is $@, '', 'Can constrain with untaint';
+ my $freeaa =
+ eval { Film->create({ title => "The Freaa", codirector => 'today' }) };
+ TODO: {
+ local $TODO = "no idea what this is supposed to do";
+ is $@, '', "Can create codirector";
+ is $freeaa && $freeaa->codirector, '2001-03-03', "Set the codirector";
+ }
}
__DATA__
use CGI::Untaint;
sub _constrain_by_untaint {
- my ($class, $col, $string, $type) = @_;
- $class->add_constraint(untaint => $col => sub {
- my ($value, $self, $column_name, $changing) = @_;
- my $h = CGI::Untaint->new({ %$changing });
- return unless my $val = $h->extract("-as_$type" => $column_name);
- $changing->{$column_name} = $val;
- return 1;
- });
+ my ($class, $col, $string, $type) = @_;
+ $class->add_constraint(untaint => $col => sub {
+ my ($value, $self, $column_name, $changing) = @_;
+ my $h = CGI::Untaint->new({ %$changing });
+ return unless my $val = $h->extract("-as_$type" => $column_name);
+ $changing->{$column_name} = $val;
+ return 1;
+ });
}
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 18);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 22);
}
use lib 't/testlib';
}
-
+{
+ my $host = Film->create({ title => "Gwoemul" });
+ $host->blurb("Monsters are real.");
+ my $info = $host->info;
+ is $info->blurb, "Monsters are real.";
+
+ $host->discard_changes;
+ is $host->info->id, $info->id,
+ 'relationships still valid after discard_changes';
+
+ ok $host->info->delete;
+ $host->discard_changes;
+ ok !$host->info, 'relationships rechecked after discard_changes';
+}
\ No newline at end of file
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
+ diag $@;
plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 53);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 54);
}
INIT {
use lib 't/testlib';
require Film;
require Actor;
+ require Director;
Actor->has_a(film => 'Film');
+ Film->has_a(director => 'Director');
sub Class::DBI::sheep { ok 0; }
}
return $col;
}
-sub Actor::accessor_name {
+sub Actor::accessor_name_for {
my ($class, $col) = @_;
return "movie" if lc $col eq "film";
return $col;
}
+# This is a class with accessor_name_for() but no corresponding mutatori_name_for()
+sub Director::accessor_name_for {
+ my($class, $col) = @_;
+ return "nutty_as_a_fruitcake" if lc $col eq "isinsane";
+ return $col;
+}
+
my $data = {
Title => 'Bad Taste',
Director => 'Peter Jackson',
}
-SKIP: { # have non persistent accessor?
- #skip "Compat layer doesn't handle TEMP columns yet", 11;
+
+# Make sure a class with an accessor_name() method has a similar mutator.
+{
+ my $aki = Director->create({
+ name => "Aki Kaurismaki",
+ });
+
+ $aki->nutty_as_a_fruitcake(1);
+ is $aki->nutty_as_a_fruitcake, 1,
+ "a custom accessor without a custom mutator is setable";
+ $aki->update;
+}
+
+{
Film->columns(TEMP => qw/nonpersistent/);
ok(Film->find_column('nonpersistent'), "nonpersistent is a column");
ok(!Film->has_real_column('nonpersistent'), " - but it's not real");
}
}
-SKIP: { # was bug with TEMP and no Essential
- #skip "Compat layer doesn't have TEMP columns yet", 5;
+{
is_deeply(
- Actor->columns('Essential'),
- Actor->columns('Primary'),
+ [Actor->columns('Essential')],
+ [Actor->columns('Primary')],
"Actor has no specific essential columns"
);
ok(Actor->find_column('nonpersistent'), "nonpersistent is a column");
isa_ok $pj => "Actor";
}
-SKIP: {
- #skip "Compat layer doesn't handle read-only objects yet", 10;
+{
Film->autoupdate(1);
my $naked = Film->create({ title => 'Naked' });
my $sandl = Film->create({ title => 'Secrets and Lies' });
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 17);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 20);
}
use lib 't/testlib';
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',
+ 'multi-col __ESSENTIAL__ expansion';
}
my $f1 = Film->create({ title => 'A', director => 'AA', rating => 'PG' });
};
{
+ Film->set_sql(
+ by_id => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE __IDENTIFIER__
+ }
+ );
+
+ my $film = Film->retrieve_all->first;
+ my @found = Film->search_by_id($film->id);
+ is @found, 1;
+ is $found[0]->id, $film->id;
+}
+
+
+{
Actor->has_a(film => "Film");
Film->set_sql(
namerate => qq{
is $apg[1]->title, "B", "and B";
}
-#} # end SKIP block
BEGIN {
eval "use DBIx::Class::CDBICompat;";
if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
+ plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
next;
}
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 33);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 37);
}
use lib 't/testlib';
is $it->next->title, "Film 2", "And 2 is still next";
}
-SKIP: {
- #skip "Iterator doesn't yet have slice support", 19;
{
my $it = Film->retrieve_all;
is $it->next->title, "Film 2", "And 2 is still next";
}
-} # End SKIP
+{
+ my $it = Film->retrieve_all;
+ is $it, $it->count, "iterator returns count as a scalar";
+ ok $it, "iterator returns true when there are results";
+}
+
+{
+ my $it = Film->search( Title => "something which does not exist" );
+ is $it, 0;
+ ok !$it, "iterator returns false when no results";
+}
--- /dev/null
+$| = 1;
+use strict;
+
+use Test::More;
+
+eval { require Time::Piece::MySQL };
+plan skip_all => "Need Time::Piece::MySQL for this test" if $@;
+
+eval { require 't/testlib/Log.pm' };
+plan skip_all => "Need MySQL for this test" if $@;
+
+plan tests => 2;
+
+package main;
+
+my $log = Log->insert( { message => 'initial message' } );
+ok eval { $log->datetime_stamp }, "Have datetime";
+diag $@ if $@;
+
+$log->message( 'a revised message' );
+$log->update;
+ok eval { $log->datetime_stamp }, "Have datetime after update";
+diag $@ if $@;
+
--- /dev/null
+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 => 12);
+}
+
+INIT {
+ use lib 't/testlib';
+ use Film;
+ use Director;
+}
+
+{ # Cascade on delete
+ Director->has_many(nasties => 'Film');
+
+ my $dir = Director->insert({
+ name => "Lewis Teague",
+ });
+ my $kk = $dir->add_to_nasties({
+ Title => 'Alligator'
+ });
+ is $kk->director, $dir, "Director set OK";
+ is $dir->nasties, 1, "We have one nasty";
+
+ ok $dir->delete;
+ ok !Film->retrieve("Alligator"), "has_many cascade deletes by default";
+}
+
+
+# Two ways of saying not to cascade
+for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) {
+ Director->has_many(nasties => 'Film', $args);
+
+ my $dir = Director->insert({
+ name => "Lewis Teague",
+ });
+ my $kk = $dir->add_to_nasties({
+ Title => 'Alligator'
+ });
+ is $kk->director, $dir, "Director set OK";
+ is $dir->nasties, 1, "We have one nasty";
+
+ ok $dir->delete;
+ ok +Film->retrieve("Alligator"), "has_many with @{[ keys %$args ]} => @{[ values %$args ]}";
+ $kk->delete;
+}
+
+
+#{ # Fail on cascade
+# local $TODO = 'cascade => "Fail" unimplemented';
+#
+# Director->has_many(nasties => Film => { cascade => 'Fail' });
+#
+# my $dir = Director->insert({ name => "Nasty Noddy" });
+# my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' });
+# is $kk->director, $dir, "Director set OK";
+# is $dir->nasties, 1, "We have one nasty";
+#
+# ok !eval { $dir->delete };
+# like $@, qr/1/, "Can't delete while films exist";
+#
+# my $rr = $dir->add_to_nasties({ Title => 'Revenge of the Revengers' });
+# ok !eval { $dir->delete };
+# like $@, qr/2/, "Still can't delete";
+#
+# $dir->nasties->delete_all;
+# ok eval { $dir->delete };
+# is $@, '', "Can delete once films are gone";
+#}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+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 Test::Warn;
+
+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")
+};
+Temp::DBI->has_a(
+ date => 'Time::Piece',
+ inflate => $strptime_inflate
+);
+
+
+package Temp::Person;
+use base 'Temp::DBI';
+Temp::Person->table('people');
+Temp::Person->columns(Info => qw(name pet));
+Temp::Person->has_a( pet => 'Temp::Pet' );
+
+package Temp::Pet;
+use base 'Temp::DBI';
+Temp::Pet->table('pets');
+Temp::Pet->columns(Info => qw(name));
+Temp::Pet->has_many(owners => 'Temp::Person');
+
+package main;
+
+{
+ my $pn_meta = Temp::Person->meta_info('has_a');
+ is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet";
+}
+
+{
+ my $pt_meta = Temp::Pet->meta_info;
+ is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date";
+ is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners";
+}
+
+{
+ my $pet = Temp::Person->meta_info( has_a => 'pet' );
+ is $pet->class, 'Temp::Person';
+ is $pet->foreign_class, 'Temp::Pet';
+ is $pet->accessor, 'pet';
+ is $pet->name, 'has_a';
+}
+
+{
+ my $owners = Temp::Pet->meta_info( has_many => 'owners' );
+
+ is_deeply $owners->args, {
+ foreign_key => 'pet',
+ mapping => [],
+ };
+}
+
+{
+ my $date = Temp::Pet->meta_info( has_a => 'date' );
+ is $date->class, 'Temp::DBI';
+ is $date->foreign_class, 'Time::Piece';
+ is $date->accessor, 'date';
+ is $date->args->{inflate}, $strptime_inflate;
+}
--- /dev/null
+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/testlib';
+require Film;
+
+sub Film::accessor_name_for {
+ my ($class, $col) = @_;
+ return "sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+}
+
+my $data = {
+ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+};
+
+my $bt;
+eval {
+ my $data = $data;
+ $data->{sheep} = 1;
+ ok $bt = Film->insert($data), "Modified accessor - with
+accessor";
+ isa_ok $bt, "Film";
+};
+is $@, '', "No errors";
+
+eval {
+ ok $bt->sheep(2), 'Modified accessor, set';
+ ok $bt->update, 'Update';
+};
+is $@, '', "No errors";
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+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/testlib';
+use Film;
+
+my $waves = Film->insert({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ Rating => 'R'
+});
+
+local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 0;
+
+{
+ local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 1;
+
+ warnings_like {
+ 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};
+
+ warnings_like {
+ is $waves->{title}, $waves->Title, "columns can be accessed as hashes";
+ } qr{^Column 'title' of 'Film/$waves' was fetched as a hash at\b};
+
+ $waves->Rating("G");
+
+ warnings_like {
+ is $waves->{rating}, "G", "updating via the accessor updates the hash";
+ } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b};
+
+
+ warnings_like {
+ $waves->{rating} = "PG";
+ } qr{^Column 'rating' of 'Film/$waves' was stored as a hash at\b};
+
+ $waves->update;
+ my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" );
+ is @films, 1, "column updated as hash was saved";
+}
+
+warning_is {
+ $waves->{rating}
+} '', 'DBIC_CDBICOMPAT_HASH_WARN controls warnings';
+
+
+{
+ $waves->rating("R");
+ $waves->update;
+
+ no warnings 'redefine';
+ local *Film::rating = sub {
+ return "wibble";
+ };
+
+ is $waves->{rating}, "R";
+}
+
+
+{
+ no warnings 'redefine';
+ no warnings 'once';
+ local *Actor::accessor_name_for = sub {
+ my($class, $col) = @_;
+ return "movie" if lc $col eq "film";
+ return $col;
+ };
+
+ require Actor;
+ Actor->has_a( film => "Film" );
+
+ my $actor = Actor->insert({
+ 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 };
+
+ 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
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 5);
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(TEMP => qw[foo bar]);
+ Thing->columns(All => qw[thing_id yarrow flower]);
+ sub foo { 42 }
+ sub yarrow { "hock" }
+}
+
+is_deeply( [sort Thing->columns("TEMP")],
+ [sort qw(foo bar)],
+ "TEMP columns set"
+);
+my $thing = Thing->construct(
+ { thing_id => 23, foo => "this", bar => "that" }
+);
+
+is( $thing->id, 23 );
+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' );
--- /dev/null
+#!/usr/bin/perl -w
+
+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/testlib';
+ use Film;
+}
+
+{
+ Film->insert({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ Rating => 'R'
+ });
+
+ my $film = Film->construct({
+ Title => "Breaking the Waves",
+ Director => 'Lars von Trier',
+ });
+
+ isa_ok $film, "Film";
+ is $film->title, "Breaking the Waves";
+ is $film->director, "Lars von Trier";
+ is $film->rating, "R",
+ "constructed objects can get missing data from the db";
+}
+
+{
+ package Foo;
+ use base qw(Film);
+ Foo->columns( TEMP => qw(temp_thing) );
+ my $film = Foo->construct({
+ temp_thing => 23
+ });
+
+ ::is $film->temp_thing, 23, "construct sets temp columns";
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+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/testlib';
+}
+
+{
+ package # hide from PAUSE
+ MyFilm;
+
+ use base 'DBIx::Class::Test::SQLite';
+ use strict;
+
+ __PACKAGE__->set_table('Movies');
+ __PACKAGE__->columns(All => qw(id title));
+
+ sub create_sql {
+ return qq{
+ id INTEGER PRIMARY KEY AUTOINCREMENT,
+ title VARCHAR(255)
+ }
+ }
+}
+
+my $film = MyFilm->create({ title => "For Your Eyes Only" });
+ok $film->id;
+
+my $new_film = $film->copy;
+ok $new_film->id;
+isnt $new_film->id, $film->id, "copy() gets new primary key";
+
+$new_film = $film->copy(42);
+is $new_film->id, 42, "copy() with new id";
+
--- /dev/null
+use strict;
+
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : ('no_plan');
+}
+
+
+{
+ package Thing;
+ use base qw(DBIx::Class::CDBICompat);
+}
+
+{
+ package Stuff;
+ use base qw(DBIx::Class::CDBICompat);
+}
+
+# There was a bug where looking at a column group before any were
+# set would cause them to be shared across classes.
+is_deeply [Stuff->columns("Essential")], [];
+Thing->columns(Essential => qw(foo bar baz));
+is_deeply [Stuff->columns("Essential")], [];
+
+1;
--- /dev/null
+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 lib 't/testlib';
+use Director;
+
+# Test that has_many() will load the foreign class.
+ok !Class::Inspector->loaded( 'Film' );
+ok eval { Director->has_many( films => 'Film' ); 1; } || diag $@;
+
+my $shan_hua = Director->create({
+ Name => "Shan Hua",
+});
+
+my $inframan = Film->create({
+ Title => "Inframan",
+ Director => "Shan Hua",
+});
+my $guillotine2 = Film->create({
+ Title => "Flying Guillotine 2",
+ Director => "Shan Hua",
+});
+my $guillotine = Film->create({
+ Title => "Master of the Flying Guillotine",
+ Director => "Yu Wang",
+});
+
+is_deeply [sort $shan_hua->films], [sort $inframan, $guillotine2];
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
+ : (tests=> 2);
+}
+
+package Foo;
+
+use base qw(DBIx::Class::CDBICompat);
+
+eval {
+ Foo->table("foo");
+ Foo->columns(Essential => qw(foo bar));
+ #Foo->has_a( bar => "This::Does::Not::Exist::Yet" );
+};
+#::is $@, '';
+::is(Foo->table, "foo");
+::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)];
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+#----------------------------------------------------------------------
+# 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/testlib';
+use Film;
+
+Film->create({
+ title => "Bad Taste",
+ numexplodingsheep => 10,
+});
+
+Film->create({
+ title => "Evil Alien Conquerers",
+ numexplodingsheep => 2,
+});
+
+is( Film->maximum_value_of("numexplodingsheep"), 10 );
+is( Film->minimum_value_of("numexplodingsheep"), 2 );
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBIx::Class::CDBICompat;";
+ plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
+ : (tests=> 3);
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(TEMP => qw[foo bar baz]);
+ Thing->columns(All => qw[some real stuff]);
+}
+
+my $thing = Thing->construct({ foo => 23, some => 42, baz => 99 });
+$thing->set( foo => "wibble", some => "woosh" );
+is $thing->foo, "wibble";
+is $thing->some, "woosh";
+is $thing->baz, 99;
+
+$thing->discard_changes;
--- /dev/null
+use strict;
+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/testlib';
+ use Film;
+}
+
+plan skip_all => "Object cache is turned off"
+ if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
+
+plan tests => 5;
+
+
+ok +Film->create({
+ Title => 'This Is Spinal Tap',
+ Director => 'Rob Reiner',
+ Rating => 'R',
+});
+
+{
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Marty DiBergi", 'retrieve returns the same object';
+
+ $film1->discard_changes;
+}
+
+{
+ 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;
+}
+
+{
+ Film->nocache(0);
+
+ my $film1 = Film->retrieve( "This Is Spinal Tap" );
+ my $film2 = Film->retrieve( "This Is Spinal Tap" );
+
+ $film1->Director("Marty DiBergi");
+ is $film2->Director, "Marty DiBergi",
+ 'caching back on';
+
+ $film1->discard_changes;
+}
+
+
+{
+ Film->nocache(1);
+
+ local $Class::DBI::Weaken_Is_Available = 0;
+
+ 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",
+ 'CDBI::Weaken_Is_Available turns off all caching';
+
+ $film1->discard_changes;
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+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/testlib';
+ use Film;
+}
+
+for my $title ("Bad Taste", "Braindead", "Forgotten Silver") {
+ Film->insert({ Title => $title, Director => 'Peter Jackson' });
+}
+
+Film->insert({ Title => "Transformers", Director => "Michael Bay"});
+
+{
+ my @films = Film->retrieve_from_sql(qq[director = "Peter Jackson" LIMIT 2]);
+ is @films, 2, "retrieve_from_sql with LIMIT";
+ is( $_->director, "Peter Jackson" ) for @films;
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+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;
+}
+
+use Test::NoWarnings;
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(All => qw[thing_id this that date]);
+}
+
+my $thing = Thing->construct({ thing_id => 23, this => 42 });
+$thing->set( this => undef );
+$thing->discard_changes;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use Test::Exception;
+
+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;
+}
+
+{
+ package Thing;
+
+ use base 'DBIx::Class::Test::SQLite';
+
+ Thing->columns(All => qw[thing_id this that date]);
+}
+
+my $thing = Thing->construct({ thing_id => 23, date => "01-02-1994" });
+my $date = DateTime->now;
+lives_ok {
+ $thing->set( date => $date );
+ $thing->set( date => $date );
+};
+
+
+
+$thing->discard_changes;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+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";
+};
+
+$storage->dbh_do(
+ $test_func,
+ "foo", "bar"
+);
+
+my $storage_class = ref $storage;
+{
+ no strict 'refs';
+ *{$storage_class .'::__test_method'} = $test_func;
+}
+$storage->dbh_do("__test_method", "foo", "bar");
+
+
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+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";
+
+$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
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+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( {
+ artistid => 10,
+ name => "artist number 10",
+ });
+
+ $artist->name("Wibble");
+
+ print "# About to call DESTROY\n";
+ }
+ is_deeply \@warnings, [];
+}
\ No newline at end of file
--- /dev/null
+package # hide from PAUSE
+ DBICNGTest::Schema;
+
+ use Moose;
+ use Path::Class::File;
+ extends 'DBIx::Class::Schema', 'Moose::Object';
+
+
+=head1 NAME
+
+DBICNGTest::Schema; Schema Base For Testing Moose Roles, Traits, etc.
+
+=head1 SYNOPSIS
+
+ my $schema = DBICNGTest::Schema->connect($dsn);
+
+ ## Do anything you would as with a normal $schema object.
+
+=head1 DESCRIPTION
+
+Defines the base case for loading DBIC Schemas. We add in some additional
+helpful functions for administering you schemas. This namespace is dedicated
+to integration of Moose based development practices.
+
+=head1 PACKAGE METHODS
+
+The following is a list of package methods declared with this class.
+
+=head2 load_namespaces
+
+Automatically load the classes and resultsets from their default namespaces.
+
+=cut
+
+__PACKAGE__->load_namespaces(
+ default_resultset_class => 'ResultSet',
+);
+
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This module declares the following methods
+
+=head2 new
+
+overload new to make sure we get a good meta object and that the attributes all
+get properly setup. This is done so that our instances properly get a L<Moose>
+meta class.
+
+=cut
+
+sub new
+{
+ my $class = shift @_;
+ my $obj = $class->SUPER::new(@_);
+
+ return $class->meta->new_object(
+ __INSTANCE__ => $obj, @_
+ );
+}
+
+
+=head2 connect_and_setup
+
+Creates a schema, deploys a database and sets the testing data.
+
+=cut
+
+sub connect_and_setup {
+ my $class = shift @_;
+ my $db_file = shift @_;
+
+ my ($dsn, $user, $pass) = (
+ $ENV{DBICNG_DSN} || "dbi:SQLite:${db_file}",
+ $ENV{DBICNG_USER} || '',
+ $ENV{DBICNG_PASS} || '',
+ );
+
+ return $class
+ ->connect($dsn, $user, $pass, { AutoCommit => 1 })
+ ->setup;
+}
+
+
+=head2 setup
+
+deploy a database and populate it with the initial data
+
+=cut
+
+sub setup {
+ my $self = shift @_;
+ $self->deploy();
+ $self->initial_populate(@_);
+
+ return $self;
+}
+
+
+=head2 initial_populate
+
+initializing the startup database information
+
+=cut
+
+sub initial_populate {
+ my $self = shift @_;
+
+ my @genders = $self->populate('Gender' => [
+ [qw(gender_id label)],
+ [qw(1 female)],
+ [qw(2 male)],
+ [qw(3 transgender)],
+ ]);
+
+ my @persons = $self->populate('Person' => [
+ [ qw(person_id fk_gender_id name age) ],
+ [ qw(1 1 john 25) ],
+ [ qw(2 1 dan 35) ],
+ [ qw(3 2 mary 15) ],
+ [ qw(4 2 jane 95) ],
+ [ qw(5 3 steve 40) ],
+ ]);
+
+ my @friends = $self->populate('FriendList' => [
+ [ qw(fk_person_id fk_friend_id) ],
+ [ qw(1 2) ],
+ [ qw(1 3) ],
+ [ qw(2 3) ],
+ [ qw(3 2) ],
+ ]);
+}
+
+
+=head2 job_handler_echo
+
+This is a method to test the job handler role.
+
+=cut
+
+sub job_handler_echo {
+ my ($schema, $job, $alert) = @_;
+ return $alert;
+}
+
+
+=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;
--- /dev/null
+package # hide from PAUSE
+ DBICNGTest::Schema::Result;
+
+ use Moose;
+ extends 'DBIx::Class', 'Moose::Object';
+
+=head1 NAME
+
+DBICNGTest::Schema::Result; Base Class for result and class objects
+
+=head1 SYNOPSIS
+
+ package DBICNGTest::Schema::Result::Member;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::Result';
+
+ ## Rest of the class definition.
+
+=head1 DESCRIPTION
+
+Defines the base case for loading DBIC Schemas. We add in some additional
+helpful functions for administering you schemas. This namespace is dedicated
+to integration of Moose based development practices
+
+=head1 PACKAGE METHODS
+
+The following is a list of package methods declared with this class.
+
+=head2 load_components
+
+Components to preload.
+
+=cut
+
+__PACKAGE__->load_components(qw/
+ PK::Auto
+ InflateColumn::DateTime
+ Core
+/);
+
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This module declares the following methods
+
+=head2 new
+
+overload new to make sure we get a good meta object and that the attributes all
+get properly setup. This is done so that our instances properly get a L<Moose>
+meta class.
+
+=cut
+
+sub new
+{
+ my $class = shift @_;
+ my $attrs = shift @_;
+
+ my $obj = $class->SUPER::new($attrs);
+
+ return $class->meta->new_object(
+ __INSTANCE__ => $obj, %$attrs
+ );
+}
+
+
+=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;
\ No newline at end of file
--- /dev/null
+package #hide from pause
+ DBICNGTest::Schema::Result::FriendList;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::Result';
+
+
+=head1 NAME
+
+Zoomwit::tlib::DBIC::Schema::Result::FriendList; An example Friends Class;
+
+=head1 VERSION
+
+0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+
+=head1 DESCRIPTION
+
+A Person can have zero or more friends
+A Person can't be their own friend
+A Person over 18 can't be friends with Persons under 18 and vis versa.
+A Person can have friendships that are not mutual.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 PACKAGE METHODS
+
+This module defines the following package methods
+
+=head2 table
+
+Name of the Physical table in the database
+
+=cut
+
+__PACKAGE__
+ ->table('friend_list');
+
+
+=head2 add_columns
+
+Add columns and meta information
+
+=head3 fk_person_id
+
+ID of the person with friends
+
+=head3 fk_friend_id
+
+Who is the friend?
+
+=cut
+
+__PACKAGE__
+ ->add_columns(
+ fk_person_id => {
+ data_type=>'integer',
+ },
+ fk_friend_id => {
+ data_type=>'integer',
+ },
+);
+
+
+=head2 primary_key
+
+Sets the Primary keys for this table
+
+=cut
+
+__PACKAGE__
+ ->set_primary_key(qw/fk_person_id fk_friend_id/);
+
+
+=head2 befriender
+
+The person that 'owns' the friendship (list)
+
+=cut
+
+__PACKAGE__
+ ->belongs_to( befriender => 'DBICNGTest::Schema::Result::Person', {
+ 'foreign.person_id' => 'self.fk_person_id' });
+
+
+=head2 friendee
+
+The actual friend that befriender is listing
+
+=cut
+
+__PACKAGE__
+ ->belongs_to( friendee => 'DBICNGTest::Schema::Result::Person', {
+ 'foreign.person_id' => 'self.fk_friend_id' });
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=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;
--- /dev/null
+package #hide from pause
+ DBICNGTest::Schema::Result::Gender;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::Result';
+
+
+=head1 NAME
+
+DBICNGTest::Schema::Result::Gender; An example Gender Class;
+
+=head1 DESCRIPTION
+
+Tests for this type of FK relationship
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 label
+
+example of using an attribute to add constraints on a table insert
+
+=cut
+
+has 'label' =>(is=>'rw', required=>1, isa=>'Str');
+
+
+=head1 PACKAGE METHODS
+
+This module defines the following package methods
+
+=head2 table
+
+Name of the Physical table in the database
+
+=cut
+
+__PACKAGE__
+ ->table('gender');
+
+
+=head2 add_columns
+
+Add columns and meta information
+
+=head3 gender_id
+
+Primary Key which is an auto generated UUID
+
+=head3 label
+
+Text label of the gender (ie, 'male', 'female', 'transgender', etc.).
+
+=cut
+
+__PACKAGE__
+ ->add_columns(
+ gender_id => {
+ data_type=>'integer',
+ },
+ label => {
+ data_type=>'varchar',
+ size=>12,
+ },
+ );
+
+
+=head2 primary_key
+
+Sets the Primary keys for this table
+
+=cut
+
+__PACKAGE__
+ ->set_primary_key(qw/gender_id/);
+
+
+=head2
+
+Marks the unique columns
+
+=cut
+
+__PACKAGE__
+ ->add_unique_constraint('gender_label_unique' => [ qw/label/ ]);
+
+
+=head2 people
+
+A resultset of people with this gender
+
+=cut
+
+__PACKAGE__
+ ->has_many(
+ people => 'DBICNGTest::Schema::Result::Person',
+ {'foreign.fk_gender_id' => 'self.gender_id'}
+ );
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=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;
--- /dev/null
+package #hide from pause
+ DBICNGTest::Schema::Result::Person;
+
+ use Moose;
+ use DateTime;
+ extends 'DBICNGTest::Schema::Result';
+
+
+=head1 NAME
+
+DBICNGTest::Schema::Result::Person; An example Person Class;
+
+=head1 DESCRIPTION
+
+Tests for this type of FK relationship
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 created
+
+attribute for the created column
+
+=cut
+
+has 'created' => (
+ is=>'ro',
+ isa=>'DateTime',
+ required=>1,
+ default=>sub {
+ DateTime->now;
+ },
+);
+
+
+=head1 PACKAGE METHODS
+
+This module defines the following package methods
+
+=head2 table
+
+Name of the Physical table in the database
+
+=cut
+
+__PACKAGE__
+ ->table('person');
+
+
+=head2 add_columns
+
+Add columns and meta information
+
+=head3 person_id
+
+Primary Key which is an auto generated autoinc
+
+=head3 fk_gender_id
+
+foreign key to the Gender table
+
+=head3 name
+
+Just an ordinary name
+
+=head3 age
+
+The person's age
+
+head3 created
+
+When the person was added to the database
+
+=cut
+
+__PACKAGE__
+ ->add_columns(
+ person_id => {
+ data_type=>'integer',
+ },
+ fk_gender_id => {
+ data_type=>'integer',
+ },
+ name => {
+ data_type=>'varchar',
+ size=>32,
+ },
+ age => {
+ data_type=>'integer',
+ default_value=>25,
+ },
+ created => {
+ data_type=>'datetime',
+ default_value=>'date("now")',
+ });
+
+
+=head2 primary_key
+
+Sets the Primary keys for this table
+
+=cut
+
+__PACKAGE__
+ ->set_primary_key(qw/person_id/);
+
+
+=head2 friendlist
+
+Each Person might have a resultset of friendlist
+
+=cut
+
+__PACKAGE__
+ ->has_many(
+ friendlist => 'DBICNGTest::Schema::Result::FriendList',
+ {'foreign.fk_person_id' => 'self.person_id'});
+
+
+=head2 gender
+
+This person's gender
+
+=cut
+
+__PACKAGE__
+ ->belongs_to( gender => 'DBICNGTest::Schema::Result::Gender', {
+ 'foreign.gender_id' => 'self.fk_gender_id' });
+
+
+=head2 fanlist
+
+A resultset of the people listing me as a friend (if any)
+
+=cut
+
+__PACKAGE__
+ ->belongs_to( fanlist => 'DBICNGTest::Schema::Result::FriendList', {
+ 'foreign.fk_friend_id' => 'self.person_id' });
+
+
+=head2 friends
+
+A resultset of Persons who are in my FriendList
+
+=cut
+
+__PACKAGE__
+ ->many_to_many( friends => 'friendlist', 'friend' );
+
+
+=head2 fans
+
+A resultset of people that have me in their friendlist
+
+=cut
+
+__PACKAGE__
+ ->many_to_many( fans => 'fanlist', 'befriender' );
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=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;
--- /dev/null
+package # hide from PAUSE
+ DBICNGTest::Schema::ResultSet;
+
+ use Moose;
+ extends 'DBIx::Class::ResultSet', 'Moose::Object';
+
+=head1 NAME
+
+DBICNGTest::Schema::ResultSet; A base ResultSet Class
+
+=head1 SYNOPSIS
+
+ package DBICNGTest::Schema::ResultSet::Member;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::ResultSet';
+
+ ## Rest of the class definition.
+
+=head1 DESCRIPTION
+
+All ResultSet classes will inherit from this. This provides some base function
+for all your resultsets and it is also the default resultset if you don't
+bother to declare a custom resultset in the resultset namespace
+
+=head1 PACKAGE METHODS
+
+The following is a list of package methods declared with this class.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This module declares the following methods
+
+=head2 new
+
+overload new to make sure we get a good meta object and that the attributes all
+get properly setup. This is done so that our instances properly get a L<Moose>
+meta class.
+
+=cut
+
+sub new
+{
+ my $class = shift @_;
+ my $obj = $class->SUPER::new(@_);
+
+ return $class->meta->new_object(
+ __INSTANCE__ => $obj, @_
+ );
+}
+
+
+=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;
\ No newline at end of file
--- /dev/null
+package # hide from pause
+ DBICNGTest::Schema::ResultSet::Person;
+
+ use Moose;
+ extends 'DBICNGTest::Schema::ResultSet';
+
+
+=head1 NAME
+
+DBICNGTest::Schema::ResultSet:Person; Example Resultset
+
+=head1 VERSION
+
+0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+
+=head1 SYNOPSIS
+
+ ##Example Usage
+
+See Tests for more example usage.
+
+=head1 DESCRIPTION
+
+Resultset Methods for the Person Source
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 literal
+
+a literal attribute for testing
+
+=cut
+
+has 'literal' => (is=>'ro', isa=>'Str', required=>1, lazy=>1, default=>'hi');
+
+
+=head2 available_genders
+
+A resultset of the genders people can have. Keep in mind this get's run once
+only at the first compile, so it's only good for stuff that doesn't change
+between reboots.
+
+=cut
+
+has 'available_genders' => (
+ is=>'ro',
+ isa=>'DBICNGTest::Schema::ResultSet',
+ required=>1,
+ lazy=>1,
+ default=> sub {
+ shift
+ ->result_source
+ ->schema
+ ->resultset('Gender');
+ }
+);
+
+
+=head1 METHODS
+
+This module defines the following methods.
+
+=head2 older_than($int)
+
+Only people over a given age
+
+=cut
+
+sub older_than
+{
+ my ($self, $age) = @_;
+
+ return $self->search({age=>{'>'=>$age}});
+}
+
+
+=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;
=cut
-sub init_schema {
+sub _database {
my $self = shift;
- my %args = @_;
my $db_file = "t/var/DBIxClass.db";
unlink($db_file) if -e $db_file;
my $dbuser = $ENV{"DBICTEST_DBUSER"} || '';
my $dbpass = $ENV{"DBICTEST_DBPASS"} || '';
- my $schema = DBICTest::Schema->compose_namespace('DBICTest')
- ->connect($dsn, $dbuser, $dbpass);
- $schema->storage->on_connect_do(['PRAGMA synchronous = OFF']);
+ my @connect_info = ($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
+
+ return @connect_info;
+}
+
+sub init_schema {
+ my $self = shift;
+ my %args = @_;
+
+ my $schema;
+
+ if ($args{compose_connection}) {
+ $schema = DBICTest::Schema->compose_connection(
+ 'DBICTest', $self->_database
+ );
+ } else {
+ $schema = DBICTest::Schema->compose_namespace('DBICTest');
+ }
+ if ( !$args{no_connect} ) {
+ $schema = $schema->connect($self->_database);
+ $schema->storage->on_connect_do(['PRAGMA synchronous = OFF']);
+ }
if ( !$args{no_deploy} ) {
__PACKAGE__->deploy_schema( $schema );
__PACKAGE__->populate_schema( $schema ) if( !$args{no_populate} );
my $dsn = "dbi:SQLite:${db_file}";
__PACKAGE__->load_classes("Test");
-my $schema = __PACKAGE__->compose_connection(__PACKAGE__, $dsn);
+my $schema = __PACKAGE__->compose_connection(
+ __PACKAGE__,
+ $dsn,
+ undef,
+ undef,
+ { AutoCommit => 1 }
+);
my $dbh = DBI->connect($dsn);
__PACKAGE__->load_classes(qw/
Artist
+ SequenceTest
Employee
CD
+ FileColumn
Link
Bookmark
#dummy
'Producer',
'CD_to_Producer',
),
- qw/SelfRefAlias TreeLike TwoKeyTreeLike Event NoPrimaryKey/,
- qw/Collection CollectionObject TypedObject/,
- qw/Owners BooksInLibrary/
+ qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/,
+ qw/Collection CollectionObject TypedObject Owners BooksInLibrary/,
+ qw/ForceForeign/,
);
+sub sqlt_deploy_hook {
+ my ($self, $sqlt_schema) = @_;
+
+ $sqlt_schema->drop_table('dummy');
+}
+
1;
__PACKAGE__->add_columns(
'artistid' => {
data_type => 'integer',
- is_auto_increment => 1
+ is_auto_increment => 1,
},
'name' => {
data_type => 'varchar',
cds => 'DBICTest::Schema::CD', undef,
{ order_by => 'year' },
);
+__PACKAGE__->has_many(
+ cds_unordered => 'DBICTest::Schema::CD'
+);
__PACKAGE__->has_many( twokeys => 'DBICTest::Schema::TwoKeys' );
__PACKAGE__->has_many( onekeys => 'DBICTest::Schema::OneKey' );
{ cascade_copy => 0 } # this would *so* not make sense
);
+sub sqlt_deploy_hook {
+ my ($self, $sqlt_table) = @_;
+
+
+ if ($sqlt_table->schema->translator->producer_type =~ /SQLite$/ ) {
+ $sqlt_table->add_index( name => 'artist_name', fields => ['name'] )
+ or die $sqlt_table->error;
+ }
+}
+
1;
DBICTest::Schema::ArtistSourceName;
use base 'DBICTest::Schema::Artist';
-
+__PACKAGE__->table(__PACKAGE__->table);
__PACKAGE__->source_name('SourceNameArtists');
1;
__PACKAGE__->set_primary_key('cdid');
__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
-__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' );
+__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, { is_deferrable => 1 } );
__PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track' );
__PACKAGE__->has_many(
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::Dummy;
+
+use base 'DBIx::Class::Core';
+
+use strict;
+use warnings;
+
+__PACKAGE__->table('dummy');
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1
+ },
+ 'gittery' => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+__PACKAGE__->set_primary_key('id');
+
+1;
data_type => 'integer',
is_nullable => 1,
},
+ group_id_2 => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
name => {
data_type => 'varchar',
size => 100,
--- /dev/null
+package DBICTest::Schema::EventTZ;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->load_components(qw/InflateColumn::DateTime/);
+
+__PACKAGE__->table('event');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago" } },
+ created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago" } },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
--- /dev/null
+package
+DBICTest::Schema::FileColumn;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Core/;
+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;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::ForceForeign;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('forceforeign');
+__PACKAGE__->add_columns(
+ 'artist' => { data_type => 'integer' },
+ 'cd' => { data_type => 'integer' },
+);
+__PACKAGE__->set_primary_key(qw/artist/);
+
+# Normally this would not appear as a FK constraint
+# since it uses the PK
+__PACKAGE__->might_have(
+ 'artist_1', 'DBICTest::Schema::Artist', {
+ 'foreign.artist_id' => 'self.artist',
+ }, {
+ is_foreign_key_constraint => 1,
+ },
+);
+
+# Normally this would appear as a FK constraint
+__PACKAGE__->might_have(
+ 'cd_1', 'DBICTest::Schema::CD', {
+ 'foreign.cdid' => 'self.cd',
+ }, {
+ is_foreign_key_constraint => 0,
+ },
+);
+
+1;
__PACKAGE__->set_primary_key(qw/foo bar hello goodbye/);
__PACKAGE__->has_many(
- 'fourkeys_to_twokeys', '__PACKAGE___to_TwoKeys', {
+ 'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
'foreign.f_foo' => 'self.foo',
'foreign.f_bar' => 'self.bar',
'foreign.f_hello' => 'self.hello',
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::SequenceTest;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('sequence_test');
+__PACKAGE__->source_info({
+ "source_info_key_A" => "source_info_value_A",
+ "source_info_key_B" => "source_info_value_B",
+ "source_info_key_C" => "source_info_value_C",
+ "source_info_key_D" => "source_info_value_D",
+});
+__PACKAGE__->add_columns(
+ 'pkid1' => {
+ data_type => 'integer',
+ auto_nextval => 1,
+ sequence => 'pkid1_seq',
+ },
+ 'pkid2' => {
+ data_type => 'integer',
+ auto_nextval => 1,
+ sequence => 'pkid2_seq',
+ },
+ 'nonpkid' => {
+ data_type => 'integer',
+ auto_nextval => 1,
+ sequence => 'nonpkid_seq',
+ },
+ 'name' => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+__PACKAGE__->set_primary_key('pkid1', 'pkid2');
+
+1;
DBICTest::Schema::Track;
use base 'DBIx::Class::Core';
+__PACKAGE__->load_components(qw/InflateColumn::DateTime/);
__PACKAGE__->table('track');
__PACKAGE__->add_columns(
data_type => 'varchar',
size => 100,
},
+ last_updated_on => {
+ data_type => 'datetime',
+ accessor => 'updated_date',
+ is_nullable => 1
+ },
);
__PACKAGE__->set_primary_key('trackid');
__PACKAGE__->set_primary_key(qw/artist cd/);
__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' );
-__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD' );
+__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { is_deferrable => 0, add_fk_index => 0 } );
__PACKAGE__->has_many(
'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
--- /dev/null
+package DBICTest::Stats;
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::Statistics/;
+
+sub txn_begin {
+ my $self = shift;
+
+ $self->{'TXN_BEGIN'}++;
+ return $self->{'TXN_BEGIN'};
+}
+
+sub txn_rollback {
+ my $self = shift;
+
+ $self->{'TXN_ROLLBACK'}++;
+ return $self->{'TXN_ROLLBACK'};
+}
+
+sub txn_commit {
+ my $self = shift;
+
+ $self->{'TXN_COMMIT'}++;
+ return $self->{'TXN_COMMIT'};
+}
+
+sub svp_begin {
+ my ($self, $name) = @_;
+
+ $self->{'SVP_BEGIN'}++;
+ return $self->{'SVP_BEGIN'};
+}
+
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->{'SVP_RELEASE'}++;
+ return $self->{'SVP_RELEASE'};
+}
+
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->{'SVP_ROLLBACK'}++;
+ return $self->{'SVP_ROLLBACK'};
+}
+
+sub query_start {
+ my ($self, $string, @bind) = @_;
+
+ $self->{'QUERY_START'}++;
+ return $self->{'QUERY_START'};
+}
+
+sub query_end {
+ my ($self, $string) = @_;
+
+ $self->{'QUERY_END'}++;
+ return $self->{'QUERY_START'};
+}
+
+1;
--- /dev/null
+package DBICErrorTest::SyntaxError;
+
+use strict;
+
+I'm a syntax error!
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
+ 'is_nullable' => 0,
+ 'size' => '10'
+ },
+ 'NewVersionName' => {
+ 'data_type' => 'VARCHAR',
+ 'is_auto_increment' => 0,
+ 'default_value' => undef,
+ 'is_foreign_key' => 0,
'is_nullable' => 1,
'size' => '20'
- },
+ }
);
__PACKAGE__->set_primary_key('Version');
__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/';
-}
+#sub upgrade_directory
+#{
+# return 't/var/';
+#}
1;
employee_id INTEGER PRIMARY KEY NOT NULL,
position integer NOT NULL,
group_id integer,
+ group_id_2 integer,
name varchar(100)
);
trackid INTEGER PRIMARY KEY NOT NULL,
cd integer NOT NULL,
position integer NOT NULL,
- title varchar(100) NOT NULL
+ title varchar(100) NOT NULL,
+ last_updated_on datetime NULL
);
--
);
--
+-- Table: file_columns
+--
+CREATE TABLE file_columns (
+ id INTEGER PRIMARY KEY NOT NULL,
+ file varchar(255)
+);
+
+--
-- Table: tags
--
CREATE TABLE tags (
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 2;
+
+my $bookmark = $schema->resultset("Bookmark")->find(1);
+my $link = $bookmark->link;
+my $link_id = $link->id;
+
+my $new_link = $schema->resultset("Link")->new({
+ id => 42,
+ url => "http://monstersarereal.com",
+ title => "monstersarereal.com"
+});
+
+# Changing a relationship by id rather than by object would cause
+# old related_resultsets to be used.
+$bookmark->link($new_link->id);
+is $bookmark->link->id, $new_link->id;
+
+$bookmark->update;
+is $bookmark->link->id, $new_link->id;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 3;
+
+my $bookmark = $schema->resultset("Bookmark")->find(1);
+my $link = $bookmark->link;
+my $link_id = $link->id;
+ok $link->id;
+
+$link->delete;
+is $schema->resultset("Link")->search(id => $link_id)->count, 0,
+ "link $link_id was deleted";
+
+# Get a fresh object with nothing cached
+$bookmark = $schema->resultset("Bookmark")->find($bookmark->id);
+
+# This would create a new link row if none existed
+$bookmark->link;
+
+is $schema->resultset("Link")->search(id => $link_id)->count, 0,
+ 'accessor did not create a link object where there was none';
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use Class::Inspector ();
+
+unshift(@INC, './t/lib');
+use lib 't/lib';
+plan tests => 5;
+
+use DBICTest;
+
+is(DBICTest::Schema->source('Artist')->resultset_class, 'DBIx::Class::ResultSet', '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');
+is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set');
+
+my $schema = DBICTest->init_schema;
+my $resultset = $schema->resultset('Artist')->search;
+isa_ok($resultset, 'DBICNSTest::ResultSet::A', 'resultset is custom class');
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 6;
+
+{
+ my $rs = $schema->resultset("CD")->search({});
+
+ ok $rs->count;
+ is $rs, $rs->count, "resultset as number with results";
+ ok $rs, "resultset as boolean always true";
+}
+
+{
+ 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
__PACKAGE__->columns(TEMP => qw/ nonpersistent /);
__PACKAGE__->add_constructor(salary_between => 'salary >= ? AND salary <= ?');
-sub mutator_name { "set_$_[1]" }
+sub mutator_name_for { "set_$_[1]" }
sub create_sql {
return qq{
MyBase;
use strict;
-use base qw(DBIx::Class);
+use base qw(DBIx::Class::CDBICompat);
+
+use DBI;
use vars qw/$dbh/;
inflate => sub { Date::Simple->new(shift) },
deflate => 'format',
);
-__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)");
+#__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)");
sub create_sql {
return qq{
--- /dev/null
+package OtherThing;
+use base 'DBIx::Class::Test::SQLite';
+
+OtherThing->set_table("other_thing");
+OtherThing->columns(All => qw(id));
+
+sub create_sql {
+ return qq{
+ id INTEGER
+ };
+}
PgBase;
use strict;
-use base 'DBIx::Class';
+use base 'DBIx::Class::CDBICompat';
my $db = $ENV{DBD_PG_DBNAME} || 'template1';
my $user = $ENV{DBD_PG_USER} || 'postgres';
--- /dev/null
+package Thing;
+use base 'DBIx::Class::Test::SQLite';
+
+Thing->set_table("thing");
+Thing->columns(All => qw(id that_thing));
+
+sub create_sql {
+ return qq{
+ id INTEGER,
+ that_thing INTEGER
+ };
+}
+
+1;
projects / dbsrgits/DBIx-Class.git / commitdiff