Revision history for DBIx::Class
-
+0.08118 2010-02-08 11:53:00 (UTC)
+ - Fix a bug causing UTF8 columns not to be decoded (RT#54395)
+ - Fix bug in One->Many->One prefetch-collapse handling (RT#54039)
+ - Cleanup handling of relationship accessor types
+
+0.08117 2010-02-05 17:10:00 (UTC)
+ - Perl 5.8.1 is now the minimum supported version
+ - Massive optimization of the join resolution code - now joins
+ will be removed from the resulting SQL if DBIC can prove they
+ are not referenced by anything
+ - Subqueries no longer marked experimental
+ - Support for Informix RDBMS (limit/offset and auto-inc columns)
+ - Support for Sybase SQLAnywhere, both native and via ODBC
+ - might_have/has_one now warn if applied calling class's column
+ has is_nullable set to true.
+ - Fixed regression in deploy() with a {sources} table limit applied
+ (RT#52812)
+ - Views without a view_definition will throw an exception when
+ parsed by SQL::Translator::Parser::DBIx::Class
+ - Stop the SQLT parser from auto-adding indexes identical to the
+ Primary Key
+ - InflateColumn::DateTime refactoring to allow fine grained method
+ overloads
+ - Fix ResultSetColumn improperly selecting more than the requested
+ column when +columns/+select is present
+ - Fix failure when update/delete of resultsets with complex WHERE
+ SQLA structures
+ - Fix regression in context sensitiveness of deployment_statements
+ - Fix regression resulting in overcomplicated query on
+ search_related from prefetching resultsets
+ - Fix regression on all-null returning searches (properly switch
+ LEFT JOIN to JOIN in order to distinguish between both cases)
+ - Fix regression in groupedresultset count() used on strict-mode
+ MySQL connections
+ - Better isolation of RNO-limited queries from the rest of a
+ prefetching resultset
+ - New MSSQL specific resultset attribute to allow hacky ordered
+ subquery support
+ - Fix nasty schema/dbhandle leak due to SQL::Translator
+ - Initial implementation of a mechanism for Schema::Version to
+ apply multiple step upgrades
+ - Fix regression on externally supplied $dbh with AutoCommit=0
+ - FAQ "Custom methods in Result classes"
+ - Cookbook POD fix for add_drop_table instead of add_drop_tables
+ - Schema POD improvement for dclone
+
+0.08115 2009-12-10 09:02:00 (CST)
+ - Real limit/offset support for MSSQL server (via Row_Number)
+ - Fix distinct => 1 with non-selecting order_by (the columns
+ in order_by also need to be aded to the resulting group_by)
+ - Do not attempt to deploy FK constraints pointing to a View
+ - Fix count/objects from search_related on limited resultset
+ - Stop propagating distinct => 1 over search_related chains
+ - Make sure populate() inherits the resultset conditions just
+ like create() does
+ - Make get_inflated_columns behave identically to get_columns
+ wrt +select/+as (RT#46953)
+ - Fix problems with scalarrefs under InflateColumn (RT#51559)
+ - Throw exception on delete/update of PK-less resultsets
+ - Refactored Sybase storage driver into a central ::DBI::Sybase
+ dispatcher, and a sybase-specific ::DBI::Sybase::ASE
+ - Fixed an atrocious DBD::ADO bind-value bug
+ - Cookbook/Intro POD improvements
+
+0.08114 2009-11-14 17:45:00 (UTC)
+ - Preliminary support for MSSQL via DBD::ADO
+ - Fix botched 0.08113 release (invalid tarball)
+
+0.08113 2009-11-13 23:13:00 (UTC)
+ - Fix populate with has_many bug
+ (RT #50828)
+ - Fix Oracle autoincrement broken for Resultsets with scalar refs
+ (RT #50874)
- Complete Sybase RDBMS support including:
- Support for TEXT/IMAGE columns
- Support for the 'money' datatype
- Support for interpolated variables with proper quoting when
connecting to an older Sybase and/or via FreeTDS
- bulk API support for populate()
+ - Transaction support for MSSQL via DBD::Sybase
- Add is_paged method to DBIx::Class::ResultSet so that we can
check that if we want a pager
- Skip versioning test on really old perls lacking Time::HiRes
- Fixed on_connect_do/call regression when used with a coderef
connector (RT #50003)
- A couple of fixes to Ordered to remedy subclassing issues
+ - Fixed another lingering problem with PostgreSQL
+ auto-increment support and its interaction with multiple
+ schemas
+ - Remove some IN workarounds, and require a recent version of
+ SQLA instead
+ - Improvements to populate's handling of mixed scalarref values
+ - Fixed regression losing result_class after $rs->find (introduced
+ in 0.08108)
+ - Fix in_storage() to return 1|0 as per existing documentation
+ - Centralize handling of _determine_driver calls prior to certain
+ ::Storage::DBI methods
+ - Fix update/delete arbitrary condition handling (RT#51409)
+ - POD improvements
0.08112 2009-09-21 10:57:00 (UTC)
- Remove the recommends from Makefile.PL, DBIx::Class is not
use warnings;
use POSIX ();
-use 5.006001; # delete this line if you want to send patches for earlier.
+use 5.008001;
# ****** DO NOT ADD OPTIONAL DEPENDENCIES. EVER. --mst ******
name 'DBIx-Class';
-perl_version '5.006001';
+perl_version '5.008001';
all_from 'lib/DBIx/Class.pm';
requires 'Scalar::Util' => '0';
requires 'Storable' => '0';
-# Perl 5.8.0 doesn't have utf8::is_utf8()
-requires 'Encode' => '0' if ($] <= 5.008000);
-
# Dependencies (keep in alphabetical order)
requires 'Carp::Clan' => '6.0';
-requires 'Class::Accessor::Grouped' => '0.09000';
+requires 'Class::Accessor::Grouped' => '0.09002';
requires 'Class::C3::Componentised' => '1.0005';
requires 'Class::Inspector' => '1.24';
requires 'Data::Page' => '2.00';
requires 'DBD::SQLite' => '1.25';
-requires 'DBI' => '1.605';
+requires 'DBI' => '1.609';
requires 'JSON::Any' => '1.18';
requires 'MRO::Compat' => '0.09';
requires 'Module::Find' => '0.06';
requires 'Path::Class' => '0.16';
requires 'Scope::Guard' => '0.03';
-requires 'SQL::Abstract' => '1.60';
+requires 'SQL::Abstract' => '1.61';
requires 'SQL::Abstract::Limit' => '0.13';
requires 'Sub::Name' => '0.04';
requires 'Data::Dumper::Concise' => '1.000';
my %replication_requires = (
- 'Moose', => '0.87',
- 'MooseX::AttributeHelpers' => '0.21',
- 'MooseX::Types', => '0.16',
+ 'Moose', => '0.90',
+ 'MooseX::Types', => '0.21',
'namespace::clean' => '0.11',
'Hash::Merge', => '0.11',
);
# when changing also adjust version in t/02pod.t
'Test::Pod' => '1.26',
+ # when changing also adjust version in t/06notabs.t
+# 'Test::NoTabs' => '0.9',
+
+ # when changing also adjust version in t/07eol.t
+# 'Test::EOL' => '0.6',
+
# when changing also adjust version in t/03podcoverage.t
'Test::Pod::Coverage' => '1.08',
'Pod::Coverage' => '0.20',
) : ()
,
- $ENV{DBICTEST_ORACLE_DSN}
+ $ENV{DBICTEST_ORA_DSN}
? (
'DateTime::Format::Oracle' => '0',
) : ()
'DateTime::Format::Sybase' => 0,
) : ()
,
+ grep $_, @ENV{qw/DBICTEST_SYBASE_ASA_DSN DBICTEST_SYBASE_ASA_ODBC_DSN/}
+ ? (
+ 'DateTime::Format::Strptime' => 0,
+ ) : ()
+ ,
);
#************************************************************************#
# Make ABSOLUTELY SURE that nothing on the list above is a real require, #
resources 'repository' => 'http://dev.catalyst.perl.org/repos/bast/DBIx-Class/';
resources 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class';
-no_index 'DBIx::Class::Storage::DBI::Sybase::Common';
-no_index 'DBIx::Class::SQLAHacks';
-no_index 'DBIx::Class::SQLAHacks::MSSQL';
-no_index 'DBIx::Class::Storage::DBI::AmbiguousGlob';
-no_index 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server';
-no_index 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars';
+# Deprecated/internal modules need no exposure
+no_index directory => $_ for (qw|
+ lib/DBIx/Class/SQLAHacks
+ lib/DBIx/Class/PK/Auto
+|);
+no_index package => $_ for (qw/
+ DBIx::Class::Storage::DBI::AmbiguousGlob
+ DBIx::Class::SQLAHacks DBIx::Class::Storage::DBIHacks
+/);
# re-build README and require extra modules for testing if we're in a checkout
# Re-write META.yml to _exclude_ all forced requires (we do not want to ship this)
if ($Module::Install::AUTHOR) {
- Meta->{values}{build_requires} = [ grep
+ Meta->{values}{build_requires} = [ grep
{ not exists $force_requires_if_author{$_->[0]} }
( @{Meta->{values}{build_requires}} )
];
package MyDatabase::Main::Result::Artist;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+
+use warnings;
+use strict;
+
+use base qw/DBIx::Class::Core/;
+
__PACKAGE__->table('artist');
+
__PACKAGE__->add_columns(qw/ artistid name /);
+
__PACKAGE__->set_primary_key('artistid');
+
__PACKAGE__->has_many('cds' => 'MyDatabase::Main::Result::Cd');
1;
package MyDatabase::Main::Result::Cd;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+
+use warnings;
+use strict;
+
+use base qw/DBIx::Class::Core/;
+
__PACKAGE__->table('cd');
+
__PACKAGE__->add_columns(qw/ cdid artist title/);
+
__PACKAGE__->set_primary_key('cdid');
+
__PACKAGE__->belongs_to('artist' => 'MyDatabase::Main::Result::Artist');
__PACKAGE__->has_many('tracks' => 'MyDatabase::Main::Result::Track');
package MyDatabase::Main::Result::Track;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+
+use warnings;
+use strict;
+
+use base qw/DBIx::Class::Core/;
+
__PACKAGE__->table('track');
+
__PACKAGE__->add_columns(qw/ trackid cd title/);
+
__PACKAGE__->set_primary_key('trackid');
+
__PACKAGE__->belongs_to('cd' => 'MyDatabase::Main::Result::Cd');
1;
use warnings;
use MRO::Compat;
+use mro 'c3';
use vars qw($VERSION);
-use base qw/Class::C3::Componentised Class::Accessor::Grouped/;
+use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
use DBIx::Class::StartupCheck;
sub mk_classdata {
# Always remember to do all digits for the version even if they're 0
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-$VERSION = '0.08112';
+$VERSION = '0.08118_01';
$VERSION = eval $VERSION; # numify for warning-free dev releases
See L<DBIx::Class::ResultSource> for docs on defining result classes.
package MyDB::Schema::Result::Artist;
- use base qw/DBIx::Class/;
+ use base qw/DBIx::Class::Core/;
- __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/ artistid name /);
__PACKAGE__->set_primary_key('artistid');
MyDB/Schema/Result/CD.pm:
package MyDB::Schema::Result::CD;
- use base qw/DBIx::Class/;
+ use base qw/DBIx::Class::Core/;
- __PACKAGE__->load_components(qw/Core/);
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
__PACKAGE__->table('cd');
__PACKAGE__->add_columns(qw/ cdid artistid title year /);
__PACKAGE__->set_primary_key('cdid');
my $all_artists_rs = $schema->resultset('Artist');
# Output all artists names
- # $artist here is a DBIx::Class::Row, which has accessors
+ # $artist here is a DBIx::Class::Row, which has accessors
# for all its columns. Rows are also subclasses of your Result class.
- foreach $artist (@artists) {
+ foreach $artist (@all_artists) {
print $artist->name, "\n";
}
bluefeet: Aran Deltac <bluefeet@cpan.org>
+boghead: Bryan Beeley <cpan@beeley.org>
+
bricas: Brian Cassidy <bricas@cpan.org>
brunov: Bruno Vecchi <vecchi.b@gmail.com>
jguenther: Justin Guenther <jguenther@cpan.org>
+jhannah: Jay Hannah <jay@jays.net>
+
jnapiorkowski: John Napiorkowski <jjn1056@yahoo.com>
jon: Jon Schutz <jjschutz@cpan.org>
Numa: Dan Sully <daniel@cpan.org>
+ovid: Curtis "Ovid" Poe <ovid@cpan.org>
+
oyse: Øystein Torget <oystein.torget@dnv.com>
paulm: Paul Makepeace
rdj: Ryan D Johnson <ryan@innerfence.com>
-ribasushi: Peter Rabbitson <rabbit+dbic@rabbit.us>
+ribasushi: Peter Rabbitson <ribasushi@cpan.org>
rjbs: Ricardo Signes <rjbs@cpan.org>
robkinyon: Rob Kinyon <rkinyon@cpan.org>
+Roman: Roman Filippov <romanf@cpan.org>
+
sc_: Just Another Perl Hacker
scotty: Scotty Allen <scotty@scottyallen.com>
This class now exists in its own right on CPAN as Class::Accessor::Grouped
-1;
-
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
use base qw(DBIx::Class::CDBICompat::ImaDBI);
+use Sub::Name();
+
use strict;
use warnings;
return carp("$method already exists in $class")
if *$meth{CODE};
- *$meth = sub {
+ *$meth = Sub::Name::subname $meth => sub {
my $self = shift;
$self->sth_to_objects($self->sql_Retrieve($fragment), \@_);
};
use strict;
use warnings;
-###
-# Keep this class for backwards compatibility
-###
-
use base 'Class::C3::Componentised';
+use Carp::Clan qw/^DBIx::Class|^Class::C3::Componentised/;
+use mro 'c3';
+
+# this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
+sub inject_base {
+ my $class = shift;
+ my $target = shift;
+
+ my @present_components = (@{mro::get_linear_isa ($target)||[]});
+
+ no strict 'refs';
+ for my $comp (reverse @_) {
+
+ if ($comp->isa ('DBIx::Class::UTF8Columns') ) {
+ require B;
+ my @broken;
+
+ for (@present_components) {
+ my $cref = $_->can ('store_column')
+ or next;
+ push @broken, $_ if B::svref_2object($cref)->STASH->NAME ne 'DBIx::Class::Row';
+ }
+
+ carp "Incorrect loading order of $comp by ${target} will affect other components overriding store_column ("
+ . join (', ', @broken)
+ .'). Refer to the documentation of DBIx::Class::UTF8Columns for more info'
+ if @broken;
+ }
+
+ unshift @present_components, $comp;
+ }
+
+ $class->next::method($target, @_);
+}
1;
use strict;
use warnings;
-no warnings 'qw';
use base qw/DBIx::Class/;
PK::Auto
PK
Row
- ResultSourceProxy::Table/);
+ ResultSourceProxy::Table
+/);
1;
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/Core/);
+ # In your result (table) classes
+ use base 'DBIx::Class::Core';
=head1 DESCRIPTION
$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' => [$self->column_info($col)->{accessor} || $col, $col]);
+ my $acc = $self->column_info($col)->{accessor};
+ $self->mk_group_accessors('inflated_column' => [ (defined $acc ? $acc : $col), $col]);
return 1;
}
unless exists $self->column_info($col)->{_inflate_info};
return $self->{_inflated_column}{$col}
if exists $self->{_inflated_column}{$col};
- return $self->{_inflated_column}{$col} =
- $self->_inflated_column($col, $self->get_column($col));
+
+ my $val = $self->get_column($col);
+ return $val if ref $val eq 'SCALAR'; #that would be a not-yet-reloaded sclarref update
+
+ return $self->{_inflated_column}{$col} = $self->_inflated_column($col, $val);
}
=head2 set_inflated_column
=over 4
=item L<DBIx::Class::Core> - This component is loaded as part of the
- "core" L<DBIx::Class> components; generally there is no need to
+ C<core> L<DBIx::Class> components; generally there is no need to
load it directly
=back
columns to be of the datetime, timestamp or date datatype.
package Event;
- __PACKAGE__->load_components(qw/InflateColumn::DateTime Core/);
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
__PACKAGE__->add_columns(
starts_when => { data_type => 'datetime' }
create_date => { data_type => 'date' }
);
-NOTE: You B<must> load C<InflateColumn::DateTime> B<before> C<Core>. See
-L<DBIx::Class::Manual::Component> for details.
-
Then you can treat the specified column as a L<DateTime> object.
print "This event starts the month of ".
}
}
- my $timezone;
if ( defined $info->{extra}{timezone} ) {
carp "Putting timezone into extra => { timezone => '...' } has been deprecated, ".
"please put it directly into the '$column' column definition.";
- $timezone = $info->{extra}{timezone};
+ $info->{timezone} = $info->{extra}{timezone} unless defined $info->{timezone};
}
- my $locale;
if ( defined $info->{extra}{locale} ) {
carp "Putting locale into extra => { locale => '...' } has been deprecated, ".
"please put it directly into the '$column' column definition.";
- $locale = $info->{extra}{locale};
+ $info->{locale} = $info->{extra}{locale} unless defined $info->{locale};
}
- $locale = $info->{locale} if defined $info->{locale};
- $timezone = $info->{timezone} if defined $info->{timezone};
-
my $undef_if_invalid = $info->{datetime_undef_if_invalid};
if ($type eq 'datetime' || $type eq 'date' || $type eq 'timestamp') {
$self->throw_exception ("Error while inflating ${value} for ${column} on ${self}: $err");
}
- $dt->set_time_zone($timezone) if $timezone;
- $dt->set_locale($locale) if $locale;
- return $dt;
+ return $obj->_post_inflate_datetime( $dt, \%info );
},
deflate => sub {
my ($value, $obj) = @_;
- if ($timezone) {
- carp "You're using a floating timezone, please see the documentation of"
- . " DBIx::Class::InflateColumn::DateTime for an explanation"
- if ref( $value->time_zone ) eq 'DateTime::TimeZone::Floating'
- and not $info{floating_tz_ok}
- and not $ENV{DBIC_FLOATING_TZ_OK};
- $value->set_time_zone($timezone);
- $value->set_locale($locale) if $locale;
- }
+
+ $value = $obj->_pre_deflate_datetime( $value, \%info );
$obj->_deflate_from_datetime( $value, \%info );
},
}
shift->result_source->storage->datetime_parser (@_);
}
+sub _post_inflate_datetime {
+ my( $self, $dt, $info ) = @_;
+
+ $dt->set_time_zone($info->{timezone}) if defined $info->{timezone};
+ $dt->set_locale($info->{locale}) if defined $info->{locale};
+
+ return $dt;
+}
+
+sub _pre_deflate_datetime {
+ my( $self, $dt, $info ) = @_;
+
+ if (defined $info->{timezone}) {
+ carp "You're using a floating timezone, please see the documentation of"
+ . " DBIx::Class::InflateColumn::DateTime for an explanation"
+ if ref( $dt->time_zone ) eq 'DateTime::TimeZone::Floating'
+ and not $info->{floating_tz_ok}
+ and not $ENV{DBIC_FLOATING_TZ_OK};
+
+ $dt->set_time_zone($info->{timezone});
+ }
+
+ $dt->set_locale($info->{locale}) if defined $info->{locale};
+
+ return $dt;
+}
+
1;
__END__
In your L<DBIx::Class> table class:
- __PACKAGE__->load_components( "PK::Auto", "InflateColumn::File", "Core" );
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->load_components(qw/InflateColumn::File/);
# define your columns
__PACKAGE__->add_columns(
=head1 USING
-Components are loaded using the load_components() method within your
+Components are loaded using the load_components() method within your
DBIx::Class classes.
package My::Thing;
- use base qw( DBIx::Class );
- __PACKAGE__->load_components(qw/ PK::Auto Core /);
+ use base qw( DBIx::Class::Core );
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime TimeStamp/);
-Generally you do not want to specify the full package name
-of a component, instead take off the DBIx::Class:: part of
-it and just include the rest. If you do want to load a
-component outside of the normal namespace you can do so
+Generally you do not want to specify the full package name
+of a component, instead take off the DBIx::Class:: part of
+it and just include the rest. If you do want to load a
+component outside of the normal namespace you can do so
by prepending the component name with a +.
__PACKAGE__->load_components(qw/ +My::Component /);
-Once a component is loaded all of it's methods, or otherwise,
+Once a component is loaded all of it's methods, or otherwise,
that it provides will be available in your class.
-The order in which is you load the components may be
-very important, depending on the component. The general
-rule of thumb is to first load extra components and then
-load core ones last. If you are not sure, then read the
-docs for the components you are using and see if they
-mention anything about the order in which you should load
-them.
+The order in which is you load the components may be very
+important, depending on the component. If you are not sure,
+then read the docs for the components you are using and see
+if they mention anything about the order in which you should
+load them.
=head1 CREATING COMPONENTS
# Create methods, accessors, load other components, etc.
1;
-When a component is loaded it is included in the calling
-class' inheritance chain using L<Class::C3>. As well as
-providing custom utility methods, a component may also
-override methods provided by other core components, like
-L<DBIx::Class::Row> and others. For example, you
+When a component is loaded it is included in the calling
+class' inheritance chain using L<Class::C3>. As well as
+providing custom utility methods, a component may also
+override methods provided by other core components, like
+L<DBIx::Class::Row> and others. For example, you
could override the insert and delete methods.
sub insert {
=head2 Experimental
-These components are under development, there interfaces may
-change, they may not work, etc. So, use them if you want, but
+These components are under development, there interfaces may
+change, they may not work, etc. So, use them if you want, but
be warned.
L<DBIx::Class::Validation> - Validate all data before submitting to your database.
=head2 Core
-These are the components that all, or nearly all, people will use
-without even knowing it. These components provide most of
+These are the components that all, or nearly all, people will use
+without even knowing it. These components provide most of
DBIx::Class' functionality.
-L<DBIx::Class::AccessorGroup> - Lets you build groups of accessors.
-
L<DBIx::Class::Core> - Loads various components that "most people" would want.
+L<DBIx::Class::AccessorGroup> - Lets you build groups of accessors.
+
L<DBIx::Class::DB> - Non-recommended classdata schema component.
L<DBIx::Class::InflateColumn> - Automatically create objects from column data.
package My::Schema::Result::UserFriendsComplex;
use strict;
use warnings;
- use base qw/DBIx::Class/;
+ use base qw/DBIx::Class::Core/;
- __PACKAGE__->load_components('Core');
__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
# ->table, ->add_columns, etc.
are in any way unsure about the use of the attributes above (C< join
>, C< select >, C< as > and C< group_by >).
-=head2 Subqueries (EXPERIMENTAL)
+=head2 Subqueries
You can write subqueries relatively easily in DBIC.
WHERE artist_id = me.artist_id
)
-=head3 EXPERIMENTAL
-
-Please note that subqueries are considered an experimental feature.
-
=head2 Predefined searches
You can write your own L<DBIx::Class::ResultSet> class by inheriting from it
1;
-To use your resultset, first tell DBIx::Class to create an instance of it
-for you, in your My::DBIC::Schema::CD class:
+If you're using L<DBIx::Class::Schema/load_namespaces>, simply place the file
+into the C<ResultSet> directory next to your C<Result> directory, and it will
+be automatically loaded.
+
+If however you are still using L<DBIx::Class::Schema/load_classes>, first tell
+DBIx::Class to create an instance of the ResultSet class for you, in your
+My::DBIC::Schema::CD class:
# class definition as normal
- __PACKAGE__->load_components(qw/ Core /);
+ use base 'DBIx::Class::Core';
__PACKAGE__->table('cd');
# tell DBIC to use the custom ResultSet class
use strict;
use warnings;
- use base qw/DBIx::Class/;
+ use base qw/DBIx::Class::Core/;
### Define 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
This is straightforward using L<ManyToMany|DBIx::Class::Relationship/many_to_many>:
package My::User;
- use base 'DBIx::Class';
- __PACKAGE__->load_components('Core');
+ use base 'DBIx::Class::Core';
__PACKAGE__->table('user');
__PACKAGE__->add_columns(qw/id name/);
__PACKAGE__->set_primary_key('id');
__PACKAGE__->many_to_many('addresses' => 'user_address', 'address');
package My::UserAddress;
- use base 'DBIx::Class';
- __PACKAGE__->load_components('Core');
+ use base 'DBIx::Class::Core';
__PACKAGE__->table('user_address');
__PACKAGE__->add_columns(qw/user address/);
__PACKAGE__->set_primary_key(qw/user address/);
__PACKAGE__->belongs_to('address' => 'My::Address');
package My::Address;
- use base 'DBIx::Class';
- __PACKAGE__->load_components('Core');
+ use base 'DBIx::Class::Core';
__PACKAGE__->table('address');
__PACKAGE__->add_columns(qw/id street town area_code country/);
__PACKAGE__->set_primary_key('id');
declaration, like so...
package MyDatabase::Main::Artist;
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ use base qw/DBIx::Class::Core/;
__PACKAGE__->table('database1.artist'); # will use "database1.artist" in FROM clause
Nested transactions will work as expected. That is, only the outermost
transaction will actually issue a commit to the $dbh, and a rollback
at any level of any transaction will cause the entire nested
-transaction to fail. Support for savepoints and for true nested
-transactions (for databases that support them) will hopefully be added
-in the future.
+transaction to fail.
+
+=head2 Nested transactions and auto-savepoints
+
+If savepoints are supported by your RDBMS, it is possible to achieve true
+nested transactions with minimal effort. To enable auto-savepoints via nested
+transactions, supply the C<< auto_savepoint = 1 >> connection attribute.
+
+Here is an example of true nested transactions. In the example, we start a big
+task which will create several rows. Generation of data for each row is a
+fragile operation and might fail. If we fail creating something, depending on
+the type of failure, we want to abort the whole task, or only skip the failed
+row.
+
+ my $schema = MySchema->connect("dbi:Pg:dbname=my_db");
+
+ # Start a transaction. Every database change from here on will only be
+ # commited into the database if the eval block succeeds.
+ eval {
+ $schema->txn_do(sub {
+ # SQL: BEGIN WORK;
+
+ my $job = $schema->resultset('Job')->create({ name=> 'big job' });
+ # SQL: INSERT INTO job ( name) VALUES ( 'big job' );
+
+ for (1..10) {
+
+ # Start a nested transaction, which in fact sets a savepoint.
+ eval {
+ $schema->txn_do(sub {
+ # SQL: SAVEPOINT savepoint_0;
+
+ my $thing = $schema->resultset('Thing')->create({ job=>$job->id });
+ # SQL: INSERT INTO thing ( job) VALUES ( 1 );
+
+ if (rand > 0.8) {
+ # This will generate an error, thus setting $@
+
+ $thing->update({force_fail=>'foo'});
+ # SQL: UPDATE thing SET force_fail = 'foo'
+ # WHERE ( id = 42 );
+ }
+ });
+ };
+ if ($@) {
+ # SQL: ROLLBACK TO SAVEPOINT savepoint_0;
+
+ # There was an error while creating a $thing. Depending on the error
+ # we want to abort the whole transaction, or only rollback the
+ # changes related to the creation of this $thing
+
+ # Abort the whole job
+ if ($@ =~ /horrible_problem/) {
+ print "something horrible happend, aborting job!";
+ die $@; # rethrow error
+ }
+
+ # Ignore this $thing, report the error, and continue with the
+ # next $thing
+ print "Cannot create thing: $@";
+ }
+ # There was no error, so save all changes since the last
+ # savepoint.
+
+ # SQL: RELEASE SAVEPOINT savepoint_0;
+ }
+ });
+ };
+ if ($@) {
+ # There was an error while handling the $job. Rollback all changes
+ # since the transaction started, including the already commited
+ # ('released') savepoints. There will be neither a new $job nor any
+ # $thing entry in the database.
+
+ # SQL: ROLLBACK;
+
+ print "ERROR: $@\n";
+ }
+ else {
+ # There was no error while handling the $job. Commit all changes.
+ # Only now other connections can see the newly created $job and
+ # @things.
+
+ # SQL: COMMIT;
+
+ print "Ok\n";
+ }
+
+In this example it might be hard to see where the rollbacks, releases and
+commits are happening, but it works just the same as for plain L<<txn_do>>: If
+the C<eval>-block around C<txn_do> fails, a rollback is issued. If the C<eval>
+succeeds, the transaction is committed (or the savepoint released).
+
+While you can get more fine-grained controll using C<svp_begin>, C<svp_release>
+and C<svp_rollback>, it is strongly recommended to use C<txn_do> with coderefs.
=head1 SQL
To create a new database using the schema:
my $schema = My::Schema->connect($dsn);
- $schema->deploy({ add_drop_tables => 1});
+ $schema->deploy({ add_drop_table => 1});
To import created .sql files using the mysql client:
package MyAppDB::Dual;
use strict;
use warnings;
- use base 'DBIx::Class';
- __PACKAGE__->load_components("Core");
+ use base 'DBIx::Class::Core';
__PACKAGE__->table("Dual");
__PACKAGE__->add_columns(
"dummy",
Typically L<DBIx::Class> result classes start off with
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/InflateColumn::DateTime Core/);
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
If this preamble is moved into a common base class:-
package MyDBICbase;
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/InflateColumn::DateTime Core/);
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
1;
and each result class then uses this as a base:-
MyDatabase/Main/Result/Artist.pm:
package MyDatabase::Main::Result::Artist;
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/Core/);
+ use base qw/DBIx::Class::Core/;
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/ artistid name /);
__PACKAGE__->set_primary_key('artistid');
MyDatabase/Main/Result/Cd.pm:
package MyDatabase::Main::Result::Cd;
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/Core/);
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
__PACKAGE__->table('cd');
__PACKAGE__->add_columns(qw/ cdid artist title/);
__PACKAGE__->set_primary_key('cdid');
MyDatabase/Main/Result/Track.pm:
package MyDatabase::Main::Result::Track;
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/Core/);
+ use base qw/DBIx::Class::Core/;
__PACKAGE__->table('track');
- __PACKAGE__->add_columns(qw/ trackid cd title/);
+ __PACKAGE__->add_columns(qw/ trackid cd title /);
__PACKAGE__->set_primary_key('trackid');
__PACKAGE__->belongs_to('cd' => 'MyDatabase::Main::Result::Cd');
=item .. insert many rows of data efficiently?
+The C<populate> method in L<DBIx::Class::ResultSet> provides
+efficient bulk inserts.
+
=item .. update a collection of rows at the same time?
Create a resultset using a search, to filter the rows of data you
=back
+=head2 Custom methods in Result classes
+
+You can add custom methods that do arbitrary things, even to unrelated tables.
+For example, to provide a C<< $book->foo() >> method which searches the
+cd table, you'd could add this to Book.pm:
+
+ sub foo {
+ my ($self, $col_data) = @_;
+ return $self->result_source->schema->resultset('cd')->search($col_data);
+ }
+
+And invoke that on any Book Result object like so:
+
+ my $rs = $book->foo({ title => 'Down to Earth' });
+
+When two tables ARE related, L<DBIx::Class::Relationship::Base> provides many
+methods to find or create data in related tables for you. But if you want to
+write your own methods, you can.
+
+For example, to provide a C<< $book->foo() >> method to manually implement
+what create_related() from L<DBIx::Class::Relationship::Base> does, you could
+add this to Book.pm:
+
+ sub foo {
+ my ($self, $relname, $col_data) = @_;
+ return $self->related_resultset($relname)->create($col_data);
+ }
+
+Invoked like this:
+
+ my $author = $book->foo('author', { name => 'Fred' });
+
=head2 Misc
=over 4
using the tips in L<DBIx::Class::Manual::Cookbook/"Skip row object creation for faster results">
and L<DBIx::Class::Manual::Cookbook/"Get raw data for blindingly fast results">
+=item How do I override a run time method (e.g. a relationship accessor)?
+
+If you need access to the original accessor, then you must "wrap around" the original method.
+You can do that either with L<Moose::Manual::MethodModifiers> or L<Class::Method::Modifiers>.
+The code example works for both modules:
+
+ package Your::Schema::Group;
+ use Class::Method::Modifiers;
+
+ # ... declare columns ...
+
+ __PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id');
+ __PACKAGE__->many_to_many('servers', 'group_servers', 'server');
+
+ # if the server group is a "super group", then return all servers
+ # otherwise return only servers that belongs to the given group
+ around 'servers' => sub {
+ my $orig = shift;
+ my $self = shift;
+
+ return $self->$orig(@_) unless $self->is_super_group;
+ return $self->result_source->schema->resultset('Server')->all;
+ };
+
+If you just want to override the original method, and don't care about the data
+from the original accessor, then you have two options. Either use
+L<Method::Signatures::Simple> that does most of the work for you, or do
+it the "dirty way".
+
+L<Method::Signatures::Simple> way:
+
+ package Your::Schema::Group;
+ use Method::Signatures::Simple;
+
+ # ... declare columns ...
+
+ __PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id');
+ __PACKAGE__->many_to_many('servers', 'group_servers', 'server');
+
+ # The method keyword automatically injects the annoying my $self = shift; for you.
+ method servers {
+ return $self->result_source->schema->resultset('Server')->search({ ... });
+ }
+
+The dirty way:
+
+ package Your::Schema::Group;
+ use Sub::Name;
+
+ # ... declare columns ...
+
+ __PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id');
+ __PACKAGE__->many_to_many('servers', 'group_servers', 'server');
+
+ *servers = subname servers => sub {
+ my $self = shift;
+ return $self->result_source->schema->resultset('Server')->search({ ... });
+ };
+
=back
=head2 Notes for CDBI users
Next, create each of the classes you want to load as specified above:
package My::Schema::Result::Album;
- use base qw/DBIx::Class/;
+ use base qw/DBIx::Class::Core/;
-Load any components required by each class with the load_components() method.
-This should consist of "Core" plus any additional components you want to use.
-For example, if you want to force columns to use UTF-8 encoding:
+Load any additional components you may need with the load_components() method,
+and provide component configuration if required. For example, if you want
+automatic row ordering:
- __PACKAGE__->load_components(qw/ ForceUTF8 Core /);
+ __PACKAGE__->load_components(qw/ Ordered /);
+ __PACKAGE__->position_column('rank');
Set the table for your class:
Add columns to your class:
- __PACKAGE__->add_columns(qw/ albumid artist title /);
+ __PACKAGE__->add_columns(qw/ albumid artist title rank /);
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:
is_nullable => 0,
is_auto_increment => 0,
default_value => '',
+ },
+ rank =>
+ { data_type => 'integer',
+ size => 16,
+ is_nullable => 0,
+ is_auto_increment => 0,
+ default_value => '',
}
);
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::Schema/deploy> for details.
See L<DBIx::Class::ResultSource> for more details of the possible column
attributes.
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
+containing information about C<CD>s, 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.
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
-MySQL's doc on JOINs: L<http://dev.mysql.com/doc/refman/5.0/en/join.html>.
+MySQL's doc on JOINs:
+L<http://dev.mysql.com/doc/refman/5.0/en/join.html>.
=head1 DEFINING JOINS AND RELATIONSHIPS
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.
+then it needs to be defined for both tables.
For the CDs/Tracks example, that means writing, in C<MySchema::CD>:
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
+C<relations> to also refine your results based on, using the
L<join|DBIx::Class::ResultSet/join> attribute, like this:
$schema->resultset('CD')->search(
- { 'Title' => 'Funky CD' },
+ { 'Title' => 'Funky CD',
+ 'tracks.Name' => { like => 'T%' }
+ },
{ join => 'tracks',
- '+select' => [ 'tracks.Name', 'tracks.Artist' ],
- '+as' => [ 'TrackName', 'ArtistName' ]
+ order_by => ['tracks.id'],
}
);
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.
+this case a restriction on the Title column in the CD table, and a
+restriction on the name of the track in the Tracks table, but ONLY for
+tracks actually related to the chosen CD(s). The second argument is a
+hashref of attributes to the search, the results will be returned
+sorted by the C<id> of the related tracks.
+
+The special 'join' attribute 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 slightly nonsense example will produce SQL similar to:
+
+ SELECT cd.ID, cd.Title, cd.Year FROM CD cd JOIN Tracks tracks ON cd.ID = tracks.CDID WHERE cd.Title = 'Funky CD' AND tracks.Name LIKE 'T%' ORDER BY 'tracks.id';
+
+=head1 FETCHING RELATED DATA
+
+Another common use for joining to related tables, is to fetch the data
+from both tables in one query, preventing extra round-trips to the
+database. See the example above in L</WHAT ARE JOINS>.
+
+Three techniques are described here. Of the three, only the
+C<prefetch> technique will deal sanely with fetching related objects
+over a C<has_many> relation. The others work fine for 1 to 1 type
+relationships.
+
+=head2 Whole related objects
+
+To fetch entire related objects, eg CDs and all Track data, use the
+'prefetch' attribute:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD',
+ },
+ { prefetch => 'tracks',
+ order_by => ['tracks.id'],
+ }
+ );
+
+This will produce SQL similar to the following:
+
+ SELECT cd.ID, cd.Title, cd.Year, tracks.id, tracks.Name, tracks.Artist FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD' ORDER BY 'tracks.id';
+
+The syntax of 'prefetch' is the same as 'join' and implies the
+joining, so no need to use both together.
+
+=head2 Subset of related fields
+
+To fetch a subset or the related fields, the '+select' and '+as'
+attributes can be used. For example, if the CD data is required and
+just the track name from the Tracks table:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD',
+ },
+ { join => 'tracks',
+ '+select' => ['tracks.Name'],
+ '+as' => ['track_name'],
+ order_by => ['tracks.id'],
+ }
+ );
+
+Which will produce the query:
+
+ SELECT cd.ID, cd.Title, cd.Year, tracks.Name FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD' ORDER BY 'tracks.id';
+
+Note that the '+as' does not produce an SQL 'AS' keyword in the
+output, see the L<DBIx::Class::Manual::FAQ> for an explanation.
+
+This type of column restriction has a downside, the resulting $row
+object will have no 'track_name' accessor:
+
+ while(my $row = $search_rs->next) {
+ print $row->track_name; ## ERROR
+ }
+
+Instead C<get_column> must be used:
+
+ while(my $row = $search_rs->next) {
+ print $row->get_colum('track_name'); ## WORKS
+ }
+
+=head2 Incomplete related objects
+
+In rare circumstances, you may also wish to fetch related data as
+incomplete objects. The usual reason to do is when the related table
+has a very large field you don't need for the current data
+output. This is better solved by storing that field in a separate
+table which you only join to when needed.
+
+To fetch an incomplete related object, supply the dotted notation to the '+as' attribute:
+
+ $schema->resultset('CD')->search(
+ { 'Title' => 'Funky CD',
+ },
+ { join => 'tracks',
+ '+select' => ['tracks.Name'],
+ '+as' => ['tracks.Name'],
+ order_by => ['tracks.id'],
+ }
+ );
+
+Which will produce same query as above;
+
+ SELECT cd.ID, cd.Title, cd.Year, tracks.Name FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD' ORDER BY 'tracks.id';
+
+Now you can access the result using the relationship accessor:
+
+ while(my $row = $search_rs->next) {
+ print $row->tracks->name; ## WORKS
+ }
-'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.
+However, this will produce broken objects. If the tracks id column is
+not fetched, the object will not be usable for any operation other
+than reading its data. Use the L</Whole related objects> method as
+much as possible to avoid confusion in your code later.
-This example should magically produce SQL like the second select in
-L</WHAT ARE JOINS> above.
+Broken means: Update will not work. Fetching other related objects
+will not work. Deleting the object will not work.
=head1 COMPLEX JOINS AND STUFF
$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';
+ SELECT me.ID, me.Title, me.Year 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
{ '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;
+ SELECT me.ID, me.Title, me.Year 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.
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:
+This can happen if you are still using the obsolete order hack, and also
+happen to turn on sql-quoting.
$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' ] } );
+Since L<DBIx::Class> >= 0.08100 and L<SQL::Abstract> >= 1.50 the above
+should be written as:
-Now you'll get SQL like this:
+ $rs->search( {}, { order_by => { -desc => 'name' } } );
- ... ORDER BY name DESC
+For more ways to express order clauses refer to
+L<SQL::Abstract/ORDER_BY_CLAUSES>
=head2 Perl Performance Issues on Red Hat Systems
=head1 SYNOPSIS
-__PACKAGE__->load_components(qw/Core/);
+use base 'DBIx::Class::Core';
__PACKAGE__->set_primary_key('id');
=head1 DESCRIPTION
This class overrides the insert method to get automatically incremented primary
keys.
- __PACKAGE__->load_components(qw/Core/);
-
PK::Auto is now part of Core.
See L<DBIx::Class::Manual::Component> for details of component interactions.
=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 the foreign class 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<$their_fk_column> specifies the foreign
-key column in C<$related_class> or C<cond> specifies a reference to a
-join condition hash.
+Creates a one-to-many relationship where the foreign class refers to
+this class's primary key. This relationship refers to zero or more
+records in the foreign table (ie, a C<LEFT JOIN>). This relationship
+defaults to using the end of this classes namespace as the foreign key
+in C<$related_class> to resolve the join, unless C<$their_fk_column>
+specifies the foreign key column in C<$related_class> or C<cond>
+specifies a reference to a join condition hash.
=over
for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
which can be assigned to relationships as well.
+Note that if you supply a condition on which to join, if the column in the
+current table allows nulls (i.e., has the C<is_nullable> attribute set to a
+true value), than C<might_have> will warn about this because it's naughty and
+you shouldn't do that.
+
+ "might_have/has_one" must not be on columns with is_nullable set to true (MySchema::SomeClass/key)
+
+If you must be naughty, you can suppress the warning by setting
+C<DBIC_DONT_VALIDATE_RELS> environment variable to a true value. Otherwise,
+you probably just want to use C<DBIx::Class::Relationship/belongs_to>.
+
=head2 has_one
=over 4
for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
which can be assigned to relationships as well.
+Note that if you supply a condition on which to join, if the column in the
+current table allows nulls (i.e., has the C<is_nullable> attribute set to a
+true value), than warnings might apply just as with
+L<DBIx::Class::Relationship/might_have>.
+
=head2 many_to_many
=over 4
__PACKAGE__->add_relationship('relname', 'Foreign::Class', $cond, $attrs);
+=head3 condition
+
The condition needs to be an L<SQL::Abstract>-style representation of the
join between the tables. When resolving the condition for use in a C<JOIN>,
keys using the pseudo-table C<foreign> are resolved to mean "the Table on the
To add an C<OR>ed condition, use an arrayref of hashrefs. See the
L<SQL::Abstract> documentation for more details.
-In addition to the
-L<standard ResultSet attributes|DBIx::Class::ResultSet/ATTRIBUTES>,
-the following attributes are also valid:
+=head3 attributes
+
+The L<standard ResultSet attributes|DBIx::Class::ResultSet/ATTRIBUTES> may
+be used as relationship attributes. In particular, the 'where' attribute is
+useful for filtering relationships:
+
+ __PACKAGE__->has_many( 'valid_users', 'MyApp::Schema::User',
+ { 'foreign.user_id' => 'self.user_id' },
+ { where => { valid => 1 } }
+ );
+
+The following attributes are also valid:
=over 4
if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
my $reverse = $source->reverse_relationship_info($rel);
foreach my $rev_rel (keys %$reverse) {
- if ($reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
+ if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
$attrs->{related_objects}{$rev_rel} = [ $self ];
Scalar::Util::weaken($attrs->{related_object}{$rev_rel}[0]);
} else {
my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
foreach my $rel (@cascade) {
next if (
+ $rels{$rel}{attrs}{accessor}
+ &&
$rels{$rel}{attrs}{accessor} eq 'single'
- && !exists($self->{_relationship_data}{$rel})
+ &&
+ !exists($self->{_relationship_data}{$rel})
);
$_->update for grep defined, $self->$rel;
}
use strict;
use warnings;
+use Carp::Clan qw/^DBIx::Class/;
our %_pod_inherit_config =
(
my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_;
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;
+ my $pri = $class->_get_primary_key;
+
$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);
+ my ($f_key,$too_many,$guess);
if (defined $cond && length $cond) {
$f_key = $cond;
$guess = "caller specified foreign key '$f_key'";
$f_key = $rel;
$guess = "using given relationship '$rel' for foreign key";
} else {
- ($f_key, $too_many) = $f_class->primary_columns;
- $class->throw_exception(
- "might_have/has_one can only infer join for a single primary key; ".
- "${f_class} has more"
- ) if $too_many;
+ $f_key = $class->_get_primary_key($f_class);
$guess = "using primary key of foreign class for foreign key";
}
$class->throw_exception(
) if $f_class_loaded && !$f_class->has_column($f_key);
$cond = { "foreign.${f_key}" => "self.${pri}" };
}
+ $class->_validate_cond($cond);
$class->add_relationship($rel, $f_class,
$cond,
{ accessor => 'single',
1;
}
+sub _get_primary_key {
+ my ( $class, $target_class ) = @_;
+ $target_class ||= $class;
+ my ($pri, $too_many) = $target_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;
+ return $pri;
+}
+
+sub _validate_cond {
+ my ($class, $cond ) = @_;
+
+ return if $ENV{DBIC_DONT_VALIDATE_RELS};
+ return unless 'HASH' eq ref $cond;
+ foreach my $foreign_id ( keys %$cond ) {
+ my $self_id = $cond->{$foreign_id};
+
+ # we can ignore a bad $self_id because add_relationship handles this
+ # warning
+ return unless $self_id =~ /^self\.(.*)$/;
+ my $key = $1;
+ my $column_info = $class->column_info($key);
+ if ( $column_info->{is_nullable} ) {
+ carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.');
+ }
+ }
+}
+
1;
my $rs = $self->search_related($rel)->search_related(
$f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
);
- return $rs;
+ return $rs;
};
my $meth_name = join '::', $class, $meth;
*$meth_name = Sub::Name::subname $meth_name, sub {
- my $self = shift;
- my $rs = $self->$rs_meth( @_ );
- return (wantarray ? $rs->all : $rs);
- };
+ my $self = shift;
+ my $rs = $self->$rs_meth( @_ );
+ return (wantarray ? $rs->all : $rs);
+ };
my $add_meth_name = join '::', $class, $add_meth;
*$add_meth_name = Sub::Name::subname $add_meth_name, sub {
my $link = $self->search_related($rel)->new_result($link_vals);
$link->set_from_related($f_rel, $obj);
$link->insert();
- return $obj;
+ return $obj;
};
my $set_meth_name = join '::', $class, $set_meth;
}
my $rs = (ref $self)->new($self->result_source, $new_attrs);
- if ($rows) {
- $rs->set_cache($rows);
- }
+
+ $rs->set_cache($rows) if ($rows);
+
return $rs;
}
}
# Run the query
- my $rs = $self->search ($query, $attrs);
+ my $rs = $self->search ($query, {result_class => $self->result_class, %$attrs});
if (keys %{$rs->_resolved_attrs->{collapse}}) {
my $row = $rs->next;
carp "Query returned more than one row" if $rs->next;
sub _collapse_result {
my ($self, $as_proto, $row) = @_;
- # if the first row that ever came in is totally empty - this means we got
- # hit by a smooth^Wempty left-joined resultset. Just noop in that case
- # instead of producing a {}
- #
- my $has_def;
- for (@$row) {
- if (defined $_) {
- $has_def++;
- last;
- }
- }
- return undef unless $has_def;
-
my @copy = @$row;
# 'foo' => [ undef, 'foo' ]
$tmp_attrs->{select} = $rsrc->storage->_count_select ($rsrc, $tmp_attrs);
$tmp_attrs->{as} = 'count';
- # read the comment on top of the actual function to see what this does
- $tmp_attrs->{from} = $self->_switch_to_inner_join_if_needed (
- $tmp_attrs->{from}, $tmp_attrs->{alias}
- );
-
my $tmp_rs = $rsrc->resultset_class->new($rsrc, $tmp_attrs)->get_column ('count');
return $tmp_rs;
# extra selectors do not go in the subquery and there is no point of ordering it
delete $sub_attrs->{$_} for qw/collapse select _prefetch_select as order_by/;
- # if we prefetch, we group_by primary keys only as this is what we would get out
- # of the rs via ->next/->all. We DO WANT to clobber old group_by regardless
- if ( keys %{$attrs->{collapse}} ) {
+ # if we multi-prefetch we group_by primary keys only as this is what we would
+ # get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless
+ if ( keys %{$attrs->{collapse}} ) {
$sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } ($rsrc->primary_columns) ]
}
$sub_attrs->{select} = $rsrc->storage->_subq_count_select ($rsrc, $sub_attrs);
- # read the comment on top of the actual function to see what this does
- $sub_attrs->{from} = $self->_switch_to_inner_join_if_needed (
- $sub_attrs->{from}, $sub_attrs->{alias}
- );
-
- # this is so that ordering can be thrown away in things like Top limit
+ # this is so that the query can be simplified e.g.
+ # * ordering can be thrown away in things like Top limit
$sub_attrs->{-for_count_only} = 1;
my $sub_rs = $rsrc->resultset_class->new ($rsrc, $sub_attrs);
return $self->_count_rs ($attrs);
}
-
-# The DBIC relationship chaining implementation is pretty simple - every
-# new related_relationship is pushed onto the {from} stack, and the {select}
-# window simply slides further in. This means that when we count somewhere
-# in the middle, we got to make sure that everything in the join chain is an
-# actual inner join, otherwise the count will come back with unpredictable
-# results (a resultset may be generated with _some_ rows regardless of if
-# the relation which the $rs currently selects has rows or not). E.g.
-# $artist_rs->cds->count - normally generates:
-# SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid
-# which actually returns the number of artists * (number of cds || 1)
-#
-# So what we do here is crawl {from}, determine if the current alias is at
-# the top of the stack, and if not - make sure the chain is inner-joined down
-# to the root.
-#
-sub _switch_to_inner_join_if_needed {
- my ($self, $from, $alias) = @_;
-
- # subqueries and other oddness is naturally not supported
- return $from if (
- ref $from ne 'ARRAY'
- ||
- @$from <= 1
- ||
- ref $from->[0] ne 'HASH'
- ||
- ! $from->[0]{-alias}
- ||
- $from->[0]{-alias} eq $alias
- );
-
- my $switch_branch;
- JOINSCAN:
- for my $j (@{$from}[1 .. $#$from]) {
- if ($j->[0]{-alias} eq $alias) {
- $switch_branch = $j->[0]{-join_path};
- last JOINSCAN;
- }
- }
-
- # something else went wrong
- return $from unless $switch_branch;
-
- # So it looks like we will have to switch some stuff around.
- # local() is useless here as we will be leaving the scope
- # anyway, and deep cloning is just too fucking expensive
- # So replace the inner hashref manually
- my @new_from = ($from->[0]);
- my $sw_idx = { map { $_ => 1 } @$switch_branch };
-
- for my $j (@{$from}[1 .. $#$from]) {
- my $jalias = $j->[0]{-alias};
-
- if ($sw_idx->{$jalias}) {
- my %attrs = %{$j->[0]};
- delete $attrs{-join_type};
- push @new_from, [
- \%attrs,
- @{$j}[ 1 .. $#$j ],
- ];
- }
- else {
- push @new_from, $j;
- }
- }
-
- return \@new_from;
-}
-
-
sub _bool {
return 1;
}
my $rsrc = $self->result_source;
+ # if a condition exists we need to strip all table qualifiers
+ # if this is not possible we'll force a subquery below
+ my $cond = $rsrc->schema->storage->_strip_cond_qualifiers ($self->{cond});
+
my $needs_group_by_subq = $self->_has_resolved_attr (qw/collapse group_by -join/);
- my $needs_subq = $self->_has_resolved_attr (qw/row offset/);
+ my $needs_subq = $needs_group_by_subq || (not defined $cond) || $self->_has_resolved_attr(qw/row offset/);
if ($needs_group_by_subq or $needs_subq) {
return $rsrc->storage->$op(
$rsrc,
$op eq 'update' ? $values : (),
- $self->_cond_for_update_delete,
+ $cond,
);
}
}
-
-# _cond_for_update_delete
-#
-# update/delete require the condition to be modified to handle
-# the differing SQL syntax available. This transforms the $self->{cond}
-# appropriately, returning the new condition.
-
-sub _cond_for_update_delete {
- my ($self, $full_cond) = @_;
- my $cond = {};
-
- $full_cond ||= $self->{cond};
- # No-op. No condition, we're updating/deleting everything
- return $cond unless ref $full_cond;
-
- if (ref $full_cond eq 'ARRAY') {
- $cond = [
- map {
- my %hash;
- foreach my $key (keys %{$_}) {
- $key =~ /([^.]+)$/;
- $hash{$1} = $_->{$key};
- }
- \%hash;
- } @{$full_cond}
- ];
- }
- elsif (ref $full_cond eq 'HASH') {
- if ((keys %{$full_cond})[0] eq '-and') {
- $cond->{-and} = [];
- my @cond = @{$full_cond->{-and}};
- for (my $i = 0; $i < @cond; $i++) {
- my $entry = $cond[$i];
- my $hash;
- if (ref $entry eq 'HASH') {
- $hash = $self->_cond_for_update_delete($entry);
- }
- else {
- $entry =~ /([^.]+)$/;
- $hash->{$1} = $cond[++$i];
- }
- push @{$cond->{-and}}, $hash;
- }
- }
- else {
- foreach my $key (keys %{$full_cond}) {
- $key =~ /([^.]+)$/;
- $cond->{$1} = $full_cond->{$key};
- }
- }
- }
- else {
- $self->throw_exception("Can't update/delete on resultset with condition unless hash or array");
- }
-
- return $cond;
-}
-
-
=head2 update
=over 4
=cut
sub populate {
- my $self = shift @_;
- my $data = ref $_[0][0] eq 'HASH'
- ? $_[0] : ref $_[0][0] eq 'ARRAY' ? $self->_normalize_populate_args($_[0]) :
- $self->throw_exception('Populate expects an arrayref of hashes or arrayref of arrayrefs');
+ my $self = shift;
+
+ # cruft placed in standalone method
+ my $data = $self->_normalize_populate_args(@_);
if(defined wantarray) {
my @created;
}
return wantarray ? @created : \@created;
} else {
- my ($first, @rest) = @$data;
-
- require overload;
- my @names = grep {
- (not ref $first->{$_}) || (ref $first->{$_} eq 'SCALAR') ||
- (overload::Method($first->{$_}, '""'))
- } keys %$first;
+ my $first = $data->[0];
+
+ # if a column is a registered relationship, and is a non-blessed hash/array, consider
+ # it relationship data
+ my (@rels, @columns);
+ for (keys %$first) {
+ my $ref = ref $first->{$_};
+ $self->result_source->has_relationship($_) && ($ref eq 'ARRAY' or $ref eq 'HASH')
+ ? push @rels, $_
+ : push @columns, $_
+ ;
+ }
- my @rels = grep { $self->result_source->has_relationship($_) } keys %$first;
my @pks = $self->result_source->primary_columns;
## do the belongs_to relationships
delete $data->[$index]->{$rel};
$data->[$index] = {%{$data->[$index]}, %$related};
- push @names, keys %$related if $index == 0;
+ push @columns, keys %$related if $index == 0;
}
}
- ## do bulk insert on current row
- my @values = map { [ @$_{@names} ] } @$data;
+ ## inherit the data locked in the conditions of the resultset
+ my ($rs_data) = $self->_merge_cond_with_data({});
+ delete @{$rs_data}{@columns};
+ my @inherit_cols = keys %$rs_data;
+ my @inherit_data = values %$rs_data;
+ ## do bulk insert on current row
$self->result_source->storage->insert_bulk(
$self->result_source,
- \@names,
- \@values,
+ [@columns, @inherit_cols],
+ [ map { [ @$_{@columns}, @inherit_data ] } @$data ],
);
## do the has_many relationships
foreach my $rel (@rels) {
next unless $item->{$rel} && ref $item->{$rel} eq "ARRAY";
- my $parent = $self->find(map {{$_=>$item->{$_}} } @pks)
+ my $parent = $self->find({map { $_ => $item->{$_} } @pks})
|| $self->throw_exception('Cannot find the relating object.');
my $child = $parent->$rel;
}
}
-=head2 _normalize_populate_args ($args)
-
-Private method used by L</populate> to normalize its incoming arguments. Factored
-out in case you want to subclass and accept new argument structures to the
-L</populate> method.
-
-=cut
+# populate() argumnets went over several incarnations
+# What we ultimately support is AoH
sub _normalize_populate_args {
- my ($self, $data) = @_;
- my @names = @{shift(@$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];
+ my ($self, $arg) = @_;
+
+ if (ref $arg eq 'ARRAY') {
+ if (ref $arg->[0] eq 'HASH') {
+ return $arg;
+ }
+ elsif (ref $arg->[0] eq 'ARRAY') {
+ my @ret;
+ my @colnames = @{$arg->[0]};
+ foreach my $values (@{$arg}[1 .. $#$arg]) {
+ push @ret, { map { $colnames[$_] => $values->[$_] } (0 .. $#colnames) };
+ }
+ return \@ret;
}
- push @results_to_create, \%result_to_create;
}
- return \@results_to_create;
+
+ $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs');
}
=head2 pager
$self->throw_exception( "new_result needs a hash" )
unless (ref $values eq 'HASH');
- my %new;
+ my ($merged_cond, $cols_from_relations) = $self->_merge_cond_with_data($values);
+
+ my %new = (
+ %$merged_cond,
+ @$cols_from_relations
+ ? (-cols_from_relations => $cols_from_relations)
+ : (),
+ -source_handle => $self->_source_handle,
+ -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED
+ );
+
+ return $self->result_class->new(\%new);
+}
+
+# _merge_cond_with_data
+#
+# Takes a simple hash of K/V data and returns its copy merged with the
+# condition already present on the resultset. Additionally returns an
+# arrayref of value/condition names, which were inferred from related
+# objects (this is needed for in-memory related objects)
+sub _merge_cond_with_data {
+ my ($self, $data) = @_;
+
+ my (%new_data, @cols_from_relations);
+
my $alias = $self->{attrs}{alias};
- if (
- defined $self->{cond}
- && $self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
- ) {
- %new = %{ $self->{attrs}{related_objects} || {} }; # nothing might have been inserted yet
- $new{-from_resultset} = [ keys %new ] if keys %new;
- } else {
+ if (! defined $self->{cond}) {
+ # just massage $data below
+ }
+ elsif ($self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
+ %new_data = %{ $self->{attrs}{related_objects} || {} }; # nothing might have been inserted yet
+ @cols_from_relations = keys %new_data;
+ }
+ elsif (ref $self->{cond} ne 'HASH') {
$self->throw_exception(
- "Can't abstract implicit construct, condition not a hash"
- ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
-
- my $collapsed_cond = (
- $self->{cond}
- ? $self->_collapse_cond($self->{cond})
- : {}
+ "Can't abstract implicit construct, resultset condition not a hash"
);
-
+ }
+ else {
# precendence must be given to passed values over values inherited from
# the cond, so the order here is important.
- my %implied = %{$self->_remove_alias($collapsed_cond, $alias)};
- while( my($col,$value) = each %implied ){
- if(ref($value) eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '='){
- $new{$col} = $value->{'='};
+ my $collapsed_cond = $self->_collapse_cond($self->{cond});
+ my %implied = %{$self->_remove_alias($collapsed_cond, $alias)};
+
+ while ( my($col, $value) = each %implied ) {
+ if (ref($value) eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '=') {
+ $new_data{$col} = $value->{'='};
next;
}
- $new{$col} = $value if $self->_is_deterministic_value($value);
+ $new_data{$col} = $value if $self->_is_deterministic_value($value);
}
}
- %new = (
- %new,
- %{ $self->_remove_alias($values, $alias) },
- -source_handle => $self->_source_handle,
- -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED
+ %new_data = (
+ %new_data,
+ %{ $self->_remove_alias($data, $alias) },
);
- return $self->result_class->new(\%new);
+ return (\%new_data, \@cols_from_relations);
}
# _is_deterministic_value
return \%unaliased;
}
-=head2 as_query (EXPERIMENTAL)
+=head2 as_query
=over 4
This is generally used as the RHS for a subquery.
-B<NOTE>: This feature is still experimental.
-
=cut
sub as_query {
$self->{related_resultsets} ||= {};
return $self->{related_resultsets}{$rel} ||= do {
- my $rel_info = $self->result_source->relationship_info($rel);
+ my $rsrc = $self->result_source;
+ my $rel_info = $rsrc->relationship_info($rel);
$self->throw_exception(
- "search_related: result source '" . $self->result_source->source_name .
+ "search_related: result source '" . $rsrc->source_name .
"' has no such relationship $rel")
unless $rel_info;
- my ($from,$seen) = $self->_chain_relationship($rel);
+ my $attrs = $self->_chain_relationship($rel);
+
+ my $join_count = $attrs->{seen_join}{$rel};
+
+ my $alias = $self->result_source->storage
+ ->relname_to_table_alias($rel, $join_count);
+
+ # since this is search_related, and we already slid the select window inwards
+ # (the select/as attrs were deleted in the beginning), we need to flip all
+ # left joins to inner, so we get the expected results
+ # read the comment on top of the actual function to see what this does
+ $attrs->{from} = $rsrc->schema->storage->_straight_join_to_node ($attrs->{from}, $alias);
- my $join_count = $seen->{$rel};
- my $alias = ($join_count > 1 ? join('_', $rel, $join_count) : $rel);
#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)};
+ delete @{$attrs}{qw(result_class alias)};
my $new_cache;
}
}
- my $rel_source = $self->result_source->related_source($rel);
+ my $rel_source = $rsrc->related_source($rel);
my $new = do {
# 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;
+ my $rel_attrs = $rel_source->resultset_attributes;
+ local $rel_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,
+ %$attrs,
+ where => $attrs->{where},
});
};
$new->set_cache($new_cache) if $new_cache;
return ($self->{attrs} || {})->{alias} || 'me';
}
+=head2 as_subselect_rs
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $resultset
+
+=back
+
+Act as a barrier to SQL symbols. The resultset provided will be made into a
+"virtual view" by including it as a subquery within the from clause. From this
+point on, any joined tables are inaccessible to ->search on the resultset (as if
+it were simply where-filtered without joins). For example:
+
+ my $rs = $schema->resultset('Bar')->search({'x.name' => 'abc'},{ join => 'x' });
+
+ # 'x' now pollutes the query namespace
+
+ # So the following works as expected
+ my $ok_rs = $rs->search({'x.other' => 1});
+
+ # But this doesn't: instead of finding a 'Bar' related to two x rows (abc and
+ # def) we look for one row with contradictory terms and join in another table
+ # (aliased 'x_2') which we never use
+ my $broken_rs = $rs->search({'x.name' => 'def'});
+
+ my $rs2 = $rs->as_subselect_rs;
+
+ # doesn't work - 'x' is no longer accessible in $rs2, having been sealed away
+ my $not_joined_rs = $rs2->search({'x.other' => 1});
+
+ # works as expected: finds a 'table' row related to two x rows (abc and def)
+ my $correctly_joined_rs = $rs2->search({'x.name' => 'def'});
+
+Another example of when one might use this would be to select a subset of
+columns in a group by clause:
+
+ my $rs = $schema->resultset('Bar')->search(undef, {
+ group_by => [qw{ id foo_id baz_id }],
+ })->as_subselect_rs->search(undef, {
+ columns => [qw{ id foo_id }]
+ });
+
+In the above example normally columns would have to be equal to the group by,
+but because we isolated the group by into a subselect the above works.
+
+=cut
+
+sub as_subselect_rs {
+ my $self = shift;
+
+ return $self->result_source->resultset->search( undef, {
+ alias => $self->current_source_alias,
+ from => [{
+ $self->current_source_alias => $self->as_query,
+ -alias => $self->current_source_alias,
+ -source_handle => $self->result_source->handle,
+ }]
+ });
+}
+
# This code is called by search_related, and makes sure there
# is clear separation between the joins before, during, and
# after the relationship. This information is needed later
# with a relation_chain_depth less than the depth of the
# current prefetch is not considered)
#
-# The increments happen in 1/2s to make it easier to correlate the
-# join depth with the join path. An integer means a relationship
-# specified via a search_related, whereas a fraction means an added
-# join/prefetch via attributes
+# The increments happen twice per join. An even number means a
+# relationship specified via a search_related, whereas an odd
+# number indicates a join/prefetch added via attributes
+#
+# Also this code will wrap the current resultset (the one we
+# chain to) in a subselect IFF it contains limiting attributes
sub _chain_relationship {
my ($self, $rel) = @_;
my $source = $self->result_source;
- my $attrs = $self->{attrs};
+ my $attrs = { %{$self->{attrs}||{}} };
- my $from = [ @{
- $attrs->{from}
- ||
- [{
- -source_handle => $source->handle,
- -alias => $attrs->{alias},
- $attrs->{alias} => $source->from,
- }]
- }];
+ # we need to take the prefetch the attrs into account before we
+ # ->_resolve_join as otherwise they get lost - captainL
+ my $join = $self->_merge_attr( $attrs->{join}, $attrs->{prefetch} );
- my $seen = { %{$attrs->{seen_join} || {} } };
- my $jpath = ($attrs->{seen_join} && keys %{$attrs->{seen_join}})
- ? $from->[-1][0]{-join_path}
- : [];
+ delete @{$attrs}{qw/join prefetch collapse distinct select as columns +select +as +columns/};
+ my $seen = { %{ (delete $attrs->{seen_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( $attrs->{join}, $attrs->{prefetch} );
+ my $from;
+ my @force_subq_attrs = qw/offset rows group_by having/;
+
+ if (
+ ($attrs->{from} && ref $attrs->{from} ne 'ARRAY')
+ ||
+ $self->_has_resolved_attr (@force_subq_attrs)
+ ) {
+ # Nuke the prefetch (if any) before the new $rs attrs
+ # are resolved (prefetch is useless - we are wrapping
+ # a subquery anyway).
+ my $rs_copy = $self->search;
+ $rs_copy->{attrs}{join} = $self->_merge_attr (
+ $rs_copy->{attrs}{join},
+ delete $rs_copy->{attrs}{prefetch},
+ );
+
+ $from = [{
+ -source_handle => $source->handle,
+ -alias => $attrs->{alias},
+ $attrs->{alias} => $rs_copy->as_query,
+ }];
+ delete @{$attrs}{@force_subq_attrs, 'where'};
+ $seen->{-relation_chain_depth} = 0;
+ }
+ elsif ($attrs->{from}) { #shallow copy suffices
+ $from = [ @{$attrs->{from}} ];
+ }
+ else {
+ $from = [{
+ -source_handle => $source->handle,
+ -alias => $attrs->{alias},
+ $attrs->{alias} => $source->from,
+ }];
+ }
+
+ my $jpath = ($seen->{-relation_chain_depth})
+ ? $from->[-1][0]{-join_path}
+ : [];
my @requested_joins = $source->_resolve_join(
- $merged,
+ $join,
$attrs->{alias},
$seen,
$jpath,
push @$from, @requested_joins;
- $seen->{-relation_chain_depth} += 0.5;
+ $seen->{-relation_chain_depth}++;
# if $self already had a join/prefetch specified on it, the requested
# $rel might very well be already included. What we do in this case
# the join in question so we could tell it *is* the search_related)
my $already_joined;
-
# we consider the last one thus reverse
for my $j (reverse @requested_joins) {
- if ($rel eq $j->[0]{-join_path}[-1]) {
- $j->[0]{-relation_chain_depth} += 0.5;
+ my ($last_j) = keys %{$j->[0]{-join_path}[-1]};
+ if ($rel eq $last_j) {
+ $j->[0]{-relation_chain_depth}++;
$already_joined++;
last;
}
}
-# alternative way to scan the entire chain - not backwards compatible
-# for my $j (reverse @$from) {
-# next unless ref $j eq 'ARRAY';
-# if ($j->[0]{-join_path} && $j->[0]{-join_path}[-1] eq $rel) {
-# $j->[0]{-relation_chain_depth} += 0.5;
-# $already_joined++;
-# last;
-# }
-# }
-
unless ($already_joined) {
push @$from, $source->_resolve_join(
$rel,
);
}
- $seen->{-relation_chain_depth} += 0.5;
+ $seen->{-relation_chain_depth}++;
- return ($from,$seen);
+ return {%$attrs, from => $from, seen_join => $seen};
}
# too many times we have to do $attrs = { %{$self->_resolved_attrs} }
}
else {
$attrs->{group_by} = [ grep { !ref($_) || (ref($_) ne 'HASH') } @{$attrs->{select}} ];
+
+ # add any order_by parts that are not already present in the group_by
+ # we need to be careful not to add any named functions/aggregates
+ # i.e. select => [ ... { count => 'foo', -as 'foocount' } ... ]
+ my %already_grouped = map { $_ => 1 } (@{$attrs->{group_by}});
+
+ my $storage = $self->result_source->schema->storage;
+
+ my $rs_column_list = $storage->_resolve_column_info ($attrs->{from});
+
+ for my $chunk ($storage->_parse_order_by($attrs->{order_by})) {
+ if ($rs_column_list->{$chunk} && not $already_grouped{$chunk}++) {
+ push @{$attrs->{group_by}}, $chunk;
+ }
+ }
}
}
my $prefetch_ordering = [];
- my $join_map = $self->_joinpath_aliases ($attrs->{from}, $attrs->{seen_join});
+ # this is a separate structure (we don't look in {from} directly)
+ # as the resolver needs to shift things off the lists to work
+ # properly (identical-prefetches on different branches)
+ my $join_map = {};
+ if (ref $attrs->{from} eq 'ARRAY') {
+
+ my $start_depth = $attrs->{seen_join}{-relation_chain_depth} || 0;
+
+ for my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) {
+ next unless $j->[0]{-alias};
+ next unless $j->[0]{-join_path};
+ next if ($j->[0]{-relation_chain_depth} || 0) < $start_depth;
+
+ my @jpath = map { keys %$_ } @{$j->[0]{-join_path}};
+
+ my $p = $join_map;
+ $p = $p->{$_} ||= {} for @jpath[ ($start_depth/2) .. $#jpath]; #only even depths are actual jpath boundaries
+ push @{$p->{-join_aliases} }, $j->[0]{-alias};
+ }
+ }
my @prefetch =
$source->_resolve_prefetch( $prefetch, $alias, $join_map, $prefetch_ordering, $attrs->{collapse} );
return $self->{_attrs} = $attrs;
}
-sub _joinpath_aliases {
- my ($self, $fromspec, $seen) = @_;
-
- my $paths = {};
- return $paths unless ref $fromspec eq 'ARRAY';
-
- my $cur_depth = $seen->{-relation_chain_depth} || 0;
-
- if (int ($cur_depth) != $cur_depth) {
- $self->throw_exception ("-relation_chain_depth is not an integer, something went horribly wrong ($cur_depth)");
- }
-
- for my $j (@$fromspec) {
-
- next if ref $j ne 'ARRAY';
- next if ($j->[0]{-relation_chain_depth} || 0) < $cur_depth;
-
- my $jpath = $j->[0]{-join_path};
-
- my $p = $paths;
- $p = $p->{$_} ||= {} for @{$jpath}[$cur_depth .. $#$jpath];
- push @{$p->{-join_aliases} }, $j->[0]{-alias};
- }
-
- return $paths;
-}
-
sub _rollout_attr {
my ($self, $attr) = @_;
attribute, the column names returned are storage-dependent. E.g. MySQL would
return a column named C<count(employeeid)> in the above example.
+B<NOTE:> You will almost always need a corresponding 'as' entry when you use
+'select'.
+
=head2 +select
=over 4
my ($class, $rs, $column) = @_;
$class = ref $class if ref $class;
- $rs->throw_exception("column must be supplied") unless $column;
+ $rs->throw_exception('column must be supplied') unless $column;
my $orig_attrs = $rs->_resolved_attrs;
- my $new_parent_rs = $rs->search_rs;
-
- # prefetch causes additional columns to be fetched, but we can not just make a new
- # rs via the _resolved_attrs trick - we need to retain the separation between
- # +select/+as and select/as. At the same time we want to preserve any joins that the
- # prefetch would otherwise generate.
-
- my $new_attrs = $new_parent_rs->{attrs} ||= {};
- $new_attrs->{join} = $rs->_merge_attr( delete $new_attrs->{join}, delete $new_attrs->{prefetch} );
# If $column can be found in the 'as' list of the parent resultset, use the
# corresponding element of its 'select' list (to keep any custom column
# definition set up with 'select' or '+select' attrs), otherwise use $column
# (to create a new column definition on-the-fly).
-
my $as_list = $orig_attrs->{as} || [];
my $select_list = $orig_attrs->{select} || [];
my $as_index = List::Util::first { ($as_list->[$_] || "") eq $column } 0..$#$as_list;
my $select = defined $as_index ? $select_list->[$as_index] : $column;
+ my $new_parent_rs;
+ # analyze the order_by, and see if it is done over a function/nonexistentcolumn
+ # if this is the case we will need to wrap a subquery since the result of RSC
+ # *must* be a single column select
+ my %collist = map { $_ => 1 } ($rs->result_source->columns, $column);
+ if (
+ scalar grep
+ { ! $collist{$_} }
+ ( $rs->result_source->schema->storage->_parse_order_by ($orig_attrs->{order_by} ) )
+ ) {
+ my $alias = $rs->current_source_alias;
+ # nuke the prefetch before collapsing to sql
+ my $subq_rs = $rs->search;
+ $subq_rs->{attrs}{join} = $subq_rs->_merge_attr( $subq_rs->{attrs}{join}, delete $subq_rs->{attrs}{prefetch} );
+
+ $new_parent_rs = $rs->result_source->resultset->search ( {}, {
+ alias => $alias,
+ from => [{
+ $alias => $subq_rs->as_query,
+ -alias => $alias,
+ -source_handle => $rs->result_source->handle,
+ }]
+ });
+ }
+
+ $new_parent_rs ||= $rs->search_rs;
+ my $new_attrs = $new_parent_rs->{attrs} ||= {};
+
+ # FIXME - this should go away when the chaining branch is merged
+ # since what we do is actually chain to the original resultset, we need to throw
+ # away all selectors (otherwise they'll chain)
+ delete $new_attrs->{$_} for (qw/columns +columns select +select as +as cols include_columns/);
+
+ # prefetch causes additional columns to be fetched, but we can not just make a new
+ # rs via the _resolved_attrs trick - we need to retain the separation between
+ # +select/+as and select/as. At the same time we want to preserve any joins that the
+ # prefetch would otherwise generate.
+ $new_attrs->{join} = $rs->_merge_attr( $new_attrs->{join}, delete $new_attrs->{prefetch} );
+
# {collapse} would mean a has_many join was injected, which in turn means
# we need to group *IF WE CAN* (only if the column in question is unique)
if (!$new_attrs->{group_by} && keys %{$orig_attrs->{collapse}}) {
return $new;
}
-=head2 as_query (EXPERIMENTAL)
+=head2 as_query
=over 4
This is generally used as the RHS for a subquery.
-B<NOTE>: This feature is still experimental.
-
=cut
sub as_query { return shift->_resultset->as_query(@_) }
# Create a table based result source, in a result class.
package MyDB::Schema::Result::Artist;
- use base qw/DBIx::Class/;
+ use base qw/DBIx::Class::Core/;
- __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/ artistid name /);
__PACKAGE__->set_primary_key('artistid');
# Create a query (view) based result source, in a result class
package MyDB::Schema::Result::Year2000CDs;
+ use base qw/DBIx::Class::Core/;
- __PACKAGE__->load_components('Core');
+ __PACKAGE__->load_components('InflateColumn::DateTime');
__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
__PACKAGE__->table('year2000cds');
default result source type, so one is created for you when defining a
result class as described in the synopsis above.
-More specifically, the L<DBIx::Class::Core> component pulls in the
-L<DBIx::Class::ResultSourceProxy::Table> as a base class, which
-defines the L<table|DBIx::Class::ResultSourceProxy::Table/table>
-method. When called, C<table> creates and stores an instance of
+More specifically, the L<DBIx::Class::Core> base class pulls in the
+L<DBIx::Class::ResultSourceProxy::Table> component, which defines
+the L<table|DBIx::Class::ResultSourceProxy::Table/table> method.
+When called, C<table> creates and stores an instance of
L<DBIx::Class::ResultSoure::Table>. Luckily, to use tables as result
sources, you don't need to remember any of this.
return $found;
}
-sub resolve_join {
- carp 'resolve_join is a private method, stop calling it';
- my $self = shift;
- $self->_resolve_join (@_);
-}
-
# Returns the {from} structure used to express JOIN conditions
sub _resolve_join {
my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
$self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
unless ref $jpath eq 'ARRAY';
- $jpath = [@$jpath];
+ $jpath = [@$jpath]; # copy
if (not defined $join) {
return ();
$force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
# the actual seen value will be incremented by the recursion
- my $as = ($seen->{$rel} ? join ('_', $rel, $seen->{$rel} + 1) : $rel);
+ my $as = $self->storage->relname_to_table_alias(
+ $rel, ($seen->{$rel} && $seen->{$rel} + 1)
+ );
push @ret, (
$self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left),
$self->related_source($rel)->_resolve_join(
- $join->{$rel}, $as, $seen, [@$jpath, $rel], $force_left
+ $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left
)
);
}
}
else {
my $count = ++$seen->{$join};
- my $as = ($count > 1 ? "${join}_${count}" : $join);
+ my $as = $self->storage->relname_to_table_alias(
+ $join, ($count > 1 && $count)
+ );
my $rel_info = $self->relationship_info($join)
or $self->throw_exception("No such relationship ${join}");
? 'left'
: $rel_info->{attrs}{join_type}
,
- -join_path => [@$jpath, $join],
+ -join_path => [@$jpath, { $join => $as } ],
+ -is_single => (
+ $rel_info->{attrs}{accessor}
+ &&
+ List::Util::first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
+ ),
-alias => $as,
-relation_chain_depth => $seen->{-relation_chain_depth} || 0,
},
unless ($for->has_column_loaded($v)) {
if ($for->in_storage) {
$self->throw_exception(sprintf
- 'Unable to resolve relationship from %s to %s: column %s.%s not '
- . 'loaded from storage (or not passed to new() prior to insert()). '
- . 'Maybe you forgot to call ->discard_changes to get defaults from the db.',
-
- $for->result_source->source_name,
+ "Unable to resolve relationship '%s' from object %s: column '%s' not "
+ . 'loaded from storage (or not passed to new() prior to insert()). You '
+ . 'probably need to call ->discard_changes to get the server-side defaults '
+ . 'from the database.',
$as,
- $as, $v,
+ $for,
+ $v,
);
}
return $UNRESOLVABLE_CONDITION;
}
}
-# Legacy code, needs to go entirely away (fully replaced by _resolve_prefetch)
-sub resolve_prefetch {
- carp 'resolve_prefetch is a private method, stop calling it';
-
- my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
- $seen ||= {};
- if( ref $pre eq 'ARRAY' ) {
- return
- map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
- @$pre;
- }
- elsif( ref $pre eq 'HASH' ) {
- my @ret =
- map {
- $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
- $self->related_source($_)->resolve_prefetch(
- $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
- } keys %$pre;
- return @ret;
- }
- elsif( ref $pre ) {
- $self->throw_exception(
- "don't know how to resolve prefetch reftype ".ref($pre));
- }
- else {
- my $count = ++$seen->{$pre};
- my $as = ($count > 1 ? "${pre}_${count}" : $pre);
- my $rel_info = $self->relationship_info( $pre );
- $self->throw_exception( $self->name . " has no such relationship '$pre'" )
- unless $rel_info;
- my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
- my $rel_source = $self->related_source($pre);
-
- if (exists $rel_info->{attrs}{accessor}
- && $rel_info->{attrs}{accessor} eq 'multi') {
- $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 =~ /([^\.]+)$/);
- carp (
- "Prefetching multiple has_many rels ${last} and ${pre} "
- .(length($as_prefix)
- ? "at the same level (${as_prefix}) "
- : "at top level "
- )
- . 'will explode the number of row objects retrievable via ->next or ->all. '
- . 'Use at your own risk.'
- );
- }
- #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}};
- my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
- ? @{$rel_info->{attrs}{order_by}}
- : (defined $rel_info->{attrs}{order_by}
- ? ($rel_info->{attrs}{order_by})
- : ()));
- push(@$order, map { "${as}.$_" } (@key, @ord));
- }
-
- return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
- $rel_source->columns;
- }
-}
# Accepts one or more relationships for the current source and returns an
# array of column names for each of those relationships. Column names are
# prefixed relative to the current source, in accordance with where they appear
-# in the supplied relationships. Needs an alias_map generated by
-# $rs->_joinpath_aliases
+# in the supplied relationships.
sub _resolve_prefetch {
my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
my $rel_source = $self->related_source($pre);
- if (exists $rel_info->{attrs}{accessor}
- && $rel_info->{attrs}{accessor} eq 'multi') {
+ if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') {
$self->throw_exception(
"Can't prefetch has_many ${pre} (join cond too complex)")
unless ref($rel_info->{cond}) eq 'HASH';
keys %{$rel_info->{cond}};
my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
? @{$rel_info->{attrs}{order_by}}
- : (defined $rel_info->{attrs}{order_by}
+
+ : (defined $rel_info->{attrs}{order_by}
? ($rel_info->{attrs}{order_by})
: ()));
push(@$order, map { "${as}.$_" } (@key, @ord));
=cut
sub handle {
- return new DBIx::Class::ResultSourceHandle({
+ return DBIx::Class::ResultSourceHandle->new({
schema => $_[0]->schema,
source_moniker => $_[0]->source_name
});
package MyDB::Schema::Result::Year2000CDs;
- use base qw/DBIx::Class/;
+ use base qw/DBIx::Class::Core/;
- __PACKAGE__->load_components('Core');
__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
__PACKAGE__->table('year2000cds');
}
}
-*add_column = \&add_columns;
+sub add_column {
+ shift->add_columns(@_);
+}
sub has_column {
shift->result_source_instance->has_column(@_);
$new->result_source($source);
}
- if (my $related = delete $attrs->{-from_resultset}) {
+ if (my $related = delete $attrs->{-cols_from_relations}) {
@{$new->{_ignore_at_insert}={}}{@$related} = ();
}
$new->throw_exception("Can't do multi-create without result source")
unless $source;
my $info = $source->relationship_info($key);
- if ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single')
- {
+ my $acc_type = $info->{attrs}{accessor} || '';
+ if ($acc_type eq 'single') {
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
$related->{$key} = $rel_obj;
next;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'multi'
- && ref $attrs->{$key} eq 'ARRAY') {
+ }
+ elsif ($acc_type eq 'multi' && ref $attrs->{$key} eq 'ARRAY' ) {
my $others = delete $attrs->{$key};
my $total = @$others;
my @objects;
}
$related->{$key} = \@objects;
next;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'filter')
- {
+ }
+ elsif ($acc_type eq 'filter') {
## 'filter' should disappear and get merged in with 'single' above!
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
sub in_storage {
my ($self, $val) = @_;
$self->{_in_storage} = $val if @_ > 1;
- return $self->{_in_storage};
+ return $self->{_in_storage} ? 1 : 0;
}
=head2 update
this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
hashref of the relationship, see L<DBIx::Class::Relationship>. Any
database-level cascade or restrict will take precedence over a
-DBIx-Class-based cascading delete.
+DBIx-Class-based cascading delete, since DBIx-Class B<deletes the
+main row first> and only then attempts to delete any remaining related
+rows.
If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
and the transaction subsequently fails, the row object will remain marked as
sub get_inflated_columns {
my $self = shift;
- return map {
- my $accessor = $self->column_info($_)->{'accessor'} || $_;
- ($_ => $self->$accessor);
- } grep $self->has_column_loaded($_), $self->columns;
+
+ my %loaded_colinfo = (map
+ { $_ => $self->column_info($_) }
+ (grep { $self->has_column_loaded($_) } $self->columns)
+ );
+
+ my %inflated;
+ for my $col (keys %loaded_colinfo) {
+ if (exists $loaded_colinfo{$col}{accessor}) {
+ my $acc = $loaded_colinfo{$col}{accessor};
+ $inflated{$col} = $self->$acc if defined $acc;
+ }
+ else {
+ $inflated{$col} = $self->$col;
+ }
+ }
+
+ # return all loaded columns with the inflations overlayed on top
+ return ($self->get_columns, %inflated);
+}
+
+sub _is_column_numeric {
+ my ($self, $column) = @_;
+ my $colinfo = $self->column_info ($column);
+
+ # cache for speed (the object may *not* have a resultsource instance)
+ if (not defined $colinfo->{is_numeric} && $self->_source_handle) {
+ $colinfo->{is_numeric} =
+ $self->result_source->schema->storage->is_datatype_numeric ($colinfo->{data_type})
+ ? 1
+ : 0
+ ;
+ }
+
+ return $colinfo->{is_numeric};
}
=head2 set_column
$self->{_orig_ident} ||= $self->ident_condition;
my $old_value = $self->get_column($column);
- $self->store_column($column, $new_value);
+ $new_value = $self->store_column($column, $new_value);
my $dirty;
if (!$self->in_storage) { # no point tracking dirtyness on uninserted data
$dirty = 0;
}
else { # do a numeric comparison if datatype allows it
- my $colinfo = $self->column_info ($column);
-
- # cache for speed (the object may *not* have a resultsource instance)
- if (not defined $colinfo->{is_numeric} && $self->_source_handle) {
- $colinfo->{is_numeric} =
- $self->result_source->schema->storage->is_datatype_numeric ($colinfo->{data_type})
- ? 1
- : 0
- ;
- }
-
- if ($colinfo->{is_numeric}) {
+ if ($self->_is_column_numeric($column)) {
$dirty = $old_value != $new_value;
}
else {
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 $acc_type = $info->{attrs}{accessor} || '';
+ if ($acc_type 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') {
- $self->throw_exception(
- "Recursive update is not supported over relationships of type multi ($key)"
- );
}
- elsif ($self->has_column($key)
- && exists $self->column_info($key)->{_inflate_info})
- {
+ elsif ($acc_type eq 'multi') {
+ $self->throw_exception(
+ "Recursive update is not supported over relationships of type '$acc_type' ($key)"
+ );
+ }
+ elsif ($self->has_column($key) && exists $self->column_info($key)->{_inflate_info}) {
$self->set_inflated_column($key, delete $upd->{$key});
}
}
my ($source_handle) = $source;
if ($source->isa('DBIx::Class::ResultSourceHandle')) {
- $source = $source_handle->resolve
- } else {
- $source_handle = $source->handle
+ $source = $source_handle->resolve
+ }
+ else {
+ $source_handle = $source->handle
}
my $new = {
};
bless $new, (ref $class || $class);
- my $schema;
foreach my $pre (keys %{$prefetch||{}}) {
- my $pre_val = $prefetch->{$pre};
- my $pre_source = $source->related_source($pre);
- $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
- unless $pre_source;
- if (ref($pre_val->[0]) eq 'ARRAY') { # multi
- my @pre_objects;
- for my $me_pref (@$pre_val) {
+ my $pre_source = $source->related_source($pre)
+ or $class->throw_exception("Can't prefetch non-existent relationship ${pre}");
+
+ my $accessor = $source->relationship_info($pre)->{attrs}{accessor}
+ or $class->throw_exception("No accessor for prefetched $pre");
+ my @pre_vals;
+ if (ref $prefetch->{$pre}[0] eq 'ARRAY') {
+ @pre_vals = @{$prefetch->{$pre}};
+ }
+ elsif ($accessor eq 'multi') {
+ $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor 'multi'");
+ }
+ else {
+ @pre_vals = $prefetch->{$pre};
+ }
+
+ my @pre_objects;
+ for my $me_pref (@pre_vals) {
+
+ # FIXME - this should not be necessary
# the collapser currently *could* return bogus elements with all
# columns set to undef
my $has_def;
push @pre_objects, $pre_source->result_class->inflate_result(
$pre_source, @$me_pref
);
- }
+ }
- $new->related_resultset($pre)->set_cache(\@pre_objects);
- } elsif (defined $pre_val->[0]) {
- my $fetched;
- unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
- and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
- {
- $fetched = $pre_source->result_class->inflate_result(
- $pre_source, @{$pre_val});
- }
- my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
- $class->throw_exception("No accessor for prefetched $pre")
- unless defined $accessor;
- if ($accessor eq 'single') {
- $new->{_relationship_data}{$pre} = $fetched;
- } elsif ($accessor eq 'filter') {
- $new->{_inflated_column}{$pre} = $fetched;
- } else {
- $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor '$accessor'");
- }
- $new->related_resultset($pre)->set_cache([ $fetched ]);
+ if ($accessor eq 'single') {
+ $new->{_relationship_data}{$pre} = $pre_objects[0];
+ }
+ elsif ($accessor eq 'filter') {
+ $new->{_inflated_column}{$pre} = $pre_objects[0];
}
+
+ $new->related_resultset($pre)->set_cache(\@pre_objects);
}
$new->in_storage (1);
use strict;
use warnings;
use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
+use Sub::Name();
BEGIN {
# reinstall the carp()/croak() functions imported into SQL::Abstract
for my $f (qw/carp croak/) {
my $orig = \&{"SQL::Abstract::$f"};
- *{"SQL::Abstract::$f"} = sub {
-
- local $Carp::CarpLevel = 1; # even though Carp::Clan ignores this, $orig will not
-
- if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) {
- __PACKAGE__->can($f)->(@_);
- }
- else {
- $orig->(@_);
- }
- }
+ *{"SQL::Abstract::$f"} = Sub::Name::subname "SQL::Abstract::$f" =>
+ sub {
+ if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) {
+ __PACKAGE__->can($f)->(@_);
+ }
+ else {
+ goto $orig;
+ }
+ };
}
}
}
-# Slow but ANSI standard Limit/Offset support. DB2 uses this
+# ANSI standard Limit/Offset implementation. DB2 and MSSQL use this
sub _RowNumberOver {
my ($self, $sql, $order, $rows, $offset ) = @_;
- $offset += 1;
- my $last = $rows + $offset - 1;
- my ( $order_by ) = $self->_order_by( $order );
+ # get the select to make the final amount of columns equal the original one
+ my ($select) = $sql =~ /^ \s* SELECT \s+ (.+?) \s+ FROM/ix
+ or croak "Unrecognizable SELECT: $sql";
- $sql = <<"SQL";
-SELECT * FROM
-(
- SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
- $sql
- $order_by
- ) Q1
-) Q2
-WHERE ROW_NUM BETWEEN $offset AND $last
+ # get the order_by only (or make up an order if none exists)
+ my $order_by = $self->_order_by(
+ (delete $order->{order_by}) || $self->_rno_default_order
+ );
-SQL
+ # whatever is left of the order_by
+ my $group_having = $self->_order_by($order);
+
+ my $qalias = $self->_quote ($self->{_dbic_rs_attrs}{alias});
+ $sql = sprintf (<<EOS, $offset + 1, $offset + $rows, );
+
+SELECT $select FROM (
+ SELECT $qalias.*, ROW_NUMBER() OVER($order_by ) AS rno__row__index FROM (
+ ${sql}${group_having}
+ ) $qalias
+) $qalias WHERE rno__row__index BETWEEN %d AND %d
+
+EOS
+
+ $sql =~ s/\s*\n\s*/ /g; # easier to read in the debugger
return $sql;
}
-# Crappy Top based Limit/Offset support. MSSQL uses this currently,
-# but may have to switch to RowNumberOver one day
+# some databases are happy with OVER (), some need OVER (ORDER BY (SELECT (1)) )
+sub _rno_default_order {
+ return undef;
+}
+
+# Informix specific limit, almost like LIMIT/OFFSET
+sub _SkipFirst {
+ my ($self, $sql, $order, $rows, $offset) = @_;
+
+ $sql =~ s/^ \s* SELECT \s+ //ix
+ or croak "Unrecognizable SELECT: $sql";
+
+ return sprintf ('SELECT %s%s%s%s',
+ $offset
+ ? sprintf ('SKIP %d ', $offset)
+ : ''
+ ,
+ sprintf ('FIRST %d ', $rows),
+ $sql,
+ $self->_order_by ($order),
+ );
+}
+
+# Crappy Top based Limit/Offset support. Legacy from MSSQL.
sub _Top {
my ( $self, $sql, $order, $rows, $offset ) = @_;
$self->_sqlcase($func),
$self->_recurse_fields($args),
$as
- ? sprintf (' %s %s', $self->_sqlcase('as'), $as)
+ ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
: ''
);
use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
#
-# MSSQL is retarded wrt TOP (crappy limit) and ordering.
-# One needs to add a TOP to *all* ordered subqueries, if
-# TOP has been used in the statement at least once.
-# Do it here.
+# MSSQL does not support ... OVER() ... RNO limits
#
-sub select {
- my $self = shift;
-
- my ($sql, @bind) = $self->SUPER::select (@_);
-
- # ordering was requested and there are at least 2 SELECT/FROM pairs
- # (thus subquery), and there is no TOP specified
- if (
- $sql =~ /\bSELECT\b .+? \bFROM\b .+? \bSELECT\b .+? \bFROM\b/isx
- &&
- $sql !~ /^ \s* SELECT \s+ TOP \s+ \d+ /xi
- &&
- scalar $self->_order_by_chunks ($_[3]->{order_by})
- ) {
- $sql =~ s/^ \s* SELECT \s/SELECT TOP 100 PERCENT /xi;
- }
-
- return wantarray ? ($sql, @bind) : $sql;
+sub _rno_default_order {
+ return \ '(SELECT(1))';
}
1;
use DBIx::Class::Exception;
use Carp::Clan qw/^DBIx::Class/;
-use Scalar::Util qw/weaken/;
+use Scalar::Util ();
use File::Spec;
use Sub::Name ();
use Module::Find();
__PACKAGE__->load_namespaces();
package Library::Schema::Result::CD;
- use base qw/DBIx::Class/;
- __PACKAGE__->load_components(qw/Core/); # for example
+ use base qw/DBIx::Class::Core/;
+
+ __PACKAGE__->load_components(qw/InflateColumn::DateTime/); # for example
__PACKAGE__->table('cd');
# Elsewhere in your code:
Set the storage class that will be instantiated when L</connect> is called.
If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
-assumed by L</connect>.
+assumed by L</connect>.
You want to use this to set subclasses of L<DBIx::Class::Storage::DBI>
-in cases where the appropriate subclass is not autodetected, such as
-when dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it
-to C<::DBI::Sybase::MSSQL>.
+in cases where the appropriate subclass is not autodetected.
If your storage type requires instantiation arguments, those are
defined as a second argument in the form of a hashref and the entire
This interface is preferred over using the individual methods L</txn_begin>,
L</txn_commit>, and L</txn_rollback> below.
-WARNING: If you are connected with C<AutoCommit => 0> the transaction is
+WARNING: If you are connected with C<< AutoCommit => 0 >> the transaction is
considered nested, and you will still need to call L</txn_commit> to write your
-changes when appropriate. You will also want to connect with C<auto_savepoint =>
-1> to get partial rollback to work, if the storage driver for your database
+changes when appropriate. You will also want to connect with C<< auto_savepoint =>
+1 >> to get partial rollback to work, if the storage driver for your database
supports it.
-Connecting with C<AutoCommit => 1> is recommended.
+Connecting with C<< AutoCommit => 1 >> is recommended.
=cut
no strict 'refs';
no warnings 'redefine';
foreach my $meth (qw/class source resultset/) {
- *{"${target}::${meth}"} =
+ *{"${target}::${meth}"} = Sub::Name::subname "${target}::${meth}" =>
sub { shift->schema->$meth(@_) };
}
}
$self->storage->deployment_statements($self, @_);
}
-=head2 create_ddl_dir (EXPERIMENTAL)
+=head2 create_ddl_dir
=over 4
=head2 dclone
-Recommeneded way of dcloning objects. This is needed to properly maintain
-references to the schema object (which itself is B<not> cloned.)
+=over 4
+
+=item Arguments: $object
+
+=item Return Value: dcloned $object
+
+=back
+
+Recommended way of dcloning L<DBIx::Class::Row> and L<DBIx::Class::ResultSet>
+objects so their references to the schema object
+(which itself is B<not> cloned) are properly maintained.
=cut
$self->_register_source(@_);
}
+=head2 unregister_source
+
+=over 4
+
+=item Arguments: $moniker
+
+=back
+
+Removes the L<DBIx::Class::ResultSource> from the schema for the given moniker.
+
+=cut
+
+sub unregister_source {
+ my $self = shift;
+
+ $self->_unregister_source(@_);
+}
+
=head2 register_extra_source
=over 4
$source = $source->new({ %$source, source_name => $moniker });
$source->schema($self);
- weaken($source->{schema}) if ref($self);
+ Scalar::Util::weaken($source->{schema}) if ref($self);
my $rs_class = $source->result_class;
package # Hide from PAUSE
DBIx::Class::Version::Table;
-use base 'DBIx::Class';
+use base 'DBIx::Class::Core';
use strict;
use warnings;
-__PACKAGE__->load_components(qw/ Core/);
__PACKAGE__->table('dbix_class_schema_versions');
__PACKAGE__->add_columns
package # Hide from PAUSE
DBIx::Class::Version::TableCompat;
-use base 'DBIx::Class';
-__PACKAGE__->load_components(qw/ Core/);
+use base 'DBIx::Class::Core';
__PACKAGE__->table('SchemaVersions');
__PACKAGE__->add_columns
use Getopt::Long;
use MyApp::Schema;
- my ( $preversion, $help );
+ my ( $preversion, $help );
GetOptions(
'p|preversion:s' => \$preversion,
) or die pod2usage;
and we can safely deploy the DDL to it. However things are not always so simple.
if you want to initialise a pre-existing database where the DDL is not the same
-as the DDL for your current schema version then you will need a diff which
+as the DDL for your current schema version then you will need a diff which
converts the database's DDL to the current DDL. The best way to do this is
to get a dump of the database schema (without data) and save that in your
SQL directory as version 0.000 (the filename must be as with
-L<DBIx::Class::Schema/ddl_filename>) then create a diff using your create DDL
+L<DBIx::Class::Schema/ddl_filename>) then create a diff using your create DDL
script given above from version 0.000 to the current version. Then hand check
-and if necessary edit the resulting diff to ensure that it will apply. Once you have
+and if necessary edit the resulting diff to ensure that it will apply. Once you have
done all that you can do this:
if (!$schema->get_db_version()) {
$schema->upgrade();
In the case of an unversioned database the above code will create the
-dbix_class_schema_versions table and write version 0.000 to it, then
+dbix_class_schema_versions table and write version 0.000 to it, then
upgrade will then apply the diff we talked about creating in the previous paragraph
and then you're good to go.
use strict;
use warnings;
-use base 'DBIx::Class';
+use base 'DBIx::Class::Schema';
use Carp::Clan qw/^DBIx::Class/;
-use POSIX 'strftime';
+use Time::HiRes qw/gettimeofday/;
__PACKAGE__->mk_classdata('_filedata');
__PACKAGE__->mk_classdata('upgrade_directory');
=back
-Virtual method that should be overriden to create an upgrade file.
-This is useful in the case of upgrading across multiple versions
+Virtual method that should be overriden to create an upgrade file.
+This is useful in the case of upgrading across multiple versions
to concatenate several files to create one upgrade file.
You'll probably want the db_version retrieved via $self->get_db_version
-and the schema_version which is retrieved via $self->schema_version
+and the schema_version which is retrieved via $self->schema_version
=cut
sub create_upgrade_path {
- ## override this method
+ ## override this method
+}
+
+=head2 ordered_schema_versions
+
+=over 4
+
+=item Returns: a list of version numbers, ordered from lowest to highest
+
+=back
+
+Virtual method that should be overriden to return an ordered list
+of schema versions. This is then used to produce a set of steps to
+upgrade through to achieve the required schema version.
+
+You may want the db_version retrieved via $self->get_db_version
+and the schema_version which is retrieved via $self->schema_version
+
+=cut
+
+sub ordered_schema_versions {
+ ## override this method
}
=head2 upgrade
-Call this to attempt to upgrade your database from the version it is at to the version
-this DBIC schema is at. If they are the same it does nothing.
+Call this to attempt to upgrade your database from the version it
+is at to the version this DBIC schema is at. If they are the same
+it does nothing.
-It requires an SQL diff file to exist in you I<upgrade_directory>, normally you will
-have created this using L<DBIx::Class::Schema/create_ddl_dir>.
+It will call L</ordered_schema_versions> to retrieve an ordered
+list of schema versions (if ordered_schema_versions returns nothing
+then it is assumed you can do the upgrade as a single step). It
+then iterates through the list of versions between the current db
+version and the schema version applying one update at a time until
+all relvant updates are applied.
-If successful the dbix_class_schema_versions table is updated with the current
-DBIC schema version.
+The individual update steps are performed by using
+L</upgrade_single_step>, which will apply the update and also
+update the dbix_class_schema_versions table.
=cut
-sub upgrade
-{
- my ($self) = @_;
- my $db_version = $self->get_db_version();
+sub upgrade {
+ my ($self) = @_;
+ my $db_version = $self->get_db_version();
- # db unversioned
- unless ($db_version) {
- carp 'Upgrade not possible as database is unversioned. Please call install first.';
- return;
- }
+ # db unversioned
+ unless ($db_version) {
+ carp 'Upgrade not possible as database is unversioned. Please call install first.';
+ return;
+ }
+
+ # db and schema at same version. do nothing
+ if ( $db_version eq $self->schema_version ) {
+ carp "Upgrade not necessary\n";
+ return;
+ }
+
+ my @version_list = $self->ordered_schema_versions;
+
+ # if nothing returned then we preload with min/max
+ @version_list = ( $db_version, $self->schema_version )
+ unless ( scalar(@version_list) );
+
+ # catch the case of someone returning an arrayref
+ @version_list = @{ $version_list[0] }
+ if ( ref( $version_list[0] ) eq 'ARRAY' );
+
+ # remove all versions in list above the required version
+ while ( scalar(@version_list)
+ && ( $version_list[-1] ne $self->schema_version ) )
+ {
+ pop @version_list;
+ }
+
+ # remove all versions in list below the current version
+ while ( scalar(@version_list) && ( $version_list[0] ne $db_version ) ) {
+ shift @version_list;
+ }
+
+ # check we have an appropriate list of versions
+ if ( scalar(@version_list) < 2 ) {
+ die;
+ }
+
+ # do sets of upgrade
+ while ( scalar(@version_list) >= 2 ) {
+ $self->upgrade_single_step( $version_list[0], $version_list[1] );
+ shift @version_list;
+ }
+}
+
+=head2 upgrade_single_step
+
+=over 4
+
+=item Arguments: db_version - the version currently within the db
+
+=item Arguments: target_version - the version to upgrade to
+
+=back
+
+Call this to attempt to upgrade your database from the
+I<db_version> to the I<target_version>. If they are the same it
+does nothing.
+
+It requires an SQL diff file to exist in your I<upgrade_directory>,
+normally you will have created this using L<DBIx::Class::Schema/create_ddl_dir>.
+
+If successful the dbix_class_schema_versions table is updated with
+the I<target_version>.
+
+This method may be called repeatedly by the upgrade method to
+upgrade through a series of updates.
+
+=cut
+
+sub upgrade_single_step
+{
+ my ($self,
+ $db_version,
+ $target_version) = @_;
# db and schema at same version. do nothing
- if ($db_version eq $self->schema_version) {
+ if ($db_version eq $target_version) {
carp "Upgrade not necessary\n";
return;
}
# strangely the first time this is called can
- # differ to subsequent times. so we call it
+ # 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,
+ $target_version,
$self->upgrade_directory,
$db_version,
);
return;
}
- carp "\nDB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
+ carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
# backup if necessary then apply upgrade
$self->_filedata($self->_read_sql_file($upgrade_file));
$self->txn_do(sub { $self->do_upgrade() });
# set row in dbix_class_schema_versions table
- $self->_set_db_version;
+ $self->_set_db_version({version => $target_version});
}
=head2 do_upgrade
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
+commands, then migrate your data from old to new tables/formats, then
issue the DROP commands when you are finished. Will run the whole file as it is by default.
=cut
{
my ($self) = @_;
- # just run all the commands (including inserts) in order
+ # just run all the commands (including inserts) in order
$self->run_upgrade(qr/.*?/);
}
$self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
for (@statements)
- {
+ {
$self->storage->debugobj->query_start($_) if $self->storage->debug;
$self->apply_statement($_);
$self->storage->debugobj->query_end($_) if $self->storage->debug;
sub apply_statement {
my ($self, $statement) = @_;
- $self->storage->dbh->do($_) or carp "SQL was:\n $_";
+ $self->storage->dbh->do($_) or carp "SQL was: $_";
}
=head2 get_db_version
my ($self, $rs) = @_;
my $vtable = $self->{vschema}->resultset('Table');
- my $version = 0;
- eval {
- my $stamp = $vtable->get_column('installed')->max;
- $version = $vtable->search({ installed => $stamp })->first->version;
+ my $version = eval {
+ $vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } )
+ ->get_column ('version')
+ ->next;
};
- return $version;
+ return $version || 0;
}
=head2 schema_version
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.
+database type.
This method should return the name of the backup file, if appropriate..
my ($self, $args) = @_;
$args = {} unless $args;
+
$self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
my $vtable = $self->{vschema}->resultset('Table');
+ # useful when connecting from scripts etc
+ return if ($args->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $args->{ignore_version}));
+
# 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)) {
}
}
- # 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)
return 1;
}
- carp "Versions out of sync. This is " . $self->schema_version .
+ carp "Versions out of sync. This is " . $self->schema_version .
", your database contains version $pversion, please call upgrade on your Schema.\n";
}
$tr->parser->($tr, $$data);
}
- my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
+ 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 $version = $params->{version} ? $params->{version} : $self->schema_version;
my $vtable = $self->{vschema}->resultset('Table');
- $vtable->create({ version => $version,
- installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
- });
+ ##############################################################################
+ # !!! NOTE !!!
+ ##############################################################################
+ #
+ # The travesty below replaces the old nice timestamp format of %Y-%m-%d %H:%M:%S
+ # This is necessary since there are legitimate cases when upgrades can happen
+ # back to back within the same second. This breaks things since we relay on the
+ # ability to sort by the 'installed' value. The logical choice of an autoinc
+ # is not possible, as it will break multiple legacy installations. Also it is
+ # not possible to format the string sanely, as the column is a varchar(20).
+ # The 'v' character is added to the front of the string, so that any version
+ # formatted by this new function will sort _after_ any existing 200... strings.
+ my @tm = gettimeofday();
+ my @dt = gmtime ($tm[0]);
+ my $o = $vtable->create({
+ version => $version,
+ installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f",
+ $dt[5] + 1900,
+ $dt[4] + 1,
+ $dt[3],
+ $dt[2],
+ $dt[1],
+ $dt[0],
+ $tm[1] / 1000, # convert to millisecs, format as up/down rounded int above
+ ),
+ });
}
sub _read_sql_file {
my $self = shift;
my $file = shift || return;
- my $fh;
- open $fh, "<$file" or carp("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;
+ open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
+ my @data = split /\n/, join '', <$fh>;
+ close $fh;
+
+ @data = grep {
+ $_ &&
+ !/^--/ &&
+ !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
+ } split /;/,
+ join '', @data;
+
return \@data;
}
use strict;
use warnings;
-use base 'DBIx::Class::Storage';
+use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/;
use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util();
use List::Util();
use Data::Dumper::Concise();
+use Sub::Name ();
# what version of sqlt do we require if deploy() without a ddl_dir is invoked
# when changing also adjust the corresponding author_require in Makefile.PL
__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
+# Each of these methods need _determine_driver called before itself
+# in order to function reliably. This is a purely DRY optimization
+my @rdbms_specific_methods = qw/
+ sqlt_type
+ build_datetime_parser
+ datetime_parser_type
+
+ insert
+ insert_bulk
+ update
+ delete
+ select
+ select_single
+/;
+
+for my $meth (@rdbms_specific_methods) {
+
+ my $orig = __PACKAGE__->can ($meth)
+ or next;
+
+ no strict qw/refs/;
+ no warnings qw/redefine/;
+ *{__PACKAGE__ ."::$meth"} = Sub::Name::subname $meth => sub {
+ if (not $_[0]->_driver_determined) {
+ $_[0]->_determine_driver;
+ goto $_[0]->can($meth);
+ }
+ $orig->(@_);
+ };
+}
+
+
=head1 NAME
DBIx::Class::Storage::DBI - DBI storage handler
=cut
sub connect_info {
- my ($self, $info_arg) = @_;
+ my ($self, $info) = @_;
- return $self->_connect_info if !$info_arg;
+ return $self->_connect_info if !$info;
- my @args = @$info_arg; # take a shallow copy for further mutilation
- $self->_connect_info([@args]); # copy for _connect_info
+ $self->_connect_info($info); # copy for _connect_info
+ $info = $self->_normalize_connect_info($info)
+ if ref $info eq 'ARRAY';
+
+ for my $storage_opt (keys %{ $info->{storage_options} }) {
+ my $value = $info->{storage_options}{$storage_opt};
+
+ $self->$storage_opt($value);
+ }
+
+ # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
+ # the new set of options
+ $self->_sql_maker(undef);
+ $self->_sql_maker_opts({});
+
+ for my $sql_maker_opt (keys %{ $info->{sql_maker_options} }) {
+ my $value = $info->{sql_maker_options}{$sql_maker_opt};
+
+ $self->_sql_maker_opts->{$sql_maker_opt} = $value;
+ }
+
+ my %attrs = (
+ %{ $self->_default_dbi_connect_attributes || {} },
+ %{ $info->{attributes} || {} },
+ );
+
+ my @args = @{ $info->{arguments} };
+
+ $self->_dbi_connect_info([@args,
+ %attrs && !(ref $args[0] eq 'CODE') ? \%attrs : ()]);
+
+ return $self->_connect_info;
+}
+
+sub _normalize_connect_info {
+ my ($self, $info_arg) = @_;
+ my %info;
+
+ my @args = @$info_arg; # take a shallow copy for further mutilation
# combine/pre-parse arguments depending on invocation style
@args = @args[0,1,2];
}
- # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
- # the new set of options
- $self->_sql_maker(undef);
- $self->_sql_maker_opts({});
+ $info{arguments} = \@args;
- if(keys %attrs) {
- for my $storage_opt (@storage_options, 'cursor_class') { # @storage_options is declared at the top of the module
- if(my $value = delete $attrs{$storage_opt}) {
- $self->$storage_opt($value);
- }
- }
- for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
- if(my $opt_val = delete $attrs{$sql_maker_opt}) {
- $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
- }
- }
- }
+ my @storage_opts = grep exists $attrs{$_},
+ @storage_options, 'cursor_class';
- if (ref $args[0] eq 'CODE') {
- # _connect() never looks past $args[0] in this case
- %attrs = ()
- } else {
- %attrs = (
- %{ $self->_default_dbi_connect_attributes || {} },
- %attrs,
- );
- }
+ @{ $info{storage_options} }{@storage_opts} =
+ delete @attrs{@storage_opts} if @storage_opts;
+
+ my @sql_maker_opts = grep exists $attrs{$_},
+ qw/limit_dialect quote_char name_sep/;
- $self->_dbi_connect_info([@args, keys %attrs ? \%attrs : ()]);
- $self->_connect_info;
+ @{ $info{sql_maker_options} }{@sql_maker_opts} =
+ delete @attrs{@sql_maker_opts} if @sql_maker_opts;
+
+ $info{attributes} = \%attrs if %attrs;
+
+ return \%info;
}
sub _default_dbi_connect_attributes {
# Storage subclasses should override this
sub with_deferred_fk_checks {
my ($self, $sub) = @_;
-
$sub->();
}
eval {
if(ref $info[0] eq 'CODE') {
- $dbh = &{$info[0]}
+ $dbh = $info[0]->();
}
else {
$dbh = DBI->connect(@info);
sub txn_begin {
my $self = shift;
+
+ # this means we have not yet connected and do not know the AC status
+ # (e.g. coderef $dbh)
+ $self->ensure_connected if (! defined $self->_dbh_autocommit);
+
if($self->{transaction_depth} == 0) {
$self->debugobj->txn_begin()
if $self->debug;
sub txn_commit {
my $self = shift;
if ($self->{transaction_depth} == 1) {
- my $dbh = $self->_dbh;
$self->debugobj->txn_commit()
if ($self->debug);
$self->_dbh_commit;
sub _dbh_commit {
my $self = shift;
- $self->_dbh->commit;
+ my $dbh = $self->_dbh
+ or $self->throw_exception('cannot COMMIT on a disconnected handle');
+ $dbh->commit;
}
sub txn_rollback {
sub _dbh_rollback {
my $self = shift;
- $self->_dbh->rollback;
+ my $dbh = $self->_dbh
+ or $self->throw_exception('cannot ROLLBACK on a disconnected handle');
+ $dbh->rollback;
}
# This used to be the top-half of _execute. It was split out to make it
sub insert {
my ($self, $source, $to_insert) = @_;
-# redispatch to insert method of storage we reblessed into, if necessary
- if (not $self->_driver_determined) {
- $self->_determine_driver;
- goto $self->can('insert');
- }
-
my $ident = $source->from;
my $bind_attributes = $self->source_bind_attributes($source);
return $updated_cols;
}
-## Still not quite perfect, and EXPERIMENTAL
## Currently it is assumed that all values passed will be "normal", i.e. not
## scalar refs, or at least, all the same type as the first set, the statement is
## only prepped once.
sub insert_bulk {
my ($self, $source, $cols, $data) = @_;
-# redispatch to insert_bulk method of storage we reblessed into, if necessary
- if (not $self->_driver_determined) {
- $self->_determine_driver;
- goto $self->can('insert_bulk');
- }
-
my %colvalues;
@colvalues{@$cols} = (0..$#$cols);
);
}
+ # neither _execute_array, nor _execute_inserts_with_no_binds are
+ # atomic (even if _execute _array is a single call). Thus a safety
+ # scope guard
+ my $guard = $self->txn_scope_guard unless $self->{transaction_depth} != 0;
+
$self->_query_start( $sql, ['__BULK__'] );
my $sth = $self->sth($sql);
-
my $rv = do {
if ($empty_bind) {
# bind_param_array doesn't work if there are no binds
$self->_query_end( $sql, ['__BULK__'] );
+
+ $guard->commit if $guard;
+
return (wantarray ? ($rv, $sth, @bind) : $rv);
}
sub _execute_array {
my ($self, $source, $sth, $bind, $cols, $data, @extra) = @_;
- my $guard = $self->txn_scope_guard unless $self->{transaction_depth} != 0;
-
## This must be an arrayref, else nothing works!
my $tuple_status = [];
}),
);
}
-
- $guard->commit if $guard;
-
return $rv;
}
sub _dbh_execute_inserts_with_no_binds {
my ($self, $sth, $count) = @_;
- my $guard = $self->txn_scope_guard unless $self->{transaction_depth} != 0;
-
eval {
my $dbh = $self->_get_dbh;
local $dbh->{RaiseError} = 1;
$self->throw_exception($exception) if $exception;
- $guard->commit if $guard;
-
return $count;
}
sub update {
- my ($self, $source, @args) = @_;
+ my ($self, $source, @args) = @_;
-# redispatch to update method of storage we reblessed into, if necessary
- if (not $self->_driver_determined) {
- $self->_determine_driver;
- goto $self->can('update');
- }
-
- my $bind_attributes = $self->source_bind_attributes($source);
+ my $bind_attrs = $self->source_bind_attributes($source);
- return $self->_execute('update' => [], $source, $bind_attributes, @args);
+ return $self->_execute('update' => [], $source, $bind_attrs, @args);
}
sub delete {
- my $self = shift @_;
- my $source = shift @_;
- $self->_determine_driver;
+ my ($self, $source, @args) = @_;
+
my $bind_attrs = $self->source_bind_attributes($source);
- return $self->_execute('delete' => [], $source, $bind_attrs, @_);
+ return $self->_execute('delete' => [], $source, $bind_attrs, @args);
}
# We were sent here because the $rs contains a complex search
# which will require a subquery to select the correct rows
-# (i.e. joined or limited resultsets)
+# (i.e. joined or limited resultsets, or non-introspectable conditions)
#
-# Genarating a single PK column subquery is trivial and supported
+# Generating a single PK column subquery is trivial and supported
# by all RDBMS. However if we have a multicolumn PK, things get ugly.
# Look at _multipk_update_delete()
sub _subq_update_delete {
my $rsrc = $rs->result_source;
- # we already check this, but double check naively just in case. Should be removed soon
+ # quick check if we got a sane rs on our hands
+ my @pcols = $rsrc->primary_columns;
+ unless (@pcols) {
+ $self->throw_exception (
+ sprintf (
+ "You must declare primary key(s) on source '%s' (via set_primary_key) in order to update or delete complex resultsets",
+ $rsrc->source_name || $rsrc->from
+ )
+ );
+ }
+
my $sel = $rs->_resolved_attrs->{select};
$sel = [ $sel ] unless ref $sel eq 'ARRAY';
- my @pcols = $rsrc->primary_columns;
- if (@$sel != @pcols) {
+
+ if (
+ join ("\x00", map { join '.', $rs->{attrs}{alias}, $_ } sort @pcols)
+ ne
+ join ("\x00", sort @$sel )
+ ) {
$self->throw_exception (
- 'Subquery update/delete can not be called on resultsets selecting a'
- .' number of columns different than the number of primary keys'
+ '_subq_update_delete can not be called on resultsets selecting columns other than the primary keys'
);
}
my $row_cnt = '0E0';
my $subrs_cur = $rs->cursor;
- while (my @pks = $subrs_cur->next) {
+ my @all_pk = $subrs_cur->all;
+ for my $pks ( @all_pk) {
my $cond;
for my $i (0.. $#pcols) {
- $cond->{$pcols[$i]} = $pks[$i];
+ $cond->{$pcols[$i]} = $pks->[$i];
}
$self->$op (
select => $select,
from => $ident,
where => $where,
- $rs_alias
+ $rs_alias && $alias2source->{$rs_alias}
? ( _source_handle => $alias2source->{$rs_alias}->handle )
: ()
,
my @limit;
- # see if we need to tear the prefetch apart (either limited has_many or grouped prefetch)
- # otherwise delegate the limiting to the storage, unless software limit was requested
+ # see if we need to tear the prefetch apart otherwise delegate the limiting to the
+ # storage, unless software limit was requested
if (
+ #limited has_many
( $attrs->{rows} && keys %{$attrs->{collapse}} )
||
- ( $attrs->{group_by} && @{$attrs->{group_by}} &&
- $attrs->{_prefetch_select} && @{$attrs->{_prefetch_select}} )
+ # limited prefetch with RNO subqueries
+ (
+ $attrs->{rows}
+ &&
+ $sql_maker->limit_dialect eq 'RowNumberOver'
+ &&
+ $attrs->{_prefetch_select}
+ &&
+ @{$attrs->{_prefetch_select}}
+ )
+ ||
+ # grouped prefetch
+ ( $attrs->{group_by}
+ &&
+ @{$attrs->{group_by}}
+ &&
+ $attrs->{_prefetch_select}
+ &&
+ @{$attrs->{_prefetch_select}}
+ )
) {
($ident, $select, $where, $attrs)
= $self->_adjust_select_args_for_complex_prefetch ($ident, $select, $where, $attrs);
}
+
+ elsif (
+ ($attrs->{rows} || $attrs->{offset})
+ &&
+ $sql_maker->limit_dialect eq 'RowNumberOver'
+ &&
+ (ref $ident eq 'ARRAY' && @$ident > 1) # indicates a join
+ &&
+ scalar $self->_parse_order_by ($attrs->{order_by})
+ ) {
+ # the RNO limit dialect above mangles the SQL such that the join gets lost
+ # wrap a subquery here
+
+ push @limit, delete @{$attrs}{qw/rows offset/};
+
+ my $subq = $self->_select_args_to_query (
+ $ident,
+ $select,
+ $where,
+ $attrs,
+ );
+
+ $ident = {
+ -alias => $attrs->{alias},
+ -source_handle => $ident->[0]{-source_handle},
+ $attrs->{alias} => $subq,
+ };
+
+ # all part of the subquery now
+ delete @{$attrs}{qw/order_by group_by having/};
+ $where = undef;
+ }
+
elsif (! $attrs->{software_limit} ) {
push @limit, $attrs->{rows}, $attrs->{offset};
}
+ # try to simplify the joinmap further (prune unreferenced type-single joins)
+ $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs);
+
###
# This would be the point to deflate anything found in $where
# (and leave $attrs->{bind} intact). Problem is - inflators historically
return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $order, @limit);
}
-#
-# This is the code producing joined subqueries like:
-# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ...
-#
-sub _adjust_select_args_for_complex_prefetch {
- my ($self, $from, $select, $where, $attrs) = @_;
-
- $self->throw_exception ('Nothing to prefetch... how did we get here?!')
- if not @{$attrs->{_prefetch_select}};
-
- $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
- if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY');
-
-
- # generate inner/outer attribute lists, remove stuff that doesn't apply
- my $outer_attrs = { %$attrs };
- delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/;
-
- my $inner_attrs = { %$attrs };
- delete $inner_attrs->{$_} for qw/for collapse _prefetch_select _collapse_order_by select as/;
-
-
- # bring over all non-collapse-induced order_by into the inner query (if any)
- # the outer one will have to keep them all
- delete $inner_attrs->{order_by};
- if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}} ) {
- $inner_attrs->{order_by} = [
- @{$outer_attrs->{order_by}}[ 0 .. $ord_cnt - 1]
- ];
- }
-
-
- # generate the inner/outer select lists
- # for inside we consider only stuff *not* brought in by the prefetch
- # on the outside we substitute any function for its alias
- my $outer_select = [ @$select ];
- my $inner_select = [];
- for my $i (0 .. ( @$outer_select - @{$outer_attrs->{_prefetch_select}} - 1) ) {
- my $sel = $outer_select->[$i];
-
- if (ref $sel eq 'HASH' ) {
- $sel->{-as} ||= $attrs->{as}[$i];
- $outer_select->[$i] = join ('.', $attrs->{alias}, ($sel->{-as} || "inner_column_$i") );
- }
-
- push @$inner_select, $sel;
- }
-
- # normalize a copy of $from, so it will be easier to work with further
- # down (i.e. promote the initial hashref to an AoH)
- $from = [ @$from ];
- $from->[0] = [ $from->[0] ];
- my %original_join_info = map { $_->[0]{-alias} => $_->[0] } (@$from);
-
-
- # decide which parts of the join will remain in either part of
- # the outer/inner query
-
- # First we compose a list of which aliases are used in restrictions
- # (i.e. conditions/order/grouping/etc). Since we do not have
- # introspectable SQLA, we fall back to ugly scanning of raw SQL for
- # WHERE, and for pieces of ORDER BY in order to determine which aliases
- # need to appear in the resulting sql.
- # It may not be very efficient, but it's a reasonable stop-gap
- # Also unqualified column names will not be considered, but more often
- # than not this is actually ok
- #
- # In the same loop we enumerate part of the selection aliases, as
- # it requires the same sqla hack for the time being
- my ($restrict_aliases, $select_aliases, $prefetch_aliases);
- {
- # produce stuff unquoted, so it can be scanned
- my $sql_maker = $self->sql_maker;
- local $sql_maker->{quote_char};
- my $sep = $self->_sql_maker_opts->{name_sep} || '.';
- $sep = "\Q$sep\E";
-
- my $non_prefetch_select_sql = $sql_maker->_recurse_fields ($inner_select);
- my $prefetch_select_sql = $sql_maker->_recurse_fields ($outer_attrs->{_prefetch_select});
- my $where_sql = $sql_maker->where ($where);
- my $group_by_sql = $sql_maker->_order_by({
- map { $_ => $inner_attrs->{$_} } qw/group_by having/
- });
- my @non_prefetch_order_by_chunks = (map
- { ref $_ ? $_->[0] : $_ }
- $sql_maker->_order_by_chunks ($inner_attrs->{order_by})
- );
-
-
- for my $alias (keys %original_join_info) {
- my $seen_re = qr/\b $alias $sep/x;
-
- for my $piece ($where_sql, $group_by_sql, @non_prefetch_order_by_chunks ) {
- if ($piece =~ $seen_re) {
- $restrict_aliases->{$alias} = 1;
- }
- }
-
- if ($non_prefetch_select_sql =~ $seen_re) {
- $select_aliases->{$alias} = 1;
- }
-
- if ($prefetch_select_sql =~ $seen_re) {
- $prefetch_aliases->{$alias} = 1;
- }
-
- }
- }
-
- # Add any non-left joins to the restriction list (such joins are indeed restrictions)
- for my $j (values %original_join_info) {
- my $alias = $j->{-alias} or next;
- $restrict_aliases->{$alias} = 1 if (
- (not $j->{-join_type})
- or
- ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
- );
- }
-
- # mark all join parents as mentioned
- # (e.g. join => { cds => 'tracks' } - tracks will need to bring cds too )
- for my $collection ($restrict_aliases, $select_aliases) {
- for my $alias (keys %$collection) {
- $collection->{$_} = 1
- for (@{ $original_join_info{$alias}{-join_path} || [] });
- }
- }
-
- # construct the inner $from for the subquery
- my %inner_joins = (map { %{$_ || {}} } ($restrict_aliases, $select_aliases) );
- my @inner_from;
- for my $j (@$from) {
- push @inner_from, $j if $inner_joins{$j->[0]{-alias}};
- }
-
- # if a multi-type join was needed in the subquery ("multi" is indicated by
- # presence in {collapse}) - add a group_by to simulate the collapse in the subq
- unless ($inner_attrs->{group_by}) {
- for my $alias (keys %inner_joins) {
-
- # the dot comes from some weirdness in collapse
- # remove after the rewrite
- if ($attrs->{collapse}{".$alias"}) {
- $inner_attrs->{group_by} ||= $inner_select;
- last;
- }
- }
- }
-
- # demote the inner_from head
- $inner_from[0] = $inner_from[0][0];
-
- # generate the subquery
- my $subq = $self->_select_args_to_query (
- \@inner_from,
- $inner_select,
- $where,
- $inner_attrs,
- );
-
- my $subq_joinspec = {
- -alias => $attrs->{alias},
- -source_handle => $inner_from[0]{-source_handle},
- $attrs->{alias} => $subq,
- };
-
- # Generate the outer from - this is relatively easy (really just replace
- # the join slot with the subquery), with a major caveat - we can not
- # join anything that is non-selecting (not part of the prefetch), but at
- # the same time is a multi-type relationship, as it will explode the result.
- #
- # There are two possibilities here
- # - either the join is non-restricting, in which case we simply throw it away
- # - it is part of the restrictions, in which case we need to collapse the outer
- # result by tackling yet another group_by to the outside of the query
-
- # so first generate the outer_from, up to the substitution point
- my @outer_from;
- while (my $j = shift @$from) {
- if ($j->[0]{-alias} eq $attrs->{alias}) { # time to swap
- push @outer_from, [
- $subq_joinspec,
- @{$j}[1 .. $#$j],
- ];
- last; # we'll take care of what's left in $from below
- }
- else {
- push @outer_from, $j;
- }
- }
-
- # see what's left - throw away if not selecting/restricting
- # also throw in a group_by if restricting to guard against
- # cross-join explosions
- #
- while (my $j = shift @$from) {
- my $alias = $j->[0]{-alias};
-
- if ($select_aliases->{$alias} || $prefetch_aliases->{$alias}) {
- push @outer_from, $j;
- }
- elsif ($restrict_aliases->{$alias}) {
- push @outer_from, $j;
-
- # FIXME - this should be obviated by SQLA2, as I'll be able to
- # have restrict_inner and restrict_outer... or something to that
- # effect... I think...
-
- # FIXME2 - I can't find a clean way to determine if a particular join
- # is a multi - instead I am just treating everything as a potential
- # explosive join (ribasushi)
- #
- # if (my $handle = $j->[0]{-source_handle}) {
- # my $rsrc = $handle->resolve;
- # ... need to bail out of the following if this is not a multi,
- # as it will be much easier on the db ...
-
- $outer_attrs->{group_by} ||= $outer_select;
- # }
- }
- }
-
- # demote the outer_from head
- $outer_from[0] = $outer_from[0][0];
-
- # This is totally horrific - the $where ends up in both the inner and outer query
- # Unfortunately not much can be done until SQLA2 introspection arrives, and even
- # then if where conditions apply to the *right* side of the prefetch, you may have
- # to both filter the inner select (e.g. to apply a limit) and then have to re-filter
- # the outer select to exclude joins you didin't want in the first place
- #
- # OTOH it can be seen as a plus: <ash> (notes that this query would make a DBA cry ;)
- return (\@outer_from, $outer_select, $where, $outer_attrs);
-}
-
-sub _resolve_ident_sources {
- my ($self, $ident) = @_;
-
- my $alias2source = {};
- my $rs_alias;
-
- # the reason this is so contrived is that $ident may be a {from}
- # structure, specifying multiple tables to join
- if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
- # this is compat mode for insert/update/delete which do not deal with aliases
- $alias2source->{me} = $ident;
- $rs_alias = 'me';
- }
- elsif (ref $ident eq 'ARRAY') {
-
- for (@$ident) {
- my $tabinfo;
- if (ref $_ eq 'HASH') {
- $tabinfo = $_;
- $rs_alias = $tabinfo->{-alias};
- }
- if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') {
- $tabinfo = $_->[0];
- }
-
- $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-source_handle}->resolve
- if ($tabinfo->{-source_handle});
- }
- }
-
- return ($alias2source, $rs_alias);
-}
-
-# Takes $ident, \@column_names
-#
-# returns { $column_name => \%column_info, ... }
-# also note: this adds -result_source => $rsrc to the column info
-#
-# usage:
-# my $col_sources = $self->_resolve_column_info($ident, @column_names);
-sub _resolve_column_info {
- my ($self, $ident, $colnames) = @_;
- my ($alias2src, $root_alias) = $self->_resolve_ident_sources($ident);
-
- my $sep = $self->_sql_maker_opts->{name_sep} || '.';
- $sep = "\Q$sep\E";
-
- my (%return, %seen_cols);
-
- # compile a global list of column names, to be able to properly
- # disambiguate unqualified column names (if at all possible)
- for my $alias (keys %$alias2src) {
- my $rsrc = $alias2src->{$alias};
- for my $colname ($rsrc->columns) {
- push @{$seen_cols{$colname}}, $alias;
- }
- }
-
- COLUMN:
- foreach my $col (@$colnames) {
- my ($alias, $colname) = $col =~ m/^ (?: ([^$sep]+) $sep)? (.+) $/x;
-
- unless ($alias) {
- # see if the column was seen exactly once (so we know which rsrc it came from)
- if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1) {
- $alias = $seen_cols{$colname}[0];
- }
- else {
- next COLUMN;
- }
- }
-
- my $rsrc = $alias2src->{$alias};
- $return{$col} = $rsrc && {
- %{$rsrc->column_info($colname)},
- -result_source => $rsrc,
- -source_alias => $alias,
- };
- }
-
- return \%return;
-}
-
# Returns a counting SELECT for a simple count
# query. Abstracted so that a storage could override
# this to { count => 'firstcol' } or whatever makes
=cut
sub _dbh_last_insert_id {
- # All Storage's need to register their own _dbh_last_insert_id
- # the old SQLite-based method was highly inappropriate
+ my ($self, $dbh, $source, $col) = @_;
- my $self = shift;
- my $class = ref $self;
- $self->throw_exception (<<EOE);
+ my $id = eval { $dbh->last_insert_id (undef, undef, $source->name, $col) };
+
+ return $id if defined $id;
-No _dbh_last_insert_id() method found in $class.
-Since the method of obtaining the autoincrement id of the last insert
-operation varies greatly between different databases, this method must be
-individually implemented for every storage class.
-EOE
+ my $class = ref $self;
+ $self->throw_exception ("No storage specific _dbh_last_insert_id() method implemented in $class, and the generic DBI::last_insert_id() failed");
}
sub last_insert_id {
This API is B<EXPERIMENTAL>, will almost definitely change in the future, and
currently only used by L<::AutoCast|DBIx::Class::Storage::DBI::AutoCast> and
-L<::Sybase|DBIx::Class::Storage::DBI::Sybase>.
+L<::Sybase::ASE|DBIx::Class::Storage::DBI::Sybase::ASE>.
The default implementation returns C<undef>, implement in your Storage driver if
you need this functionality.
=cut
sub sqlt_type {
- my ($self) = @_;
-
- if (not $self->_driver_determined) {
- $self->_determine_driver;
- goto $self->can ('sqlt_type');
- }
-
- $self->_get_dbh->{Driver}->{Name};
+ shift->_get_dbh->{Driver}->{Name};
}
=head2 bind_attribute_by_data_type
}
-=head2 create_ddl_dir (EXPERIMENTAL)
+=head2 create_ddl_dir
=over 4
{ ignore_constraint_names => 0, # ... other options }
-Note that this feature is currently EXPERIMENTAL and may not work correctly
-across all databases, or fully handle complex relationships.
-
-WARNING: Please check all SQL files created, before applying them.
+WARNING: You are strongly advised to check all SQL files created, before applying
+them.
=cut
data => $schema,
);
- my $ret = $tr->translate
- or $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error);
+ my @ret;
+ my $wa = wantarray;
+ if ($wa) {
+ @ret = $tr->translate;
+ }
+ else {
+ $ret[0] = $tr->translate;
+ }
+
+ $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
+ unless (@ret && defined $ret[0]);
- return $ret;
+ return $wa ? @ret : $ret[0];
}
sub deploy {
=cut
sub build_datetime_parser {
- if (not $_[0]->_driver_determined) {
- $_[0]->_determine_driver;
- goto $_[0]->can('build_datetime_parser');
- }
-
my $self = shift;
my $type = $self->datetime_parser_type(@_);
$self->ensure_class_loaded ($type);
sub _sqlt_minimum_version { $minimum_sqlt_version };
}
+=head2 relname_to_table_alias
+
+=over 4
+
+=item Arguments: $relname, $join_count
+
+=back
+
+L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
+queries.
+
+This hook is to allow specific L<DBIx::Class::Storage> drivers to change the
+way these aliases are named.
+
+The default behavior is C<"$relname_$join_count" if $join_count > 1>, otherwise
+C<"$relname">.
+
+=cut
+
+sub relname_to_table_alias {
+ my ($self, $relname, $join_count) = @_;
+
+ my $alias = ($join_count && $join_count > 1 ?
+ join('_', $relname, $join_count) : $relname);
+
+ return $alias;
+}
+
sub DESTROY {
my $self = shift;
# some databases need this to stop spewing warnings
if (my $dbh = $self->_dbh) {
local $@;
- eval { $dbh->disconnect };
+ eval {
+ %{ $dbh->{CachedKids} } = ();
+ $dbh->disconnect;
+ };
}
$self->_dbh(undef);
--- /dev/null
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ADO;
+
+use base 'DBIx::Class::Storage::DBI';
+
+sub _rebless {
+ my $self = shift;
+
+# check for MSSQL
+# XXX This should be using an OpenSchema method of some sort, but I don't know
+# how.
+# Current version is stolen from Sybase.pm
+ my $dbtype = eval {
+ @{$self->_get_dbh
+ ->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})
+ }[2]
+ };
+
+ unless ($@) {
+ $dbtype =~ s/\W/_/gi;
+ my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}";
+ if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
+ bless $self, $subclass;
+ $self->_rebless;
+ }
+ }
+}
+
+# Here I was just experimenting with ADO cursor types, left in as a comment in
+# case you want to as well. See the DBD::ADO docs.
+#sub _dbh_sth {
+# my ($self, $dbh, $sql) = @_;
+#
+# my $sth = $self->disable_sth_caching
+# ? $dbh->prepare($sql, { CursorType => 'adOpenStatic' })
+# : $dbh->prepare_cached($sql, { CursorType => 'adOpenStatic' }, 3);
+#
+# $self->throw_exception($dbh->errstr) if !$sth;
+#
+# $sth;
+#}
+
+1;
--- /dev/null
+package DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server;
+
+use strict;
+use warnings;
+
+use base qw/
+ DBIx::Class::Storage::DBI::ADO
+ DBIx::Class::Storage::DBI::MSSQL
+/;
+use mro 'c3';
+
+sub _rebless {
+ my $self = shift;
+ $self->_identity_method('@@identity');
+}
+
+sub source_bind_attributes {
+ my $self = shift;
+ my ($source) = @_;
+
+ my $bind_attributes = $self->next::method(@_);
+
+ foreach my $column ($source->columns) {
+ $bind_attributes->{$column}{ado_size} ||= 8000; # max VARCHAR
+ }
+
+ return $bind_attributes;
+}
+
+sub bind_attribute_by_data_type {
+ my ($self, $data_type) = @_;
+
+ ($data_type = lc($data_type)) =~ s/\s+.*//;
+
+ my $max_size =
+ $self->_mssql_max_data_type_representation_size_in_bytes->{$data_type};
+
+ my $res = {};
+ $res->{ado_size} = $max_size if $max_size;
+
+ return $res;
+}
+
+# approximate
+# XXX needs to support varchar(max) and varbinary(max)
+sub _mssql_max_data_type_representation_size_in_bytes {
+ my $self = shift;
+
+ my $blob_max = $self->_get_dbh->{LongReadLen} || 32768;
+
+ return +{
+# MSSQL types
+ char => 8000,
+ varchar => 8000,
+ binary => 8000,
+ varbinary => 8000,
+ nchar => 8000,
+ nvarchar => 8000,
+ numeric => 100,
+ smallint => 100,
+ tinyint => 100,
+ smallmoney => 100,
+ bigint => 100,
+ bit => 100,
+ decimal => 100,
+ integer => 100,
+ int => 100,
+ money => 100,
+ float => 100,
+ real => 100,
+ uniqueidentifier => 100,
+ ntext => $blob_max,
+ text => $blob_max,
+ image => $blob_max,
+ date => 100,
+ datetime => 100,
+ datetime2 => 100,
+ datetimeoffset => 100,
+ smalldatetime => 100,
+ time => 100,
+ timestamp => 100,
+ cursor => 100,
+ hierarchyid => 100,
+ sql_variant => 100,
+ table => 100,
+ xml => $blob_max, # ???
+
+# some non-MSSQL types
+ serial => 100,
+ bigserial => 100,
+ varchar2 => 8000,
+ blob => $blob_max,
+ clob => $blob_max,
+ }
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server - Support for Microsoft
+SQL Server via DBD::ADO
+
+=head1 SYNOPSIS
+
+This subclass supports MSSQL server connections via L<DBD::ADO>.
+
+=head1 DESCRIPTION
+
+The MSSQL specific functionality is provided by
+L<DBIx::Class::Storage::DBI::MSSQL>.
+
+=head2 CAVEATS
+
+=head3 identities
+
+C<_identity_method> is set to C<@@identity>, as C<SCOPE_IDENTITY()> doesn't work
+with L<DBD::ADO>. See L<DBIx::Class::Storage::DBI::MSSQL/IMPLEMENTATION NOTES>
+for caveats regarding this.
+
+=head3 truncation bug
+
+There is a bug with MSSQL ADO providers where data gets truncated based on the
+size of the bind sizes in the first prepare call:
+
+L<https://rt.cpan.org/Ticket/Display.html?id=52048>
+
+The C<ado_size> workaround is used (see L<DBD::ADO/"ADO Providers">) with the
+approximate maximum size of the data_type of the bound column, or 8000 (maximum
+VARCHAR size) if the data_type is not available.
+
+This code is incomplete and may be buggy. Particularly, C<VARCHAR(MAX)> is not
+supported yet. The data_type list for other DBs is also incomplete. Please
+report problems (and send patches.)
+
+=head1 AUTHOR
+
+See L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
=head1 NAME
-DBIx::Class::Storage::DBI::AmbiguousGlob - Storage component for RDBMS supporting multicolumn in clauses
+DBIx::Class::Storage::DBI::AmbiguousGlob - Storage component for RDBMS choking on count(*)
=head1 DESCRIPTION
sub _subq_count_select {
my ($self, $source, $rs_attrs) = @_;
+
+ return $rs_attrs->{group_by} if $rs_attrs->{group_by};
+
my @pcols = map { join '.', $rs_attrs->{alias}, $_ } ($source->primary_columns);
return @pcols ? \@pcols : [ 1 ];
}
=head1 SYNOPSIS
# In your table classes
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ use base 'DBIx::Class::Core';
__PACKAGE__->set_primary_key('id');
=head1 DESCRIPTION
--- /dev/null
+package DBIx::Class::Storage::DBI::Informix;
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+
+use mro 'c3';
+
+__PACKAGE__->mk_group_accessors('simple' => '__last_insert_id');
+
+sub _execute {
+ my $self = shift;
+ my ($op) = @_;
+ my ($rv, $sth, @rest) = $self->next::method(@_);
+ if ($op eq 'insert') {
+ $self->__last_insert_id($sth->{ix_sqlerrd}[1]);
+ }
+ return (wantarray ? ($rv, $sth, @rest) : $rv);
+}
+
+sub last_insert_id {
+ shift->__last_insert_id;
+}
+
+sub _sql_maker_opts {
+ my ( $self, $opts ) = @_;
+
+ if ( $opts ) {
+ $self->{_sql_maker_opts} = { %$opts };
+ }
+
+ return { limit_dialect => 'SkipFirst', %{$self->{_sql_maker_opts}||{}} };
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Informix - Base Storage Class for INFORMIX Support
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This class implements storage-specific support for Informix
+
+=head1 AUTHORS
+
+See L<DBIx::Class/CONTRIBUTORS>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
# this should bring back the result of SELECT SCOPE_IDENTITY() we tacked
# on in _prep_for_execute above
- my ($identity) = $sth->fetchrow_array;
+ my ($identity) = eval { $sth->fetchrow_array };
# SCOPE_IDENTITY failed, but we can do something else
if ( (! $identity) && $self->_identity_method) {
sub last_insert_id { shift->_identity }
+#
+# MSSQL is retarded wrt ordered subselects. One needs to add a TOP
+# to *all* subqueries, but one also can't use TOP 100 PERCENT
+# http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931
+#
+sub _select_args_to_query {
+ my $self = shift;
+
+ my ($sql, $prep_bind, @rest) = $self->next::method (@_);
+
+ # see if this is an ordered subquery
+ my $attrs = $_[3];
+ if ( scalar $self->_parse_order_by ($attrs->{order_by}) ) {
+ $self->throw_exception(
+ 'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL
+ ') unless $attrs->{unsafe_subselect_ok};
+ my $max = 2 ** 32;
+ $sql =~ s/^ \s* SELECT \s/SELECT TOP $max /xi;
+ }
+
+ return wantarray
+ ? ($sql, $prep_bind, @rest)
+ : \[ "($sql)", @$prep_bind ]
+ ;
+}
+
+
# savepoint syntax is the same as in Sybase ASE
sub _svp_begin {
sub sqlt_type { 'SQLServer' }
-sub _sql_maker_opts {
- my ( $self, $opts ) = @_;
+sub _get_mssql_version {
+ my $self = shift;
+
+ my $data = $self->_get_dbh->selectrow_hashref('xp_msver ProductVersion');
- if ( $opts ) {
- $self->{_sql_maker_opts} = { %$opts };
+ if ($data->{Character_Value} =~ /^(\d+)\./) {
+ return $1;
+ } else {
+ $self->throw_exception(q{Your ProductVersion's Character_Value is missing or malformed!});
}
+}
+
+sub sql_maker {
+ my $self = shift;
- return { limit_dialect => 'Top', %{$self->{_sql_maker_opts}||{}} };
+ unless ($self->_sql_maker) {
+ unless ($self->{_sql_maker_opts}{limit_dialect}) {
+ my $version = eval { $self->_get_mssql_version; } || 0;
+
+ $self->{_sql_maker_opts} = {
+ limit_dialect => ($version >= 9 ? 'RowNumberOver' : 'Top'),
+ %{$self->{_sql_maker_opts}||{}}
+ };
+ }
+
+ my $maker = $self->next::method (@_);
+ }
+
+ return $self->_sql_maker;
}
1;
C<db_ddladmin> privilege, which is normally not included in the standard
write-permissions.
+=head2 Ordered Subselects
+
+If you attempted the following query (among many others) in Microsoft SQL
+Server
+
+ $rs->search ({}, {
+ prefetch => 'relation',
+ rows => 2,
+ offset => 3,
+ });
+
+You may be surprised to receive an exception. The reason for this is a quirk
+in the MSSQL engine itself, and sadly doesn't have a sensible workaround due
+to the way DBIC is built. DBIC can do truly wonderful things with the aid of
+subselects, and does so automatically when necessary. The list of situations
+when a subselect is necessary is long and still changes often, so it can not
+be exhaustively enumerated here. The general rule of thumb is a joined
+L<has_many|DBIx::Class::Relationship/has_many> relationship with limit/group
+applied to the left part of the join.
+
+In its "pursuit of standards" Microsft SQL Server goes to great lengths to
+forbid the use of ordered subselects. This breaks a very useful group of
+searches like "Give me things number 4 to 6 (ordered by name), and prefetch
+all their relations, no matter how many". While there is a hack which fools
+the syntax checker, the optimizer may B<still elect to break the subselect>.
+Testing has determined that while such breakage does occur (the test suite
+contains an explicit test which demonstrates the problem), it is relative
+rare. The benefits of ordered subselects are on the other hand too great to be
+outright disabled for MSSQL.
+
+Thus compromise between usability and perfection is the MSSQL-specific
+L<resultset attribute|DBIx::Class::ResultSet/ATTRIBUTES> C<unsafe_subselect_ok>.
+It is deliberately not possible to set this on the Storage level, as the user
+should inspect (and preferrably regression-test) the return of every such
+ResultSet individually. The example above would work if written like:
+
+ $rs->search ({}, {
+ unsafe_subselect_ok => 1,
+ prefetch => 'relation',
+ rows => 2,
+ offset => 3,
+ });
+
+If it is possible to rewrite the search() in a way that will avoid the need
+for this flag - you are urged to do so. If DBIC internals insist that an
+ordered subselect is necessary for an operation, and you believe there is a
+differnt/better way to get the same result - please file a bugreport.
+
=head1 AUTHOR
See L<DBIx::Class/CONTRIBUTORS>.
}
}
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
-
- # punt: if there is no derived class for the specific backend, attempt
- # to use the DBI->last_insert_id, which may not be sufficient (see the
- # discussion of last_insert_id in perldoc DBI)
- return $dbh->last_insert_id(undef, undef, $source->from, $col);
-}
-
1;
=head1 NAME
DBIx::Class::Storage::DBI::ODBC - Base class for ODBC drivers
-=head1 SYNOPSIS
-
- # In your table classes
- __PACKAGE__->load_components(qw/Core/);
-
-
=head1 DESCRIPTION
This class simply provides a mechanism for discovering and loading a sub-class
for a specific ODBC backend. It should be transparent to the user.
-
=head1 AUTHORS
Marc Mims C<< <marc@questright.com> >>
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ # In your result (table) classes
+ use base 'DBIx::Class::Core';
__PACKAGE__->set_primary_key('id');
}
}
+sub _get_mssql_version {
+ my $self = shift;
+
+ my ($version) = $self->_get_dbh->get_info(18) =~ /^(\d+)/;
+
+ return $version;
+}
+
1;
=head1 AUTHOR
--- /dev/null
+package DBIx::Class::Storage::DBI::ODBC::SQL_Anywhere;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI::SQLAnywhere/;
+use mro 'c3';
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ODBC::SQL_Anywhere - Driver for using Sybase SQL
+Anywhere through ODBC
+
+=head1 SYNOPSIS
+
+All functionality is provided by L<DBIx::Class::Storage::DBI::SQLAnywhere>, see
+that module for details.
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
DBIx::Class::Storage::DBI::Oracle - Base class for Oracle driver
-=head1 SYNOPSIS
-
- # In your table classes
- __PACKAGE__->load_components(qw/Core/);
-
=head1 DESCRIPTION
This class simply provides a mechanism for discovering and loading a sub-class
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ # In your result (table) classes
+ use base 'DBIx::Class::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.
+This class implements base Oracle support. The subclass
+L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
+versions before 9.
=head1 METHODS
my $sth;
+ my $source_name;
+ if ( ref $source->name ne 'SCALAR' ) {
+ $source_name = $source->name;
+ }
+ else {
+ $source_name = ${$source->name};
+ }
+
# check for fully-qualified name (eg. SCHEMA.TABLENAME)
- if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
+ if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) {
$sql = q{
SELECT trigger_body FROM ALL_TRIGGERS t
WHERE t.owner = ? AND t.table_name = ?
}
else {
$sth = $dbh->prepare($sql);
- $sth->execute( uc( $source->name ) );
+ $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???
my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
- $self->_do_query("alter session set nls_date_format = '$date_format'");
$self->_do_query(
-"alter session set nls_timestamp_format = '$timestamp_format'");
+ "alter session set nls_date_format = '$date_format'"
+ );
$self->_do_query(
-"alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
+ "alter session set nls_timestamp_format = '$timestamp_format'"
+ );
+ $self->_do_query(
+ "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
+ );
}
=head2 source_bind_attributes
=cut
-sub source_bind_attributes
+sub source_bind_attributes
{
- require DBD::Oracle;
- my $self = shift;
- my($source) = @_;
+ require DBD::Oracle;
+ my $self = shift;
+ my($source) = @_;
- my %bind_attributes;
+ my %bind_attributes;
- foreach my $column ($source->columns) {
- my $data_type = $source->column_info($column)->{data_type} || '';
- next unless $data_type;
+ foreach my $column ($source->columns) {
+ my $data_type = $source->column_info($column)->{data_type} || '';
+ next unless $data_type;
- my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
+ my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
- if ($data_type =~ /^[BC]LOB$/i) {
- $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB' ?
- DBD::Oracle::ORA_CLOB() :
- DBD::Oracle::ORA_BLOB();
- $column_bind_attrs{'ora_field'} = $column;
- }
+ if ($data_type =~ /^[BC]LOB$/i) {
+ if ($DBD::Oracle::VERSION eq '1.23') {
+ $self->throw_exception(
+"BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
+"version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
+ );
+ }
- $bind_attributes{$column} = \%column_bind_attrs;
- }
+ $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
+ ? DBD::Oracle::ORA_CLOB()
+ : DBD::Oracle::ORA_BLOB()
+ ;
+ $column_bind_attrs{'ora_field'} = $column;
+ }
- return \%bind_attributes;
+ $bind_attributes{$column} = \%column_bind_attrs;
+ }
+
+ return \%bind_attributes;
}
sub _svp_begin {
- my ($self, $name) = @_;
-
- $self->_get_dbh->do("SAVEPOINT $name");
+ my ($self, $name) = @_;
+ $self->_get_dbh->do("SAVEPOINT $name");
}
# Oracle automatically releases a savepoint when you start another one with the
sub _svp_release { 1 }
sub _svp_rollback {
- my ($self, $name) = @_;
+ my ($self, $name) = @_;
+ $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
+=head2 relname_to_table_alias
+
+L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
+queries.
+
+Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
+the L<DBIx::Class::Relationship> name is shortened and appended with half of an
+MD5 hash.
+
+See L<DBIx::Class::Storage/"relname_to_table_alias">.
+
+=cut
+
+sub relname_to_table_alias {
+ my $self = shift;
+ my ($relname, $join_count) = @_;
+
+ my $alias = $self->next::method(@_);
+
+ return $alias if length($alias) <= 30;
+
+ # get a base64 md5 of the alias with join_count
+ require Digest::MD5;
+ my $ctx = Digest::MD5->new;
+ $ctx->add($alias);
+ my $md5 = $ctx->b64digest;
+
+ # remove alignment mark just in case
+ $md5 =~ s/=*\z//;
+
+ # truncate and prepend to truncated relname without vowels
+ (my $devoweled = $relname) =~ s/[aeiou]//g;
+ my $shortened = substr($devoweled, 0, 18);
+
+ my $new_alias =
+ $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
- $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+ return $new_alias;
}
=head1 AUTHOR
for my $col (@cols) {
my $seq = ( $source->column_info($col)->{sequence} ||= $self->dbh_do('_dbh_get_autoinc_seq', $source, $col) )
- or $self->throw_exception( "could not determine sequence for "
- . $source->name
- . ".$col, please consider adding a "
- . "schema-qualified sequence to its column info"
- );
+ or $self->throw_exception( sprintf(
+ 'could not determine sequence for column %s.%s, please consider adding a schema-qualified sequence to its column info',
+ $source->name,
+ $col,
+ ));
push @values, $self->_dbh_last_insert_id ($self->_dbh, $seq);
}
( $schema, $table ) = ( $1, $2 );
}
-### XXX This is unsafe in DBD::Pg 2.15.1, it can disconnect for some reason
-###
- # use DBD::Pg to fetch the column info if it is recent enough to
- # work. otherwise, use custom SQL
-# my $seq_expr = $DBD::Pg::VERSION >= 2.015001
-# ? eval{ $dbh->column_info(undef,$schema,$table,$col)->fetchrow_hashref->{COLUMN_DEF} }
-# : $self->_dbh_get_column_default( $dbh, $schema, $table, $col );
-
+ # get the column default using a Postgres-specific pg_catalog query
my $seq_expr = $self->_dbh_get_column_default( $dbh, $schema, $table, $col );
# if no default value is set on the column, or if we can't parse the
# default value as a sequence, throw.
- unless ( defined $seq_expr and $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i ){
+ unless ( defined $seq_expr and $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i ) {
$seq_expr = '' unless defined $seq_expr;
$schema = "$schema." if defined $schema && length $schema;
- $self->throw_exception( "no sequence found for $schema$table.$col, check table definition, "
- . "or explicitly set the 'sequence' for this column in the "
- . $source->source_name
- . " class"
- );
+ $self->throw_exception( sprintf (
+ 'no sequence found for %s%s.%s, check the RDBMS table definition or explicitly set the '.
+ "'sequence' for this column in %s",
+ $schema ? "$schema." : '',
+ $table,
+ $col,
+ $source->source_name,
+ ));
}
return $1;
=head1 SYNOPSIS
- # In your table classes
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ # In your result (table) classes
+ use base 'DBIx::Class::Core';
__PACKAGE__->set_primary_key('id');
__PACKAGE__->sequence('mysequence');
## use, so we explicitly test for these.
my %replication_required = (
- 'Moose' => '0.87',
- 'MooseX::AttributeHelpers' => '0.21',
- 'MooseX::Types' => '0.16',
+ 'Moose' => '0.98',
+ 'MooseX::Types' => '0.21',
'namespace::clean' => '0.11',
'Hash::Merge' => '0.11'
);
also define your arguments, such as which balancer you want and any arguments
that the Pool object should get.
+ my $schema = Schema::Class->clone;
$schema->storage_type( ['::DBI::Replicated', {balancer=>'::Random'}] );
+ $schema->connection(...);
Next, you need to add in the Replicants. Basically this is an array of
arrayrefs, where each arrayref is database connect information. Think of these
Replicated Storage has additional requirements not currently part of L<DBIx::Class>
- Moose => '0.87',
- MooseX::AttributeHelpers => '0.20',
- MooseX::Types => '0.16',
+ Moose => '0.98',
+ MooseX::Types => '0.21',
namespace::clean => '0.11',
Hash::Merge => '0.11'
svp_rollback
svp_begin
svp_release
+ relname_to_table_alias
+ _straight_join_to_node
/],
);
my $master = $self->master;
$master->_determine_driver;
Moose::Meta::Class->initialize(ref $master);
+
DBIx::Class::Storage::DBI::Replicated::WithDSN->meta->apply($master);
+ # link pool back to master
+ $self->pool->master($master);
+
$wantarray ? @res : $res;
};
=cut
sub BUILDARGS {
- my ($class, $schema, $storage_type_args, @args) = @_;
+ my ($class, $schema, $storage_type_args, @args) = @_;
return {
schema=>$schema,
=head2 debugobj
-set a debug object across all storages
+set a debug object
=cut
sub debugobj {
my $self = shift @_;
- if(@_) {
- foreach my $source ($self->all_storages) {
- $source->debugobj(@_);
- }
- }
- return $self->master->debugobj;
+ return $self->master->debugobj(@_);
}
=head2 debugfh
-set a debugfh object across all storages
+set a debugfh object
=cut
sub debugfh {
my $self = shift @_;
- if(@_) {
- foreach my $source ($self->all_storages) {
- $source->debugfh(@_);
- }
- }
- return $self->master->debugfh;
+ return $self->master->debugfh(@_);
}
=head2 debugcb
-set a debug callback across all storages
+set a debug callback
=cut
sub debugcb {
my $self = shift @_;
- if(@_) {
- foreach my $source ($self->all_storages) {
- $source->debugcb(@_);
- }
- }
- return $self->master->debugcb;
+ return $self->master->debugcb(@_);
}
=head2 disconnect
you use (or upgrade to) the latest L<Catalyst::Model::DBIC::Schema>, which makes
this job even easier.
-First, you need to connect your L<DBIx::Class::Schema>. Let's assume you have
-such a schema called, "MyApp::Schema".
-
- use MyApp::Schema;
- my $schema = MyApp::Schema->connect($dsn, $user, $pass);
-
-Next, you need to set the storage_type.
-
- $schema->storage_type(
- ::DBI::Replicated' => {
- balancer_type => '::Random',
- balancer_args => {
- auto_validate_every => 5,
- master_read_weight => 1
- },
- pool_args => {
- maximum_lag =>2,
- },
- }
- );
+First, you need to get a C<$schema> object and set the storage_type:
+
+ my $schema = MyApp::Schema->clone;
+ $schema->storage_type([
+ '::DBI::Replicated' => {
+ balancer_type => '::Random',
+ balancer_args => {
+ auto_validate_every => 5,
+ master_read_weight => 1
+ },
+ pool_args => {
+ maximum_lag =>2,
+ },
+ }
+ ]);
+
+Then, you need to connect your L<DBIx::Class::Schema>.
+
+ $schema->connection($dsn, $user, $pass);
Let's break down the settings. The method L<DBIx::Class::Schema/storage_type>
takes one mandatory parameter, a scalar value, and an option second value which
After you've configured the replicated storage, you need to add the connection
information for the replicants:
- $schema->storage->connect_replicants(
- [$dsn1, $user, $pass, \%opts],
- [$dsn2, $user, $pass, \%opts],
- [$dsn3, $user, $pass, \%opts],
- );
+ $schema->storage->connect_replicants(
+ [$dsn1, $user, $pass, \%opts],
+ [$dsn2, $user, $pass, \%opts],
+ [$dsn3, $user, $pass, \%opts],
+ );
These replicants should be configured as slaves to the master using the
instructions for MySQL native replication, or if you are just learning, you
package DBIx::Class::Storage::DBI::Replicated::Pool;
use Moose;
-use MooseX::AttributeHelpers;
use DBIx::Class::Storage::DBI::Replicated::Replicant;
use List::Util 'sum';
use Scalar::Util 'reftype';
use DBI ();
use Carp::Clan qw/^DBIx::Class/;
use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
+use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
use namespace::clean -except => 'meta';
has 'replicants' => (
is=>'rw',
- metaclass => 'Collection::Hash',
+ traits => ['Hash'],
isa=>HashRef['Object'],
default=>sub {{}},
- provides => {
- 'set' => 'set_replicant',
- 'get' => 'get_replicant',
- 'empty' => 'has_replicants',
- 'count' => 'num_replicants',
- 'delete' => 'delete_replicant',
- 'values' => 'all_replicant_storages',
+ handles => {
+ 'set_replicant' => 'set',
+ 'get_replicant' => 'get',
+ 'has_replicants' => 'is_empty',
+ 'num_replicants' => 'count',
+ 'delete_replicant' => 'delete',
+ 'all_replicant_storages' => 'values',
},
);
+around has_replicants => sub {
+ my ($orig, $self) = @_;
+ return !$self->$orig;
+};
+
has next_unknown_replicant_id => (
is => 'rw',
- metaclass => 'Counter',
+ traits => ['Counter'],
isa => Int,
default => 1,
- provides => {
- inc => 'inc_unknown_replicant_id'
+ handles => {
+ 'inc_unknown_replicant_id' => 'inc',
},
);
+=head2 master
+
+Reference to the master Storage.
+
+=cut
+
+has master => (is => 'rw', isa => DBICStorageDBI, weak_ref => 1);
+
=head1 METHODS
This class defines the following methods.
$replicant->_determine_driver
});
- DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
+ Moose::Meta::Class->initialize(ref $replicant);
+
+ DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
+
+ # link back to master
+ $replicant->master($self->master);
+
return $replicant;
}
eval {
$code->()
- };
+ };
if ($@) {
- $replicant
- ->debugobj
- ->print(
- sprintf( "Exception trying to $name for replicant %s, error is %s",
- $replicant->_dbi_connect_info->[0], $@)
- );
- return;
+ $replicant->debugobj->print(sprintf(
+ "Exception trying to $name for replicant %s, error is %s",
+ $replicant->_dbi_connect_info->[0], $@)
+ );
+ return undef;
}
+
return 1;
}
requires qw/_query_start/;
with 'DBIx::Class::Storage::DBI::Replicated::WithDSN';
use MooseX::Types::Moose qw/Bool Str/;
+use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
use namespace::clean -except => 'meta';
has dsn => (is => 'rw', isa => Str);
has id => (is => 'rw', isa => Str);
+=head2 master
+
+Reference to the master Storage.
+
+=cut
+
+has master => (is => 'rw', isa => DBICStorageDBI, weak_ref => 1);
+
=head1 METHODS
This class defines the following methods.
=cut
sub debugobj {
- return shift->schema->storage->debugobj;
+ my $self = shift;
+
+ return $self->master->debugobj;
}
=head1 ALSO SEE
--- /dev/null
+package DBIx::Class::Storage::DBI::SQLAnywhere;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+use List::Util ();
+
+__PACKAGE__->mk_group_accessors(simple => qw/
+ _identity
+/);
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::SQLAnywhere - Driver for Sybase SQL Anywhere
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for Sybase SQL Anywhere, selects the
+RowNumberOver limit implementation and provides
+L<DBIx::Class::InflateColumn::DateTime> support.
+
+You need the C<DBD::SQLAnywhere> driver that comes with the SQL Anywhere
+distribution, B<NOT> the one on CPAN. It is usually under a path such as:
+
+ /opt/sqlanywhere11/sdk/perl
+
+Recommended L<DBIx::Class::Storage::DBI/connect_info> settings:
+
+ on_connect_call => 'datetime_setup'
+
+=head1 METHODS
+
+=cut
+
+sub last_insert_id { shift->_identity }
+
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
+
+ my $identity_col = List::Util::first {
+ $source->column_info($_)->{is_auto_increment}
+ } $source->columns;
+
+# user might have an identity PK without is_auto_increment
+ if (not $identity_col) {
+ foreach my $pk_col ($source->primary_columns) {
+ if (not exists $to_insert->{$pk_col}) {
+ $identity_col = $pk_col;
+ last;
+ }
+ }
+ }
+
+ if ($identity_col && (not exists $to_insert->{$identity_col})) {
+ my $dbh = $self->_get_dbh;
+ my $table_name = $source->from;
+ $table_name = $$table_name if ref $table_name;
+
+ my ($identity) = $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')");
+
+ $to_insert->{$identity_col} = $identity;
+
+ $self->_identity($identity);
+ }
+
+ return $self->next::method(@_);
+}
+
+# this sub stolen from DB2
+
+sub _sql_maker_opts {
+ my ( $self, $opts ) = @_;
+
+ if ( $opts ) {
+ $self->{_sql_maker_opts} = { %$opts };
+ }
+
+ return { limit_dialect => 'RowNumberOver', %{$self->{_sql_maker_opts}||{}} };
+}
+
+# this sub stolen from MSSQL
+
+sub build_datetime_parser {
+ my $self = shift;
+ my $type = "DateTime::Format::Strptime";
+ eval "use ${type}";
+ $self->throw_exception("Couldn't load ${type}: $@") if $@;
+ return $type->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' );
+}
+
+=head2 connect_call_datetime_setup
+
+Used as:
+
+ on_connect_call => 'datetime_setup'
+
+In L<DBIx::Class::Storage::DBI/connect_info> to set the date and timestamp
+formats (as temporary options for the session) for use with
+L<DBIx::Class::InflateColumn::DateTime>.
+
+The C<TIMESTAMP> data type supports up to 6 digits after the decimal point for
+second precision. The full precision is used.
+
+The C<DATE> data type supposedly stores hours and minutes too, according to the
+documentation, but I could not get that to work. It seems to only store the
+date.
+
+You will need the L<DateTime::Format::Strptime> module for inflation to work.
+
+=cut
+
+sub connect_call_datetime_setup {
+ my $self = shift;
+
+ $self->_do_query(
+ "set temporary option timestamp_format = 'yyyy-mm-dd hh:mm:ss.ssssss'"
+ );
+ $self->_do_query(
+ "set temporary option date_format = 'yyyy-mm-dd hh:mm:ss.ssssss'"
+ );
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
use File::Copy;
use File::Spec;
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
- $dbh->func('last_insert_rowid');
-}
-
sub backup
{
my ($self, $dir) = @_;
=head1 SYNOPSIS
# In your table classes
- __PACKAGE__->load_components(qw/PK::Auto Core/);
+ use base 'DBIx::Class::Core';
__PACKAGE__->set_primary_key('id');
=head1 DESCRIPTION
use strict;
use warnings;
-use base qw/
- DBIx::Class::Storage::DBI::Sybase::Common
- DBIx::Class::Storage::DBI::AutoCast
-/;
-use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
-use List::Util();
-use Sub::Name();
-use Data::Dumper::Concise();
-
-__PACKAGE__->mk_group_accessors('simple' =>
- qw/_identity _blob_log_on_update _writer_storage _is_extra_storage
- _bulk_storage _is_bulk_storage _began_bulk_work
- _bulk_disabled_due_to_coderef_connect_info_warned
- _identity_method/
-);
-
-my @also_proxy_to_extra_storages = qw/
- connect_call_set_auto_cast auto_cast connect_call_blob_setup
- connect_call_datetime_setup
-
- disconnect _connect_info _sql_maker _sql_maker_opts disable_sth_caching
- auto_savepoint unsafe cursor_class debug debugobj schema
-/;
+use base qw/DBIx::Class::Storage::DBI/;
=head1 NAME
-DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class
-
-=head1 SYNOPSIS
-
-This subclass supports L<DBD::Sybase> for real Sybase databases. If you are
-using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
-L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
+DBIx::Class::Storage::DBI::Sybase - Base class for drivers using
+L<DBD::Sybase>
=head1 DESCRIPTION
-If your version of Sybase does not support placeholders, then your storage
-will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
-also enable that driver explicitly, see the documentation for more details.
-
-With this driver there is unfortunately no way to get the C<last_insert_id>
-without doing a C<SELECT MAX(col)>. This is done safely in a transaction
-(locking the table.) See L</INSERTS WITH PLACEHOLDERS>.
-
-A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
-
- on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
+This is the base class/dispatcher for Storage's designed to work with
+L<DBD::Sybase>
=head1 METHODS
sub _rebless {
my $self = shift;
- if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
- my $dbtype = eval {
- @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
- } || '';
-
- my $exception = $@;
- $dbtype =~ s/\W/_/gi;
- my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
-
- if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
- bless $self, $subclass;
- $self->_rebless;
- } else { # real Sybase
- my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
-
- if ($self->using_freetds) {
- carp <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN};
-
-You are using FreeTDS with Sybase.
-
-We will do our best to support this configuration, but please consider this
-support experimental.
-
-TEXT/IMAGE columns will definitely not work.
-
-You are encouraged to recompile DBD::Sybase with the Sybase Open Client libraries
-instead.
-
-See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
-
-To turn off this warning set the DBIC_SYBASE_FREETDS_NOWARN environment
-variable.
-EOF
- if (not $self->_typeless_placeholders_supported) {
- if ($self->_placeholders_supported) {
- $self->auto_cast(1);
- } else {
- $self->ensure_class_loaded($no_bind_vars);
- bless $self, $no_bind_vars;
- $self->_rebless;
- }
- }
- }
- elsif (not $self->_get_dbh->{syb_dynamic_supported}) {
- # not necessarily FreeTDS, but no placeholders nevertheless
- $self->ensure_class_loaded($no_bind_vars);
- bless $self, $no_bind_vars;
- $self->_rebless;
- } elsif (not $self->_typeless_placeholders_supported) {
- # this is highly unlikely, but we check just in case
- $self->auto_cast(1);
- }
- }
- }
-}
-
-sub _init {
- my $self = shift;
- $self->_set_max_connect(256);
-
- # based on LongReadLen in connect_info
- $self->set_textsize if $self->using_freetds;
-
-# create storage for insert/(update blob) transactions,
-# unless this is that storage
- return if $self->_is_extra_storage;
-
- my $writer_storage = (ref $self)->new;
-
- $writer_storage->_is_extra_storage(1);
- $writer_storage->connect_info($self->connect_info);
- $writer_storage->auto_cast($self->auto_cast);
-
- $self->_writer_storage($writer_storage);
-
-# create a bulk storage unless connect_info is a coderef
- return
- if (Scalar::Util::reftype($self->_dbi_connect_info->[0])||'') eq 'CODE';
-
- my $bulk_storage = (ref $self)->new;
-
- $bulk_storage->_is_extra_storage(1);
- $bulk_storage->_is_bulk_storage(1); # for special ->disconnect acrobatics
- $bulk_storage->connect_info($self->connect_info);
-
-# this is why
- $bulk_storage->_dbi_connect_info->[0] .= ';bulkLogin=1';
-
- $self->_bulk_storage($bulk_storage);
-}
-
-for my $method (@also_proxy_to_extra_storages) {
- no strict 'refs';
- no warnings 'redefine';
-
- my $replaced = __PACKAGE__->can($method);
-
- *{$method} = Sub::Name::subname $method => sub {
- my $self = shift;
- $self->_writer_storage->$replaced(@_) if $self->_writer_storage;
- $self->_bulk_storage->$replaced(@_) if $self->_bulk_storage;
- return $self->$replaced(@_);
+ my $dbtype = eval {
+ @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
};
-}
-
-sub disconnect {
- my $self = shift;
-# Even though we call $sth->finish for uses off the bulk API, there's still an
-# "active statement" warning on disconnect, which we throw away here.
-# This is due to the bug described in insert_bulk.
-# Currently a noop because 'prepare' is used instead of 'prepare_cached'.
- local $SIG{__WARN__} = sub {
- warn $_[0] unless $_[0] =~ /active statement/i;
- } if $self->_is_bulk_storage;
-
-# so that next transaction gets a dbh
- $self->_began_bulk_work(0) if $self->_is_bulk_storage;
-
- $self->next::method;
-}
-
-# Make sure we have CHAINED mode turned on if AutoCommit is off in non-FreeTDS
-# DBD::Sybase (since we don't know how DBD::Sybase was compiled.) If however
-# we're using FreeTDS, CHAINED mode turns on an implicit transaction which we
-# only want when AutoCommit is off.
-sub _populate_dbh {
- my $self = shift;
-
- $self->next::method(@_);
-
- if ($self->_is_bulk_storage) {
-# this should be cleared on every reconnect
- $self->_began_bulk_work(0);
- return;
- }
-
- if (not $self->using_freetds) {
- $self->_dbh->{syb_chained_txn} = 1;
- } else {
- if ($self->_dbh_autocommit) {
- $self->_dbh->do('SET CHAINED OFF');
- } else {
- $self->_dbh->do('SET CHAINED ON');
- }
- }
-}
-
-=head2 connect_call_blob_setup
-
-Used as:
-
- on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
-
-Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
-instead of as a hex string.
-
-Recommended.
-
-Also sets the C<log_on_update> value for blob write operations. The default is
-C<1>, but C<0> is better if your database is configured for it.
-
-See
-L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
-
-=cut
-
-sub connect_call_blob_setup {
- my $self = shift;
- my %args = @_;
- my $dbh = $self->_dbh;
- $dbh->{syb_binary_images} = 1;
-
- $self->_blob_log_on_update($args{log_on_update})
- if exists $args{log_on_update};
-}
-
-sub _is_lob_type {
- my $self = shift;
- my $type = shift;
- $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
-}
-
-sub _is_lob_column {
- my ($self, $source, $column) = @_;
-
- return $self->_is_lob_type($source->column_info($column)->{data_type});
-}
-
-sub _prep_for_execute {
- my $self = shift;
- my ($op, $extra_bind, $ident, $args) = @_;
-
- my ($sql, $bind) = $self->next::method (@_);
-
- my $table = Scalar::Util::blessed($ident) ? $ident->from : $ident;
-
- my $bind_info = $self->_resolve_column_info(
- $ident, [map $_->[0], @{$bind}]
- );
- my $bound_identity_col = List::Util::first
- { $bind_info->{$_}{is_auto_increment} }
- (keys %$bind_info)
- ;
- my $identity_col = Scalar::Util::blessed($ident) &&
- List::Util::first
- { $ident->column_info($_)->{is_auto_increment} }
- $ident->columns
- ;
-
- if (($op eq 'insert' && $bound_identity_col) ||
- ($op eq 'update' && exists $args->[0]{$identity_col})) {
- $sql = join ("\n",
- $self->_set_table_identity_sql($op => $table, 'on'),
- $sql,
- $self->_set_table_identity_sql($op => $table, 'off'),
- );
- }
-
- if ($op eq 'insert' && (not $bound_identity_col) && $identity_col &&
- (not $self->{insert_bulk})) {
- $sql =
- "$sql\n" .
- $self->_fetch_identity_sql($ident, $identity_col);
- }
-
- return ($sql, $bind);
-}
+ $self->throw_exception("Unable to estable connection to determine database type: $@")
+ if $@;
-sub _set_table_identity_sql {
- my ($self, $op, $table, $on_off) = @_;
-
- return sprintf 'SET IDENTITY_%s %s %s',
- uc($op), $self->sql_maker->_quote($table), uc($on_off);
-}
-
-# Stolen from SQLT, with some modifications. This is a makeshift
-# solution before a sane type-mapping library is available, thus
-# the 'our' for easy overrides.
-our %TYPE_MAPPING = (
- number => 'numeric',
- money => 'money',
- varchar => 'varchar',
- varchar2 => 'varchar',
- timestamp => 'datetime',
- text => 'varchar',
- real => 'double precision',
- comment => 'text',
- bit => 'bit',
- tinyint => 'smallint',
- float => 'double precision',
- serial => 'numeric',
- bigserial => 'numeric',
- boolean => 'varchar',
- long => 'varchar',
-);
-
-sub _native_data_type {
- my ($self, $type) = @_;
-
- $type = lc $type;
- $type =~ s/\s* identity//x;
-
- return uc($TYPE_MAPPING{$type} || $type);
-}
-
-sub _fetch_identity_sql {
- my ($self, $source, $col) = @_;
-
- return sprintf ("SELECT MAX(%s) FROM %s",
- map { $self->sql_maker->_quote ($_) } ($col, $source->from)
- );
-}
-
-sub _execute {
- my $self = shift;
- my ($op) = @_;
-
- my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
-
- if ($op eq 'insert') {
- $self->_identity($sth->fetchrow_array);
- $sth->finish;
- }
-
- return wantarray ? ($rv, $sth, @bind) : $rv;
-}
-
-sub last_insert_id { shift->_identity }
-
-# handles TEXT/IMAGE and transaction for last_insert_id
-sub insert {
- my $self = shift;
- my ($source, $to_insert) = @_;
-
- my $identity_col = (List::Util::first
- { $source->column_info($_)->{is_auto_increment} }
- $source->columns) || '';
-
- # check for empty insert
- # INSERT INTO foo DEFAULT VALUES -- does not work with Sybase
- # try to insert explicit 'DEFAULT's instead (except for identity)
- if (not %$to_insert) {
- for my $col ($source->columns) {
- next if $col eq $identity_col;
- $to_insert->{$col} = \'DEFAULT';
- }
- }
-
- my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
-
- # do we need the horrific SELECT MAX(COL) hack?
- my $dumb_last_insert_id =
- $identity_col
- && (not exists $to_insert->{$identity_col})
- && ($self->_identity_method||'') ne '@@IDENTITY';
-
- my $next = $self->next::can;
-
- # we are already in a transaction, or there are no blobs
- # and we don't need the PK - just (try to) do it
- if ($self->{transaction_depth}
- || (!$blob_cols && !$dumb_last_insert_id)
- ) {
- return $self->_insert (
- $next, $source, $to_insert, $blob_cols, $identity_col
- );
- }
-
- # otherwise use the _writer_storage to do the insert+transaction on another
- # connection
- my $guard = $self->_writer_storage->txn_scope_guard;
-
- my $updated_cols = $self->_writer_storage->_insert (
- $next, $source, $to_insert, $blob_cols, $identity_col
- );
-
- $self->_identity($self->_writer_storage->_identity);
-
- $guard->commit;
-
- return $updated_cols;
-}
-
-sub _insert {
- my ($self, $next, $source, $to_insert, $blob_cols, $identity_col) = @_;
-
- my $updated_cols = $self->$next ($source, $to_insert);
-
- my $final_row = {
- ($identity_col ?
- ($identity_col => $self->last_insert_id($source, $identity_col)) : ()),
- %$to_insert,
- %$updated_cols,
- };
-
- $self->_insert_blobs ($source, $blob_cols, $final_row) if $blob_cols;
-
- return $updated_cols;
-}
-
-sub update {
- my $self = shift;
- my ($source, $fields, $where, @rest) = @_;
-
- my $wantarray = wantarray;
-
- my $blob_cols = $self->_remove_blob_cols($source, $fields);
-
- my $table = $source->name;
-
- my $identity_col = List::Util::first
- { $source->column_info($_)->{is_auto_increment} }
- $source->columns;
-
- my $is_identity_update = $identity_col && defined $fields->{$identity_col};
-
- return $self->next::method(@_) unless $blob_cols;
-
-# If there are any blobs in $where, Sybase will return a descriptive error
-# message.
-# XXX blobs can still be used with a LIKE query, and this should be handled.
-
-# update+blob update(s) done atomically on separate connection
- $self = $self->_writer_storage;
-
- my $guard = $self->txn_scope_guard;
-
-# First update the blob columns to be updated to '' (taken from $fields, where
-# it is originally put by _remove_blob_cols .)
- my %blobs_to_empty = map { ($_ => delete $fields->{$_}) } keys %$blob_cols;
-
-# We can't only update NULL blobs, because blobs cannot be in the WHERE clause.
-
- $self->next::method($source, \%blobs_to_empty, $where, @rest);
+ if ($dbtype) {
+ $dbtype =~ s/\W/_/gi;
-# Now update the blobs before the other columns in case the update of other
-# columns makes the search condition invalid.
- $self->_update_blobs($source, $blob_cols, $where);
+ # saner class name
+ $dbtype = 'ASE' if $dbtype eq 'SQL_Server';
- my @res;
- if (%$fields) {
- if ($wantarray) {
- @res = $self->next::method(@_);
- }
- elsif (defined $wantarray) {
- $res[0] = $self->next::method(@_);
- }
- else {
- $self->next::method(@_);
+ my $subclass = __PACKAGE__ . "::$dbtype";
+ if ($self->load_optional_class($subclass)) {
+ bless $self, $subclass;
+ $self->_rebless;
}
}
-
- $guard->commit;
-
- return $wantarray ? @res : $res[0];
}
-sub insert_bulk {
+sub _ping {
my $self = shift;
- my ($source, $cols, $data) = @_;
-
- my $identity_col = List::Util::first
- { $source->column_info($_)->{is_auto_increment} }
- $source->columns;
-
- my $is_identity_insert = (List::Util::first
- { $_ eq $identity_col }
- @{$cols}
- ) ? 1 : 0;
-
- my @source_columns = $source->columns;
-
- my $use_bulk_api =
- $self->_bulk_storage &&
- $self->_get_dbh->{syb_has_blk};
-
- if ((not $use_bulk_api) &&
- (Scalar::Util::reftype($self->_dbi_connect_info->[0])||'') eq 'CODE' &&
- (not $self->_bulk_disabled_due_to_coderef_connect_info_warned)) {
- carp <<'EOF';
-Bulk API support disabled due to use of a CODEREF connect_info. Reverting to
-regular array inserts.
-EOF
- $self->_bulk_disabled_due_to_coderef_connect_info_warned(1);
- }
-
- if (not $use_bulk_api) {
- my $blob_cols = $self->_remove_blob_cols_array($source, $cols, $data);
-
-# _execute_array uses a txn anyway, but it ends too early in case we need to
-# select max(col) to get the identity for inserting blobs.
- ($self, my $guard) = $self->{transaction_depth} == 0 ?
- ($self->_writer_storage, $self->_writer_storage->txn_scope_guard)
- :
- ($self, undef);
-
- local $self->{insert_bulk} = 1;
-
- $self->next::method(@_);
-
- if ($blob_cols) {
- if ($is_identity_insert) {
- $self->_insert_blobs_array ($source, $blob_cols, $cols, $data);
- }
- else {
- my @cols_with_identities = (@$cols, $identity_col);
-
- ## calculate identities
- # XXX This assumes identities always increase by 1, which may or may not
- # be true.
- my ($last_identity) =
- $self->_dbh->selectrow_array (
- $self->_fetch_identity_sql($source, $identity_col)
- );
- my @identities = (($last_identity - @$data + 1) .. $last_identity);
-
- my @data_with_identities = map [@$_, shift @identities], @$data;
-
- $self->_insert_blobs_array (
- $source, $blob_cols, \@cols_with_identities, \@data_with_identities
- );
- }
- }
-
- $guard->commit if $guard;
-
- return;
- }
-
-# otherwise, use the bulk API
-# rearrange @$data so that columns are in database order
- my %orig_idx;
- @orig_idx{@$cols} = 0..$#$cols;
+ my $dbh = $self->_dbh or return 0;
- my %new_idx;
- @new_idx{@source_columns} = 0..$#source_columns;
+ local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
- my @new_data;
- for my $datum (@$data) {
- my $new_datum = [];
- for my $col (@source_columns) {
-# identity data will be 'undef' if not $is_identity_insert
-# columns with defaults will also be 'undef'
- $new_datum->[ $new_idx{$col} ] =
- exists $orig_idx{$col} ? $datum->[ $orig_idx{$col} ] : undef;
- }
- push @new_data, $new_datum;
+ if ($dbh->{syb_no_child_con}) {
+# if extra connections are not allowed, then ->ping is reliable
+ my $ping = eval { $dbh->ping };
+ return $@ ? 0 : $ping;
}
-# bcp identity index is 1-based
- my $identity_idx = exists $new_idx{$identity_col} ?
- $new_idx{$identity_col} + 1 : 0;
-
-## Set a client-side conversion error handler, straight from DBD::Sybase docs.
-# This ignores any data conversion errors detected by the client side libs, as
-# they are usually harmless.
- my $orig_cslib_cb = DBD::Sybase::set_cslib_cb(
- Sub::Name::subname insert_bulk => sub {
- my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_;
-
- return 1 if $errno == 36;
-
- carp
- "Layer: $layer, Origin: $origin, Severity: $severity, Error: $errno" .
- ($errmsg ? "\n$errmsg" : '') .
- ($osmsg ? "\n$osmsg" : '') .
- ($blkmsg ? "\n$blkmsg" : '');
-
- return 0;
- });
-
eval {
- my $bulk = $self->_bulk_storage;
-
- my $guard = $bulk->txn_scope_guard;
-
-## XXX get this to work instead of our own $sth
-## will require SQLA or *Hacks changes for ordered columns
-# $bulk->next::method($source, \@source_columns, \@new_data, {
-# syb_bcp_attribs => {
-# identity_flag => $is_identity_insert,
-# identity_column => $identity_idx,
-# }
-# });
- my $sql = 'INSERT INTO ' .
- $bulk->sql_maker->_quote($source->name) . ' (' .
-# colname list is ignored for BCP, but does no harm
- (join ', ', map $bulk->sql_maker->_quote($_), @source_columns) . ') '.
- ' VALUES ('. (join ', ', ('?') x @source_columns) . ')';
-
-## XXX there's a bug in the DBD::Sybase bulk support that makes $sth->finish for
-## a prepare_cached statement ineffective. Replace with ->sth when fixed, or
-## better yet the version above. Should be fixed in DBD::Sybase .
- my $sth = $bulk->_get_dbh->prepare($sql,
-# 'insert', # op
- {
- syb_bcp_attribs => {
- identity_flag => $is_identity_insert,
- identity_column => $identity_idx,
- }
- }
- );
-
- my @bind = do {
- my $idx = 0;
- map [ $_, $idx++ ], @source_columns;
- };
-
- $self->_execute_array(
- $source, $sth, \@bind, \@source_columns, \@new_data, sub {
- $guard->commit
- }
- );
-
- $bulk->_query_end($sql);
+# XXX if the main connection goes stale, does opening another for this statement
+# really determine anything?
+ $dbh->do('select 1');
};
- my $exception = $@;
- DBD::Sybase::set_cslib_cb($orig_cslib_cb);
-
- if ($exception =~ /-Y option/) {
- carp <<"EOF";
-
-Sybase bulk API operation failed due to character set incompatibility, reverting
-to regular array inserts:
-
-*** Try unsetting the LANG environment variable.
-
-$exception
-EOF
- $self->_bulk_storage(undef);
- unshift @_, $self;
- goto \&insert_bulk;
- }
- elsif ($exception) {
-# rollback makes the bulkLogin connection unusable
- $self->_bulk_storage->disconnect;
- $self->throw_exception($exception);
- }
-}
-
-sub _dbh_execute_array {
- my ($self, $sth, $tuple_status, $cb) = @_;
-
- my $rv = $self->next::method($sth, $tuple_status);
- $cb->() if $cb;
-
- return $rv;
+ return $@ ? 0 : 1;
}
-# Make sure blobs are not bound as placeholders, and return any non-empty ones
-# as a hash.
-sub _remove_blob_cols {
- my ($self, $source, $fields) = @_;
-
- my %blob_cols;
-
- for my $col (keys %$fields) {
- if ($self->_is_lob_column($source, $col)) {
- my $blob_val = delete $fields->{$col};
- if (not defined $blob_val) {
- $fields->{$col} = \'NULL';
- }
- else {
- $fields->{$col} = \"''";
- $blob_cols{$col} = $blob_val unless $blob_val eq '';
- }
- }
- }
-
- return %blob_cols ? \%blob_cols : undef;
-}
-
-# same for insert_bulk
-sub _remove_blob_cols_array {
- my ($self, $source, $cols, $data) = @_;
-
- my @blob_cols;
-
- for my $i (0..$#$cols) {
- my $col = $cols->[$i];
-
- if ($self->_is_lob_column($source, $col)) {
- for my $j (0..$#$data) {
- my $blob_val = delete $data->[$j][$i];
- if (not defined $blob_val) {
- $data->[$j][$i] = \'NULL';
- }
- else {
- $data->[$j][$i] = \"''";
- $blob_cols[$j][$i] = $blob_val
- unless $blob_val eq '';
- }
- }
- }
- }
-
- return @blob_cols ? \@blob_cols : undef;
-}
-
-sub _update_blobs {
- my ($self, $source, $blob_cols, $where) = @_;
-
- my (@primary_cols) = $source->primary_columns;
-
- $self->throw_exception('Cannot update TEXT/IMAGE column(s) without a primary key')
- unless @primary_cols;
-
-# check if we're updating a single row by PK
- my $pk_cols_in_where = 0;
- for my $col (@primary_cols) {
- $pk_cols_in_where++ if defined $where->{$col};
- }
- my @rows;
-
- if ($pk_cols_in_where == @primary_cols) {
- my %row_to_update;
- @row_to_update{@primary_cols} = @{$where}{@primary_cols};
- @rows = \%row_to_update;
- } else {
- my $cursor = $self->select ($source, \@primary_cols, $where, {});
- @rows = map {
- my %row; @row{@primary_cols} = @$_; \%row
- } $cursor->all;
- }
-
- for my $row (@rows) {
- $self->_insert_blobs($source, $blob_cols, $row);
- }
-}
-
-sub _insert_blobs {
- my ($self, $source, $blob_cols, $row) = @_;
- my $dbh = $self->_get_dbh;
-
- my $table = $source->name;
-
- my %row = %$row;
- my (@primary_cols) = $source->primary_columns;
-
- $self->throw_exception('Cannot update TEXT/IMAGE column(s) without a primary key')
- unless @primary_cols;
-
- $self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values')
- if ((grep { defined $row{$_} } @primary_cols) != @primary_cols);
-
- for my $col (keys %$blob_cols) {
- my $blob = $blob_cols->{$col};
-
- my %where = map { ($_, $row{$_}) } @primary_cols;
-
- my $cursor = $self->select ($source, [$col], \%where, {});
- $cursor->next;
- my $sth = $cursor->sth;
-
- if (not $sth) {
-
- $self->throw_exception(
- "Could not find row in table '$table' for blob update:\n"
- . Data::Dumper::Concise::Dumper (\%where)
- );
- }
-
- eval {
- do {
- $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
- } while $sth->fetch;
-
- $sth->func('ct_prepare_send') or die $sth->errstr;
-
- my $log_on_update = $self->_blob_log_on_update;
- $log_on_update = 1 if not defined $log_on_update;
-
- $sth->func('CS_SET', 1, {
- total_txtlen => length($blob),
- log_on_update => $log_on_update
- }, 'ct_data_info') or die $sth->errstr;
-
- $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
-
- $sth->func('ct_finish_send') or die $sth->errstr;
- };
- my $exception = $@;
- $sth->finish if $sth;
- if ($exception) {
- if ($self->using_freetds) {
- $self->throw_exception (
- 'TEXT/IMAGE operation failed, probably because you are using FreeTDS: '
- . $exception
- );
- } else {
- $self->throw_exception($exception);
- }
- }
- }
-}
-
-sub _insert_blobs_array {
- my ($self, $source, $blob_cols, $cols, $data) = @_;
-
- for my $i (0..$#$data) {
- my $datum = $data->[$i];
+sub _set_max_connect {
+ my $self = shift;
+ my $val = shift || 256;
- my %row;
- @row{ @$cols } = @$datum;
+ my $dsn = $self->_dbi_connect_info->[0];
- my %blob_vals;
- for my $j (0..$#$cols) {
- if (exists $blob_cols->[$i][$j]) {
- $blob_vals{ $cols->[$j] } = $blob_cols->[$i][$j];
- }
- }
+ return if ref($dsn) eq 'CODE';
- $self->_insert_blobs ($source, \%blob_vals, \%row);
+ if ($dsn !~ /maxConnect=/) {
+ $self->_dbi_connect_info->[0] = "$dsn;maxConnect=$val";
+ my $connected = defined $self->_dbh;
+ $self->disconnect;
+ $self->ensure_connected if $connected;
}
}
-=head2 connect_call_datetime_setup
-
-Used as:
-
- on_connect_call => 'datetime_setup'
-
-In L<DBIx::Class::Storage::DBI/connect_info> to set:
+=head2 using_freetds
- $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
- $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
-
-On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
-L<DateTime::Format::Sybase>, which you will need to install.
-
-This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
-C<SMALLDATETIME> columns only have minute precision.
+Whether or not L<DBD::Sybase> was compiled against FreeTDS. If false, it means
+the Sybase OpenClient libraries were used.
=cut
-{
- my $old_dbd_warned = 0;
-
- sub connect_call_datetime_setup {
- my $self = shift;
- my $dbh = $self->_get_dbh;
-
- if ($dbh->can('syb_date_fmt')) {
- # amazingly, this works with FreeTDS
- $dbh->syb_date_fmt('ISO_strict');
- } elsif (not $old_dbd_warned) {
- carp "Your DBD::Sybase is too old to support ".
- "DBIx::Class::InflateColumn::DateTime, please upgrade!";
- $old_dbd_warned = 1;
- }
-
- $dbh->do('SET DATEFORMAT mdy');
-
- 1;
- }
-}
-
-sub datetime_parser_type { "DateTime::Format::Sybase" }
-
-# ->begin_work and such have no effect with FreeTDS but we run them anyway to
-# let the DBD keep any state it needs to.
-#
-# If they ever do start working, the extra statements will do no harm (because
-# Sybase supports nested transactions.)
-
-sub _dbh_begin_work {
+sub using_freetds {
my $self = shift;
-# bulkLogin=1 connections are always in a transaction, and can only call BEGIN
-# TRAN once. However, we need to make sure there's a $dbh.
- return if $self->_is_bulk_storage && $self->_dbh && $self->_began_bulk_work;
-
- $self->next::method(@_);
-
- if ($self->using_freetds) {
- $self->_get_dbh->do('BEGIN TRAN');
- }
-
- $self->_began_bulk_work(1) if $self->_is_bulk_storage;
+ return $self->_get_dbh->{syb_oc_version} =~ /freetds/i;
}
-sub _dbh_commit {
- my $self = shift;
- if ($self->using_freetds) {
- $self->_dbh->do('COMMIT');
- }
- return $self->next::method(@_);
-}
+=head2 set_textsize
-sub _dbh_rollback {
- my $self = shift;
- if ($self->using_freetds) {
- $self->_dbh->do('ROLLBACK');
- }
- return $self->next::method(@_);
-}
+When using FreeTDS and/or MSSQL, C<< $dbh->{LongReadLen} >> is not available,
+use this function instead. It does:
-# savepoint support using ASE syntax
+ $dbh->do("SET TEXTSIZE $bytes");
-sub _svp_begin {
- my ($self, $name) = @_;
+Takes the number of bytes, or uses the C<LongReadLen> value from your
+L<DBIx::Class/connect_info> if omitted, lastly falls back to the C<32768> which
+is the L<DBD::Sybase> default.
- $self->_get_dbh->do("SAVE TRANSACTION $name");
-}
+=cut
-# A new SAVE TRANSACTION with the same name releases the previous one.
-sub _svp_release { 1 }
+sub set_textsize {
+ my $self = shift;
+ my $text_size = shift ||
+ eval { $self->_dbi_connect_info->[-1]->{LongReadLen} } ||
+ 32768; # the DBD::Sybase default
-sub _svp_rollback {
- my ($self, $name) = @_;
+ return unless defined $text_size;
- $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
+ $self->_dbh->do("SET TEXTSIZE $text_size");
}
1;
-=head1 Schema::Loader Support
-
-There is an experimental branch of L<DBIx::Class::Schema::Loader> that will
-allow you to dump a schema from most (if not all) versions of Sybase.
-
-It is available via subversion from:
-
- http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/current/
-
-=head1 FreeTDS
-
-This driver supports L<DBD::Sybase> compiled against FreeTDS
-(L<http://www.freetds.org/>) to the best of our ability, however it is
-recommended that you recompile L<DBD::Sybase> against the Sybase Open Client
-libraries. They are a part of the Sybase ASE distribution:
-
-The Open Client FAQ is here:
-L<http://www.isug.com/Sybase_FAQ/ASE/section7.html>.
-
-Sybase ASE for Linux (which comes with the Open Client libraries) may be
-downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
-
-To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
-
- perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
-
-Some versions of the libraries involved will not support placeholders, in which
-case the storage will be reblessed to
-L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>.
-
-In some configurations, placeholders will work but will throw implicit type
-conversion errors for anything that's not expecting a string. In such a case,
-the C<auto_cast> option from L<DBIx::Class::Storage::DBI::AutoCast> is
-automatically set, which you may enable on connection with
-L<DBIx::Class::Storage::DBI::AutoCast/connect_call_set_auto_cast>. The type info
-for the C<CAST>s is taken from the L<DBIx::Class::ResultSource/data_type>
-definitions in your Result classes, and are mapped to a Sybase type (if it isn't
-already) using a mapping based on L<SQL::Translator>.
-
-In other configurations, placeholers will work just as they do with the Sybase
-Open Client libraries.
-
-Inserts or updates of TEXT/IMAGE columns will B<NOT> work with FreeTDS.
-
-=head1 INSERTS WITH PLACEHOLDERS
-
-With placeholders enabled, inserts are done in a transaction so that there are
-no concurrency issues with getting the inserted identity value using
-C<SELECT MAX(col)>, which is the only way to get the C<IDENTITY> value in this
-mode.
-
-In addition, they are done on a separate connection so that it's possible to
-have active cursors when doing an insert.
-
-When using C<DBIx::Class::Storage::DBI::Sybase::NoBindVars> transactions are
-disabled, as there are no concurrency issues with C<SELECT @@IDENTITY> as it's a
-session variable.
-
-=head1 TRANSACTIONS
-
-Due to limitations of the TDS protocol, L<DBD::Sybase>, or both; you cannot
-begin a transaction while there are active cursors; nor can you use multiple
-active cursors within a transaction. An active cursor is, for example, a
-L<ResultSet|DBIx::Class::ResultSet> that has been executed using C<next> or
-C<first> but has not been exhausted or L<reset|DBIx::Class::ResultSet/reset>.
-
-For example, this will not work:
-
- $schema->txn_do(sub {
- my $rs = $schema->resultset('Book');
- while (my $row = $rs->next) {
- $schema->resultset('MetaData')->create({
- book_id => $row->id,
- ...
- });
- }
- });
-
-This won't either:
-
- my $first_row = $large_rs->first;
- $schema->txn_do(sub { ... });
-
-Transactions done for inserts in C<AutoCommit> mode when placeholders are in use
-are not affected, as they are done on an extra database handle.
-
-Some workarounds:
-
-=over 4
-
-=item * use L<DBIx::Class::Storage::DBI::Replicated>
-
-=item * L<connect|DBIx::Class::Schema/connect> another L<Schema|DBIx::Class::Schema>
-
-=item * load the data from your cursor with L<DBIx::Class::ResultSet/all>
-
-=back
-
-=head1 MAXIMUM CONNECTIONS
-
-The TDS protocol makes separate connections to the server for active statements
-in the background. By default the number of such connections is limited to 25,
-on both the client side and the server side.
-
-This is a bit too low for a complex L<DBIx::Class> application, so on connection
-the client side setting is set to C<256> (see L<DBD::Sybase/maxConnect>.) You
-can override it to whatever setting you like in the DSN.
-
-See
-L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
-for information on changing the setting on the server side.
-
-=head1 DATES
-
-See L</connect_call_datetime_setup> to setup date formats
-for L<DBIx::Class::InflateColumn::DateTime>.
-
-=head1 TEXT/IMAGE COLUMNS
-
-L<DBD::Sybase> compiled with FreeTDS will B<NOT> allow you to insert or update
-C<TEXT/IMAGE> columns.
-
-Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either:
-
- $schema->storage->dbh->do("SET TEXTSIZE $bytes");
-
-or
-
- $schema->storage->set_textsize($bytes);
-
-instead.
-
-However, the C<LongReadLen> you pass in
-L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
-C<SET TEXTSIZE> command on connection.
-
-See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
-setting you need to work with C<IMAGE> columns.
-
-=head1 BULK API
-
-The experimental L<DBD::Sybase> Bulk API support is used for
-L<populate|DBIx::Class::ResultSet/populate> in B<void> context, in a transaction
-on a separate connection.
-
-To use this feature effectively, use a large number of rows for each
-L<populate|DBIx::Class::ResultSet/populate> call, eg.:
-
- while (my $rows = $data_source->get_100_rows()) {
- $rs->populate($rows);
- }
-
-B<NOTE:> the L<add_columns|DBIx::Class::ResultSource/add_columns>
-calls in your C<Result> classes B<must> list columns in database order for this
-to work. Also, you may have to unset the C<LANG> environment variable before
-loading your app, if it doesn't match the character set of your database.
-
-When inserting IMAGE columns using this method, you'll need to use
-L</connect_call_blob_setup> as well.
-
-=head1 TODO
-
-=over
-
-=item *
-
-Transitions to AutoCommit=0 (starting a transaction) mode by exhausting
-any active cursors, using eager cursors.
-
-=item *
-
-Real limits and limited counts using stored procedures deployed on startup.
-
-=item *
-
-Adaptive Server Anywhere (ASA) support, with possible SQLA::Limit support.
-
-=item *
-
-Blob update with a LIKE query on a blob, without invalidating the WHERE condition.
-
-=item *
-
-bulk_insert using prepare_cached (see comments.)
-
-=back
-
-=head1 AUTHOR
+=head1 AUTHORS
See L<DBIx::Class/CONTRIBUTORS>.
You may distribute this code under the same terms as Perl itself.
=cut
-# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::Sybase::ASE;
+
+use strict;
+use warnings;
+
+use base qw/
+ DBIx::Class::Storage::DBI::Sybase
+ DBIx::Class::Storage::DBI::AutoCast
+/;
+use mro 'c3';
+use Carp::Clan qw/^DBIx::Class/;
+use Scalar::Util();
+use List::Util();
+use Sub::Name();
+use Data::Dumper::Concise();
+
+__PACKAGE__->mk_group_accessors('simple' =>
+ qw/_identity _blob_log_on_update _writer_storage _is_extra_storage
+ _bulk_storage _is_bulk_storage _began_bulk_work
+ _bulk_disabled_due_to_coderef_connect_info_warned
+ _identity_method/
+);
+
+my @also_proxy_to_extra_storages = qw/
+ connect_call_set_auto_cast auto_cast connect_call_blob_setup
+ connect_call_datetime_setup
+
+ disconnect _connect_info _sql_maker _sql_maker_opts disable_sth_caching
+ auto_savepoint unsafe cursor_class debug debugobj schema
+/;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Sybase::ASE - Sybase ASE SQL Server support for
+DBIx::Class
+
+=head1 SYNOPSIS
+
+This subclass supports L<DBD::Sybase> for real (non-Microsoft) Sybase databases.
+
+=head1 DESCRIPTION
+
+If your version of Sybase does not support placeholders, then your storage will
+be reblessed to L<DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars>.
+You can also enable that driver explicitly, see the documentation for more
+details.
+
+With this driver there is unfortunately no way to get the C<last_insert_id>
+without doing a C<SELECT MAX(col)>. This is done safely in a transaction
+(locking the table.) See L</INSERTS WITH PLACEHOLDERS>.
+
+A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
+
+ on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
+
+=head1 METHODS
+
+=cut
+
+sub _rebless {
+ my $self = shift;
+
+ my $no_bind_vars = __PACKAGE__ . '::NoBindVars';
+
+ if ($self->using_freetds) {
+ carp <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN};
+
+You are using FreeTDS with Sybase.
+
+We will do our best to support this configuration, but please consider this
+support experimental.
+
+TEXT/IMAGE columns will definitely not work.
+
+You are encouraged to recompile DBD::Sybase with the Sybase Open Client libraries
+instead.
+
+See perldoc DBIx::Class::Storage::DBI::Sybase::ASE for more details.
+
+To turn off this warning set the DBIC_SYBASE_FREETDS_NOWARN environment
+variable.
+EOF
+
+ if (not $self->_typeless_placeholders_supported) {
+ if ($self->_placeholders_supported) {
+ $self->auto_cast(1);
+ }
+ else {
+ $self->ensure_class_loaded($no_bind_vars);
+ bless $self, $no_bind_vars;
+ $self->_rebless;
+ }
+ }
+ }
+
+ elsif (not $self->_get_dbh->{syb_dynamic_supported}) {
+ # not necessarily FreeTDS, but no placeholders nevertheless
+ $self->ensure_class_loaded($no_bind_vars);
+ bless $self, $no_bind_vars;
+ $self->_rebless;
+ }
+ # this is highly unlikely, but we check just in case
+ elsif (not $self->_typeless_placeholders_supported) {
+ $self->auto_cast(1);
+ }
+}
+
+sub _init {
+ my $self = shift;
+ $self->_set_max_connect(256);
+
+# create storage for insert/(update blob) transactions,
+# unless this is that storage
+ return if $self->_is_extra_storage;
+
+ my $writer_storage = (ref $self)->new;
+
+ $writer_storage->_is_extra_storage(1);
+ $writer_storage->connect_info($self->connect_info);
+ $writer_storage->auto_cast($self->auto_cast);
+
+ $self->_writer_storage($writer_storage);
+
+# create a bulk storage unless connect_info is a coderef
+ return if ref($self->_dbi_connect_info->[0]) eq 'CODE';
+
+ my $bulk_storage = (ref $self)->new;
+
+ $bulk_storage->_is_extra_storage(1);
+ $bulk_storage->_is_bulk_storage(1); # for special ->disconnect acrobatics
+ $bulk_storage->connect_info($self->connect_info);
+
+# this is why
+ $bulk_storage->_dbi_connect_info->[0] .= ';bulkLogin=1';
+
+ $self->_bulk_storage($bulk_storage);
+}
+
+for my $method (@also_proxy_to_extra_storages) {
+ no strict 'refs';
+ no warnings 'redefine';
+
+ my $replaced = __PACKAGE__->can($method);
+
+ *{$method} = Sub::Name::subname $method => sub {
+ my $self = shift;
+ $self->_writer_storage->$replaced(@_) if $self->_writer_storage;
+ $self->_bulk_storage->$replaced(@_) if $self->_bulk_storage;
+ return $self->$replaced(@_);
+ };
+}
+
+sub disconnect {
+ my $self = shift;
+
+# Even though we call $sth->finish for uses off the bulk API, there's still an
+# "active statement" warning on disconnect, which we throw away here.
+# This is due to the bug described in insert_bulk.
+# Currently a noop because 'prepare' is used instead of 'prepare_cached'.
+ local $SIG{__WARN__} = sub {
+ warn $_[0] unless $_[0] =~ /active statement/i;
+ } if $self->_is_bulk_storage;
+
+# so that next transaction gets a dbh
+ $self->_began_bulk_work(0) if $self->_is_bulk_storage;
+
+ $self->next::method;
+}
+
+# Set up session settings for Sybase databases for the connection.
+#
+# Make sure we have CHAINED mode turned on if AutoCommit is off in non-FreeTDS
+# DBD::Sybase (since we don't know how DBD::Sybase was compiled.) If however
+# we're using FreeTDS, CHAINED mode turns on an implicit transaction which we
+# only want when AutoCommit is off.
+#
+# Also SET TEXTSIZE for FreeTDS because LongReadLen doesn't work.
+sub _run_connection_actions {
+ my $self = shift;
+
+ if ($self->_is_bulk_storage) {
+# this should be cleared on every reconnect
+ $self->_began_bulk_work(0);
+ return;
+ }
+
+ if (not $self->using_freetds) {
+ $self->_dbh->{syb_chained_txn} = 1;
+ } else {
+ # based on LongReadLen in connect_info
+ $self->set_textsize;
+
+ if ($self->_dbh_autocommit) {
+ $self->_dbh->do('SET CHAINED OFF');
+ } else {
+ $self->_dbh->do('SET CHAINED ON');
+ }
+ }
+
+ $self->next::method(@_);
+}
+
+=head2 connect_call_blob_setup
+
+Used as:
+
+ on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
+
+Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
+instead of as a hex string.
+
+Recommended.
+
+Also sets the C<log_on_update> value for blob write operations. The default is
+C<1>, but C<0> is better if your database is configured for it.
+
+See
+L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
+
+=cut
+
+sub connect_call_blob_setup {
+ my $self = shift;
+ my %args = @_;
+ my $dbh = $self->_dbh;
+ $dbh->{syb_binary_images} = 1;
+
+ $self->_blob_log_on_update($args{log_on_update})
+ if exists $args{log_on_update};
+}
+
+sub _is_lob_type {
+ my $self = shift;
+ my $type = shift;
+ $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
+}
+
+sub _is_lob_column {
+ my ($self, $source, $column) = @_;
+
+ return $self->_is_lob_type($source->column_info($column)->{data_type});
+}
+
+sub _prep_for_execute {
+ my $self = shift;
+ my ($op, $extra_bind, $ident, $args) = @_;
+
+ my ($sql, $bind) = $self->next::method (@_);
+
+ my $table = Scalar::Util::blessed($ident) ? $ident->from : $ident;
+
+ my $bind_info = $self->_resolve_column_info(
+ $ident, [map $_->[0], @{$bind}]
+ );
+ my $bound_identity_col = List::Util::first
+ { $bind_info->{$_}{is_auto_increment} }
+ (keys %$bind_info)
+ ;
+ my $identity_col = Scalar::Util::blessed($ident) &&
+ List::Util::first
+ { $ident->column_info($_)->{is_auto_increment} }
+ $ident->columns
+ ;
+
+ if (($op eq 'insert' && $bound_identity_col) ||
+ ($op eq 'update' && exists $args->[0]{$identity_col})) {
+ $sql = join ("\n",
+ $self->_set_table_identity_sql($op => $table, 'on'),
+ $sql,
+ $self->_set_table_identity_sql($op => $table, 'off'),
+ );
+ }
+
+ if ($op eq 'insert' && (not $bound_identity_col) && $identity_col &&
+ (not $self->{insert_bulk})) {
+ $sql =
+ "$sql\n" .
+ $self->_fetch_identity_sql($ident, $identity_col);
+ }
+
+ return ($sql, $bind);
+}
+
+sub _set_table_identity_sql {
+ my ($self, $op, $table, $on_off) = @_;
+
+ return sprintf 'SET IDENTITY_%s %s %s',
+ uc($op), $self->sql_maker->_quote($table), uc($on_off);
+}
+
+# Stolen from SQLT, with some modifications. This is a makeshift
+# solution before a sane type-mapping library is available, thus
+# the 'our' for easy overrides.
+our %TYPE_MAPPING = (
+ number => 'numeric',
+ money => 'money',
+ varchar => 'varchar',
+ varchar2 => 'varchar',
+ timestamp => 'datetime',
+ text => 'varchar',
+ real => 'double precision',
+ comment => 'text',
+ bit => 'bit',
+ tinyint => 'smallint',
+ float => 'double precision',
+ serial => 'numeric',
+ bigserial => 'numeric',
+ boolean => 'varchar',
+ long => 'varchar',
+);
+
+sub _native_data_type {
+ my ($self, $type) = @_;
+
+ $type = lc $type;
+ $type =~ s/\s* identity//x;
+
+ return uc($TYPE_MAPPING{$type} || $type);
+}
+
+sub _fetch_identity_sql {
+ my ($self, $source, $col) = @_;
+
+ return sprintf ("SELECT MAX(%s) FROM %s",
+ map { $self->sql_maker->_quote ($_) } ($col, $source->from)
+ );
+}
+
+sub _execute {
+ my $self = shift;
+ my ($op) = @_;
+
+ my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
+
+ if ($op eq 'insert') {
+ $self->_identity($sth->fetchrow_array);
+ $sth->finish;
+ }
+
+ return wantarray ? ($rv, $sth, @bind) : $rv;
+}
+
+sub last_insert_id { shift->_identity }
+
+# handles TEXT/IMAGE and transaction for last_insert_id
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
+
+ my $identity_col = (List::Util::first
+ { $source->column_info($_)->{is_auto_increment} }
+ $source->columns) || '';
+
+ # check for empty insert
+ # INSERT INTO foo DEFAULT VALUES -- does not work with Sybase
+ # try to insert explicit 'DEFAULT's instead (except for identity, timestamp
+ # and computed columns)
+ if (not %$to_insert) {
+ for my $col ($source->columns) {
+ next if $col eq $identity_col;
+
+ my $info = $source->column_info($col);
+
+ next if ref $info->{default_value} eq 'SCALAR'
+ || (exists $info->{data_type} && (not defined $info->{data_type}));
+
+ next if $info->{data_type} && $info->{data_type} =~ /^timestamp\z/i;
+
+ $to_insert->{$col} = \'DEFAULT';
+ }
+ }
+
+ my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
+
+ # do we need the horrific SELECT MAX(COL) hack?
+ my $dumb_last_insert_id =
+ $identity_col
+ && (not exists $to_insert->{$identity_col})
+ && ($self->_identity_method||'') ne '@@IDENTITY';
+
+ my $next = $self->next::can;
+
+ # we are already in a transaction, or there are no blobs
+ # and we don't need the PK - just (try to) do it
+ if ($self->{transaction_depth}
+ || (!$blob_cols && !$dumb_last_insert_id)
+ ) {
+ return $self->_insert (
+ $next, $source, $to_insert, $blob_cols, $identity_col
+ );
+ }
+
+ # otherwise use the _writer_storage to do the insert+transaction on another
+ # connection
+ my $guard = $self->_writer_storage->txn_scope_guard;
+
+ my $updated_cols = $self->_writer_storage->_insert (
+ $next, $source, $to_insert, $blob_cols, $identity_col
+ );
+
+ $self->_identity($self->_writer_storage->_identity);
+
+ $guard->commit;
+
+ return $updated_cols;
+}
+
+sub _insert {
+ my ($self, $next, $source, $to_insert, $blob_cols, $identity_col) = @_;
+
+ my $updated_cols = $self->$next ($source, $to_insert);
+
+ my $final_row = {
+ ($identity_col ?
+ ($identity_col => $self->last_insert_id($source, $identity_col)) : ()),
+ %$to_insert,
+ %$updated_cols,
+ };
+
+ $self->_insert_blobs ($source, $blob_cols, $final_row) if $blob_cols;
+
+ return $updated_cols;
+}
+
+sub update {
+ my $self = shift;
+ my ($source, $fields, $where, @rest) = @_;
+
+ my $wantarray = wantarray;
+
+ my $blob_cols = $self->_remove_blob_cols($source, $fields);
+
+ my $table = $source->name;
+
+ my $identity_col = List::Util::first
+ { $source->column_info($_)->{is_auto_increment} }
+ $source->columns;
+
+ my $is_identity_update = $identity_col && defined $fields->{$identity_col};
+
+ return $self->next::method(@_) unless $blob_cols;
+
+# If there are any blobs in $where, Sybase will return a descriptive error
+# message.
+# XXX blobs can still be used with a LIKE query, and this should be handled.
+
+# update+blob update(s) done atomically on separate connection
+ $self = $self->_writer_storage;
+
+ my $guard = $self->txn_scope_guard;
+
+# First update the blob columns to be updated to '' (taken from $fields, where
+# it is originally put by _remove_blob_cols .)
+ my %blobs_to_empty = map { ($_ => delete $fields->{$_}) } keys %$blob_cols;
+
+# We can't only update NULL blobs, because blobs cannot be in the WHERE clause.
+
+ $self->next::method($source, \%blobs_to_empty, $where, @rest);
+
+# Now update the blobs before the other columns in case the update of other
+# columns makes the search condition invalid.
+ $self->_update_blobs($source, $blob_cols, $where);
+
+ my @res;
+ if (%$fields) {
+ if ($wantarray) {
+ @res = $self->next::method(@_);
+ }
+ elsif (defined $wantarray) {
+ $res[0] = $self->next::method(@_);
+ }
+ else {
+ $self->next::method(@_);
+ }
+ }
+
+ $guard->commit;
+
+ return $wantarray ? @res : $res[0];
+}
+
+sub insert_bulk {
+ my $self = shift;
+ my ($source, $cols, $data) = @_;
+
+ my $identity_col = List::Util::first
+ { $source->column_info($_)->{is_auto_increment} }
+ $source->columns;
+
+ my $is_identity_insert = (List::Util::first
+ { $_ eq $identity_col }
+ @{$cols}
+ ) ? 1 : 0;
+
+ my @source_columns = $source->columns;
+
+ my $use_bulk_api =
+ $self->_bulk_storage &&
+ $self->_get_dbh->{syb_has_blk};
+
+ if ((not $use_bulk_api)
+ &&
+ (ref($self->_dbi_connect_info->[0]) eq 'CODE')
+ &&
+ (not $self->_bulk_disabled_due_to_coderef_connect_info_warned)) {
+ carp <<'EOF';
+Bulk API support disabled due to use of a CODEREF connect_info. Reverting to
+regular array inserts.
+EOF
+ $self->_bulk_disabled_due_to_coderef_connect_info_warned(1);
+ }
+
+ if (not $use_bulk_api) {
+ my $blob_cols = $self->_remove_blob_cols_array($source, $cols, $data);
+
+# _execute_array uses a txn anyway, but it ends too early in case we need to
+# select max(col) to get the identity for inserting blobs.
+ ($self, my $guard) = $self->{transaction_depth} == 0 ?
+ ($self->_writer_storage, $self->_writer_storage->txn_scope_guard)
+ :
+ ($self, undef);
+
+ local $self->{insert_bulk} = 1;
+
+ $self->next::method(@_);
+
+ if ($blob_cols) {
+ if ($is_identity_insert) {
+ $self->_insert_blobs_array ($source, $blob_cols, $cols, $data);
+ }
+ else {
+ my @cols_with_identities = (@$cols, $identity_col);
+
+ ## calculate identities
+ # XXX This assumes identities always increase by 1, which may or may not
+ # be true.
+ my ($last_identity) =
+ $self->_dbh->selectrow_array (
+ $self->_fetch_identity_sql($source, $identity_col)
+ );
+ my @identities = (($last_identity - @$data + 1) .. $last_identity);
+
+ my @data_with_identities = map [@$_, shift @identities], @$data;
+
+ $self->_insert_blobs_array (
+ $source, $blob_cols, \@cols_with_identities, \@data_with_identities
+ );
+ }
+ }
+
+ $guard->commit if $guard;
+
+ return;
+ }
+
+# otherwise, use the bulk API
+
+# rearrange @$data so that columns are in database order
+ my %orig_idx;
+ @orig_idx{@$cols} = 0..$#$cols;
+
+ my %new_idx;
+ @new_idx{@source_columns} = 0..$#source_columns;
+
+ my @new_data;
+ for my $datum (@$data) {
+ my $new_datum = [];
+ for my $col (@source_columns) {
+# identity data will be 'undef' if not $is_identity_insert
+# columns with defaults will also be 'undef'
+ $new_datum->[ $new_idx{$col} ] =
+ exists $orig_idx{$col} ? $datum->[ $orig_idx{$col} ] : undef;
+ }
+ push @new_data, $new_datum;
+ }
+
+# bcp identity index is 1-based
+ my $identity_idx = exists $new_idx{$identity_col} ?
+ $new_idx{$identity_col} + 1 : 0;
+
+## Set a client-side conversion error handler, straight from DBD::Sybase docs.
+# This ignores any data conversion errors detected by the client side libs, as
+# they are usually harmless.
+ my $orig_cslib_cb = DBD::Sybase::set_cslib_cb(
+ Sub::Name::subname insert_bulk => sub {
+ my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_;
+
+ return 1 if $errno == 36;
+
+ carp
+ "Layer: $layer, Origin: $origin, Severity: $severity, Error: $errno" .
+ ($errmsg ? "\n$errmsg" : '') .
+ ($osmsg ? "\n$osmsg" : '') .
+ ($blkmsg ? "\n$blkmsg" : '');
+
+ return 0;
+ });
+
+ eval {
+ my $bulk = $self->_bulk_storage;
+
+ my $guard = $bulk->txn_scope_guard;
+
+## XXX get this to work instead of our own $sth
+## will require SQLA or *Hacks changes for ordered columns
+# $bulk->next::method($source, \@source_columns, \@new_data, {
+# syb_bcp_attribs => {
+# identity_flag => $is_identity_insert,
+# identity_column => $identity_idx,
+# }
+# });
+ my $sql = 'INSERT INTO ' .
+ $bulk->sql_maker->_quote($source->name) . ' (' .
+# colname list is ignored for BCP, but does no harm
+ (join ', ', map $bulk->sql_maker->_quote($_), @source_columns) . ') '.
+ ' VALUES ('. (join ', ', ('?') x @source_columns) . ')';
+
+## XXX there's a bug in the DBD::Sybase bulk support that makes $sth->finish for
+## a prepare_cached statement ineffective. Replace with ->sth when fixed, or
+## better yet the version above. Should be fixed in DBD::Sybase .
+ my $sth = $bulk->_get_dbh->prepare($sql,
+# 'insert', # op
+ {
+ syb_bcp_attribs => {
+ identity_flag => $is_identity_insert,
+ identity_column => $identity_idx,
+ }
+ }
+ );
+
+ my @bind = do {
+ my $idx = 0;
+ map [ $_, $idx++ ], @source_columns;
+ };
+
+ $self->_execute_array(
+ $source, $sth, \@bind, \@source_columns, \@new_data, sub {
+ $guard->commit
+ }
+ );
+
+ $bulk->_query_end($sql);
+ };
+
+ my $exception = $@;
+ DBD::Sybase::set_cslib_cb($orig_cslib_cb);
+
+ if ($exception =~ /-Y option/) {
+ carp <<"EOF";
+
+Sybase bulk API operation failed due to character set incompatibility, reverting
+to regular array inserts:
+
+*** Try unsetting the LANG environment variable.
+
+$exception
+EOF
+ $self->_bulk_storage(undef);
+ unshift @_, $self;
+ goto \&insert_bulk;
+ }
+ elsif ($exception) {
+# rollback makes the bulkLogin connection unusable
+ $self->_bulk_storage->disconnect;
+ $self->throw_exception($exception);
+ }
+}
+
+sub _dbh_execute_array {
+ my ($self, $sth, $tuple_status, $cb) = @_;
+
+ my $rv = $self->next::method($sth, $tuple_status);
+ $cb->() if $cb;
+
+ return $rv;
+}
+
+# Make sure blobs are not bound as placeholders, and return any non-empty ones
+# as a hash.
+sub _remove_blob_cols {
+ my ($self, $source, $fields) = @_;
+
+ my %blob_cols;
+
+ for my $col (keys %$fields) {
+ if ($self->_is_lob_column($source, $col)) {
+ my $blob_val = delete $fields->{$col};
+ if (not defined $blob_val) {
+ $fields->{$col} = \'NULL';
+ }
+ else {
+ $fields->{$col} = \"''";
+ $blob_cols{$col} = $blob_val unless $blob_val eq '';
+ }
+ }
+ }
+
+ return %blob_cols ? \%blob_cols : undef;
+}
+
+# same for insert_bulk
+sub _remove_blob_cols_array {
+ my ($self, $source, $cols, $data) = @_;
+
+ my @blob_cols;
+
+ for my $i (0..$#$cols) {
+ my $col = $cols->[$i];
+
+ if ($self->_is_lob_column($source, $col)) {
+ for my $j (0..$#$data) {
+ my $blob_val = delete $data->[$j][$i];
+ if (not defined $blob_val) {
+ $data->[$j][$i] = \'NULL';
+ }
+ else {
+ $data->[$j][$i] = \"''";
+ $blob_cols[$j][$i] = $blob_val
+ unless $blob_val eq '';
+ }
+ }
+ }
+ }
+
+ return @blob_cols ? \@blob_cols : undef;
+}
+
+sub _update_blobs {
+ my ($self, $source, $blob_cols, $where) = @_;
+
+ my (@primary_cols) = $source->primary_columns;
+
+ $self->throw_exception('Cannot update TEXT/IMAGE column(s) without a primary key')
+ unless @primary_cols;
+
+# check if we're updating a single row by PK
+ my $pk_cols_in_where = 0;
+ for my $col (@primary_cols) {
+ $pk_cols_in_where++ if defined $where->{$col};
+ }
+ my @rows;
+
+ if ($pk_cols_in_where == @primary_cols) {
+ my %row_to_update;
+ @row_to_update{@primary_cols} = @{$where}{@primary_cols};
+ @rows = \%row_to_update;
+ } else {
+ my $cursor = $self->select ($source, \@primary_cols, $where, {});
+ @rows = map {
+ my %row; @row{@primary_cols} = @$_; \%row
+ } $cursor->all;
+ }
+
+ for my $row (@rows) {
+ $self->_insert_blobs($source, $blob_cols, $row);
+ }
+}
+
+sub _insert_blobs {
+ my ($self, $source, $blob_cols, $row) = @_;
+ my $dbh = $self->_get_dbh;
+
+ my $table = $source->name;
+
+ my %row = %$row;
+ my (@primary_cols) = $source->primary_columns;
+
+ $self->throw_exception('Cannot update TEXT/IMAGE column(s) without a primary key')
+ unless @primary_cols;
+
+ $self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values')
+ if ((grep { defined $row{$_} } @primary_cols) != @primary_cols);
+
+ for my $col (keys %$blob_cols) {
+ my $blob = $blob_cols->{$col};
+
+ my %where = map { ($_, $row{$_}) } @primary_cols;
+
+ my $cursor = $self->select ($source, [$col], \%where, {});
+ $cursor->next;
+ my $sth = $cursor->sth;
+
+ if (not $sth) {
+
+ $self->throw_exception(
+ "Could not find row in table '$table' for blob update:\n"
+ . Data::Dumper::Concise::Dumper (\%where)
+ );
+ }
+
+ eval {
+ do {
+ $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
+ } while $sth->fetch;
+
+ $sth->func('ct_prepare_send') or die $sth->errstr;
+
+ my $log_on_update = $self->_blob_log_on_update;
+ $log_on_update = 1 if not defined $log_on_update;
+
+ $sth->func('CS_SET', 1, {
+ total_txtlen => length($blob),
+ log_on_update => $log_on_update
+ }, 'ct_data_info') or die $sth->errstr;
+
+ $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
+
+ $sth->func('ct_finish_send') or die $sth->errstr;
+ };
+ my $exception = $@;
+ $sth->finish if $sth;
+ if ($exception) {
+ if ($self->using_freetds) {
+ $self->throw_exception (
+ 'TEXT/IMAGE operation failed, probably because you are using FreeTDS: '
+ . $exception
+ );
+ } else {
+ $self->throw_exception($exception);
+ }
+ }
+ }
+}
+
+sub _insert_blobs_array {
+ my ($self, $source, $blob_cols, $cols, $data) = @_;
+
+ for my $i (0..$#$data) {
+ my $datum = $data->[$i];
+
+ my %row;
+ @row{ @$cols } = @$datum;
+
+ my %blob_vals;
+ for my $j (0..$#$cols) {
+ if (exists $blob_cols->[$i][$j]) {
+ $blob_vals{ $cols->[$j] } = $blob_cols->[$i][$j];
+ }
+ }
+
+ $self->_insert_blobs ($source, \%blob_vals, \%row);
+ }
+}
+
+=head2 connect_call_datetime_setup
+
+Used as:
+
+ on_connect_call => 'datetime_setup'
+
+In L<DBIx::Class::Storage::DBI/connect_info> to set:
+
+ $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
+ $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
+
+On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
+L<DateTime::Format::Sybase>, which you will need to install.
+
+This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
+C<SMALLDATETIME> columns only have minute precision.
+
+=cut
+
+{
+ my $old_dbd_warned = 0;
+
+ sub connect_call_datetime_setup {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
+
+ if ($dbh->can('syb_date_fmt')) {
+ # amazingly, this works with FreeTDS
+ $dbh->syb_date_fmt('ISO_strict');
+ } elsif (not $old_dbd_warned) {
+ carp "Your DBD::Sybase is too old to support ".
+ "DBIx::Class::InflateColumn::DateTime, please upgrade!";
+ $old_dbd_warned = 1;
+ }
+
+ $dbh->do('SET DATEFORMAT mdy');
+
+ 1;
+ }
+}
+
+sub datetime_parser_type { "DateTime::Format::Sybase" }
+
+# ->begin_work and such have no effect with FreeTDS but we run them anyway to
+# let the DBD keep any state it needs to.
+#
+# If they ever do start working, the extra statements will do no harm (because
+# Sybase supports nested transactions.)
+
+sub _dbh_begin_work {
+ my $self = shift;
+
+# bulkLogin=1 connections are always in a transaction, and can only call BEGIN
+# TRAN once. However, we need to make sure there's a $dbh.
+ return if $self->_is_bulk_storage && $self->_dbh && $self->_began_bulk_work;
+
+ $self->next::method(@_);
+
+ if ($self->using_freetds) {
+ $self->_get_dbh->do('BEGIN TRAN');
+ }
+
+ $self->_began_bulk_work(1) if $self->_is_bulk_storage;
+}
+
+sub _dbh_commit {
+ my $self = shift;
+ if ($self->using_freetds) {
+ $self->_dbh->do('COMMIT');
+ }
+ return $self->next::method(@_);
+}
+
+sub _dbh_rollback {
+ my $self = shift;
+ if ($self->using_freetds) {
+ $self->_dbh->do('ROLLBACK');
+ }
+ return $self->next::method(@_);
+}
+
+# savepoint support using ASE syntax
+
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->_get_dbh->do("SAVE TRANSACTION $name");
+}
+
+# A new SAVE TRANSACTION with the same name releases the previous one.
+sub _svp_release { 1 }
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
+}
+
+1;
+
+=head1 Schema::Loader Support
+
+As of version C<0.05000>, L<DBIx::Class::Schema::Loader> should work well with
+most (if not all) versions of Sybase ASE.
+
+=head1 FreeTDS
+
+This driver supports L<DBD::Sybase> compiled against FreeTDS
+(L<http://www.freetds.org/>) to the best of our ability, however it is
+recommended that you recompile L<DBD::Sybase> against the Sybase Open Client
+libraries. They are a part of the Sybase ASE distribution:
+
+The Open Client FAQ is here:
+L<http://www.isug.com/Sybase_FAQ/ASE/section7.html>.
+
+Sybase ASE for Linux (which comes with the Open Client libraries) may be
+downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
+
+To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
+
+ perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
+
+Some versions of the libraries involved will not support placeholders, in which
+case the storage will be reblessed to
+L<DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars>.
+
+In some configurations, placeholders will work but will throw implicit type
+conversion errors for anything that's not expecting a string. In such a case,
+the C<auto_cast> option from L<DBIx::Class::Storage::DBI::AutoCast> is
+automatically set, which you may enable on connection with
+L<DBIx::Class::Storage::DBI::AutoCast/connect_call_set_auto_cast>. The type info
+for the C<CAST>s is taken from the L<DBIx::Class::ResultSource/data_type>
+definitions in your Result classes, and are mapped to a Sybase type (if it isn't
+already) using a mapping based on L<SQL::Translator>.
+
+In other configurations, placeholers will work just as they do with the Sybase
+Open Client libraries.
+
+Inserts or updates of TEXT/IMAGE columns will B<NOT> work with FreeTDS.
+
+=head1 INSERTS WITH PLACEHOLDERS
+
+With placeholders enabled, inserts are done in a transaction so that there are
+no concurrency issues with getting the inserted identity value using
+C<SELECT MAX(col)>, which is the only way to get the C<IDENTITY> value in this
+mode.
+
+In addition, they are done on a separate connection so that it's possible to
+have active cursors when doing an insert.
+
+When using C<DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars> transactions
+are disabled, as there are no concurrency issues with C<SELECT @@IDENTITY> as
+it's a session variable.
+
+=head1 TRANSACTIONS
+
+Due to limitations of the TDS protocol, L<DBD::Sybase>, or both; you cannot
+begin a transaction while there are active cursors; nor can you use multiple
+active cursors within a transaction. An active cursor is, for example, a
+L<ResultSet|DBIx::Class::ResultSet> that has been executed using C<next> or
+C<first> but has not been exhausted or L<reset|DBIx::Class::ResultSet/reset>.
+
+For example, this will not work:
+
+ $schema->txn_do(sub {
+ my $rs = $schema->resultset('Book');
+ while (my $row = $rs->next) {
+ $schema->resultset('MetaData')->create({
+ book_id => $row->id,
+ ...
+ });
+ }
+ });
+
+This won't either:
+
+ my $first_row = $large_rs->first;
+ $schema->txn_do(sub { ... });
+
+Transactions done for inserts in C<AutoCommit> mode when placeholders are in use
+are not affected, as they are done on an extra database handle.
+
+Some workarounds:
+
+=over 4
+
+=item * use L<DBIx::Class::Storage::DBI::Replicated>
+
+=item * L<connect|DBIx::Class::Schema/connect> another L<Schema|DBIx::Class::Schema>
+
+=item * load the data from your cursor with L<DBIx::Class::ResultSet/all>
+
+=back
+
+=head1 MAXIMUM CONNECTIONS
+
+The TDS protocol makes separate connections to the server for active statements
+in the background. By default the number of such connections is limited to 25,
+on both the client side and the server side.
+
+This is a bit too low for a complex L<DBIx::Class> application, so on connection
+the client side setting is set to C<256> (see L<DBD::Sybase/maxConnect>.) You
+can override it to whatever setting you like in the DSN.
+
+See
+L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
+for information on changing the setting on the server side.
+
+=head1 DATES
+
+See L</connect_call_datetime_setup> to setup date formats
+for L<DBIx::Class::InflateColumn::DateTime>.
+
+=head1 TEXT/IMAGE COLUMNS
+
+L<DBD::Sybase> compiled with FreeTDS will B<NOT> allow you to insert or update
+C<TEXT/IMAGE> columns.
+
+Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either:
+
+ $schema->storage->dbh->do("SET TEXTSIZE $bytes");
+
+or
+
+ $schema->storage->set_textsize($bytes);
+
+instead.
+
+However, the C<LongReadLen> you pass in
+L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
+C<SET TEXTSIZE> command on connection.
+
+See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
+setting you need to work with C<IMAGE> columns.
+
+=head1 BULK API
+
+The experimental L<DBD::Sybase> Bulk API support is used for
+L<populate|DBIx::Class::ResultSet/populate> in B<void> context, in a transaction
+on a separate connection.
+
+To use this feature effectively, use a large number of rows for each
+L<populate|DBIx::Class::ResultSet/populate> call, eg.:
+
+ while (my $rows = $data_source->get_100_rows()) {
+ $rs->populate($rows);
+ }
+
+B<NOTE:> the L<add_columns|DBIx::Class::ResultSource/add_columns>
+calls in your C<Result> classes B<must> list columns in database order for this
+to work. Also, you may have to unset the C<LANG> environment variable before
+loading your app, if it doesn't match the character set of your database.
+
+When inserting IMAGE columns using this method, you'll need to use
+L</connect_call_blob_setup> as well.
+
+=head1 COMPUTED COLUMNS
+
+If you have columns such as:
+
+ created_dtm AS getdate()
+
+represent them in your Result classes as:
+
+ created_dtm => {
+ data_type => undef,
+ default_value => \'getdate()',
+ is_nullable => 0,
+ }
+
+The C<data_type> must exist and must be C<undef>. Then empty inserts will work
+on tables with such columns.
+
+=head1 TIMESTAMP COLUMNS
+
+C<timestamp> columns in Sybase ASE are not really timestamps, see:
+L<http://dba.fyicenter.com/Interview-Questions/SYBASE/The_timestamp_datatype_in_Sybase_.html>.
+
+They should be defined in your Result classes as:
+
+ ts => {
+ data_type => 'timestamp',
+ is_nullable => 0,
+ inflate_datetime => 0,
+ }
+
+The C<<inflate_datetime => 0>> is necessary if you use
+L<DBIx::Class::InflateColumn::DateTime>, and most people do, and still want to
+be able to read these values.
+
+The values will come back as hexadecimal.
+
+=head1 TODO
+
+=over
+
+=item *
+
+Transitions to AutoCommit=0 (starting a transaction) mode by exhausting
+any active cursors, using eager cursors.
+
+=item *
+
+Real limits and limited counts using stored procedures deployed on startup.
+
+=item *
+
+Adaptive Server Anywhere (ASA) support, with possible SQLA::Limit support.
+
+=item *
+
+Blob update with a LIKE query on a blob, without invalidating the WHERE condition.
+
+=item *
+
+bulk_insert using prepare_cached (see comments.)
+
+=back
+
+=head1 AUTHOR
+
+See L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
-package DBIx::Class::Storage::DBI::Sybase::NoBindVars;
+package DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars;
use base qw/
DBIx::Class::Storage::DBI::NoBindVars
- DBIx::Class::Storage::DBI::Sybase
+ DBIx::Class::Storage::DBI::Sybase::ASE
/;
use mro 'c3';
use List::Util ();
=head1 NAME
-DBIx::Class::Storage::DBI::Sybase::NoBindVars - Storage::DBI subclass for Sybase
-without placeholder support
+DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars - Storage::DBI subclass for
+Sybase ASE without placeholder support
=head1 DESCRIPTION
You can also enable this driver explicitly using:
my $schema = SchemaClass->clone;
- $schema->storage_type('::DBI::Sybase::NoBindVars');
+ $schema->storage_type('::DBI::Sybase::ASE::NoBindVars');
$schema->connect($dsn, $user, $pass, \%opts);
See the discussion in L<< DBD::Sybase/Using ? Placeholders & bind parameters to
+++ /dev/null
-package DBIx::Class::Storage::DBI::Sybase::Common;
-
-use strict;
-use warnings;
-
-use base qw/DBIx::Class::Storage::DBI/;
-use mro 'c3';
-
-=head1 NAME
-
-DBIx::Class::Storage::DBI::Sybase::Common - Common functionality for drivers using
-DBD::Sybase
-
-=head1 DESCRIPTION
-
-This is the base class for L<DBIx::Class::Storage::DBI::Sybase> and
-L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>. It provides some
-utility methods related to L<DBD::Sybase> and the supported functions of the
-database you are connecting to.
-
-=head1 METHODS
-
-=cut
-
-sub _ping {
- my $self = shift;
-
- my $dbh = $self->_dbh or return 0;
-
- local $dbh->{RaiseError} = 1;
- local $dbh->{PrintError} = 0;
-
- if ($dbh->{syb_no_child_con}) {
-# ping is impossible with an active statement, we return false if so
- my $ping = eval { $dbh->ping };
- return $@ ? 0 : $ping;
- }
-
- eval {
-# XXX if the main connection goes stale, does opening another for this statement
-# really determine anything?
- $dbh->do('select 1');
- };
-
- return $@ ? 0 : 1;
-}
-
-sub _set_max_connect {
- my $self = shift;
- my $val = shift || 256;
-
- my $dsn = $self->_dbi_connect_info->[0];
-
- return if ref($dsn) eq 'CODE';
-
- if ($dsn !~ /maxConnect=/) {
- $self->_dbi_connect_info->[0] = "$dsn;maxConnect=$val";
- my $connected = defined $self->_dbh;
- $self->disconnect;
- $self->ensure_connected if $connected;
- }
-}
-
-=head2 using_freetds
-
-Whether or not L<DBD::Sybase> was compiled against FreeTDS. If false, it means
-the Sybase OpenClient libraries were used.
-
-=cut
-
-sub using_freetds {
- my $self = shift;
-
- return $self->_get_dbh->{syb_oc_version} =~ /freetds/i;
-}
-
-=head2 set_textsize
-
-When using FreeTDS and/or MSSQL, C<< $dbh->{LongReadLen} >> is not available,
-use this function instead. It does:
-
- $dbh->do("SET TEXTSIZE $bytes");
-
-Takes the number of bytes, or uses the C<LongReadLen> value from your
-L<DBIx::Class/connect_info> if omitted, lastly falls back to the C<32768> which
-is the L<DBD::Sybase> default.
-
-=cut
-
-sub set_textsize {
- my $self = shift;
- my $text_size = shift ||
- eval { $self->_dbi_connect_info->[-1]->{LongReadLen} } ||
- 32768; # the DBD::Sybase default
-
- return unless defined $text_size;
-
- $self->_dbh->do("SET TEXTSIZE $text_size");
-}
-
-1;
-
-=head1 AUTHORS
-
-See L<DBIx::Class/CONTRIBUTORS>.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
use warnings;
use base qw/
- DBIx::Class::Storage::DBI::Sybase::Common
+ DBIx::Class::Storage::DBI::Sybase
DBIx::Class::Storage::DBI::MSSQL
/;
use mro 'c3';
my $self = shift;
my $dbh = $self->_get_dbh;
+ return if ref $self ne __PACKAGE__;
+
if (not $self->_typeless_placeholders_supported) {
+ require
+ DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars;
bless $self,
'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars';
$self->_rebless;
}
}
-sub _init {
+sub _run_connection_actions {
my $self = shift;
# LongReadLen doesn't work with MSSQL through DBD::Sybase, and the default is
# huge on some versions of SQL server and can cause memory problems, so we
- # fix it up here (see Sybase/Common.pm)
+ # fix it up here (see ::DBI::Sybase.pm)
$self->set_textsize;
+
+ $self->next::method(@_);
+}
+
+sub _dbh_begin_work {
+ my $self = shift;
+
+ $self->_get_dbh->do('BEGIN TRAN');
+}
+
+sub _dbh_commit {
+ my $self = shift;
+ my $dbh = $self->_dbh
+ or $self->throw_exception('cannot COMMIT on a disconnected handle');
+ $dbh->do('COMMIT');
+}
+
+sub _dbh_rollback {
+ my $self = shift;
+ my $dbh = $self->_dbh
+ or $self->throw_exception('cannot ROLLBACK on a disconnected handle');
+ $dbh->do('ROLLBACK');
}
1;
session variables such that MySQL behaves more predictably as far as the
SQL standard is concerned.
+=head1 STORAGE OPTIONS
+
+=head2 set_strict_mode
+
+Enables session-wide strict options upon connecting. Equivalent to:
+
+ ->connect ( ... , {
+ on_connect_do => [
+ q|SET SQL_MODE = CONCAT('ANSI,TRADITIONAL,ONLY_FULL_GROUP_BY,', @@sql_mode)|,
+ q|SET SQL_AUTO_IS_NULL = 0|,
+ ]
+ });
+
=head1 AUTHORS
See L<DBIx::Class/CONTRIBUTORS>
--- /dev/null
+package #hide from PAUSE
+ DBIx::Class::Storage::DBIHacks;
+
+#
+# This module contains code that should never have seen the light of day,
+# does not belong in the Storage, or is otherwise unfit for public
+# display. The arrival of SQLA2 should immediately oboslete 90% of this
+#
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Storage';
+use mro 'c3';
+
+use Carp::Clan qw/^DBIx::Class/;
+
+#
+# This code will remove non-selecting/non-restricting joins from
+# {from} specs, aiding the RDBMS query optimizer
+#
+sub _prune_unused_joins {
+ my ($self) = shift;
+
+ my ($from, $select, $where, $attrs) = @_;
+
+ if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY') {
+ return $from; # only standard {from} specs are supported
+ }
+
+ my $aliastypes = $self->_resolve_aliastypes_from_select_args(@_);
+
+ # a grouped set will not be affected by amount of rows. Thus any
+ # {multiplying} joins can go
+ delete $aliastypes->{multiplying} if $attrs->{group_by};
+
+
+ my @newfrom = $from->[0]; # FROM head is always present
+
+ my %need_joins = (map { %{$_||{}} } (values %$aliastypes) );
+ for my $j (@{$from}[1..$#$from]) {
+ push @newfrom, $j if (
+ (! $j->[0]{-alias}) # legacy crap
+ ||
+ $need_joins{$j->[0]{-alias}}
+ );
+ }
+
+ return \@newfrom;
+}
+
+#
+# This is the code producing joined subqueries like:
+# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ...
+#
+sub _adjust_select_args_for_complex_prefetch {
+ my ($self, $from, $select, $where, $attrs) = @_;
+
+ $self->throw_exception ('Nothing to prefetch... how did we get here?!')
+ if not @{$attrs->{_prefetch_select}};
+
+ $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
+ if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY');
+
+
+ # generate inner/outer attribute lists, remove stuff that doesn't apply
+ my $outer_attrs = { %$attrs };
+ delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/;
+
+ my $inner_attrs = { %$attrs };
+ delete $inner_attrs->{$_} for qw/for collapse _prefetch_select _collapse_order_by select as/;
+
+
+ # bring over all non-collapse-induced order_by into the inner query (if any)
+ # the outer one will have to keep them all
+ delete $inner_attrs->{order_by};
+ if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}} ) {
+ $inner_attrs->{order_by} = [
+ @{$outer_attrs->{order_by}}[ 0 .. $ord_cnt - 1]
+ ];
+ }
+
+ # generate the inner/outer select lists
+ # for inside we consider only stuff *not* brought in by the prefetch
+ # on the outside we substitute any function for its alias
+ my $outer_select = [ @$select ];
+ my $inner_select = [];
+ for my $i (0 .. ( @$outer_select - @{$outer_attrs->{_prefetch_select}} - 1) ) {
+ my $sel = $outer_select->[$i];
+
+ if (ref $sel eq 'HASH' ) {
+ $sel->{-as} ||= $attrs->{as}[$i];
+ $outer_select->[$i] = join ('.', $attrs->{alias}, ($sel->{-as} || "inner_column_$i") );
+ }
+
+ push @$inner_select, $sel;
+ }
+
+ # construct the inner $from for the subquery
+ # we need to prune first, because this will determine if we need a group_bu below
+ my $inner_from = $self->_prune_unused_joins ($from, $inner_select, $where, $inner_attrs);
+
+ # if a multi-type join was needed in the subquery - add a group_by to simulate the
+ # collapse in the subq
+ $inner_attrs->{group_by} ||= $inner_select
+ if List::Util::first
+ { ! $_->[0]{-is_single} }
+ (@{$inner_from}[1 .. $#$inner_from])
+ ;
+
+ # generate the subquery
+ my $subq = $self->_select_args_to_query (
+ $inner_from,
+ $inner_select,
+ $where,
+ $inner_attrs,
+ );
+
+ my $subq_joinspec = {
+ -alias => $attrs->{alias},
+ -source_handle => $inner_from->[0]{-source_handle},
+ $attrs->{alias} => $subq,
+ };
+
+ # Generate the outer from - this is relatively easy (really just replace
+ # the join slot with the subquery), with a major caveat - we can not
+ # join anything that is non-selecting (not part of the prefetch), but at
+ # the same time is a multi-type relationship, as it will explode the result.
+ #
+ # There are two possibilities here
+ # - either the join is non-restricting, in which case we simply throw it away
+ # - it is part of the restrictions, in which case we need to collapse the outer
+ # result by tackling yet another group_by to the outside of the query
+
+ # normalize a copy of $from, so it will be easier to work with further
+ # down (i.e. promote the initial hashref to an AoH)
+ $from = [ @$from ];
+ $from->[0] = [ $from->[0] ];
+
+ # so first generate the outer_from, up to the substitution point
+ my @outer_from;
+ while (my $j = shift @$from) {
+ if ($j->[0]{-alias} eq $attrs->{alias}) { # time to swap
+ push @outer_from, [
+ $subq_joinspec,
+ @{$j}[1 .. $#$j],
+ ];
+ last; # we'll take care of what's left in $from below
+ }
+ else {
+ push @outer_from, $j;
+ }
+ }
+
+ # scan the from spec against different attributes, and see which joins are needed
+ # in what role
+ my $outer_aliastypes =
+ $self->_resolve_aliastypes_from_select_args( $from, $outer_select, $where, $outer_attrs );
+
+ # see what's left - throw away if not selecting/restricting
+ # also throw in a group_by if restricting to guard against
+ # cross-join explosions
+ #
+ while (my $j = shift @$from) {
+ my $alias = $j->[0]{-alias};
+
+ if ($outer_aliastypes->{select}{$alias}) {
+ push @outer_from, $j;
+ }
+ elsif ($outer_aliastypes->{restrict}{$alias}) {
+ push @outer_from, $j;
+ $outer_attrs->{group_by} ||= $outer_select unless $j->[0]{-is_single};
+ }
+ }
+
+ # demote the outer_from head
+ $outer_from[0] = $outer_from[0][0];
+
+ # This is totally horrific - the $where ends up in both the inner and outer query
+ # Unfortunately not much can be done until SQLA2 introspection arrives, and even
+ # then if where conditions apply to the *right* side of the prefetch, you may have
+ # to both filter the inner select (e.g. to apply a limit) and then have to re-filter
+ # the outer select to exclude joins you didin't want in the first place
+ #
+ # OTOH it can be seen as a plus: <ash> (notes that this query would make a DBA cry ;)
+ return (\@outer_from, $outer_select, $where, $outer_attrs);
+}
+
+# Due to a lack of SQLA2 we fall back to crude scans of all the
+# select/where/order/group attributes, in order to determine what
+# aliases are neded to fulfill the query. This information is used
+# throughout the code to prune unnecessary JOINs from the queries
+# in an attempt to reduce the execution time.
+# Although the method is pretty horrific, the worst thing that can
+# happen is for it to fail due to an unqualified column, which in
+# turn will result in a vocal exception. Qualifying the column will
+# invariably solve the problem.
+sub _resolve_aliastypes_from_select_args {
+ my ( $self, $from, $select, $where, $attrs ) = @_;
+
+ $self->throw_exception ('Unable to analyze custom {from}')
+ if ref $from ne 'ARRAY';
+
+ # what we will return
+ my $aliases_by_type;
+
+ # see what aliases are there to work with
+ my $alias_list;
+ for (@$from) {
+ my $j = $_;
+ $j = $j->[0] if ref $j eq 'ARRAY';
+ my $al = $j->{-alias}
+ or next;
+
+ $alias_list->{$al} = $j;
+ $aliases_by_type->{multiplying}{$al} = 1
+ unless $j->{-is_single};
+ }
+
+ # set up a botched SQLA
+ my $sql_maker = $self->sql_maker;
+ my $sep = quotemeta ($self->_sql_maker_opts->{name_sep} || '.');
+ local $sql_maker->{quote_char}; # so that we can regex away
+
+
+ my $select_sql = $sql_maker->_recurse_fields ($select);
+ my $where_sql = $sql_maker->where ($where);
+ my $group_by_sql = $sql_maker->_order_by({
+ map { $_ => $attrs->{$_} } qw/group_by having/
+ });
+ my @order_by_chunks = ($self->_parse_order_by ($attrs->{order_by}) );
+
+ # match every alias to the sql chunks above
+ for my $alias (keys %$alias_list) {
+ my $al_re = qr/\b $alias $sep/x;
+
+ for my $piece ($where_sql, $group_by_sql) {
+ $aliases_by_type->{restrict}{$alias} = 1 if ($piece =~ $al_re);
+ }
+
+ for my $piece ($select_sql, @order_by_chunks ) {
+ $aliases_by_type->{select}{$alias} = 1 if ($piece =~ $al_re);
+ }
+ }
+
+ # Add any non-left joins to the restriction list (such joins are indeed restrictions)
+ for my $j (values %$alias_list) {
+ my $alias = $j->{-alias} or next;
+ $aliases_by_type->{restrict}{$alias} = 1 if (
+ (not $j->{-join_type})
+ or
+ ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
+ );
+ }
+
+ # mark all join parents as mentioned
+ # (e.g. join => { cds => 'tracks' } - tracks will need to bring cds too )
+ for my $type (keys %$aliases_by_type) {
+ for my $alias (keys %{$aliases_by_type->{$type}}) {
+ $aliases_by_type->{$type}{$_} = 1
+ for (map { keys %$_ } @{ $alias_list->{$alias}{-join_path} || [] });
+ }
+ }
+
+ return $aliases_by_type;
+}
+
+sub _resolve_ident_sources {
+ my ($self, $ident) = @_;
+
+ my $alias2source = {};
+ my $rs_alias;
+
+ # the reason this is so contrived is that $ident may be a {from}
+ # structure, specifying multiple tables to join
+ if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
+ # this is compat mode for insert/update/delete which do not deal with aliases
+ $alias2source->{me} = $ident;
+ $rs_alias = 'me';
+ }
+ elsif (ref $ident eq 'ARRAY') {
+
+ for (@$ident) {
+ my $tabinfo;
+ if (ref $_ eq 'HASH') {
+ $tabinfo = $_;
+ $rs_alias = $tabinfo->{-alias};
+ }
+ if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') {
+ $tabinfo = $_->[0];
+ }
+
+ $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-source_handle}->resolve
+ if ($tabinfo->{-source_handle});
+ }
+ }
+
+ return ($alias2source, $rs_alias);
+}
+
+# Takes $ident, \@column_names
+#
+# returns { $column_name => \%column_info, ... }
+# also note: this adds -result_source => $rsrc to the column info
+#
+# If no columns_names are supplied returns info about *all* columns
+# for all sources
+sub _resolve_column_info {
+ my ($self, $ident, $colnames) = @_;
+ my ($alias2src, $root_alias) = $self->_resolve_ident_sources($ident);
+
+ my $sep = $self->_sql_maker_opts->{name_sep} || '.';
+ my $qsep = quotemeta $sep;
+
+ my (%return, %seen_cols, @auto_colnames);
+
+ # compile a global list of column names, to be able to properly
+ # disambiguate unqualified column names (if at all possible)
+ for my $alias (keys %$alias2src) {
+ my $rsrc = $alias2src->{$alias};
+ for my $colname ($rsrc->columns) {
+ push @{$seen_cols{$colname}}, $alias;
+ push @auto_colnames, "$alias$sep$colname" unless $colnames;
+ }
+ }
+
+ $colnames ||= [
+ @auto_colnames,
+ grep { @{$seen_cols{$_}} == 1 } (keys %seen_cols),
+ ];
+
+ COLUMN:
+ foreach my $col (@$colnames) {
+ my ($alias, $colname) = $col =~ m/^ (?: ([^$qsep]+) $qsep)? (.+) $/x;
+
+ unless ($alias) {
+ # see if the column was seen exactly once (so we know which rsrc it came from)
+ if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1) {
+ $alias = $seen_cols{$colname}[0];
+ }
+ else {
+ next COLUMN;
+ }
+ }
+
+ my $rsrc = $alias2src->{$alias};
+ $return{$col} = $rsrc && {
+ %{$rsrc->column_info($colname)},
+ -result_source => $rsrc,
+ -source_alias => $alias,
+ };
+ }
+
+ return \%return;
+}
+
+# The DBIC relationship chaining implementation is pretty simple - every
+# new related_relationship is pushed onto the {from} stack, and the {select}
+# window simply slides further in. This means that when we count somewhere
+# in the middle, we got to make sure that everything in the join chain is an
+# actual inner join, otherwise the count will come back with unpredictable
+# results (a resultset may be generated with _some_ rows regardless of if
+# the relation which the $rs currently selects has rows or not). E.g.
+# $artist_rs->cds->count - normally generates:
+# SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid
+# which actually returns the number of artists * (number of cds || 1)
+#
+# So what we do here is crawl {from}, determine if the current alias is at
+# the top of the stack, and if not - make sure the chain is inner-joined down
+# to the root.
+#
+sub _straight_join_to_node {
+ my ($self, $from, $alias) = @_;
+
+ # subqueries and other oddness are naturally not supported
+ return $from if (
+ ref $from ne 'ARRAY'
+ ||
+ @$from <= 1
+ ||
+ ref $from->[0] ne 'HASH'
+ ||
+ ! $from->[0]{-alias}
+ ||
+ $from->[0]{-alias} eq $alias # this last bit means $alias is the head of $from - nothing to do
+ );
+
+ # find the current $alias in the $from structure
+ my $switch_branch;
+ JOINSCAN:
+ for my $j (@{$from}[1 .. $#$from]) {
+ if ($j->[0]{-alias} eq $alias) {
+ $switch_branch = $j->[0]{-join_path};
+ last JOINSCAN;
+ }
+ }
+
+ # something else went quite wrong
+ return $from unless $switch_branch;
+
+ # So it looks like we will have to switch some stuff around.
+ # local() is useless here as we will be leaving the scope
+ # anyway, and deep cloning is just too fucking expensive
+ # So replace the first hashref in the node arrayref manually
+ my @new_from = ($from->[0]);
+ my $sw_idx = { map { values %$_ => 1 } @$switch_branch };
+
+ for my $j (@{$from}[1 .. $#$from]) {
+ my $jalias = $j->[0]{-alias};
+
+ if ($sw_idx->{$jalias}) {
+ my %attrs = %{$j->[0]};
+ delete $attrs{-join_type};
+ push @new_from, [
+ \%attrs,
+ @{$j}[ 1 .. $#$j ],
+ ];
+ }
+ else {
+ push @new_from, $j;
+ }
+ }
+
+ return \@new_from;
+}
+
+# Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus
+# a condition containing 'me' or other table prefixes will not work
+# at all. What this code tries to do (badly) is introspect the condition
+# and remove all column qualifiers. If it bails out early (returns undef)
+# the calling code should try another approach (e.g. a subquery)
+sub _strip_cond_qualifiers {
+ my ($self, $where) = @_;
+
+ my $cond = {};
+
+ # No-op. No condition, we're updating/deleting everything
+ return $cond unless $where;
+
+ if (ref $where eq 'ARRAY') {
+ $cond = [
+ map {
+ my %hash;
+ foreach my $key (keys %{$_}) {
+ $key =~ /([^.]+)$/;
+ $hash{$1} = $_->{$key};
+ }
+ \%hash;
+ } @$where
+ ];
+ }
+ elsif (ref $where eq 'HASH') {
+ if ( (keys %$where) == 1 && ( (keys %{$where})[0] eq '-and' )) {
+ $cond->{-and} = [];
+ my @cond = @{$where->{-and}};
+ for (my $i = 0; $i < @cond; $i++) {
+ my $entry = $cond[$i];
+ my $hash;
+ my $ref = ref $entry;
+ if ($ref eq 'HASH' or $ref eq 'ARRAY') {
+ $hash = $self->_strip_cond_qualifiers($entry);
+ }
+ elsif (! $ref) {
+ $entry =~ /([^.]+)$/;
+ $hash->{$1} = $cond[++$i];
+ }
+ else {
+ $self->throw_exception ("_strip_cond_qualifiers() is unable to handle a condition reftype $ref");
+ }
+ push @{$cond->{-and}}, $hash;
+ }
+ }
+ else {
+ foreach my $key (keys %$where) {
+ $key =~ /([^.]+)$/;
+ $cond->{$1} = $where->{$key};
+ }
+ }
+ }
+ else {
+ return undef;
+ }
+
+ return $cond;
+}
+
+sub _parse_order_by {
+ my ($self, $order_by) = @_;
+
+ return scalar $self->sql_maker->_order_by_chunks ($order_by)
+ unless wantarray;
+
+ my $sql_maker = $self->sql_maker;
+ local $sql_maker->{quote_char}; #disable quoting
+ my @chunks;
+ for my $chunk (map { ref $_ ? @$_ : $_ } ($sql_maker->_order_by_chunks ($order_by) ) ) {
+ $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+ push @chunks, $chunk;
+ }
+
+ return @chunks;
+}
+
+1;
use warnings;
use base qw/DBIx::Class/;
-BEGIN {
-
- # Perl 5.8.0 doesn't have utf8::is_utf8()
- # Yes, 5.8.0 support for Unicode is suboptimal, but things like RHEL3 ship with it.
- if ($] <= 5.008000) {
- require Encode;
- } else {
- require utf8;
- }
-}
-
__PACKAGE__->mk_classdata( '_utf8_columns' );
=head1 NAME
=head1 SYNOPSIS
package Artist;
- __PACKAGE__->load_components(qw/UTF8Columns Core/);
+ use base 'DBIx::Class::Core';
+
+ __PACKAGE__->load_components(qw/UTF8Columns/);
__PACKAGE__->utf8_columns(qw/name description/);
# then belows return strings with utf8 flag
This module allows you to get columns data that have utf8 (Unicode) flag.
+=head2 Warning
+
+Note that this module overloads L<DBIx::Class::Row/store_column> in a way
+that may prevent other components overloading the same method from working
+correctly. This component must be the last one before L<DBIx::Class::Row>
+(which is provided by L<DBIx::Class::Core>). DBIx::Class will detect such
+incorrect component order and issue an appropriate warning, advising which
+components need to be loaded differently.
+
=head1 SEE ALSO
L<Template::Stash::ForceUTF8>, L<DBIx::Class::UUIDColumns>.
foreach my $col (@_) {
$self->throw_exception("column $col doesn't exist")
unless $self->has_column($col);
- }
+ }
return $self->_utf8_columns({ map { $_ => 1 } @_ });
} else {
return $self->_utf8_columns;
my ( $self, $column ) = @_;
my $value = $self->next::method($column);
- my $cols = $self->_utf8_columns;
- if ( $cols and defined $value and $cols->{$column} ) {
+ utf8::decode($value) if (
+ defined $value and $self->_is_utf8_column($column) and ! utf8::is_utf8($value)
+ );
- if ($] <= 5.008000) {
- Encode::_utf8_on($value) unless Encode::is_utf8($value);
- } else {
- utf8::decode($value) unless utf8::is_utf8($value);
- }
- }
-
- $value;
+ return $value;
}
=head2 get_columns
my $self = shift;
my %data = $self->next::method(@_);
- foreach my $col (grep { defined $data{$_} } keys %{ $self->_utf8_columns || {} }) {
-
- if ($] <= 5.008000) {
- Encode::_utf8_on($data{$col}) unless Encode::is_utf8($data{$col});
- } else {
- utf8::decode($data{$col}) unless utf8::is_utf8($data{$col});
- }
+ foreach my $col (keys %data) {
+ utf8::decode($data{$col}) if (
+ exists $data{$col} and defined $data{$col} and $self->_is_utf8_column($col) and ! utf8::is_utf8($data{$col})
+ );
}
- %data;
+ return %data;
}
=head2 store_column
sub store_column {
my ( $self, $column, $value ) = @_;
- my $cols = $self->_utf8_columns;
- if ( $cols and defined $value and $cols->{$column} ) {
+ # the dirtyness comparison must happen on the non-encoded value
+ my $copy;
- if ($] <= 5.008000) {
- Encode::_utf8_off($value) if Encode::is_utf8($value);
- } else {
- utf8::encode($value) if utf8::is_utf8($value);
- }
+ if ( defined $value and $self->_is_utf8_column($column) and utf8::is_utf8($value) ) {
+ $copy = $value;
+ utf8::encode($value);
}
$self->next::method( $column, $value );
+
+ return $copy || $value;
}
-=head1 AUTHOR
+# override this if you want to force everything to be encoded/decoded
+sub _is_utf8_column {
+ # my ($self, $col) = @_;
+ return ($_[0]->utf8_columns || {})->{$_[1]};
+}
-Daisuke Murase <typester@cpan.org>
+=head1 AUTHORS
-=head1 COPYRIGHT
+See L<DBIx::Class/CONTRIBUTORS>.
-This program is free software; you can redistribute
-it and/or modify it under the same terms as Perl itself.
+=head1 LICENSE
-The full text of the license can be found in the
-LICENSE file included with this module.
+You may distribute this code under the same terms as Perl itself.
=cut
1;
-
use Exporter;
use SQL::Translator::Utils qw(debug normalize_name);
use Carp::Clan qw/^SQL::Translator|^DBIx::Class/;
+use Scalar::Util ();
use base qw(Exporter);
# We're working with DBIx::Class Schemas, not data streams.
# -------------------------------------------------------------------
sub parse {
+ # this is a hack to prevent schema leaks due to a retarded SQLT implementation
+ # DO NOT REMOVE (until SQLT2 is out, the all of this will be rewritten anyway)
+ Scalar::Util::weaken ($_[1]);
+
my ($tr, $data) = @_;
my $args = $tr->parser_args;
my $dbicschema = $args->{'DBIx::Class::Schema'} || $args->{"DBIx::Schema"} ||$data;
}
- my(@table_monikers, @view_monikers);
+ my(%table_monikers, %view_monikers);
for my $moniker (@monikers){
my $source = $dbicschema->source($moniker);
if ( $source->isa('DBIx::Class::ResultSource::Table') ) {
- push(@table_monikers, $moniker);
+ $table_monikers{$moniker}++;
} elsif( $source->isa('DBIx::Class::ResultSource::View') ){
next if $source->is_virtual;
- push(@view_monikers, $moniker);
+ $view_monikers{$moniker}++;
}
}
my %tables;
- foreach my $moniker (sort @table_monikers)
+ foreach my $moniker (sort keys %table_monikers)
{
my $source = $dbicschema->source($moniker);
my $table_name = $source->name;
# support quoting properly to be signaled about this
$table_name = $$table_name if ref $table_name eq 'SCALAR';
- # Its possible to have multiple DBIC sources using the same table
+ # It's possible to have multiple DBIC sources using the same table
next if $tables{$table_name};
$tables{$table_name}{source} = $source;
my $f = $table->add_field(%colinfo)
|| $dbicschema->throw_exception ($table->error);
}
- $table->primary_key($source->primary_columns);
my @primary = $source->primary_columns;
+
+ $table->primary_key(@primary) if @primary;
+
my %unique_constraints = $source->unique_constraints;
foreach my $uniq (sort keys %unique_constraints) {
if (!$source->_compare_relationship_keys($unique_constraints{$uniq}, \@primary)) {
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;
+ my $add_fk_index = (exists $args->{add_fk_index} && ! $args->{add_fk_index}) ? 0 : 1;
foreach my $rel (sort @rels)
{
+
my $rel_info = $source->relationship_info($rel);
# Ignore any rel cond that isn't a straight hash
next unless ref $rel_info->{cond} eq 'HASH';
- my $othertable = $source->related_source($rel);
- my $rel_table = $othertable->name;
+ my $relsource = $source->related_source($rel);
+
+ # related sources might be excluded via a {sources} filter or might be views
+ next unless exists $table_monikers{$relsource->source_name};
+
+ my $rel_table = $relsource->name;
# FIXME - this isn't the right way to do it, but sqlt does not
# support quoting properly to be signaled about this
# Force the order of @cond to match the order of ->add_columns
my $idx;
- my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $othertable->columns;
+ my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $relsource->columns;
my @cond = sort { $other_columns_idx{$a} cmp $other_columns_idx{$b} } keys(%{$rel_info->{cond}});
# Get the key information, mapping off the foreign/self markers
}
}
- if($rel_table)
- {
+ if($rel_table) {
# Constraints are added only if applicable
next unless $fk_constraint;
# Make sure we dont create the same foreign key constraint twice
- my $key_test = join("\x00", @keys);
+ my $key_test = join("\x00", sort @keys);
next if $created_FK_rels{$rel_table}->{$key_test};
if (scalar(@keys)) {
-
$created_FK_rels{$rel_table}->{$key_test} = 1;
my $is_deferrable = $rel_info->{attrs}{is_deferrable};
- # do not consider deferrable constraints and self-references
- # for dependency calculations
+ # calculate dependencies: do not consider deferrable constraints and
+ # self-references for dependency calculations
if (! $is_deferrable and $rel_table ne $table_name) {
$tables{$table_name}{foreign_table_deps}{$rel_table}++;
}
$table->add_constraint(
- type => 'foreign_key',
- name => join('_', $table_name, 'fk', @keys),
- fields => \@keys,
- reference_fields => \@refkeys,
- reference_table => $rel_table,
- on_delete => uc ($cascade->{delete} || ''),
- on_update => uc ($cascade->{update} || ''),
- (defined $is_deferrable ? ( deferrable => $is_deferrable ) : ()),
+ type => 'foreign_key',
+ name => join('_', $table_name, 'fk', @keys),
+ fields => \@keys,
+ reference_fields => \@refkeys,
+ reference_table => $rel_table,
+ on_delete => uc ($cascade->{delete} || ''),
+ on_update => uc ($cascade->{update} || ''),
+ (defined $is_deferrable ? ( deferrable => $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;
+ # Check that we do not create an index identical to the PK index
+ # (some RDBMS croak on this, and it generally doesn't make much sense)
+ # NOTE: we do not sort the key columns because the order of
+ # columns is important for indexes and two indexes with the
+ # same cols but different order are allowed and sometimes
+ # needed
+ next if join("\x00", @keys) eq join("\x00", @primary);
+
if ($add_fk_index_rel) {
my $index = $table->add_index(
- name => join('_', $table_name, 'idx', @keys),
- fields => \@keys,
- type => 'NORMAL',
- );
+ name => join('_', $table_name, 'idx', @keys),
+ fields => \@keys,
+ type => 'NORMAL',
+ );
}
}
}
}
my %views;
- foreach my $moniker (sort @view_monikers)
+ foreach my $moniker (sort keys %view_monikers)
{
my $source = $dbicschema->source($moniker);
my $view_name = $source->name;
# Its possible to have multiple DBIC source using same table
next if $views{$view_name}++;
+ $dbicschema->throw_exception ("view $view_name is missing a view_definition")
+ unless $source->view_definition;
+
my $view = $schema->add_view (
name => $view_name,
fields => [ $source->columns ],
my $schema = MyApp::Schema->connect;
my $trans = SQL::Translator->new (
parser => 'SQL::Translator::Parser::DBIx::Class',
- parser_args => { package => $schema },
+ parser_args => {
+ package => $schema,
+ add_fk_index => 0,
+ sources => [qw/
+ Artist
+ CD
+ /],
+ },
producer => 'SQLite',
) or die SQL::Translator->error;
my $out = $trans->translate() or die $trans->error;
have SQL::Translator installed. To do this see
L<DBIx::Class::Schema/create_ddl_dir>.
+=head1 PARSER OPTIONS
+
+=head2 add_fk_index
+
+Create an index for each foreign key.
+Enabled by default, as having indexed foreign key columns is normally the
+sensible thing to do.
+
+=head2 sources
+
+=over 4
+
+=item Arguments: \@class_names
+
+=back
+
+Limit the amount of parsed sources by supplying an explicit list of source names.
+
=head1 SEE ALSO
L<SQL::Translator>, L<DBIx::Class::Schema>
=head1 AUTHORS
-Jess Robinson
+See L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
-Matt S Trout
+You may distribute this code under the same terms as Perl itself.
-Ash Berlin
+=cut
use SQL::Translator;
my $schema = DBICTest::Schema->connect;
-print scalar ($schema->storage->deployment_statements($schema, 'SQLite'));
+print scalar ($schema->storage->deployment_statements(
+ $schema,
+ 'SQLite',
+ undef,
+ undef,
+ { producer_args => { no_transaction => 1 } }
+));
use XML::Parser;
my %month = qw(
- Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06
- Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12
+ Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06
+ Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12
);
$Text::Wrap::huge = "wrap";
GetOptions(
"age=s" => \$days_back,
"repo=s" => \$svn_repo,
- "help" => \$send_help,
+ "help" => \$send_help,
) or exit;
# Find the trunk for the current repository if one isn't specified.
unless (defined $svn_repo) {
- $svn_repo = `svn info . | grep '^URL: '`;
- if (length $svn_repo) {
- chomp $svn_repo;
- $svn_repo =~ s{^URL\:\s+(.+?)/trunk/?.*$}{$1};
- }
- else {
- $send_help = 1;
- }
+ $svn_repo = `svn info . | grep '^URL: '`;
+ if (length $svn_repo) {
+ chomp $svn_repo;
+ $svn_repo =~ s{^URL\:\s+(.+?)/trunk/?.*$}{$1};
+ }
+ else {
+ $send_help = 1;
+ }
}
die(
- "$0 usage:\n",
- " --repo REPOSITORY\n",
- " [--age DAYS]\n",
- "\n",
- "REPOSITORY must have a trunk subdirectory and a tags directory where\n",
- "release tags are kept.\n",
+ "$0 usage:\n",
+ " --repo REPOSITORY\n",
+ " [--age DAYS]\n",
+ "\n",
+ "REPOSITORY must have a trunk subdirectory and a tags directory where\n",
+ "release tags are kept.\n",
) if $send_help;
my $earliest_date = strftime "%F", gmtime(time() - $days_back * 86400);
open(TAG, "svn -v list $svn_repo/tags|") or die $!;
while (<TAG>) {
- # The date is unused, however.
- next unless (
- my ($rev, $date, $tag) = m{
- (\d+).*?(\S\S\S\s+\d\d\s+(?:\d\d\d\d|\d\d:\d\d))\s+(v[0-9_.]+)
- }x
- );
-
- my @tag_log = gather_log("$svn_repo/tags/$tag", "--stop-on-copy");
- die "Tag $tag has changes after tagging!\n" if @tag_log > 1;
-
- my $timestamp = $tag_log[0][LOG_DATE];
- $tag{$timestamp} = [
- $rev, # TAG_REV
- $tag, # TAG_TAG
- [ ], # TAG_LOG
- ];
+ # The date is unused, however.
+ next unless (
+ my ($rev, $date, $tag) = m{
+ (\d+).*?(\S\S\S\s+\d\d\s+(?:\d\d\d\d|\d\d:\d\d))\s+(v[0-9_.]+)
+ }x
+ );
+
+ my @tag_log = gather_log("$svn_repo/tags/$tag", "--stop-on-copy");
+ die "Tag $tag has changes after tagging!\n" if @tag_log > 1;
+
+ my $timestamp = $tag_log[0][LOG_DATE];
+ $tag{$timestamp} = [
+ $rev, # TAG_REV
+ $tag, # TAG_TAG
+ [ ], # TAG_LOG
+ ];
}
close TAG;
# Fictitious "HEAD" tag for revisions that came after the last tag.
$tag{+MAX_TIMESTAMP} = [
- "HEAD", # TAG_REV
- "(untagged)", # TAG_TAG
- undef, # TAG_LOG
+ "HEAD", # TAG_REV
+ "(untagged)", # TAG_TAG
+ undef, # TAG_LOG
];
### 2. Gather the log for the trunk. Place log entries under their
my @tag_dates = sort keys %tag;
while (my $date = pop(@tag_dates)) {
- # We're done if this date's before our earliest date.
- if ($date lt $earliest_date) {
- delete $tag{$date};
- next;
- }
+ # We're done if this date's before our earliest date.
+ if ($date lt $earliest_date) {
+ delete $tag{$date};
+ next;
+ }
- my $tag = $tag{$date}[TAG_TAG];
- #warn "Gathering information for tag $tag...\n";
+ my $tag = $tag{$date}[TAG_TAG];
+ #warn "Gathering information for tag $tag...\n";
- my $this_rev = $tag{$date}[TAG_REV];
- my $prev_rev;
- if (@tag_dates) {
- $prev_rev = $tag{$tag_dates[-1]}[TAG_REV];
- }
- else {
- $prev_rev = 0;
- }
+ my $this_rev = $tag{$date}[TAG_REV];
+ my $prev_rev;
+ if (@tag_dates) {
+ $prev_rev = $tag{$tag_dates[-1]}[TAG_REV];
+ }
+ else {
+ $prev_rev = 0;
+ }
- my @log = gather_log("$svn_repo/trunk", "-r", "$this_rev:$prev_rev");
+ my @log = gather_log("$svn_repo/trunk", "-r", "$this_rev:$prev_rev");
- $tag{$date}[TAG_LOG] = \@log;
+ $tag{$date}[TAG_LOG] = \@log;
}
### 3. PROFIT! No, wait... generate the nice log file.
foreach my $timestamp (sort { $b cmp $a } keys %tag) {
- my $tag_rec = $tag{$timestamp};
-
- # Skip this tag if there are no log entries.
- next unless @{$tag_rec->[TAG_LOG]};
-
- my $tag_line = "$timestamp $tag_rec->[TAG_TAG]";
- my $tag_bar = "=" x length($tag_line);
- print $tag_bar, "\n", $tag_line, "\n", $tag_bar, "\n\n";
-
- foreach my $log_rec (@{$tag_rec->[TAG_LOG]}) {
-
- my @paths = @{$log_rec->[LOG_PATHS]};
- if (@paths > 1) {
- @paths = grep {
- $_->[PATH_PATH] ne "/trunk" or $_->[PATH_ACTION] ne "M"
- } @paths;
- }
-
- my $time_line = wrap(
- " ", " ",
- join(
- "; ",
- "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]",
- map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
- )
- );
-
- if ($time_line =~ /\n/) {
- $time_line = wrap(
- " ", " ",
- "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]\n"
- ) .
- wrap(
- " ", " ",
- join(
- "; ",
- map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
- )
- );
- }
-
- print $time_line, "\n\n";
-
- # Blank lines should have the indent level of whitespace. This
- # makes it easier for other utilities to parse them.
-
- my @paragraphs = split /\n\s*\n/, $log_rec->[LOG_MESSAGE];
- foreach my $paragraph (@paragraphs) {
-
- # Trim off identical leading space from every line.
- my ($whitespace) = $paragraph =~ /^(\s*)/;
- if (length $whitespace) {
- $paragraph =~ s/^$whitespace//mg;
- }
-
- # Re-flow the paragraph if it isn't indented from the norm.
- # This should preserve indented quoted text, wiki-style.
- unless ($paragraph =~ /^\s/) {
- $paragraph = fill(" ", " ", $paragraph);
- }
- }
-
- print join("\n \n", @paragraphs), "\n\n";
- }
+ my $tag_rec = $tag{$timestamp};
+
+ # Skip this tag if there are no log entries.
+ next unless @{$tag_rec->[TAG_LOG]};
+
+ my $tag_line = "$timestamp $tag_rec->[TAG_TAG]";
+ my $tag_bar = "=" x length($tag_line);
+ print $tag_bar, "\n", $tag_line, "\n", $tag_bar, "\n\n";
+
+ foreach my $log_rec (@{$tag_rec->[TAG_LOG]}) {
+
+ my @paths = @{$log_rec->[LOG_PATHS]};
+ if (@paths > 1) {
+ @paths = grep {
+ $_->[PATH_PATH] ne "/trunk" or $_->[PATH_ACTION] ne "M"
+ } @paths;
+ }
+
+ my $time_line = wrap(
+ " ", " ",
+ join(
+ "; ",
+ "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]",
+ map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
+ )
+ );
+
+ if ($time_line =~ /\n/) {
+ $time_line = wrap(
+ " ", " ",
+ "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]\n"
+ ) .
+ wrap(
+ " ", " ",
+ join(
+ "; ",
+ map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
+ )
+ );
+ }
+
+ print $time_line, "\n\n";
+
+ # Blank lines should have the indent level of whitespace. This
+ # makes it easier for other utilities to parse them.
+
+ my @paragraphs = split /\n\s*\n/, $log_rec->[LOG_MESSAGE];
+ foreach my $paragraph (@paragraphs) {
+
+ # Trim off identical leading space from every line.
+ my ($whitespace) = $paragraph =~ /^(\s*)/;
+ if (length $whitespace) {
+ $paragraph =~ s/^$whitespace//mg;
+ }
+
+ # Re-flow the paragraph if it isn't indented from the norm.
+ # This should preserve indented quoted text, wiki-style.
+ unless ($paragraph =~ /^\s/) {
+ $paragraph = fill(" ", " ", $paragraph);
+ }
+ }
+
+ print join("\n \n", @paragraphs), "\n\n";
+ }
}
print(
- "==============\n",
- "End of Excerpt\n",
- "==============\n",
+ "==============\n",
+ "End of Excerpt\n",
+ "==============\n",
);
### Z. Helper functions.
sub gather_log {
- my ($url, @flags) = @_;
-
- my (@log, @stack);
-
- my $parser = XML::Parser->new(
- Handlers => {
- Start => sub {
- my ($self, $tag, %att) = @_;
- push @stack, [ $tag, \%att ];
- if ($tag eq "logentry") {
- push @log, [ ];
- $log[-1][LOG_WHO] = "(nobody)";
- }
- },
- Char => sub {
- my ($self, $text) = @_;
- $stack[-1][1]{0} .= $text;
- },
- End => sub {
- my ($self, $tag) = @_;
- die "close $tag w/out open" unless @stack;
- my ($pop_tag, $att) = @{pop @stack};
-
- die "$tag ne $pop_tag" if $tag ne $pop_tag;
-
- if ($tag eq "date") {
- my $timestamp = $att->{0};
- my ($date, $time) = split /[T.]/, $timestamp;
- $log[-1][LOG_DATE] = "$date $time";
- return;
- }
-
- if ($tag eq "logentry") {
- $log[-1][LOG_REV] = $att->{revision};
- return;
- }
-
- if ($tag eq "msg") {
- $log[-1][LOG_MESSAGE] = $att->{0};
- return;
- }
-
- if ($tag eq "author") {
- $log[-1][LOG_WHO] = $att->{0};
- return;
- }
-
- if ($tag eq "path") {
- my $path = $att->{0};
- $path =~ s{^/trunk/}{};
- push(
- @{$log[-1][LOG_PATHS]}, [
- $path, # PATH_PATH
- $att->{action}, # PATH_ACTION
- ]
- );
-
- $log[-1][LOG_PATHS][-1][PATH_CPF_PATH] = $att->{"copyfrom-path"} if (
- exists $att->{"copyfrom-path"}
- );
-
- $log[-1][LOG_PATHS][-1][PATH_CPF_REV] = $att->{"copyfrom-rev"} if (
- exists $att->{"copyfrom-rev"}
- );
- return;
- }
-
- }
- }
- );
-
- my $cmd = "svn -v --xml @flags log $url";
- #warn "Command: $cmd\n";
-
- open(LOG, "$cmd|") or die $!;
- $parser->parse(*LOG);
- close LOG;
-
- return @log;
+ my ($url, @flags) = @_;
+
+ my (@log, @stack);
+
+ my $parser = XML::Parser->new(
+ Handlers => {
+ Start => sub {
+ my ($self, $tag, %att) = @_;
+ push @stack, [ $tag, \%att ];
+ if ($tag eq "logentry") {
+ push @log, [ ];
+ $log[-1][LOG_WHO] = "(nobody)";
+ }
+ },
+ Char => sub {
+ my ($self, $text) = @_;
+ $stack[-1][1]{0} .= $text;
+ },
+ End => sub {
+ my ($self, $tag) = @_;
+ die "close $tag w/out open" unless @stack;
+ my ($pop_tag, $att) = @{pop @stack};
+
+ die "$tag ne $pop_tag" if $tag ne $pop_tag;
+
+ if ($tag eq "date") {
+ my $timestamp = $att->{0};
+ my ($date, $time) = split /[T.]/, $timestamp;
+ $log[-1][LOG_DATE] = "$date $time";
+ return;
+ }
+
+ if ($tag eq "logentry") {
+ $log[-1][LOG_REV] = $att->{revision};
+ return;
+ }
+
+ if ($tag eq "msg") {
+ $log[-1][LOG_MESSAGE] = $att->{0};
+ return;
+ }
+
+ if ($tag eq "author") {
+ $log[-1][LOG_WHO] = $att->{0};
+ return;
+ }
+
+ if ($tag eq "path") {
+ my $path = $att->{0};
+ $path =~ s{^/trunk/}{};
+ push(
+ @{$log[-1][LOG_PATHS]}, [
+ $path, # PATH_PATH
+ $att->{action}, # PATH_ACTION
+ ]
+ );
+
+ $log[-1][LOG_PATHS][-1][PATH_CPF_PATH] = $att->{"copyfrom-path"} if (
+ exists $att->{"copyfrom-path"}
+ );
+
+ $log[-1][LOG_PATHS][-1][PATH_CPF_REV] = $att->{"copyfrom-rev"} if (
+ exists $att->{"copyfrom-rev"}
+ );
+ return;
+ }
+
+ }
+ }
+ );
+
+ my $cmd = "svn -v --xml @flags log $url";
+ #warn "Command: $cmd\n";
+
+ open(LOG, "$cmd|") or die $!;
+ $parser->parse(*LOG);
+ close LOG;
+
+ return @log;
}
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use lib 't/lib';
+use DBICTest;
+
+my @MODULES = (
+ 'Test::NoTabs 0.9',
+);
+
+plan skip_all => 'Does not work with done_testing, temp disabled';
+
+# Don't run tests for installs
+unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
+ plan( skip_all => "Author tests not required for installation" );
+}
+# Load the testing modules
+foreach my $MODULE ( @MODULES ) {
+ eval "use $MODULE";
+ if ( $@ ) {
+ $ENV{RELEASE_TESTING}
+ ? die( "Failed to load required release-testing module $MODULE" )
+ : plan( skip_all => "$MODULE not available for testing" );
+ }
+}
+
+all_perl_files_ok(qw/t lib script maint/);
+
+done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use lib 't/lib';
+use DBICTest;
+
+my @MODULES = (
+ 'Test::EOL 0.6',
+);
+
+plan skip_all => 'Does not work with done_testing, temp disabled';
+
+# Don't run tests for installs
+unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
+ plan( skip_all => "Author tests not required for installation" );
+}
+# Load the testing modules
+foreach my $MODULE ( @MODULES ) {
+ eval "use $MODULE";
+ if ( $@ ) {
+ $ENV{RELEASE_TESTING}
+ ? die( "Failed to load required release-testing module $MODULE" )
+ : plan( skip_all => "$MODULE not available for testing" );
+ }
+}
+
+TODO: {
+ local $TODO = 'Do not fix those yet - we have way too many branches out there, merging will be hell';
+ all_perl_files_ok({ trailing_whitespace => 1}, qw/t lib script maint/);
+}
+
+done_testing;
ok ($row, "Stringification test row '$_' properly inserted");
}
+lives_ok {
+ $schema->resultset('TwoKeys')->populate([{
+ artist => 1,
+ cd => 5,
+ fourkeys_to_twokeys => [{
+ f_foo => 1,
+ f_bar => 1,
+ f_hello => 1,
+ f_goodbye => 1,
+ autopilot => 'a',
+ },{
+ f_foo => 2,
+ f_bar => 2,
+ f_hello => 2,
+ f_goodbye => 2,
+ autopilot => 'b',
+ }]
+ }])
+} 'multicol-PK has_many populate works';
+
done_testing;
use lib qw(t/lib);
use DBICTest;
-plan tests => 142;
-
## ----------------------------------------------------------------------------
## 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');
+my $schema = DBICTest->init_schema();
+my $art_rs = $schema->resultset('Artist');
+my $cd_rs = $schema->resultset('CD');
+
+my $restricted_art_rs = $art_rs->search({rank => 42});
ok( $schema, 'Got a Schema object');
ok( $art_rs, 'Got Good Artist Resultset');
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;
+ ## 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: {
- ## 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");
- }
+ ## 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'});
+
+ 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");
+ }
+
+ WITH_COND_FROM_RS: {
+
+ my ($more_crap) = $restricted_art_rs->populate([
+ {
+ name => 'More Manufactured Crap',
+ },
+ ]);
+
+ ## Did it use the condition in the resultset?
+ cmp_ok( $more_crap->rank, '==', 42, "Got Correct rank for result object");
+ }
}
VOID_CONTEXT: {
- ## All these tests check the ability to use populate without asking for
- ## 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");
- }
-
+ ## 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");
+ }
+
+ WITH_COND_FROM_RS: {
+
+ $restricted_art_rs->populate([
+ {
+ name => 'VOID More Manufactured Crap',
+ },
+ ]);
+
+ my $more_crap = $art_rs->search({
+ name => 'VOID More Manufactured Crap'
+ })->first;
+
+ ## Did it use the condition in the resultset?
+ cmp_ok( $more_crap->rank, '==', 42, "Got Correct rank for result object");
+ }
}
ARRAYREF_OF_ARRAYREF_STYLE: {
[1001, 'A singer that jumped the shark two albums ago'],
[1002, 'An actually cool singer.'],
]);
-
+
ok my $unknown = $art_rs->find(1000), "got Unknown";
ok my $jumped = $art_rs->find(1001), "got Jumped";
ok my $cool = $art_rs->find(1002), "got Cool";
-
+
is $unknown->name, 'A Formally Unknown Singer', 'Correct Name';
is $jumped->name, 'A singer that jumped the shark two albums ago', 'Correct Name';
is $cool->name, 'An actually cool singer.', 'Correct Name';
-
- my ($cooler, $lamer) = $art_rs->populate([
+
+ my ($cooler, $lamer) = $restricted_art_rs->populate([
[qw/artistid name/],
[1003, 'Cooler'],
- [1004, 'Lamer'],
+ [1004, 'Lamer'],
]);
-
+
is $cooler->name, 'Cooler', 'Correct Name';
is $lamer->name, 'Lamer', 'Correct Name';
-}
\ No newline at end of file
+
+ cmp_ok $cooler->rank, '==', 42, 'Correct Rank';
+
+ ARRAY_CONTEXT_WITH_COND_FROM_RS: {
+
+ my ($mega_lamer) = $restricted_art_rs->populate([
+ {
+ name => 'Mega Lamer',
+ },
+ ]);
+
+ ## Did it use the condition in the resultset?
+ cmp_ok( $mega_lamer->rank, '==', 42, "Got Correct rank for result object");
+ }
+
+ VOID_CONTEXT_WITH_COND_FROM_RS: {
+
+ $restricted_art_rs->populate([
+ {
+ name => 'VOID Mega Lamer',
+ },
+ ]);
+
+ my $mega_lamer = $art_rs->search({
+ name => 'VOID Mega Lamer'
+ })->first;
+
+ ## Did it use the condition in the resultset?
+ cmp_ok( $mega_lamer->rank, '==', 42, "Got Correct rank for result object");
+ }
+}
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
my $schema = DBICTest->init_schema();
-plan tests => 2;
-
## Real view
my $cds_rs_2000 = $schema->resultset('CD')->search( { year => 2000 });
my $year2kcds_rs = $schema->resultset('Year2000CDs');
is($cds_rs_1999->count, $year1999cds_rs->count, 'View Year1999CDs sees all CDs in year 1999');
+# Test if relationships work correctly
+is_deeply (
+ [
+ $schema->resultset('Year1999CDs')->search (
+ {},
+ {
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ],
+ },
+ )->all
+ ],
+ [
+ $schema->resultset('CD')->search (
+ { 'me.year' => '1999'},
+ {
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ],
+ columns => [qw/cdid single_track title/], # to match the columns retrieved by the virtview
+ },
+ )->all
+ ],
+ 'Prefetch over virtual view gives expected result',
+);
+is_deeply (
+ [
+ $schema->resultset('Year2000CDs')->search (
+ {},
+ {
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ],
+ },
+ )->all
+ ],
+ [
+ $schema->resultset('CD')->search (
+ { 'me.year' => '2000'},
+ {
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ],
+ },
+ )->all
+ ],
+ 'Prefetch over regular view gives expected result',
+);
+done_testing;
-#!/usr/bin/perl
+use warnings;
+use strict;
-use Test::More tests => 1;
+use Test::More;
+use Test::Exception;
-eval {
- package BuggyTable;
- use base 'DBIx::Class';
+throws_ok (
+ sub {
+ package BuggyTable;
+ use base 'DBIx::Class::Core';
- __PACKAGE__->load_components qw/Core/;
- __PACKAGE__->table('buggy_table');
- __PACKAGE__->columns qw/this doesnt work as expected/;
-};
+ __PACKAGE__->table('buggy_table');
+ __PACKAGE__->columns qw/this doesnt work as expected/;
+ },
+ qr/\bcolumns\(\) is a read-only/,
+ 'columns() error when apparently misused',
+);
-like($@,qr/\bcolumns\(\) is a read-only/,
- "columns() error when apparently misused");
+done_testing;
use strict;
use Test::More;
-use IO::File;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1;
BEGIN {
plan skip_all => 'Your perl does not support ithreads'
- if !$Config{useithreads} || $] < 5.008;
+ if !$Config{useithreads};
}
use threads;
BEGIN {
plan skip_all => 'Your perl does not support ithreads'
- if !$Config{useithreads} || $] < 5.008;
+ if !$Config{useithreads};
}
use threads;
eval { require Test::Memory::Cycle; require Devel::Cycle };
if ($@ or Devel::Cycle->VERSION < 1.10) {
plan skip_all => "leak test needs Test::Memory::Cycle and Devel::Cycle >= 1.10";
- } else {
- plan tests => 1;
- }
+ };
}
use DBICTest;
use DBICTest::Schema;
+use Scalar::Util ();
import Test::Memory::Cycle;
-my $s = DBICTest::Schema->clone;
+my $weak;
-memory_cycle_ok($s, 'No cycles in schema');
+{
+ my $s = $weak->{schema} = DBICTest->init_schema;
+ memory_cycle_ok($s, 'No cycles in schema');
+
+ my $rs = $weak->{resultset} = $s->resultset ('Artist');
+ memory_cycle_ok($rs, 'No cycles in resultset');
+
+ my $rsrc = $weak->{resultsource} = $rs->result_source;
+ memory_cycle_ok($rsrc, 'No cycles in resultsource');
+
+ my $row = $weak->{row} = $rs->first;
+ memory_cycle_ok($row, 'No cycles in row');
+
+ Scalar::Util::weaken ($_) for values %$weak;
+ memory_cycle_ok($weak, 'No cycles in weak object collection');
+}
+
+for (keys %$weak) {
+ ok (! $weak->{$_}, "No $_ leaks");
+}
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
is(@art, 2, 'And then there were two');
-ok(!$art->in_storage, "It knows it's dead");
+is($art->in_storage, 0, "It knows it's dead");
dies_ok ( sub { $art->delete }, "Can't delete twice");
{
ok(my $artist = $schema->resultset('Artist')->create({name => 'store_column test'}));
is($artist->name, 'X store_column test'); # used to be 'X X store...'
-
+
# call store_column even though the column doesn't seem to be dirty
- ok($artist->update({name => 'X store_column test'}));
+ $artist->name($artist->name);
is($artist->name, 'X X store_column test');
+ ok($artist->is_column_changed('name'), 'changed column marked as dirty');
+
$artist->delete;
}
});
is($new_obj->name, 'find_or_new', 'find_or_new: instantiated a new artist');
- ok(! $new_obj->in_storage, 'new artist is not in storage');
+ is($new_obj->in_storage, 0, 'new artist is not in storage');
}
my $cd = $schema->resultset("CD")->find(1);
# make sure we got rid of the compat shims
SKIP: {
- skip "Remove in 0.09", 5 if $DBIx::Class::VERSION < 0.09;
+ skip "Remove in 0.082", 3 if $DBIx::Class::VERSION < 0.082;
- for (qw/compare_relationship_keys pk_depends_on resolve_condition resolve_join resolve_prefetch/) {
+ for (qw/compare_relationship_keys pk_depends_on resolve_condition/) {
ok (! DBIx::Class::ResultSource->can ($_), "$_ no longer provided by DBIx::Class::ResultSource");
}
}
$dbh->do("DROP TABLE IF EXISTS cd;");
-$dbh->do("CREATE TABLE cd (cdid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, artist INTEGER, title TEXT, year INTEGER, genreid INTEGER, single_track INTEGER);");
+$dbh->do("CREATE TABLE cd (cdid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, artist INTEGER, title TEXT, year DATE, genreid INTEGER, single_track INTEGER);");
$dbh->do("DROP TABLE IF EXISTS producer;");
my $type_info = $schema->storage->columns_info_for('artist');
is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
-
-
}
my $cd = $schema->resultset ('CD')->create ({});
=> 'Nothing Found!';
}
+# check for proper grouped counts
+{
+ my $ansi_schema = DBICTest::Schema->connect ($dsn, $user, $pass, { on_connect_call => 'set_strict_mode' });
+ my $rs = $ansi_schema->resultset('CD');
+
+ my $years;
+ $years->{$_->year|| scalar keys %$years}++ for $rs->all; # NULL != NULL, thus the keys eval
+
+ lives_ok ( sub {
+ is (
+ $rs->search ({}, { group_by => 'year'})->count,
+ scalar keys %$years,
+ 'grouped count correct',
+ );
+ }, 'Grouped count does not throw');
+}
+
+ZEROINSEARCH: {
+ my $cds_per_year = {
+ 2001 => 2,
+ 2002 => 1,
+ 2005 => 3,
+ };
+
+ my $rs = $schema->resultset ('CD');
+ $rs->delete;
+ for my $y (keys %$cds_per_year) {
+ for my $c (1 .. $cds_per_year->{$y} ) {
+ $rs->create ({ title => "CD $y-$c", artist => 1, year => "$y-01-01" });
+ }
+ }
+
+ is ($rs->count, 6, 'CDs created successfully');
+
+ $rs = $rs->search ({}, {
+ select => [ \ 'YEAR(year)' ], as => ['y'], distinct => 1,
+ });
+
+ is_deeply (
+ [ sort ($rs->get_column ('y')->all) ],
+ [ sort keys %$cds_per_year ],
+ 'Years group successfully',
+ );
+
+ $rs->create ({ artist => 1, year => '0-1-1', title => 'Jesus Rap' });
+
+ is_deeply (
+ [ sort $rs->get_column ('y')->all ],
+ [ 0, sort keys %$cds_per_year ],
+ 'Zero-year groups successfully',
+ );
+
+ # convoluted search taken verbatim from list
+ my $restrict_rs = $rs->search({ -and => [
+ year => { '!=', 0 },
+ year => { '!=', undef }
+ ]});
+
+ is_deeply (
+ [ $restrict_rs->get_column('y')->all ],
+ [ $rs->get_column ('y')->all ],
+ 'Zero year was correctly excluded from resultset',
+ );
+}
+
+## If find() is the first query after connect()
+## DBI::Storage::sql_maker() will be called before
+## _determine_driver() and so the ::SQLHacks class for MySQL
+## will not be used
+
+my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
+$schema2->resultset("Artist")->find(4);
+isa_ok($schema2->storage->sql_maker, 'DBIx::Class::SQLAHacks::MySQL');
+
done_testing;
use strict;
use warnings;
- use base 'DBIx::Class';
+ use base 'DBIx::Class::Core';
- __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('dbic_t_schema.array_test');
__PACKAGE__->add_columns(qw/id arrayfield/);
__PACKAGE__->column_info_from_storage(1);
use strict;
use warnings;
- use base 'DBIx::Class';
+ use base 'DBIx::Class::Core';
- __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('dbic_t_schema.casecheck');
__PACKAGE__->add_columns(qw/id name NAME uc_name/);
__PACKAGE__->column_info_from_storage(1);
use strict;
use warnings;
- use base 'DBIx::Class';
+ use base 'DBIx::Class::Core';
- __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('apk');
@eapk_id_columns = qw( id1 id2 id3 id4 );
my @eapk_schemas;
BEGIN{ @eapk_schemas = map "dbic_apk_$_", 0..5 }
+my %seqs; #< hash of schema.table.col => currval of its (DBIC) primary key sequence
sub run_extended_apk_tests {
my $schema = shift;
for @eapk_schemas;
$dbh->do("CREATE SEQUENCE $eapk_schemas[5].fooseq");
+ $dbh->do("SELECT setval('$eapk_schemas[5].fooseq',400)");
+ $seqs{"$eapk_schemas[1].apk.id2"} = 400;
+
$dbh->do("CREATE SEQUENCE $eapk_schemas[4].fooseq");
+ $dbh->do("SELECT setval('$eapk_schemas[4].fooseq',300)");
+ $seqs{"$eapk_schemas[3].apk.id2"} = 300;
+
$dbh->do("CREATE SEQUENCE $eapk_schemas[3].fooseq");
+ $dbh->do("SELECT setval('$eapk_schemas[3].fooseq',200)");
+ $seqs{"$eapk_schemas[4].apk.id2"} = 200;
- $dbh->do("SET search_path = ".join ',', @eapk_schemas );
+ $dbh->do("SET search_path = ".join ',', reverse @eapk_schemas );
});
# clear our search_path cache
qualify_table => 4,
);
+ eapk_poke( $schema );
eapk_poke( $schema, 0 );
eapk_poke( $schema, 2 );
eapk_poke( $schema, 4 );
eapk_poke( $schema, 1 );
eapk_poke( $schema, 0 );
eapk_poke( $schema, 1 );
+ eapk_poke( $schema );
eapk_poke( $schema, 4 );
eapk_poke( $schema, 3 );
eapk_poke( $schema, 1 );
# do a DBIC create on the apk table in the given schema number (which is an
# index of @eapk_schemas)
-my %seqs; #< sanity-check hash of schema.table.col => currval of its sequence
-
sub eapk_poke {
my ($s, $schema_num) = @_;
? $eapk_schemas[$schema_num]
: '';
- my $schema_name_actual = $schema_name || eapk_get_search_path($s)->[0];
+ my $schema_name_actual = $schema_name || eapk_find_visible_schema($s);
$s->source('ExtAPK')->name($schema_name ? $schema_name.'.apk' : 'apk');
#< clear sequence name cache
lives_ok {
my $new;
for my $inc (1,2,3) {
- $new = $schema->resultset('ExtAPK')->create({});
+ $new = $schema->resultset('ExtAPK')->create({ id1 => 1});
my $proper_seqval = ++$seqs{"$schema_name_actual.apk.id2"};
is( $new->id2, $proper_seqval, "$schema_name_actual.apk.id2 correct inc $inc" )
or eapk_seq_diag($s,$schema_name);
$new->discard_changes;
- for my $id (grep $_ ne 'id2', @eapk_id_columns) {
+ is( $new->id1, 1 );
+ for my $id ('id3','id4') {
my $proper_seqval = ++$seqs{"$schema_name_actual.apk.$id"};
is( $new->$id, $proper_seqval, "$schema_name_actual.apk.$id correct inc $inc" )
or eapk_seq_diag($s,$schema_name);
# class
sub eapk_seq_diag {
my $s = shift;
- my $schema = shift || eapk_get_search_path($s)->[0];
+ my $schema = shift || eapk_find_visible_schema($s);
diag "$schema.apk sequences: ",
join(', ',
local $_[1]->{Warn} = 0;
my $id_def = $a{nextval}
- ? "integer primary key not null default nextval('$a{nextval}'::regclass)"
- : 'serial primary key';
+ ? "integer not null default nextval('$a{nextval}'::regclass)"
+ : 'serial';
$dbh->do(<<EOS);
CREATE TABLE $table_name (
id1 serial
, id2 $id_def
- , id3 serial
+ , id3 serial primary key
, id4 serial
)
EOS
});
}
+
+sub eapk_find_visible_schema {
+ my ($s) = @_;
+
+ my ($schema) =
+ $s->storage->dbh_do(sub {
+ $_[1]->selectrow_array(<<EOS);
+SELECT n.nspname
+FROM pg_catalog.pg_namespace n
+JOIN pg_catalog.pg_class c ON c.relnamespace = n.oid
+WHERE c.relname = 'apk'
+ AND pg_catalog.pg_table_is_visible(c.oid)
+EOS
+ });
+ return $schema;
+}
}
use strict;
-use warnings;
+use warnings;
use Test::Exception;
use Test::More;
' as well as following sequences: \'pkid1_seq\', \'pkid2_seq\' and \'nonpkid_seq\''
unless ($dsn && $user && $pass);
-plan tests => 35;
-
DBICTest::Schema->load_classes('ArtistFQN');
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
eval {
$dbh->do("DROP SEQUENCE artist_seq");
+ $dbh->do("DROP SEQUENCE cd_seq");
$dbh->do("DROP SEQUENCE pkid1_seq");
$dbh->do("DROP SEQUENCE pkid2_seq");
$dbh->do("DROP SEQUENCE nonpkid_seq");
$dbh->do("DROP TABLE track");
};
$dbh->do("CREATE SEQUENCE artist_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
+$dbh->do("CREATE SEQUENCE cd_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE pkid1_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE pkid2_seq START WITH 10 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE nonpkid_seq START WITH 20 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE TABLE artist (artistid NUMBER(12), name VARCHAR(255), rank NUMBER(38), charfield VARCHAR2(10))");
$dbh->do("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 cd (cdid NUMBER(12), artist NUMBER(12), title VARCHAR(255), year VARCHAR(4), genreid NUMBER(12), single_track NUMBER(12))");
$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at DATE, small_dt DATE)");
$dbh->do("ALTER TABLE artist ADD (CONSTRAINT artist_pk PRIMARY KEY (artistid))");
+$dbh->do("ALTER TABLE cd ADD (CONSTRAINT cd_pk PRIMARY KEY (cdid))");
$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
END IF;
END;
});
+$dbh->do(qq{
+ CREATE OR REPLACE TRIGGER cd_insert_trg
+ BEFORE INSERT ON cd
+ FOR EACH ROW
+ BEGIN
+ IF :new.cdid IS NULL THEN
+ SELECT cd_seq.nextval
+ INTO :new.cdid
+ FROM DUAL;
+ END IF;
+ END;
+});
{
# Swiped from t/bindtype_columns.t to avoid creating my own Resultset.
eval { $dbh->do('DROP TABLE bindtype_test') };
$dbh->do(qq[
- CREATE TABLE bindtype_test
+ CREATE TABLE bindtype_test
(
id integer NOT NULL PRIMARY KEY,
bytea integer NULL,
my $new = $schema->resultset('Artist')->create({ name => 'foo' });
is($new->artistid, 1, "Oracle Auto-PK worked");
+my $cd = $schema->resultset('CD')->create({ artist => 1, title => 'EP C', year => '2003' });
+is($cd->cdid, 1, "Oracle Auto-PK worked - using scalar ref as table name");
+
# test again with fully-qualified table name
$new = $schema->resultset('ArtistFQN')->create( { name => 'bar' } );
is( $new->artistid, 2, "Oracle Auto-PK worked with fully-qualified tablename" );
+# test rel names over the 30 char limit
+my $query = $schema->resultset('Artist')->search({
+ artistid => 1
+}, {
+ prefetch => 'cds_very_very_very_long_relationship_name'
+});
+
+lives_and {
+ is $query->first->cds_very_very_very_long_relationship_name->first->cdid, 1
+} 'query with rel name over 30 chars survived and worked';
+
+# rel name over 30 char limit with user condition
+# This requires walking the SQLA data structure.
+{
+ local $TODO = 'user condition on rel longer than 30 chars';
+
+ $query = $schema->resultset('Artist')->search({
+ 'cds_very_very_very_long_relationship_name.title' => 'EP C'
+ }, {
+ prefetch => 'cds_very_very_very_long_relationship_name'
+ });
+
+ lives_and {
+ is $query->first->cds_very_very_very_long_relationship_name->first->cdid, 1
+ } 'query with rel name over 30 chars and user condition survived and worked';
+}
+
# test join with row count ambiguity
-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'},
$tcount = $schema->resultset('Track')->search(
{},
- {
+ {
group_by => [ qw/position title/ ]
}
);
my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
-{
- my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
- $binstr{'large'} = $binstr{'small'} x 1024;
+SKIP: {
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
- my $maxloblen = length $binstr{'large'};
- note "Localizing LongReadLen to $maxloblen to avoid truncation of test data";
- local $dbh->{'LongReadLen'} = $maxloblen;
+ my $maxloblen = length $binstr{'large'};
+ note "Localizing LongReadLen to $maxloblen to avoid truncation of test data";
+ local $dbh->{'LongReadLen'} = $maxloblen;
- my $rs = $schema->resultset('BindType');
- my $id = 0;
+ my $rs = $schema->resultset('BindType');
+ my $id = 0;
- foreach my $type (qw( blob clob )) {
- foreach my $size (qw( small large )) {
- $id++;
+ if ($DBD::Oracle::VERSION eq '1.23') {
+ throws_ok { $rs->create({ id => 1, blob => $binstr{large} }) }
+ qr/broken/,
+ 'throws on blob insert with DBD::Oracle == 1.23';
- lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
- "inserted $size $type without dying";
- ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
- }
- }
+ skip 'buggy BLOB support in DBD::Oracle 1.23', 7;
+ }
+
+ foreach my $type (qw( blob clob )) {
+ foreach my $size (qw( small large )) {
+ $id++;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying";
+
+ ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
+ }
+ }
}
+done_testing;
+
# clean up our mess
END {
if($schema && ($dbh = $schema->storage->dbh)) {
$dbh->do("DROP SEQUENCE artist_seq");
+ $dbh->do("DROP SEQUENCE cd_seq");
$dbh->do("DROP SEQUENCE pkid1_seq");
$dbh->do("DROP SEQUENCE pkid2_seq");
$dbh->do("DROP SEQUENCE nonpkid_seq");
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
plan skip_all => 'Set $ENV{DBICTEST_DB2_DSN}, _USER and _PASS to run this test'
unless ($dsn && $user);
-plan tests => 9;
-
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
my $dbh = $schema->storage->dbh;
$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);");
-# This is in core, just testing that it still loads ok
-$schema->class('Artist')->load_components('PK::Auto');
-
my $ars = $schema->resultset('Artist');
+is ( $ars->count, 0, 'No rows at first' );
# test primary key handling
my $new = $ars->create({ name => 'foo' });
ok($new->artistid, "Auto-PK worked");
-my $init_count = $ars->count;
-for (1..6) {
- $ars->create({ name => 'Artist ' . $_ });
-}
-is ($ars->count, $init_count + 6, 'Simple count works');
+# test explicit key spec
+$new = $ars->create ({ name => 'bar', artistid => 66 });
+is($new->artistid, 66, 'Explicit PK worked');
+$new->discard_changes;
+is($new->artistid, 66, 'Explicit PK assigned');
+
+# test populate
+lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+});
+
+# test populate with explicit key
+lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+});
+
+# count what we did so far
+is ($ars->count, 6, 'Simple count works');
# test LIMIT support
-my $it = $ars->search( {},
+my $lim = $ars->search( {},
{
rows => 3,
+ offset => 4,
order_by => 'artistid'
}
);
-is( $it->count, 3, "LIMIT count ok" );
-
-my @all = $it->all;
-is (@all, 3, 'Number of ->all objects matches count');
+is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+is( $lim->all, 2, 'Number of ->all objects matches count' );
-$it->reset;
-is( $it->next->name, "foo", "iterator->next ok" );
-is( $it->next->name, "Artist 1", "iterator->next ok" );
-is( $it->next->name, "Artist 2", "iterator->next ok" );
-is( $it->next, undef, "next past end of resultset ok" ); # this can not succeed if @all > 3
+# test iterator
+$lim->reset;
+is( $lim->next->artistid, 101, "iterator->next ok" );
+is( $lim->next->artistid, 102, "iterator->next ok" );
+is( $lim->next, undef, "next past end of resultset ok" );
my $test_type_info = {
'charfield' => {
'data_type' => 'CHAR',
'is_nullable' => 1,
- 'size' => 10
+ 'size' => 10
},
'rank' => {
'data_type' => 'INTEGER',
'is_nullable' => 1,
- 'size' => 10
+ 'size' => 10
},
};
my $type_info = $schema->storage->columns_info_for('artist');
is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
+done_testing;
+
# clean up our mess
END {
my $dbh = eval { $schema->storage->_dbh };
isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' );
+{
+ my $schema2 = $schema->connect ($schema->storage->connect_info);
+ ok (! $schema2->storage->connected, 'a re-connected cloned schema starts unconnected');
+}
+
$schema->storage->dbh_do (sub {
my ($storage, $dbh) = @_;
eval { $dbh->do("DROP TABLE artist") };
$schema->storage->dbh_do (sub {
my ($storage, $dbh) = @_;
- eval { $dbh->do("DROP TABLE Owners") };
- eval { $dbh->do("DROP TABLE Books") };
+ eval { $dbh->do("DROP TABLE owners") };
+ eval { $dbh->do("DROP TABLE books") };
$dbh->do(<<'SQL');
-CREATE TABLE Books (
+CREATE TABLE books (
id INT IDENTITY (1, 1) NOT NULL,
source VARCHAR(100),
owner INT,
price INT NULL
)
-CREATE TABLE Owners (
+CREATE TABLE owners (
id INT IDENTITY (1, 1) NOT NULL,
name VARCHAR(100),
)
[qw/1 wiggle/],
[qw/2 woggle/],
[qw/3 boggle/],
- [qw/4 fREW/],
- [qw/5 fRIOUX/],
- [qw/6 fROOH/],
- [qw/7 fRUE/],
+ [qw/4 fRIOUX/],
+ [qw/5 fRUE/],
+ [qw/6 fREW/],
+ [qw/7 fROOH/],
[qw/8 fISMBoC/],
[qw/9 station/],
[qw/10 mirror/],
]);
}, 'populate with PKs supplied ok' );
+
lives_ok (sub {
# start a new connection, make sure rebless works
# test an insert with a supplied identity, followed by one without
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
- for (1..2) {
+ for (2, 1) {
my $id = $_ * 20 ;
$schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" });
$schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) });
]);
}, 'populate without PKs supplied ok' );
+# plain ordered subqueries throw
+throws_ok (sub {
+ $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query
+}, qr/ordered subselect encountered/, 'Ordered Subselect detection throws ok');
+
+# make sure ordered subselects *somewhat* work
+{
+ my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
+
+ my $al = $owners->current_source_alias;
+ my $sealed_owners = $owners->result_source->resultset->search (
+ {},
+ {
+ alias => $al,
+ from => [{
+ -alias => $al,
+ -source_handle => $owners->result_source->handle,
+ $al => $owners->as_query,
+ }],
+ },
+ );
+
+ is_deeply (
+ [ map { $_->name } ($sealed_owners->all) ],
+ [ map { $_->name } ($owners->all) ],
+ 'Sort preserved from within a subquery',
+ );
+}
+
+TODO: {
+ local $TODO = "This porbably will never work, but it isn't critical either afaik";
+
+ my $book_owner_ids = $schema->resultset ('BooksInLibrary')
+ ->search ({}, { join => 'owner', distinct => 1, order_by => 'owner.name', unsafe_subselect_ok => 1 })
+ ->get_column ('owner');
+
+ my $book_owners = $schema->resultset ('Owners')->search ({
+ id => { -in => $book_owner_ids->as_query }
+ });
+
+ is_deeply (
+ [ map { $_->id } ($book_owners->all) ],
+ [ $book_owner_ids->all ],
+ 'Sort is preserved across IN subqueries',
+ );
+}
+
+# This is known not to work - thus the negative test
+{
+ my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
+ my $corelated_owners = $owners->result_source->resultset->search (
+ {
+ id => { -in => $owners->get_column('id')->as_query },
+ },
+ {
+ order_by => 'name' #reorder because of what is shown above
+ },
+ );
+
+ cmp_ok (
+ join ("\x00", map { $_->name } ($corelated_owners->all) ),
+ 'ne',
+ join ("\x00", map { $_->name } ($owners->all) ),
+ 'Sadly sort not preserved from within a corelated subquery',
+ );
+
+ cmp_ok (
+ join ("\x00", sort map { $_->name } ($corelated_owners->all) ),
+ 'ne',
+ join ("\x00", sort map { $_->name } ($owners->all) ),
+ 'Which in fact gives a completely wrong dataset',
+ );
+}
+
+
+# make sure right-join-side single-prefetch ordering limit works
+{
+ my $rs = $schema->resultset ('BooksInLibrary')->search (
+ {
+ 'owner.name' => { '!=', 'woggle' },
+ },
+ {
+ prefetch => 'owner',
+ order_by => 'owner.name',
+ }
+ );
+ # this is the order in which they should come from the above query
+ my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/;
+
+ is ($rs->all, 8, 'Correct amount of objects from right-sorted joined resultset');
+ is_deeply (
+ [map { $_->owner->name } ($rs->all) ],
+ \@owner_names,
+ 'Rows were properly ordered'
+ );
+
+ my $limited_rs = $rs->search ({}, {rows => 7, offset => 2, unsafe_subselect_ok => 1});
+ is ($limited_rs->count, 6, 'Correct count of limited right-sorted joined resultset');
+ is ($limited_rs->count_rs->next, 6, 'Correct count_rs of limited right-sorted joined resultset');
+
+ my $queries;
+ $schema->storage->debugcb(sub { $queries++; });
+ $schema->storage->debug(1);
+
+ is_deeply (
+ [map { $_->owner->name } ($limited_rs->all) ],
+ [@owner_names[2 .. 7]],
+ 'Limited rows were properly ordered'
+ );
+ is ($queries, 1, 'Only one query with prefetch');
+
+ $schema->storage->debugcb(undef);
+ $schema->storage->debug(0);
+
+
+ is_deeply (
+ [map { $_->name } ($limited_rs->search_related ('owner')->all) ],
+ [@owner_names[2 .. 7]],
+ 'Rows are still properly ordered after search_related'
+ );
+}
+
+
#
# try a prefetch on tables with identically named columns
#
{
# try a ->has_many direction
- my $owners = $schema->resultset ('Owners')->search ({
- 'books.id' => { '!=', undef }
- }, {
+ my $owners = $schema->resultset ('Owners')->search (
+ {
+ 'books.id' => { '!=', undef },
+ 'me.name' => { '!=', 'somebogusstring' },
+ },
+ {
prefetch => 'books',
- order_by => 'name',
+ order_by => { -asc => \['name + ?', [ test => 'xxx' ]] }, # test bindvar propagation
rows => 3, # 8 results total
- });
+ unsafe_subselect_ok => 1,
+ },
+ );
+
+ my ($sql, @bind) = @${$owners->page(3)->as_query};
+ is_deeply (
+ \@bind,
+ [ ([ 'me.name' => 'somebogusstring' ], [ test => 'xxx' ]) x 2 ], # double because of the prefetch subq
+ );
is ($owners->page(1)->all, 3, 'has_many prefetch returns correct number of rows');
is ($owners->page(1)->count, 3, 'has-many prefetch returns correct count');
- TODO: {
- local $TODO = 'limit past end of resultset problem';
- is ($owners->page(3)->all, 2, 'has_many prefetch returns correct number of rows');
- is ($owners->page(3)->count, 2, 'has-many prefetch returns correct count');
- is ($owners->page(3)->count_rs->next, 2, 'has-many prefetch returns correct count_rs');
-
- # make sure count does not become overly complex
- is_same_sql_bind (
- $owners->page(3)->count_rs->as_query,
- '(
- SELECT COUNT( * )
- FROM (
- SELECT TOP 3 [me].[id]
- FROM [owners] [me]
- LEFT JOIN [books] [books] ON [books].[owner] = [me].[id]
- WHERE ( [books].[id] IS NOT NULL )
- GROUP BY [me].[id]
- ORDER BY [me].[id] DESC
- ) [count_subq]
- )',
- [],
- );
- }
+ is ($owners->page(3)->all, 2, 'has_many prefetch returns correct number of rows');
+ is ($owners->page(3)->count, 2, 'has-many prefetch returns correct count');
+ is ($owners->page(3)->count_rs->next, 2, 'has-many prefetch returns correct count_rs');
+
# try a ->belongs_to direction (no select collapse, group_by should work)
- my $books = $schema->resultset ('BooksInLibrary')->search ({
+ my $books = $schema->resultset ('BooksInLibrary')->search (
+ {
'owner.name' => [qw/wiggle woggle/],
- }, {
+ },
+ {
distinct => 1,
+ having => \['1 = ?', [ test => 1 ] ], #test having propagation
prefetch => 'owner',
rows => 2, # 3 results total
- order_by => { -desc => 'owner' },
- # there is no sane way to order by the right side of a grouped prefetch currently :(
- #order_by => { -desc => 'owner.name' },
- });
-
+ order_by => { -desc => 'me.owner' },
+ unsafe_subselect_ok => 1,
+ },
+ );
+
+ ($sql, @bind) = @${$books->page(3)->as_query};
+ is_deeply (
+ \@bind,
+ [
+ # inner
+ [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], [ test => '1' ],
+ # outer
+ [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ],
+ ],
+ );
is ($books->page(1)->all, 2, 'Prefetched grouped search returns correct number of rows');
is ($books->page(1)->count, 2, 'Prefetched grouped search returns correct count');
- TODO: {
- local $TODO = 'limit past end of resultset problem';
- is ($books->page(2)->all, 1, 'Prefetched grouped search returns correct number of rows');
- is ($books->page(2)->count, 1, 'Prefetched grouped search returns correct count');
- is ($books->page(2)->count_rs->next, 1, 'Prefetched grouped search returns correct count_rs');
-
- # make sure count does not become overly complex (FIXME - the distinct-induced group_by is incorrect)
- is_same_sql_bind (
- $books->page(2)->count_rs->as_query,
- '(
- SELECT COUNT( * )
- FROM (
- SELECT TOP 2 [me].[id]
- FROM [books] [me]
- JOIN [owners] [owner] ON [owner].[id] = [me].[owner]
- WHERE ( ( ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? ) )
- GROUP BY [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price]
- ORDER BY [me].[id] DESC
- ) [count_subq]
- )',
- [
- [ 'owner.name' => 'wiggle' ],
- [ 'owner.name' => 'woggle' ],
- [ 'source' => 'Library' ],
- ],
- );
- }
+ is ($books->page(2)->all, 1, 'Prefetched grouped search returns correct number of rows');
+ is ($books->page(2)->count, 1, 'Prefetched grouped search returns correct count');
+ is ($books->page(2)->count_rs->next, 1, 'Prefetched grouped search returns correct count_rs');
}
done_testing;
END {
if (my $dbh = eval { $schema->storage->_dbh }) {
eval { $dbh->do("DROP TABLE $_") }
- for qw/artist money_test Books Owners/;
+ for qw/artist money_test books owners/;
}
}
# vim:sw=2 sts=2
use lib qw(t/lib);
use DBICTest;
-require DBIx::Class::Storage::DBI::Sybase;
-require DBIx::Class::Storage::DBI::Sybase::NoBindVars;
-
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/};
-my $TESTS = 63 + 2;
+my $TESTS = 66 + 2;
if (not ($dsn && $user)) {
plan skip_all =>
}
my @storage_types = (
- 'DBI::Sybase',
- 'DBI::Sybase::NoBindVars',
+ 'DBI::Sybase::ASE',
+ 'DBI::Sybase::ASE::NoBindVars',
);
+eval "require DBIx::Class::Storage::$_;" for @storage_types;
+
my $schema;
my $storage_idx = -1;
my $ping_count = 0;
{
- my $ping = DBIx::Class::Storage::DBI::Sybase->can('_ping');
- *DBIx::Class::Storage::DBI::Sybase::_ping = sub {
+ my $ping = DBIx::Class::Storage::DBI::Sybase::ASE->can('_ping');
+ *DBIx::Class::Storage::DBI::Sybase::ASE::_ping = sub {
$ping_count++;
goto $ping;
};
for my $storage_type (@storage_types) {
$storage_idx++;
- unless ($storage_type eq 'DBI::Sybase') { # autodetect
+ unless ($storage_type eq 'DBI::Sybase::ASE') { # autodetect
DBICTest::Schema->storage_type("::$storage_type");
}
$schema->storage->ensure_connected;
if ($storage_idx == 0 &&
- $schema->storage->isa('DBIx::Class::Storage::DBI::Sybase::NoBindVars')) {
+ $schema->storage->isa('DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars')) {
# no placeholders in this version of Sybase or DBD::Sybase (or using FreeTDS)
my $tb = Test::More->builder;
$tb->skip('no placeholders') for 1..$TESTS;
$seen_id{$new->artistid}++;
# check redispatch to storage-specific insert when auto-detected storage
- if ($storage_type eq 'DBI::Sybase') {
+ if ($storage_type eq 'DBI::Sybase::ASE') {
DBICTest::Schema->storage_type('::DBI');
$schema = get_schema();
}
my $new_str = $binstr{large} . 'mtfnpy';
# check redispatch to storage-specific update when auto-detected storage
- if ($storage_type eq 'DBI::Sybase') {
+ if ($storage_type eq 'DBI::Sybase::ASE') {
DBICTest::Schema->storage_type('::DBI');
$schema = get_schema();
}
'updated money value to NULL round-trip'
);
diag $@ if $@;
+
+# Test computed columns and timestamps
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE computed_column_test") };
+ $dbh->do(<<'SQL');
+CREATE TABLE computed_column_test (
+ id INT IDENTITY PRIMARY KEY,
+ a_computed_column AS getdate(),
+ a_timestamp timestamp,
+ charfield VARCHAR(20) DEFAULT 'foo'
+)
+SQL
+ });
+
+ require DBICTest::Schema::ComputedColumn;
+ $schema->register_class(
+ ComputedColumn => 'DBICTest::Schema::ComputedColumn'
+ );
+
+ ok (($rs = $schema->resultset('ComputedColumn')),
+ 'got rs for ComputedColumn');
+
+ lives_ok { $row = $rs->create({}) }
+ 'empty insert for a table with computed columns survived';
+
+ lives_ok {
+ $row->update({ charfield => 'bar' })
+ } 'update of a table with computed columns survived';
}
is $ping_count, 0, 'no pings';
END {
if (my $dbh = eval { $schema->storage->_dbh }) {
eval { $dbh->do("DROP TABLE $_") }
- for qw/artist bindtype_test money_test/;
+ for qw/artist bindtype_test money_test computed_column_test/;
}
}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ADO_DSN}, _USER and _PASS to run this test'
+ unless ($dsn && $user);
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+$schema->storage->ensure_connected;
+
+isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server' );
+
+$schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE artist") };
+ $dbh->do(<<'SQL');
+CREATE TABLE artist (
+ artistid INT IDENTITY NOT NULL,
+ name VARCHAR(100),
+ rank INT NOT NULL DEFAULT '13',
+ charfield CHAR(10) NULL,
+ primary key(artistid)
+)
+SQL
+});
+
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
+ok($new->artistid > 0, 'Auto-PK worked');
+
+# make sure select works
+my $found = $schema->resultset('Artist')->search({ name => 'foo' })->first;
+is $found->artistid, $new->artistid, 'search works';
+
+# test large column list in select
+$found = $schema->resultset('Artist')->search({ name => 'foo' }, {
+ select => ['artistid', 'name', map "'foo' foo_$_", 0..50],
+ as => ['artistid', 'name', map "foo_$_", 0..50],
+})->first;
+is $found->artistid, $new->artistid, 'select with big column list';
+is $found->get_column('foo_50'), 'foo', 'last item in big column list';
+
+# create a few more rows
+for (1..12) {
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
+}
+
+# test multiple active cursors
+my $rs1 = $schema->resultset('Artist')->search({}, { order_by => 'artistid' });
+my $rs2 = $schema->resultset('Artist')->search({}, { order_by => 'name' });
+
+while ($rs1->next) {
+ ok eval { $rs2->next }, 'multiple active cursors';
+}
+
+# test bug where ADO blows up if the first bindparam is shorter than the second
+is $schema->resultset('Artist')->search({ artistid => 2 })->first->name,
+ 'Artist 1',
+ 'short bindparam';
+
+is $schema->resultset('Artist')->search({ artistid => 13 })->first->name,
+ 'Artist 12',
+ 'longer bindparam';
+
+done_testing;
+
+# clean up our mess
+END {
+ if (my $dbh = eval { $schema->storage->_dbh }) {
+ eval { $dbh->do("DROP TABLE $_") }
+ for qw/artist/;
+ }
+}
+# vim:sw=2 sts=2
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/};
+
+#warn "$dsn $user $pass";
+
+plan skip_all => 'Set $ENV{DBICTEST_INFORMIX_DSN}, _USER and _PASS to run this test'
+ unless ($dsn && $user);
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+
+my $dbh = $schema->storage->dbh;
+
+eval { $dbh->do("DROP TABLE artist") };
+
+$dbh->do("CREATE TABLE artist (artistid SERIAL, name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);");
+
+my $ars = $schema->resultset('Artist');
+is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+my $new = $ars->create({ name => 'foo' });
+ok($new->artistid, "Auto-PK worked");
+
+# test explicit key spec
+$new = $ars->create ({ name => 'bar', artistid => 66 });
+is($new->artistid, 66, 'Explicit PK worked');
+$new->discard_changes;
+is($new->artistid, 66, 'Explicit PK assigned');
+
+# test populate
+lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+});
+
+# test populate with explicit key
+lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+});
+
+# count what we did so far
+is ($ars->count, 6, 'Simple count works');
+
+# test LIMIT support
+my $lim = $ars->search( {},
+ {
+ rows => 3,
+ offset => 4,
+ order_by => 'artistid'
+ }
+);
+is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+$lim->reset;
+is( $lim->next->artistid, 101, "iterator->next ok" );
+is( $lim->next->artistid, 102, "iterator->next ok" );
+is( $lim->next, undef, "next past end of resultset ok" );
+
+
+done_testing;
+
+# clean up our mess
+END {
+ my $dbh = eval { $schema->storage->_dbh };
+ $dbh->do("DROP TABLE artist") if $dbh;
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+# tests stolen from 748informix.t
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_ASA_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SYBASE_ASA_ODBC_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => <<'EOF' unless $dsn || $dsn2;
+Set $ENV{DBICTEST_SYBASE_ASA_DSN} and/or $ENV{DBICTEST_SYBASE_ASA_ODBC_DSN},
+_USER and _PASS to run these tests
+EOF
+
+my @info = (
+ [ $dsn, $user, $pass ],
+ [ $dsn2, $user2, $pass2 ],
+);
+
+my @handles_to_clean;
+
+foreach my $info (@info) {
+ my ($dsn, $user, $pass) = @$info;
+
+ next unless $dsn;
+
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+
+ my $dbh = $schema->storage->dbh;
+
+ push @handles_to_clean, $dbh;
+
+ eval { $dbh->do("DROP TABLE artist") };
+
+ $dbh->do(<<EOF);
+ CREATE TABLE artist (
+ artistid INT IDENTITY PRIMARY KEY,
+ name VARCHAR(255) NULL,
+ charfield CHAR(10) NULL,
+ rank INT DEFAULT 13
+ )
+EOF
+
+ my $ars = $schema->resultset('Artist');
+ is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+ my $new = $ars->create({ name => 'foo' });
+ ok($new->artistid, "Auto-PK worked");
+
+# test explicit key spec
+ $new = $ars->create ({ name => 'bar', artistid => 66 });
+ is($new->artistid, 66, 'Explicit PK worked');
+ $new->discard_changes;
+ is($new->artistid, 66, 'Explicit PK assigned');
+
+# test populate
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+ });
+
+# test populate with explicit key
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+ });
+
+# count what we did so far
+ is ($ars->count, 6, 'Simple count works');
+
+# test LIMIT support
+ my $lim = $ars->search( {},
+ {
+ rows => 3,
+ offset => 4,
+ order_by => 'artistid'
+ }
+ );
+ is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+ is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+ $lim->reset;
+ is( $lim->next->artistid, 101, "iterator->next ok" );
+ is( $lim->next->artistid, 102, "iterator->next ok" );
+ is( $lim->next, undef, "next past end of resultset ok" );
+
+# test empty insert
+ {
+ local $ars->result_source->column_info('artistid')->{is_auto_increment} = 0;
+
+ lives_ok { $ars->create({}) }
+ 'empty insert works';
+ }
+
+# test blobs (stolen from 73oracle.t)
+ eval { $dbh->do('DROP TABLE bindtype_test') };
+ $dbh->do(qq[
+ CREATE TABLE bindtype_test
+ (
+ id INT NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob LONG BINARY NULL,
+ clob LONG VARCHAR NULL
+ )
+ ],{ RaiseError => 1, PrintError => 1 });
+
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
+
+ my $maxloblen = length $binstr{'large'};
+ local $dbh->{'LongReadLen'} = $maxloblen;
+
+ my $rs = $schema->resultset('BindType');
+ my $id = 0;
+
+ foreach my $type (qw( blob clob )) {
+ foreach my $size (qw( small large )) {
+ $id++;
+
+# turn off horrendous binary DBIC_TRACE output
+ local $schema->storage->{debug} = 0;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying";
+
+ ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
+ }
+ }
+}
+
+done_testing;
+
+# clean up our mess
+END {
+ foreach my $dbh (@handles_to_clean) {
+ eval { $dbh->do("DROP TABLE $_") } for qw/artist bindtype_test/;
+ }
+}
plan skip_all => 'Set $ENV{DBICTEST_MSSQL_DSN}, _USER and _PASS to run this test'
unless ($dsn);
-my $TESTS = 15;
-
-plan tests => $TESTS * 2;
-
my @storage_types = (
'DBI::Sybase::Microsoft_SQL_Server',
'DBI::Sybase::Microsoft_SQL_Server::NoBindVars',
my $storage_idx = -1;
my $schema;
+my $NUMBER_OF_TESTS_IN_BLOCK = 18;
for my $storage_type (@storage_types) {
$storage_idx++;
$schema = DBICTest::Schema->clone;
- if ($storage_idx != 0) { # autodetect
- $schema->storage_type("::$storage_type");
- }
-
$schema->connection($dsn, $user, $pass);
- $schema->storage->ensure_connected;
+ if ($storage_idx != 0) { # autodetect
+ no warnings 'redefine';
+ local *DBIx::Class::Storage::DBI::_typeless_placeholders_supported =
+ sub { 0 };
+# $schema->storage_type("::$storage_type");
+ $schema->storage->ensure_connected;
+ }
+ else {
+ $schema->storage->ensure_connected;
+ }
if ($storage_idx == 0 && ref($schema->storage) =~ /NoBindVars\z/) {
my $tb = Test::More->builder;
- $tb->skip('no placeholders') for 1..$TESTS;
+ $tb->skip('no placeholders') for 1..$NUMBER_OF_TESTS_IN_BLOCK;
next;
}
$rs->reset;
} 'multiple active statements';
- # test multiple active statements in a transaction
- TODO: {
- local $TODO = 'needs similar FreeTDS fixes to the ones in Sybase.pm';
- lives_ok {
- $schema->txn_do(sub {
- $rs->create({ amount => 400 });
- });
- } 'simple transaction';
- }
+ $rs->delete;
+
+ # test simple transaction with commit
+ lives_ok {
+ $schema->txn_do(sub {
+ $rs->create({ amount => 400 });
+ });
+ } 'simple transaction';
+
+ cmp_ok $rs->first->amount, '==', 400, 'committed';
+ $rs->reset;
+
+ $rs->delete;
+
+ # test rollback
+ throws_ok {
+ $schema->txn_do(sub {
+ $rs->create({ amount => 400 });
+ die 'mtfnpy';
+ });
+ } qr/mtfnpy/, 'simple failed txn';
+
+ is $rs->first, undef, 'rolled back';
+ $rs->reset;
}
+# test op-induced autoconnect
+lives_ok (sub {
+
+ my $schema = DBICTest::Schema->clone;
+ $schema->connection($dsn, $user, $pass);
+
+ my $artist = $schema->resultset ('Artist')->search ({}, { order_by => 'artistid' })->next;
+ is ($artist->id, 1, 'Artist retrieved successfully');
+}, 'Query-induced autoconnect works');
+
+done_testing;
+
# clean up our mess
END {
if (my $dbh = eval { $schema->storage->dbh }) {
my $orig_debug = $schema->storage->debug;
-use IO::File;
-
BEGIN {
eval "use DBD::SQLite";
plan $@
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
my $schema = DBICTest->init_schema();
-plan tests => 24;
-
my $rs = $schema->resultset('CD')->search({},
{
'+select' => \ 'COUNT(*)',
lives_ok(sub { $rs->first->get_column('count') }, 'multiple +select/+as columns, 1st rscolumn present');
lives_ok(sub { $rs->first->get_column('addedtitle') }, 'multiple +select/+as columns, 2nd rscolumn present');
-# Tests a regression in ResultSetColumn wrt +select
-$rs = $schema->resultset('CD')->search(undef,
- {
- '+select' => [ \'COUNT(*) AS year_count' ],
- order_by => 'year_count'
- }
-);
-my @counts = $rs->get_column('cdid')->all;
-ok(scalar(@counts), 'got rows from ->all using +select');
-
$rs = $schema->resultset('CD')->search({},
{
'+select' => [ \ 'COUNT(*)', 'title' ],
}, 'columns 2nd rscolumn present');
lives_ok(sub {
- $rs->first->artist->get_column('name')
-}, 'columns 3rd rscolumn present');
+ $rs->first->artist->get_column('name')
+}, 'columns 3rd rscolumn present');
$rs = $schema->resultset('CD')->search({},
- {
+ {
'join' => 'artist',
'+columns' => ['cdid', 'title', 'artist.name'],
}
);
lives_ok(sub {
- $rs->first->get_column('cdid')
+ $rs->first->get_column('cdid')
}, 'columns 1st rscolumn present');
lives_ok(sub {
}
);
-is_deeply (
+is_deeply(
$sub_rs->single,
{
- artist => 1,
+ artist => 1,
track_position => 2,
- tracks =>
- {
- trackid => 17,
- title => 'Apiary',
- },
+ tracks => {
+ trackid => 17,
+ title => 'Apiary',
+ },
},
'columns/select/as fold properly on sub-searches',
);
-TODO: {
- local $TODO = "Multi-collapsing still doesn't work right - HRI should be getting an arrayref, not an individual hash";
- is_deeply (
- $sub_rs->single,
- {
- artist => 1,
- track_position => 2,
- tracks => [
- {
- trackid => 17,
- title => 'Apiary',
- },
- ],
- },
- 'columns/select/as fold properly on sub-searches',
- );
-}
+done_testing;
my $cd_rs = $schema->resultset('CD')->search({ 'artist.name' => 'Caterwauler McCrae' }, { join => 'artist' });
my $cd = $cd_rs->find_or_new({ title => 'Huh?', year => 2006 });
- ok(! $cd->in_storage, 'new CD not in storage yet');
+ is($cd->in_storage, 0, 'new CD not in storage yet');
is($cd->title, 'Huh?', 'new CD title is correct');
is($cd->year, 2006, 'new CD year is correct');
}
{ key => 'cd_artist_title' }
);
- ok(!$cd1->in_storage, 'CD is not in storage yet after update_or_new');
+ is($cd1->in_storage, 0, 'CD is not in storage yet after update_or_new');
$cd1->insert;
ok($cd1->in_storage, 'CD got added to strage after update_or_new && insert');
# Test checking of parameters
{
- eval {
+ throws_ok (sub {
(ref $schema)->txn_do(sub{});
- };
- like($@, qr/storage/, "can't call txn_do without storage");
- eval {
+ }, qr/storage/, "can't call txn_do without storage");
+
+ throws_ok ( sub {
$schema->txn_do('');
- };
- like($@, qr/must be a CODE reference/, '$coderef parameter check ok');
+ }, qr/must be a CODE reference/, '$coderef parameter check ok');
}
# Test successful txn_do() - scalar context
my $artist = $schema->resultset('Artist')->find(2);
my $count_before = $artist->cds->count;
- eval {
+ lives_ok (sub {
$schema->txn_do($nested_code, $schema, $artist, $code);
- };
+ }, 'nested txn_do succeeded');
- my $error = $@;
-
- ok(!$error, 'nested txn_do succeeded');
is($artist->cds({
title => 'nested txn_do test CD '.$_,
})->first->year, 2006, qq{nested txn_do CD$_ year ok}) for (1..10);
my $artist = $schema->resultset('Artist')->find(3);
- eval {
+ throws_ok (sub {
$schema->txn_do($fail_code, $artist);
- };
+ }, qr/the sky is falling/, 'failed txn_do threw an exception');
- 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,
my $artist = $schema->resultset('Artist')->find(3);
- eval {
+ throws_ok (sub {
$schema->txn_do($fail_code, $artist);
- };
-
- my $error = $@;
+ }, qr/the sky is falling/, 'failed txn_do threw an exception');
- like($error, qr/the sky is falling/, 'failed txn_do threw an exception');
my $cd = $artist->cds({
title => 'this should not exist',
year => 2005,
die 'FAILED';
};
- eval {
- $schema->txn_do($fail_code, $artist);
- };
-
- my $error = $@;
-
- like($error, qr/Rollback failed/, 'failed txn_do with a failed '.
- 'txn_rollback threw a rollback exception');
- like($error, qr/the sky is falling/, 'failed txn_do with a failed '.
- 'txn_rollback included the original exception');
+ throws_ok (
+ sub {
+ $schema->txn_do($fail_code, $artist);
+ },
+ qr/the sky is falling.+Rollback failed/s,
+ 'txn_rollback threw a rollback exception (and included the original exception'
+ );
my $cd = $artist->cds({
title => 'this should not exist',
my $artist = $schema->resultset('Artist')->find(3);
- eval {
+ throws_ok ( sub {
$schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code);
- };
+ }, qr/the sky is falling/, 'nested failed txn_do threw exception');
- my $error = $@;
-
- like($error, qr/the sky is falling/, 'nested failed txn_do threw exception');
ok(!defined($artist->cds({
title => 'nested txn_do test CD '.$_,
year => 2006,
# Grab a new schema to test txn before connect
{
my $schema2 = DBICTest->init_schema(no_deploy => 1);
- eval {
+ lives_ok (sub {
$schema2->txn_begin();
$schema2->txn_begin();
- };
- my $err = $@;
- ok(! $err, 'Pre-connection nested transactions.');
+ }, 'Pre-connection nested transactions.');
# although not connected DBI would still warn about rolling back at disconnect
$schema2->txn_rollback;
ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
- my $inner_exception; # set in inner() below
- eval {
+ my $inner_exception = ''; # set in inner() below
+ throws_ok (sub {
outer($schema, 1);
- };
- is($@, $inner_exception, "Nested exceptions propogated");
+ }, qr/$inner_exception/, "Nested exceptions propogated");
ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
lives_ok (sub {
warnings_exist ( sub {
- # The 0 arg says don't die, just let the scope guard go out of scope
+ # The 0 arg says don't die, just let the scope guard go out of scope
# forcing a txn_rollback to happen
outer($schema, 0);
}, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, 'Out of scope warning detected');
my $artist = $artist_rs->find({ name => 'Death Cab for Cutie' });
eval {
- $artist->cds->create({
+ $artist->cds->create({
title => 'Plans',
- year => 2005,
+ year => 2005,
$fatal ? ( foo => 'bar' ) : ()
});
};
is (@w, 2, 'Both expected warnings found');
}
+# make sure AutoCommit => 0 on external handles behaves correctly with scope_guard
+{
+ my $factory = DBICTest->init_schema (AutoCommit => 0);
+ cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
+ my $dbh = $factory->storage->dbh;
+
+ ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
+ my $schema = DBICTest::Schema->connect (sub { $dbh });
+
+
+ lives_ok ( sub {
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset('CD')->delete;
+ $guard->commit;
+ }, 'No attempt to start a transaction with scope guard');
+
+ is ($schema->resultset('CD')->count, 0, 'Deletion successful');
+}
+
+# make sure AutoCommit => 0 on external handles behaves correctly with txn_do
+{
+ my $factory = DBICTest->init_schema (AutoCommit => 0);
+ cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
+ my $dbh = $factory->storage->dbh;
+
+ ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
+ my $schema = DBICTest::Schema->connect (sub { $dbh });
+
+
+ lives_ok ( sub {
+ $schema->txn_do (sub { $schema->resultset ('CD')->delete });
+ }, 'No attempt to start a atransaction with txn_do');
+
+ is ($schema->resultset('CD')->count, 0, 'Deletion successful');
+}
+
done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-my $schema = DBICTest->init_schema();
-
-if ($] <= 5.008000) {
-
- eval 'use Encode; 1' or plan skip_all => 'Need Encode run this test';
-
-} else {
-
- eval 'use utf8; 1' or plan skip_all => 'Need utf8 run this test';
-}
-
-plan tests => 6;
+warning_like (
+ sub {
+ package A::Comp;
+ use base 'DBIx::Class';
+ sub store_column { shift->next::method (@_) };
+ 1;
+
+ package A::Test;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->load_components(qw(UTF8Columns +A::Comp));
+ 1;
+ },
+ qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding store_column \(A::Comp\)/,
+ 'incorrect order warning issued',
+);
+my $schema = DBICTest->init_schema();
DBICTest::Schema::CD->load_components('UTF8Columns');
DBICTest::Schema::CD->utf8_columns('title');
Class::C3->reinitialize();
-my $cd = $schema->resultset('CD')->create( { artist => 1, title => 'øni', year => '2048' } );
-my $utf8_char = 'uniuni';
+my $cd = $schema->resultset('CD')->create( { artist => 1, title => "weird\x{466}stuff", year => '2048' } );
+ok( utf8::is_utf8( $cd->title ), 'got title with utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store title without utf8' );
-ok( _is_utf8( $cd->title ), 'got title with utf8 flag' );
-ok(! _is_utf8( $cd->year ), 'got year without utf8 flag' );
+ok(! utf8::is_utf8( $cd->year ), 'got year without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{year} ), 'store year without utf8' );
-_force_utf8($utf8_char);
-$cd->title($utf8_char);
-ok(! _is_utf8( $cd->{_column_data}{title} ), 'store utf8-less chars' );
+$cd->title('nonunicode');
+ok(! utf8::is_utf8( $cd->title ), 'got title without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less chars' );
my $v_utf8 = "\x{219}";
TODO: {
local $TODO = 'There is currently no way to propagate aliases to inflate_result()';
$cd = $schema->resultset('CD')->find ({ title => $v_utf8 }, { select => 'title', as => 'name' });
- ok (_is_utf8( $cd->get_column ('name') ), 'utf8 flag propagates via as');
-}
-
-
-sub _force_utf8 {
- if ($] <= 5.008000) {
- Encode::_utf8_on ($_[0]);
- }
- else {
- utf8::decode ($_[0]);
- }
+ ok (utf8::is_utf8( $cd->get_column ('name') ), 'utf8 flag propagates via as');
}
-sub _is_utf8 {
- if ($] <= 5.008000) {
- return Encode::is_utf8 (shift);
- }
- else {
- return utf8::is_utf8 (shift);
- }
-}
+done_testing;
use warnings;
use Test::More;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
$schema->storage->debugcb( sub{ $queries++ } );
my $sdebug = $schema->storage->debug;
-plan tests => 2;
-
my $cd = $schema->resultset("CD")->find(1);
$cd->title('test');
is($queries, 1, 'liner_notes (might_have) prefetched - do not load
liner_notes on update');
+warning_like {
+ DBICTest::Schema::Bookmark->might_have(
+ linky => 'DBICTest::Schema::Link',
+ { "foreign.id" => "self.link" },
+ );
+}
+ qr{"might_have/has_one" must not be on columns with is_nullable set to true},
+ 'might_have should warn if the self.id column is nullable';
+
+{
+ local $ENV{DBIC_DONT_VALIDATE_RELS} = 1;
+ warning_is {
+ DBICTest::Schema::Bookmark->might_have(
+ slinky => 'DBICTest::Schema::Link',
+ { "foreign.id" => "self.link" },
+ );
+ }
+ undef,
+ 'Setting DBIC_DONT_VALIDATE_RELS suppresses nullable relation warnings';
+}
+
$schema->storage->debug($sdebug);
+done_testing();
my $schema = DBICTest->init_schema (no_deploy => 1);
+
+# Check deployment statements ctx sensitivity
+{
+ my $not_first_table_creation_re = qr/CREATE TABLE fourkeys_to_twokeys/;
+
+
+ my $statements = $schema->deployment_statements;
+ like (
+ $statements,
+ $not_first_table_creation_re,
+ 'All create statements returned in 1 string in scalar ctx'
+ );
+
+ my @statements = $schema->deployment_statements;
+ cmp_ok (scalar @statements, '>', 1, 'Multiple statement lines in array ctx');
+
+ my $i = 0;
+ while ($i <= $#statements) {
+ last if $statements[$i] =~ $not_first_table_creation_re;
+ $i++;
+ }
+
+ ok (
+ ($i > 0) && ($i <= $#statements),
+ "Creation statement was found somewherere within array ($i)"
+ );
+}
+
+
+
# replace the sqlt calback with a custom version ading an index
$schema->source('Track')->sqlt_deploy_callback(sub {
my ($self, $sqlt_table) = @_;
'name' => 'forceforeign_fk_artist', 'index_name' => 'forceforeign_idx_artist',
'selftable' => 'forceforeign', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
+ 'noindex' => 1,
on_delete => '', on_update => '', deferrable => 1,
},
],
my ($expected, $got) = @_;
my $desc = $expected->{display};
is( $got->name, $expected->{name},
- "name parameter correct for `$desc'" );
+ "name parameter correct for '$desc'" );
is( $got->on_delete, $expected->{on_delete},
- "on_delete parameter correct for `$desc'" );
+ "on_delete parameter correct for '$desc'" );
is( $got->on_update, $expected->{on_update},
- "on_update parameter correct for `$desc'" );
+ "on_update parameter correct for '$desc'" );
is( $got->deferrable, $expected->{deferrable},
- "is_deferrable parameter correct for `$desc'" );
+ "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'" );
+ 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'" );
+ ok( defined $index, "index exists for '$desc'" );
+ is( $index->name, $expected->{index_name}, "index has correct name for '$desc'" );
}
}
my ($expected, $got) = @_;
my $desc = $expected->{display};
is( $got->name, $expected->{name},
- "name parameter correct for `$desc'" );
+ "name parameter correct for '$desc'" );
}
done_testing;
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
-my $rs = $schema->resultset("CD")->search({}, { order_by => 'cdid' });
+my $rs = $schema->resultset("CD");
+
+cmp_ok (
+ $rs->count,
+ '!=',
+ $rs->search ({}, {columns => ['year'], distinct => 1})->count,
+ 'At least one year is the same in rs'
+);
my $rs_title = $rs->get_column('title');
my $rs_year = $rs->get_column('year');
is($rs_year->single, 1999, "single okay");
}, qr/Query returned more than one row/, 'single warned');
+
+# test distinct propagation
+is_deeply (
+ [$rs->search ({}, { distinct => 1 })->get_column ('year')->all],
+ [$rs_year->func('distinct')],
+ 'distinct => 1 is passed through properly',
+);
+
# test +select/+as for single column
my $psrs = $schema->resultset('CD')->search({},
{
- '+select' => \'COUNT(*)',
- '+as' => 'count'
+ '+select' => \'MAX(year)',
+ '+as' => 'last_year'
}
);
-lives_ok(sub { $psrs->get_column('count')->next }, '+select/+as additional column "count" present (scalar)');
+lives_ok(sub { $psrs->get_column('last_year')->next }, '+select/+as additional column "last_year" present (scalar)');
dies_ok(sub { $psrs->get_column('noSuchColumn')->next }, '+select/+as nonexistent column throws exception');
-# test +select/+as for multiple columns
+# test +select/+as for overriding a column
$psrs = $schema->resultset('CD')->search({},
{
- '+select' => [ \'COUNT(*)', 'title' ],
- '+as' => [ 'count', 'addedtitle' ]
+ 'select' => \"'The Final Countdown'",
+ 'as' => 'title'
}
);
-lives_ok(sub { $psrs->get_column('count')->next }, '+select/+as multiple additional columns, "count" column present');
-lives_ok(sub { $psrs->get_column('addedtitle')->next }, '+select/+as multiple additional columns, "addedtitle" column present');
+is($psrs->get_column('title')->next, 'The Final Countdown', '+select/+as overridden column "title"');
-# test +select/+as for overriding a column
+
+# test +select/+as for multiple columns
$psrs = $schema->resultset('CD')->search({},
{
- 'select' => \"'The Final Countdown'",
- 'as' => 'title'
+ '+select' => [ \'LENGTH(title) AS title_length', 'title' ],
+ '+as' => [ 'tlength', 'addedtitle' ]
}
);
-is($psrs->get_column('title')->next, 'The Final Countdown', '+select/+as overridden column "title"');
+lives_ok(sub { $psrs->get_column('tlength')->next }, '+select/+as multiple additional columns, "tlength" column present');
+lives_ok(sub { $psrs->get_column('addedtitle')->next }, '+select/+as multiple additional columns, "addedtitle" column present');
+
+# test that +select/+as specs do not leak
+is_same_sql_bind (
+ $psrs->get_column('year')->as_query,
+ '(SELECT me.year FROM cd me)',
+ [],
+ 'Correct SQL for get_column/as'
+);
+
+is_same_sql_bind (
+ $psrs->get_column('addedtitle')->as_query,
+ '(SELECT me.title FROM cd me)',
+ [],
+ 'Correct SQL for get_column/+as col'
+);
+
+is_same_sql_bind (
+ $psrs->get_column('tlength')->as_query,
+ '(SELECT LENGTH(title) AS title_length FROM cd me)',
+ [],
+ 'Correct SQL for get_column/+as func'
+);
+# test that order_by over a function forces a subquery
+lives_ok ( sub {
+ is_deeply (
+ [ $psrs->search ({}, { order_by => { -desc => 'title_length' } })->get_column ('title')->all ],
+ [
+ "Generic Manufactured Singles",
+ "Come Be Depressed With Us",
+ "Caterwaulin' Blues",
+ "Spoonful of bees",
+ "Forkful of bees",
+ ],
+ 'Subquery count induced by aliased ordering function',
+ );
+});
+
+# test for prefetch not leaking
{
my $rs = $schema->resultset("CD")->search({}, { prefetch => 'artist' });
my $rsc = $rs->get_column('year');
WHERE
cdid > CAST(? AS INT)
AND tracks.last_updated_at IS NOT NULL
- AND tracks.last_updated_on < CAST (? AS yyy)
+ AND tracks.last_updated_on < CAST (? AS DateTime)
AND tracks.position = ?
AND tracks.single_track = CAST(? AS INT)
)',
my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982, genreid => undef });
- ok(!defined($cd->genreid), 'genreid is NULL');
+ ok(!defined($cd->get_column('genreid')), 'genreid is NULL'); #no accessor was defined for this column
ok(!defined($cd->genre), 'genre accessor returns undef');
}
use strict;
use warnings;
use Test::More;
-use File::Spec;
+use Test::Warn;
+use Test::Exception;
+
+use Path::Class;
use File::Copy;
#warn "$dsn $user $pass";
if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
}
+use lib qw(t/lib);
+use DBICTest; # do not remove even though it is not used
+
+use_ok('DBICVersion_v1');
+
my $version_table_name = 'dbix_class_schema_versions';
my $old_table_name = 'SchemaVersions';
-my $ddl_dir = File::Spec->catdir ('t', 'var');
+my $ddl_dir = dir ('t', 'var');
+mkdir ($ddl_dir) unless -d $ddl_dir;
+
my $fn = {
- v1 => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-1.0-MySQL.sql'),
- v2 => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-2.0-MySQL.sql'),
- trans => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-1.0-2.0-MySQL.sql'),
+ v1 => $ddl_dir->file ('DBICVersion-Schema-1.0-MySQL.sql'),
+ v2 => $ddl_dir->file ('DBICVersion-Schema-2.0-MySQL.sql'),
+ v3 => $ddl_dir->file ('DBICVersion-Schema-3.0-MySQL.sql'),
+ trans_v12 => $ddl_dir->file ('DBICVersion-Schema-1.0-2.0-MySQL.sql'),
+ trans_v23 => $ddl_dir->file ('DBICVersion-Schema-2.0-3.0-MySQL.sql'),
};
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
-use_ok('DBICVersionOrig');
+my $schema_v1 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
+eval { $schema_v1->storage->dbh->do('drop table ' . $version_table_name) };
+eval { $schema_v1->storage->dbh->do('drop table ' . $old_table_name) };
-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) };
-
-is($schema_orig->ddl_filename('MySQL', '1.0', $ddl_dir), $fn->{v1}, 'Filename creation working');
+is($schema_v1->ddl_filename('MySQL', '1.0', $ddl_dir), $fn->{v1}, 'Filename creation working');
unlink( $fn->{v1} ) if ( -e $fn->{v1} );
-$schema_orig->create_ddl_dir('MySQL', undef, $ddl_dir);
+$schema_v1->create_ddl_dir('MySQL', undef, $ddl_dir);
ok(-f $fn->{v1}, 'Created DDL file');
-$schema_orig->deploy({ add_drop_table => 1 });
+$schema_v1->deploy({ add_drop_table => 1 });
-my $tvrs = $schema_orig->{vschema}->resultset('Table');
-is($schema_orig->_source_exists($tvrs), 1, 'Created schema from DDL file');
+my $tvrs = $schema_v1->{vschema}->resultset('Table');
+is($schema_v1->_source_exists($tvrs), 1, 'Created schema from DDL file');
# loading a new module defining a new version of the same table
DBICVersion::Schema->_unregister_source ('Table');
-eval "use DBICVersionNew";
+use_ok('DBICVersion_v2');
-my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
+my $schema_v2 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
{
unlink($fn->{v2});
- unlink($fn->{trans});
-
- 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', $ddl_dir, '1.0');
- ok(-f $fn->{trans}, 'Created DDL file');
-
- {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
-
- sleep 1; # remove this when TODO below is completed
-
- $schema_upgrade->upgrade();
- like ($w, qr/Attempting upgrade\.$/, 'Warn before 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 and warn about it
- my @w;
- local $SIG{__WARN__} = sub {
- if ($_[0] =~ /Overwriting existing/) {
- push @w, $_[0];
- }
- else {
- warn @_;
- }
- };
- $schema_upgrade->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0');
-
- is (2, @w, 'A warning generated for both the DDL and the diff');
- like ($w[0], qr/Overwriting existing DDL file - $fn->{v2}/, 'New version DDL overwrite warning');
- like ($w[1], qr/Overwriting existing diff file - $fn->{trans}/, 'Upgrade diff overwrite warning');
+ unlink($fn->{trans_v12});
+
+ is($schema_v2->get_db_version(), '1.0', 'get_db_version ok');
+ is($schema_v2->schema_version, '2.0', 'schema version ok');
+ $schema_v2->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0');
+ ok(-f $fn->{trans_v12}, 'Created DDL file');
+
+ warnings_like (
+ sub { $schema_v2->upgrade() },
+ qr/DB version .+? is lower than the schema version/,
+ 'Warn before upgrade',
+ );
+
+ is($schema_v2->get_db_version(), '2.0', 'db version number upgraded');
+
+ lives_ok ( sub {
+ $schema_v2->storage->dbh->do('select NewVersionName from TestVersion');
+ }, 'new column created' );
+
+ warnings_exist (
+ sub { $schema_v2->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0') },
+ [
+ qr/Overwriting existing DDL file - $fn->{v2}/,
+ qr/Overwriting existing diff file - $fn->{trans_v12}/,
+ ],
+ 'An overwrite warning generated for both the DDL and the diff',
+ );
}
{
my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
- eval {
+ lives_ok (sub {
$schema_version->storage->dbh->do('select * from ' . $version_table_name);
- };
- is($@, '', 'version table exists');
+ }, 'version table exists');
- eval {
+ lives_ok (sub {
$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');
+ }, 'versions table renamed to old style table');
$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 {
+ dies_ok (sub {
$schema_version->storage->dbh->do('select * from ' . $old_table_name);
- };
- ok($@, 'old version table gone');
+ }, 'old version table gone');
+
+}
+
+# repeat the v1->v2 process for v2->v3 before testing v1->v3
+DBICVersion::Schema->_unregister_source ('Table');
+use_ok('DBICVersion_v3');
+
+my $schema_v3 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
+{
+ unlink($fn->{v3});
+ unlink($fn->{trans_v23});
+ is($schema_v3->get_db_version(), '2.0', 'get_db_version 2.0 ok');
+ is($schema_v3->schema_version, '3.0', 'schema version 3.0 ok');
+ $schema_v3->create_ddl_dir('MySQL', '3.0', $ddl_dir, '2.0');
+ ok(-f $fn->{trans_v23}, 'Created DDL 2.0 -> 3.0 file');
+
+ warnings_exist (
+ sub { $schema_v3->upgrade() },
+ qr/DB version .+? is lower than the schema version/,
+ 'Warn before upgrade',
+ );
+
+ is($schema_v3->get_db_version(), '3.0', 'db version number upgraded');
+
+ lives_ok ( sub {
+ $schema_v3->storage->dbh->do('select ExtraColumn from TestVersion');
+ }, 'new column created');
+}
+
+# now put the v1 schema back again
+{
+ # drop all the tables...
+ eval { $schema_v1->storage->dbh->do('drop table ' . $version_table_name) };
+ eval { $schema_v1->storage->dbh->do('drop table ' . $old_table_name) };
+ eval { $schema_v1->storage->dbh->do('drop table TestVersion') };
+
+ {
+ local $DBICVersion::Schema::VERSION = '1.0';
+ $schema_v1->deploy;
+ }
+ is($schema_v1->get_db_version(), '1.0', 'get_db_version 1.0 ok');
+}
+
+# attempt v1 -> v3 upgrade
+{
+ local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ $schema_v3->upgrade();
+ is($schema_v3->get_db_version(), '3.0', 'db version number upgraded');
}
# check behaviour of DBIC_NO_VERSION_CHECK env var and ignore_version connect attr
};
- my $warn = '';
- local $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');
+ warnings_like ( sub {
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ }, qr/Your DB is currently unversioned/, 'warning detected without env var or attr' );
+ warnings_like ( sub {
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
+ }, [], 'warning not detected with attr set');
- # 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
local $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
+ warnings_like ( sub {
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+ }, [], 'warning not detected with env var set');
- $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
+ warnings_like ( sub {
+ $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 0 });
+ }, qr/Your DB is currently unversioned/, 'warning detected without env var or attr');
}
# attempt a deploy/upgrade cycle within one second
-TODO: {
-
- local $TODO = 'To fix this properly the table must be extended with an autoinc column, mst will not accept anything less';
-
- eval { $schema_orig->storage->dbh->do('drop table ' . $version_table_name) };
- eval { $schema_orig->storage->dbh->do('drop table ' . $old_table_name) };
- eval { $schema_orig->storage->dbh->do('drop table TestVersion') };
+{
+ eval { $schema_v2->storage->dbh->do('drop table ' . $version_table_name) };
+ eval { $schema_v2->storage->dbh->do('drop table ' . $old_table_name) };
+ eval { $schema_v2->storage->dbh->do('drop table TestVersion') };
# this attempts to sleep until the turn of the second
my $t = time();
sleep (int ($t) + 1 - $t);
- diag ('Fast deploy/upgrade start: ', time() );
+ note ('Fast deploy/upgrade start: ', time() );
{
- local $DBICVersion::Schema::VERSION = '1.0';
- $schema_orig->deploy;
+ local $DBICVersion::Schema::VERSION = '2.0';
+ $schema_v2->deploy;
}
local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
- $schema_upgrade->upgrade();
+ $schema_v2->upgrade();
- is($schema_upgrade->get_db_version(), '2.0', 'Fast deploy/upgrade');
+ is($schema_v2->get_db_version(), '3.0', 'Fast deploy/upgrade');
};
unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) {
my ($create_sql, $dsn, $user, $pass);
-if (exists $ENV{DBICTEST_PG_DSN}) {
+if ($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), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10))";
-} elsif (exists $ENV{DBICTEST_MYSQL_DSN}) {
+} elsif ($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(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10)) ENGINE=InnoDB";
-#!/usr/bin/perl
use strict;
use warnings;
+
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
+use DBICTest::Schema;
+use Scalar::Util ();
BEGIN {
require DBIx::Class::Storage::DBI;
if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
}
+# Test for SQLT-related leaks
+{
+ my $s = DBICTest::Schema->clone;
+ create_schema ({ schema => $s });
+ Scalar::Util::weaken ($s);
+
+ ok (!$s, 'Schema not leaked');
+}
+
+
my $schema = DBICTest->init_schema();
# Dummy was yanked out by the sqlt hook test
# CustomSql tests the horrific/deprecated ->name(\$sql) hack
$schema->sources
;
-{
- my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { } } });
+my $idx_exceptions = {
+ 'Artwork' => -1,
+ 'ForceForeign' => -1,
+ 'LinerNotes' => -1,
+ 'TwoKeys' => -1, # TwoKeys has the index turned off on the rel def
+};
+
+{
+ my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { } } });
+
+ foreach my $source_name (@sources) {
+ my $table = get_table($sqlt_schema, $schema, $source_name);
+
+ my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
+ $fk_count += $idx_exceptions->{$source_name} || 0;
+ my @indices = $table->get_indices;
+
+ my $index_count = scalar(@indices);
+ is($index_count, $fk_count, "correct number of indices for $source_name with no args");
+
+ for my $index (@indices) {
+ my $source = $schema->source($source_name);
+ my $pk_test = join("\x00", $source->primary_columns);
+ my $idx_test = join("\x00", $index->fields);
+ isnt ( $pk_test, $idx_test, "no additional index for the primary columns exists in $source_name");
+ }
+ }
+}
+
+{
+ my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 1 } } });
- foreach my $source (@sources) {
- my $table = get_table($sqlt_schema, $schema, $source);
+ foreach my $source_name (@sources) {
+ my $table = get_table($sqlt_schema, $schema, $source_name);
- 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 $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
+ $fk_count += $idx_exceptions->{$source_name} || 0;
+ my @indices = $table->get_indices;
+ my $index_count = scalar(@indices);
+ is($index_count, $fk_count, "correct number of indices for $source_name with add_fk_index => 1");
+ }
}
-{
- my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 1 } } });
+{
+ my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 0 } } });
- foreach my $source (@sources) {
- my $table = get_table($sqlt_schema, $schema, $source);
+ foreach my $source (@sources) {
+ my $table = get_table($sqlt_schema, $schema, $source);
- 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 @indices = $table->get_indices;
+ my $index_count = scalar(@indices);
+ is($index_count, 0, "correct number of indices for $source with add_fk_index => 0");
+ }
}
-{
- my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 0 } } });
+{
+ {
+ package # hide from PAUSE
+ DBICTest::Schema::NoViewDefinition;
- foreach my $source (@sources) {
- my $table = get_table($sqlt_schema, $schema, $source);
+ use base qw/DBICTest::BaseResult/;
- 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");
- }
+ __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+ __PACKAGE__->table('noviewdefinition');
+
+ 1;
+ }
+
+ my $schema_invalid_view = $schema->clone;
+ $schema_invalid_view->register_class('NoViewDefinition', 'DBICTest::Schema::NoViewDefinition');
+
+ throws_ok { create_schema({ schema => $schema_invalid_view }) }
+ qr/view noviewdefinition is missing a view_definition/,
+ 'parser detects views with a view_definition';
}
+lives_ok (sub {
+ my $sqlt_schema = create_schema ({
+ schema => $schema,
+ args => {
+ parser_args => {
+ sources => ['CD']
+ },
+ },
+ });
+
+ is_deeply (
+ [$sqlt_schema->get_tables ],
+ ['cd'],
+ 'sources limitng with relationships works',
+ );
+
+});
+
done_testing;
sub create_schema {
- my $args = shift;
+ my $args = shift;
- my $schema = $args->{schema};
- my $additional_sqltargs = $args->{args} || {};
+ 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 $sqltargs = {
+ add_drop_table => 1,
+ ignore_constraint_names => 1,
+ ignore_index_names => 1,
+ %{$additional_sqltargs}
+ };
- my $sqlt = SQL::Translator->new( $sqltargs );
+ my $sqlt = SQL::Translator->new( $sqltargs );
- $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
- return $sqlt->translate({ data => $schema }) or die $sqlt->error;
+ $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
+ return $sqlt->translate({ data => $schema }) || die $sqlt->error;
}
sub get_table {
->search({ artistid => 1});
is ( $rs->count, 1, 'where/bind first' );
-
+
$rs = $schema->resultset('Artist')->search({ artistid => 1})
->search({}, $where_bind);
$rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] });
is_same_sql_bind(
$rs->as_query,
- "(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) WHERE title LIKE ?)",
+ "(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) me WHERE title LIKE ?)",
[
[ '!!dummy' => '1999' ],
[ '!!dummy' => 'Spoon%' ]
$rs = $schema->resultset('CustomSql')->search({}, { bind => [ 1999 ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] });
is_same_sql_bind(
$rs->as_query,
- "(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) WHERE title LIKE ?)",
+ "(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) me WHERE title LIKE ?)",
[
[ '!!dummy' => '1999' ],
[ '!!dummy' => 'Spoon%' ]
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
unless ($dsn && $dbuser);
-
+
plan tests => 6;
my $schema = DBICTest::Schema->connection($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
],{ RaiseError => 1, PrintError => 1 });
}
-my $big_long_string = "\x00\x01\x02 abcd" x 125000;
+my $big_long_string = "\x00\x01\x02 abcd" x 125000;
my $new;
# test inserting a row
$new = $schema->resultset('BindType')->create({ bytea => $big_long_string });
ok($new->id, "Created a bytea row");
- is($new->bytea, $big_long_string, "Set the blob correctly.");
+ is($new->bytea, $big_long_string, "Set the blob correctly.");
}
# test retrieval of the bytea column
#State->has_many(cities => "City");
sub accessor_name_for {
- my ($class, $column) = @_;
- my $return = $column eq "Rain" ? "Rainfall" : $column;
- return $return;
+ my ($class, $column) = @_;
+ my $return = $column eq "Rain" ? "Rainfall" : $column;
+ return $return;
}
sub mutator_name_for {
- my ($class, $column) = @_;
- my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column";
- return $return;
+ my ($class, $column) = @_;
+ my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column";
+ return $return;
}
sub Snowfall { 1 }
is(State->table, 'State', 'State table()');
is(State->primary_column, 'name', 'State primary()');
is_deeply [ State->columns('Primary') ] => [qw/name/],
- 'State Primary:' . join ", ", State->columns('Primary');
+ 'State Primary:' . join ", ", State->columns('Primary');
is_deeply [ sort State->columns('Essential') ] => [qw/abbreviation name/],
- 'State Essential:' . join ", ", State->columns('Essential');
+ 'State Essential:' . join ", ", State->columns('Essential');
is_deeply [ sort State->columns('All') ] =>
- [ sort qw/name abbreviation rain snowfall capital population/ ],
- 'State All:' . join ", ", State->columns('All');
+ [ sort qw/name abbreviation rain snowfall capital population/ ],
+ 'State All:' . join ", ", State->columns('All');
is(CD->primary_column, 'artist', 'CD primary()');
is_deeply [ CD->columns('Primary') ] => [qw/artist/],
- 'CD primary:' . join ", ", CD->columns('Primary');
+ 'CD primary:' . join ", ", CD->columns('Primary');
is_deeply [ sort CD->columns('All') ] => [qw/artist length title/],
- 'CD all:' . join ", ", CD->columns('All');
+ 'CD all:' . join ", ", CD->columns('All');
is_deeply [ sort CD->columns('Essential') ] => [qw/artist/],
- 'CD essential:' . join ", ", CD->columns('Essential');
+ 'CD essential:' . join ", ", CD->columns('Essential');
ok(State->find_column('Rain'), 'find_column Rain');
ok(State->find_column('rain'), 'find_column rain');
ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG');
{
-
+
can_ok +State => qw/Rainfall _Rainfall_accessor set_Rainfall
- _set_Rainfall_accessor Snowfall _Snowfall_accessor set_Snowfall
- _set_Snowfall_accessor/;
-
- foreach my $method (qw/Rain _Rain_accessor rain snowfall/) {
- ok !State->can($method), "State can't $method";
+ _set_Rainfall_accessor Snowfall _Snowfall_accessor set_Snowfall
+ _set_Snowfall_accessor/;
+
+ foreach my $method (qw/Rain _Rain_accessor rain snowfall/) {
+ ok !State->can($method), "State can't $method";
}
}
{
- SKIP: {
- skip "No column objects", 1;
+ SKIP: {
+ skip "No column objects", 1;
- eval { my @grps = State->__grouper->groups_for("Huh"); };
- ok $@, "Huh not in groups";
- }
+ eval { my @grps = State->__grouper->groups_for("Huh"); };
+ ok $@, "Huh not in groups";
+ }
- my @grps = sort State->__grouper->groups_for(State->_find_columns(qw/rain capital/));
- is @grps, 2, "Rain and Capital = 2 groups";
+ my @grps = sort State->__grouper->groups_for(State->_find_columns(qw/rain capital/));
+ is @grps, 2, "Rain and Capital = 2 groups";
@grps = sort @grps; # Because the underlying API is hash-based
- is $grps[0], 'Other', " - Other";
- is $grps[1], 'Weather', " - Weather";
+ is $grps[0], 'Other', " - Other";
+ is $grps[1], 'Weather', " - Weather";
}
#{
-#
+#
# package DieTest;
# @DieTest::ISA = qw(DBIx::Class);
# DieTest->load_components(qw/CDBICompat::Retrieve Core/);
# package main;
-# local $SIG{__WARN__} = sub { };
-# eval { DieTest->retrieve(1) };
-# like $@, qr/unless primary columns are defined/, "Need primary key for retrieve";
+# local $SIG{__WARN__} = sub { };
+# eval { DieTest->retrieve(1) };
+# like $@, qr/unless primary columns are defined/, "Need primary key for retrieve";
#}
#-----------------------------------------------------------------------
}
INIT {
- use lib 't/cdbi/testlib';
- use Film;
+ use lib 't/cdbi/testlib';
+ use Film;
}
ok(Film->can('db_Main'), 'set_db()');
is(Film->__driver, "SQLite", "Driver set correctly");
{
- my $nul = eval { Film->retrieve() };
- is $nul, undef, "Can't retrieve nothing";
- like $@, qr/./, "retrieve needs parameters"; # TODO fix this...
+ my $nul = eval { Film->retrieve() };
+ is $nul, undef, "Can't retrieve nothing";
+ like $@, qr/./, "retrieve needs parameters"; # TODO fix this...
}
{
- eval { my $id = Film->id };
- like $@, qr/class method/, "Can't get id with no object";
+ eval { my $id = Film->id };
+ like $@, qr/class method/, "Can't get id with no object";
}
{
- eval { my $id = Film->title };
- #like $@, qr/class method/, "Can't get title with no object";
- ok $@, "Can't get title with no object";
+ eval { my $id = Film->title };
+ #like $@, qr/class method/, "Can't get title with no object";
+ ok $@, "Can't get title with no object";
}
eval { my $duh = Film->insert; };
is($btaste->NumExplodingSheep, 1, 'NumExplodingSheep() get');
{
- my $bt2 = Film->find_or_create(Title => 'Bad Taste');
- is $bt2->Director, $btaste->Director, "find_or_create";
- my @bt = Film->search(Title => 'Bad Taste');
- is @bt, 1, " doesn't create a new one";
+ my $bt2 = Film->find_or_create(Title => 'Bad Taste');
+ is $bt2->Director, $btaste->Director, "find_or_create";
+ my @bt = Film->search(Title => 'Bad Taste');
+ is @bt, 1, " doesn't create a new one";
}
ok my $gone = Film->find_or_create(
- {
- Title => 'Gone With The Wind',
- Director => 'Bob Baggadonuts',
- Rating => 'PG',
- NumExplodingSheep => 0
- }
- ),
- "Add Gone With The Wind";
+ {
+ Title => 'Gone With The Wind',
+ Director => 'Bob Baggadonuts',
+ Rating => 'PG',
+ NumExplodingSheep => 0
+ }
+ ),
+ "Add Gone With The Wind";
isa_ok $gone, 'Film';
ok $gone = Film->retrieve(Title => 'Gone With The Wind'),
- "Fetch it back again";
+ "Fetch it back again";
isa_ok $gone, 'Film';
# Shocking new footage found reveals bizarre Scarlet/sheep scene!
$gone->update;
{
- my @films = eval { Film->retrieve_all };
- cmp_ok(@films, '==', 2, "We have 2 films in total");
+ my @films = eval { Film->retrieve_all };
+ cmp_ok(@films, '==', 2, "We have 2 films in total");
}
# EXTRA TEST: added by mst to check a bug found by Numa
# Grab the 'Bladerunner' entry.
Film->create(
- {
- Title => 'Bladerunner',
- Director => 'Bob Ridley Scott',
- Rating => 'R'
- }
+ {
+ Title => 'Bladerunner',
+ Director => 'Bob Ridley Scott',
+ Rating => 'R'
+ }
);
my $blrunner = Film->retrieve('Bladerunner');
# Make a copy of 'Bladerunner' and create an entry of the directors cut
my $blrunner_dc = $blrunner->copy(
- {
- title => "Bladerunner: Director's Cut",
- rating => "15",
- }
+ {
+ title => "Bladerunner: Director's Cut",
+ rating => "15",
+ }
);
is(ref $blrunner_dc, 'Film', "copy() produces a film");
is($blrunner_dc->Title, "Bladerunner: Director's Cut", 'Title correct');
# Set up own SQL:
{
- 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 => "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->Title, "Ordered correctly";
- }
- {
- my @films = Film->title_desc("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";
- }
+ {
+ my @films = Film->title_asc("Bladerunner%");
+ is @films, 2, "We have 2 Bladerunners";
+ is $films[0]->Title, $blrunner->Title, "Ordered correctly";
+ }
+ {
+ my @films = Film->title_desc("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
{
- my @films = $blrunner->search (title => { -like => "Bladerunner%"}, rating => '15');
- is @films, 1, "Only one Bladerunner is a 15";
+ my @films = $blrunner->search (title => { -like => "Bladerunner%"}, rating => '15');
+ is @films, 1, "Only one Bladerunner is a 15";
}
# Inline SQL
{
- my @films = Film->retrieve_from_sql("numexplodingsheep > 0 ORDER BY title");
- is @films, 2, "Inline SQL";
- is $films[0]->id, $btaste->id, "Correct film";
- is $films[1]->id, $gone->id, "Correct film";
+ my @films = Film->retrieve_from_sql("numexplodingsheep > 0 ORDER BY title");
+ is @films, 2, "Inline SQL";
+ is $films[0]->id, $btaste->id, "Correct film";
+ is $films[1]->id, $gone->id, "Correct film";
}
# Inline SQL removes WHERE
{
- my @films =
- Film->retrieve_from_sql(" WHErE numexplodingsheep > 0 ORDER BY title");
- is @films, 2, "Inline SQL";
- is $films[0]->id, $btaste->id, "Correct film";
- is $films[1]->id, $gone->id, "Correct film";
+ my @films =
+ Film->retrieve_from_sql(" WHErE numexplodingsheep > 0 ORDER BY title");
+ is @films, 2, "Inline SQL";
+ is $films[0]->id, $btaste->id, "Correct film";
+ is $films[1]->id, $gone->id, "Correct film";
}
eval {
- my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' });
- my $mandn =
- Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
- my $new_leaf =
- Film->insert({ Title => 'A New Leaf', Director => 'Elaine May' });
+ my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' });
+ my $mandn =
+ Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' });
+ my $new_leaf =
+ 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,
- "3 Films by Elaine May");
- ok(Film->retrieve('Ishtar')->delete,
- "Ishtar doesn't deserve an entry any more");
- ok(!Film->retrieve('Ishtar'), 'Ishtar no longer there');
- {
- my $deprecated = 0;
- local $SIG{__WARN__} = sub { $deprecated++ if $_[0] =~ /deprecated/ };
- ok(
- Film->delete(Director => 'Elaine May'),
- "In fact, delete all films by Elaine May"
- );
- cmp_ok(Film->search(Director => 'Elaine May'), '==',
- 0, "0 Films by Elaine May");
- is $deprecated, 0, "No deprecated warnings from compat layer";
- }
+ cmp_ok(Film->search(Director => 'Elaine May'), '==', 3,
+ "3 Films by Elaine May");
+ ok(Film->retrieve('Ishtar')->delete,
+ "Ishtar doesn't deserve an entry any more");
+ ok(!Film->retrieve('Ishtar'), 'Ishtar no longer there');
+ {
+ my $deprecated = 0;
+ local $SIG{__WARN__} = sub { $deprecated++ if $_[0] =~ /deprecated/ };
+ ok(
+ Film->delete(Director => 'Elaine May'),
+ "In fact, delete all films by Elaine May"
+ );
+ cmp_ok(Film->search(Director => 'Elaine May'), '==',
+ 0, "0 Films by Elaine May");
+ is $deprecated, 0, "No deprecated warnings from compat layer";
+ }
};
is $@, '', "No problems with deletes";
@films = Film->search ( { 'Director' => { -like => 'Bob %' } });
is(scalar @films, 3, ' search_like returns 3 films');
ok(
- eq_array(
- [ sort map { $_->id } @films ],
- [ sort map { $_->id } $blrunner_dc, $gone, $blrunner ]
- ),
- 'the correct ones'
+ eq_array(
+ [ sort map { $_->id } @films ],
+ [ sort map { $_->id } $blrunner_dc, $gone, $blrunner ]
+ ),
+ 'the correct ones'
);
# Find Ridley Scott films which don't have vomit
@films =
- Film->search(numExplodingSheep => undef, Director => 'Bob Ridley Scott');
+ Film->search(numExplodingSheep => undef, Director => 'Bob Ridley Scott');
is(scalar @films, 2, ' search where attribute is null returns 2 films');
ok(
- eq_array(
- [ sort map { $_->id } @films ],
- [ sort map { $_->id } $blrunner_dc, $blrunner ]
- ),
- 'the correct ones'
+ eq_array(
+ [ sort map { $_->id } @films ],
+ [ sort map { $_->id } $blrunner_dc, $blrunner ]
+ ),
+ 'the correct ones'
);
# Test that a disconnect doesnt harm anything.
}
SKIP: {
- skip "ActiveState perl produces additional warnings", 3
+ skip "ActiveState perl produces additional warnings", 3
if ($^O eq 'MSWin32');
- Film->autoupdate(1);
- my $btaste2 = Film->retrieve($btaste->id);
- $btaste->NumExplodingSheep(18);
- my @warnings;
- local $SIG{__WARN__} = sub { push(@warnings, @_); };
- {
-
- # unhook from live object cache, so next one is not from cache
- $btaste2->remove_from_object_index;
- my $btaste3 = Film->retrieve($btaste->id);
- is $btaste3->NumExplodingSheep, 18, "Class based AutoCommit";
- $btaste3->autoupdate(0); # obj a/c should override class a/c
- is @warnings, 0, "No warnings so far";
- $btaste3->NumExplodingSheep(13);
- }
- is @warnings, 1, "DESTROY without update warns";
- Film->autoupdate(0);
+ Film->autoupdate(1);
+ my $btaste2 = Film->retrieve($btaste->id);
+ $btaste->NumExplodingSheep(18);
+ my @warnings;
+ local $SIG{__WARN__} = sub { push(@warnings, @_); };
+ {
+
+ # unhook from live object cache, so next one is not from cache
+ $btaste2->remove_from_object_index;
+ my $btaste3 = Film->retrieve($btaste->id);
+ is $btaste3->NumExplodingSheep, 18, "Class based AutoCommit";
+ $btaste3->autoupdate(0); # obj a/c should override class a/c
+ is @warnings, 0, "No warnings so far";
+ $btaste3->NumExplodingSheep(13);
+ }
+ is @warnings, 1, "DESTROY without update warns";
+ Film->autoupdate(0);
}
{ # update unchanged object
- my $film = Film->retrieve($btaste->id);
- my $retval = $film->update;
- is $retval, -1, "Unchanged object";
+ my $film = Film->retrieve($btaste->id);
+ my $retval = $film->update;
+ is $retval, -1, "Unchanged object";
}
{ # update deleted object
- my $rt = "Royal Tenenbaums";
- 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);
- my @films = Film->search({ title => $rt });
- is @films, 0, "RT gone";
- my $retval = eval { $ten->update };
- like $@, qr/row not found/, "Update deleted object throws error";
- $ten->discard_changes;
+ my $rt = "Royal Tenenbaums";
+ 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);
+ my @films = Film->search({ title => $rt });
+ is @films, 0, "RT gone";
+ my $retval = eval { $ten->update };
+ like $@, qr/row not found/, "Update deleted object throws error";
+ $ten->discard_changes;
}
{
- $btaste->autoupdate(1);
- $btaste->NumExplodingSheep(32);
- my $btaste2 = Film->retrieve($btaste->id);
- is $btaste2->NumExplodingSheep, 32, "Object based AutoCommit";
- $btaste->autoupdate(0);
+ $btaste->autoupdate(1);
+ $btaste->NumExplodingSheep(32);
+ my $btaste2 = Film->retrieve($btaste->id);
+ is $btaste2->NumExplodingSheep, 32, "Object based AutoCommit";
+ $btaste->autoupdate(0);
}
# Primary key of 0
{
- 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";
- is $ret->Rating, "U", "Rating OK";
+ 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";
+ is $ret->Rating, "U", "Rating OK";
}
# Change after_update policy
SKIP: {
skip "DBIx::Class compat doesn't handle the exists stuff quite right yet", 4;
- my $bt = Film->retrieve($btaste->id);
- $bt->autoupdate(1);
-
- $bt->rating("17");
- ok !$bt->_attribute_exists('rating'), "changed column needs reloaded";
- ok $bt->_attribute_exists('title'), "but we still have the title";
-
- # Don't re-load
- $bt->add_trigger(
- after_update => sub {
- my ($self, %args) = @_;
- my $discard_columns = $args{discard_columns};
- @$discard_columns = qw/title/;
- }
- );
- $bt->rating("19");
- ok $bt->_attribute_exists('rating'), "changed column needs reloaded";
- ok !$bt->_attribute_exists('title'), "but no longer have the title";
+ my $bt = Film->retrieve($btaste->id);
+ $bt->autoupdate(1);
+
+ $bt->rating("17");
+ ok !$bt->_attribute_exists('rating'), "changed column needs reloaded";
+ ok $bt->_attribute_exists('title'), "but we still have the title";
+
+ # Don't re-load
+ $bt->add_trigger(
+ after_update => sub {
+ my ($self, %args) = @_;
+ my $discard_columns = $args{discard_columns};
+ @$discard_columns = qw/title/;
+ }
+ );
+ $bt->rating("19");
+ ok $bt->_attribute_exists('rating'), "changed column needs reloaded";
+ ok !$bt->_attribute_exists('title'), "but no longer have the title";
}
# Make sure that we can have other accessors. (Bugfix in 0.28)
if (0) {
- Film->mk_accessors(qw/temp1 temp2/);
- my $blrunner = Film->retrieve('Bladerunner');
- $blrunner->temp1("Foo");
- $blrunner->NumExplodingSheep(2);
- eval { $blrunner->update };
- ok(!$@, "Other accessors");
+ Film->mk_accessors(qw/temp1 temp2/);
+ my $blrunner = Film->retrieve('Bladerunner');
+ $blrunner->temp1("Foo");
+ $blrunner->NumExplodingSheep(2);
+ eval { $blrunner->update };
+ ok(!$@, "Other accessors");
}
# overloading
{
- is "$blrunner", "Bladerunner", "stringify";
+ is "$blrunner", "Bladerunner", "stringify";
- ok(Film->columns(Stringify => 'rating'), "Can change stringify column");
- is "$blrunner", "R", "And still stringifies correctly";
+ ok(Film->columns(Stringify => 'rating'), "Can change stringify column");
+ is "$blrunner", "R", "And still stringifies correctly";
- ok(
- Film->columns(Stringify => qw/title rating/),
- "Can have multiple stringify columns"
- );
- is "$blrunner", "Bladerunner/R", "And still stringifies correctly";
+ ok(
+ Film->columns(Stringify => qw/title rating/),
+ "Can have multiple stringify columns"
+ );
+ is "$blrunner", "Bladerunner/R", "And still stringifies correctly";
- no warnings 'once';
- local *Film::stringify_self = sub { join ":", $_[0]->title, $_[0]->rating };
- is "$blrunner", "Bladerunner:R", "Provide stringify_self()";
+ no warnings 'once';
+ local *Film::stringify_self = sub { join ":", $_[0]->title, $_[0]->rating };
+ is "$blrunner", "Bladerunner:R", "Provide stringify_self()";
}
{
- {
- ok my $byebye = DeletingFilm->insert(
- {
- Title => 'Goodbye Norma Jean',
- Rating => 'PG',
- }
- ),
- "Add a deleting Film";
-
- isa_ok $byebye, 'DeletingFilm';
- isa_ok $byebye, 'Film';
- ok(Film->retrieve('Goodbye Norma Jean'), "Fetch it back again");
- }
- my $film;
- eval { $film = Film->retrieve('Goodbye Norma Jean') };
- ok !$film, "It destroys itself";
+ {
+ ok my $byebye = DeletingFilm->insert(
+ {
+ Title => 'Goodbye Norma Jean',
+ Rating => 'PG',
+ }
+ ),
+ "Add a deleting Film";
+
+ isa_ok $byebye, 'DeletingFilm';
+ isa_ok $byebye, 'Film';
+ ok(Film->retrieve('Goodbye Norma Jean'), "Fetch it back again");
+ }
+ my $film;
+ eval { $film = Film->retrieve('Goodbye Norma Jean') };
+ ok !$film, "It destroys itself";
}
SKIP: {
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');
- my $btaste2 = Film->retrieve('Bad Taste');
- is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
- "Retrieving twice gives ref to same object";
-
- my ($btaste5) = Film->search(title=>'Bad Taste');
- is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste5),
- "Searching also gives ref to same object";
-
- $btaste2->remove_from_object_index;
- my $btaste3 = Film->retrieve('Bad Taste');
- isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste3),
- "Removing from object_index and retrieving again gives new object";
-
- $btaste3->clear_object_index;
- my $btaste4 = Film->retrieve('Bad Taste');
- isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4),
- "Clearing cache and retrieving again gives new object";
+ # my bad taste is your bad taste
+ my $btaste = Film->retrieve('Bad Taste');
+ my $btaste2 = Film->retrieve('Bad Taste');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
+ "Retrieving twice gives ref to same object";
+
+ my ($btaste5) = Film->search(title=>'Bad Taste');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste5),
+ "Searching also gives ref to same object";
+
+ $btaste2->remove_from_object_index;
+ my $btaste3 = Film->retrieve('Bad Taste');
+ isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste3),
+ "Removing from object_index and retrieving again gives new object";
+
+ $btaste3->clear_object_index;
+ my $btaste4 = Film->retrieve('Bad Taste');
+ isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4),
+ "Clearing cache and retrieving again gives new object";
$btaste=Film->insert({
- Title => 'Bad Taste 2',
- Director => 'Peter Jackson',
- Rating => 'R',
- NumExplodingSheep => 2,
- });
- $btaste2 = Film->retrieve('Bad Taste 2');
- is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
- "Creating and retrieving gives ref to same object";
+ Title => 'Bad Taste 2',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 2,
+ });
+ $btaste2 = Film->retrieve('Bad Taste 2');
+ is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
+ "Creating and retrieving gives ref to same object";
}
ok(Film::Threat->db_Main->ping, 'subclass db_Main()');
is_deeply [ sort Film::Threat->columns ], [ sort Film->columns ],
- 'has the same columns';
+ 'has the same columns';
my $bt = Film->create_test_film;
ok my $btaste = Film::Threat->retrieve('Bad Taste'), "subclass retrieve";
}
INIT {
- use lib 't/cdbi/testlib';
- use Lazy;
+ use lib 't/cdbi/testlib';
+ use Lazy;
}
is_deeply [ Lazy->columns('Primary') ], [qw/this/], "Pri";
is_deeply [ sort Lazy->columns('All') ], [qw/eep oop opop orp that this/], "All";
{
- my @groups = Lazy->__grouper->groups_for(Lazy->find_column('this'));
- is_deeply [ sort @groups ], [sort qw/things Essential Primary/], "this (@groups)";
+ my @groups = Lazy->__grouper->groups_for(Lazy->find_column('this'));
+ is_deeply [ sort @groups ], [sort qw/things Essential Primary/], "this (@groups)";
}
{
- my @groups = Lazy->__grouper->groups_for(Lazy->find_column('that'));
- is_deeply \@groups, [qw/things/], "that (@groups)";
+ my @groups = Lazy->__grouper->groups_for(Lazy->find_column('that'));
+ is_deeply \@groups, [qw/things/], "that (@groups)";
}
Lazy->create({ this => 1, that => 2, oop => 3, opop => 4, eep => 5 });
ok(!$obj->_attribute_exists('that'), 'nor that');
{
- Lazy->columns(All => qw/this that eep orp oop opop/);
- ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary');
- ok !$obj->_attribute_exists('oop'), " Don't have oop";
- my $null = $obj->eep;
- ok !$obj->_attribute_exists('oop'),
- " Don't have oop - even after getting eep";
+ Lazy->columns(All => qw/this that eep orp oop opop/);
+ ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary');
+ ok !$obj->_attribute_exists('oop'), " Don't have oop";
+ my $null = $obj->eep;
+ ok !$obj->_attribute_exists('oop'),
+ " Don't have oop - even after getting eep";
}
# Test contructor breaking.
eval { # Need a hashref
- Lazy->create(this => 10, that => 20, oop => 30, opop => 40, eep => 50);
+ Lazy->create(this => 10, that => 20, oop => 30, opop => 40, eep => 50);
};
ok($@, $@);
eval { # False column
- Lazy->create({ this => 10, that => 20, theother => 30 });
+ Lazy->create({ this => 10, that => 20, theother => 30 });
};
ok($@, $@);
eval { # Multiple false columns
- Lazy->create({ this => 10, that => 20, theother => 30, andanother => 40 });
+ Lazy->create({ this => 10, that => 20, theother => 30, andanother => 40 });
};
ok($@, $@);
#local $SIG{__WARN__} = sub { };
INIT {
- use lib 't/cdbi/testlib';
- use Film;
- use Director;
+ use lib 't/cdbi/testlib';
+ use Film;
+ use Director;
}
Film->create_test_film;
ok(Film->has_a('Director' => 'Director'), "Link Director table");
ok(
- Director->create(
- {
- Name => 'Peter Jackson',
- Birthday => -300000000,
- IsInsane => 1
- }
- ),
- 'create Director'
+ Director->create(
+ {
+ Name => 'Peter Jackson',
+ Birthday => -300000000,
+ IsInsane => 1
+ }
+ ),
+ 'create Director'
);
$btaste = Film->retrieve('Bad Taste');
# Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him.
my $sj = Director->create(
- {
- Name => 'Skippy Jackson',
- Birthday => (-300000000 + 60),
- IsInsane => 1,
- }
+ {
+ Name => 'Skippy Jackson',
+ Birthday => (-300000000 + 60),
+ IsInsane => 1,
+ }
);
is($sj->id, 'Skippy Jackson', 'We have a new director');
$btaste->update;
is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed');
is(
- $btaste->Director->Name,
- 'Peter Jackson',
- "Didnt interfere with each other"
+ $btaste->Director->Name,
+ 'Peter Jackson',
+ "Didnt interfere with each other"
);
{ # Ensure search can take an object
- my @films = Film->search(Director => $pj);
- is @films, 1, "1 Film directed by $pj";
- is $films[0]->id, "Bad Taste", "Bad Taste";
+ my @films = Film->search(Director => $pj);
+ is @films, 1, "1 Film directed by $pj";
+ is $films[0]->id, "Bad Taste", "Bad Taste";
}
inheriting_hasa();
{
- # Skippy directs a film and Peter helps!
- $sj = Director->retrieve('Skippy Jackson');
- $pj = Director->retrieve('Peter Jackson');
+ # Skippy directs a film and Peter helps!
+ $sj = Director->retrieve('Skippy Jackson');
+ $pj = Director->retrieve('Peter Jackson');
- fail_with_bad_object($sj, $btaste);
- taste_bad($sj, $pj);
+ fail_with_bad_object($sj, $btaste);
+ taste_bad($sj, $pj);
}
sub inheriting_hasa {
- my $btaste = YA::Film->retrieve('Bad Taste');
- is(ref($btaste->Director), 'Director', 'inheriting has_a()');
- is(ref($btaste->CoDirector), 'Director', 'inheriting has_a()');
- is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
+ my $btaste = YA::Film->retrieve('Bad Taste');
+ is(ref($btaste->Director), 'Director', 'inheriting has_a()');
+ is(ref($btaste->CoDirector), 'Director', 'inheriting has_a()');
+ is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
}
sub taste_bad {
- my ($dir, $codir) = @_;
- my $tastes_bad = YA::Film->create(
- {
- Title => 'Tastes Bad',
- Director => $dir,
- CoDirector => $codir,
- Rating => 'R',
- NumExplodingSheep => 23
- }
- );
- is($tastes_bad->_Director_accessor, 'Skippy Jackson', 'Director_accessor');
- is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director');
- is($tastes_bad->CoDirector->Name, 'Peter Jackson', 'CoDirector');
- is(
- $tastes_bad->_CoDirector_accessor,
- 'Peter Jackson',
- 'CoDirector_accessor'
- );
+ my ($dir, $codir) = @_;
+ my $tastes_bad = YA::Film->create(
+ {
+ Title => 'Tastes Bad',
+ Director => $dir,
+ CoDirector => $codir,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ }
+ );
+ is($tastes_bad->_Director_accessor, 'Skippy Jackson', 'Director_accessor');
+ is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director');
+ is($tastes_bad->CoDirector->Name, 'Peter Jackson', 'CoDirector');
+ is(
+ $tastes_bad->_CoDirector_accessor,
+ 'Peter Jackson',
+ 'CoDirector_accessor'
+ );
}
sub fail_with_bad_object {
- my ($dir, $codir) = @_;
- eval {
- YA::Film->create(
- {
- Title => 'Tastes Bad',
- Director => $dir,
- CoDirector => $codir,
- Rating => 'R',
- NumExplodingSheep => 23
- }
- );
- };
- ok $@, $@;
+ my ($dir, $codir) = @_;
+ eval {
+ YA::Film->create(
+ {
+ Title => 'Tastes Bad',
+ Director => $dir,
+ CoDirector => $codir,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ }
+ );
+ };
+ ok $@, $@;
}
package Foo;
# fav is a film
__PACKAGE__->db_Main->do( qq{
CREATE TABLE foo (
- id INTEGER,
- fav VARCHAR(255)
+ id INTEGER,
+ fav VARCHAR(255)
)
});
# fav is a foo
__PACKAGE__->db_Main->do( qq{
CREATE TABLE bar (
- id INTEGER,
- fav INTEGER
+ id INTEGER,
+ fav INTEGER
)
});
isa_ok($foo->fav, "Film");
{
- my $foo;
- Foo->add_trigger(after_create => sub { $foo = shift->fav });
- my $gwh = Foo->create({ id => 93, fav => 'Good Will Hunting' });
- isa_ok $foo, "Film", "Object in after_create trigger";
+ my $foo;
+ Foo->add_trigger(after_create => sub { $foo = shift->fav });
+ my $gwh = Foo->create({ id => 93, fav => 'Good Will Hunting' });
+ isa_ok $foo, "Film", "Object in after_create trigger";
}
ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste");
ok(
- my $pvj = Actor->create(
- {
- Name => 'Peter Vere-Jones',
- Film => undef,
- Salary => '30_000', # For a voice!
- }
- ),
- 'create Actor'
+ my $pvj = Actor->create(
+ {
+ Name => 'Peter Vere-Jones',
+ Film => undef,
+ Salary => '30_000', # For a voice!
+ }
+ ),
+ 'create Actor'
);
is $pvj->Name, "Peter Vere-Jones", "PVJ name ok";
is $pvj->Film, undef, "No film";
$pvj->update;
is $pvj->Film->id, $btaste->id, "Now film";
{
- my @actors = $btaste->actors;
- is(@actors, 1, "Bad taste has one actor");
- is($actors[0]->Name, $pvj->Name, " - the correct one");
+ my @actors = $btaste->actors;
+ is(@actors, 1, "Bad taste has one actor");
+ is($actors[0]->Name, $pvj->Name, " - the correct one");
}
my %pj_data = (
- Name => 'Peter Jackson',
- Salary => '0', # it's a labour of love
+ Name => 'Peter Jackson',
+ Salary => '0', # it's a labour of love
);
eval { my $pj = Film->add_to_actors(\%pj_data) };
like $@, qr/needs/, "add_to_actors takes hash";
ok(
- my $pj = $btaste->add_to_actors(
- {
- Name => 'Peter Jackson',
- Salary => '0', # it's a labour of love
- }
- ),
- 'add_to_actors'
+ my $pj = $btaste->add_to_actors(
+ {
+ Name => 'Peter Jackson',
+ Salary => '0', # it's a labour of love
+ }
+ ),
+ 'add_to_actors'
);
is $pj->Name, "Peter Jackson", "PJ ok";
is $pvj->Name, "Peter Vere-Jones", "PVJ still ok";
{
- my @actors = $btaste->actors;
- is @actors, 2, " - so now we have 2";
- is $actors[0]->Name, $pj->Name, "PJ first";
- is $actors[1]->Name, $pvj->Name, "PVJ first";
+ my @actors = $btaste->actors;
+ is @actors, 2, " - so now we have 2";
+ is $actors[0]->Name, $pj->Name, "PJ first";
+ is $actors[1]->Name, $pvj->Name, "PVJ first";
}
eval {
- my @actors = $btaste->actors(Name => $pj->Name);
- is @actors, 1, "One actor from restricted (sorted) has_many";
- is $actors[0]->Name, $pj->Name, "It's PJ";
+ my @actors = $btaste->actors(Name => $pj->Name);
+ is @actors, 1, "One actor from restricted (sorted) has_many";
+ is $actors[0]->Name, $pj->Name, "It's PJ";
};
is $@, '', "No errors";
my $as = Actor->create(
- {
- Name => 'Arnold Schwarzenegger',
- Film => 'Terminator 2',
- Salary => '15_000_000'
- }
+ {
+ Name => 'Arnold Schwarzenegger',
+ Film => 'Terminator 2',
+ Salary => '15_000_000'
+ }
);
eval { $btaste->actors($pj, $pvj, $as) };
sub delete_trigger { ::ok(1, "Deleting " . shift->Title) }
sub pre_up_trigger {
- $_[0]->_attribute_set(numexplodingsheep => 1);
- ::ok(1, "Running pre-update trigger");
+ $_[0]->_attribute_set(numexplodingsheep => 1);
+ ::ok(1, "Running pre-update trigger");
}
sub pst_up_trigger { ::ok(1, "Running post-update trigger"); }
Film->add_trigger(after_update => \&pst_up_trigger);
ok(
- my $ver = Film->create({
- title => 'La Double Vie De Veronique',
- director => 'Kryzstof Kieslowski',
+ my $ver = Film->create({
+ title => 'La Double Vie De Veronique',
+ director => 'Kryzstof Kieslowski',
- # rating => '15',
- numexplodingsheep => 0,
- }
- ),
- "Create Veronique"
+ # rating => '15',
+ numexplodingsheep => 0,
+ }
+ ),
+ "Create Veronique"
);
is $ver->Rating, 15, "Default rating";
ok $ver->Rating('12') && $ver->update, "Change the rating";
is $ver->NumExplodingSheep, 1, "Updated object's sheep count";
is + (
- $ver->db_Main->selectall_arrayref(
- 'SELECT numexplodingsheep FROM '
- . $ver->table
- . ' WHERE '
- . $ver->primary_column . ' = '
- . $ver->db_Main->quote($ver->id))
+ $ver->db_Main->selectall_arrayref(
+ 'SELECT numexplodingsheep FROM '
+ . $ver->table
+ . ' WHERE '
+ . $ver->primary_column . ' = '
+ . $ver->db_Main->quote($ver->id))
)->[0]->[0], 1, "Updated database's sheep count";
ok $ver->delete, "Delete";
{
- Film->add_trigger(before_create => sub {
- my $self = shift;
- ok !$self->_attribute_exists('title'), "PK doesn't auto-vivify";
- });
- Film->create({director => "Me"});
+ Film->add_trigger(before_create => sub {
+ my $self = shift;
+ ok !$self->_attribute_exists('title'), "PK doesn't auto-vivify";
+ });
+ Film->create({director => "Me"});
}
my $film2 = Film->create({ Title => 'Another Film' });
my @act = (
- Actor->create(
- {
- name => 'Actor 1',
- film => $film,
- salary => 10,
- }
- ),
- Actor->create(
- {
- name => 'Actor 2',
- film => $film,
- salary => 20,
- }
- ),
- Actor->create(
- {
- name => 'Actor 3',
- film => $film,
- salary => 30,
- }
- ),
- Actor->create(
- {
- name => 'Actor 4',
- film => $film2,
- salary => 50,
- }
- ),
+ Actor->create(
+ {
+ name => 'Actor 1',
+ film => $film,
+ salary => 10,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 2',
+ film => $film,
+ salary => 20,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 3',
+ film => $film,
+ salary => 30,
+ }
+ ),
+ Actor->create(
+ {
+ name => 'Actor 4',
+ film => $film2,
+ salary => 50,
+ }
+ ),
);
eval {
- my @actors = $film->actors(name => 'Actor 1');
- is @actors, 1, "Got one actor from restricted has_many";
- is $actors[0]->name, "Actor 1", "Correct name";
+ my @actors = $film->actors(name => 'Actor 1');
+ is @actors, 1, "Got one actor from restricted has_many";
+ is $actors[0]->name, "Actor 1", "Correct name";
};
is $@, '', "No errors";
{
- my @actors = Actor->double_search("Actor 1", 10);
- is @actors, 1, "Got one actor";
- is $actors[0]->name, "Actor 1", "Correct name";
+ my @actors = Actor->double_search("Actor 1", 10);
+ is @actors, 1, "Got one actor";
+ is $actors[0]->name, "Actor 1", "Correct name";
}
{
- ok my @actors = Actor->salary_between(0, 100), "Range 0 - 100";
- is @actors, 4, "Got all";
+ ok my @actors = Actor->salary_between(0, 100), "Range 0 - 100";
+ is @actors, 4, "Got all";
}
{
- my @actors = Actor->salary_between(100, 200);
- is @actors, 0, "None in Range 100 - 200";
+ my @actors = Actor->salary_between(100, 200);
+ is @actors, 0, "None in Range 100 - 200";
}
{
- ok my @actors = Actor->salary_between(0, 10), "Range 0 - 10";
- is @actors, 1, "Got 1";
- is $actors[0]->name, $act[0]->name, "Actor 1";
+ ok my @actors = Actor->salary_between(0, 10), "Range 0 - 10";
+ is @actors, 1, "Got 1";
+ is $actors[0]->name, $act[0]->name, "Actor 1";
}
{
- ok my @actors = Actor->salary_between(20, 30), "Range 20 - 20";
- @actors = sort { $a->salary <=> $b->salary } @actors;
- is @actors, 2, "Got 2";
- is $actors[0]->name, $act[1]->name, "Actor 2";
- is $actors[1]->name, $act[2]->name, "and Actor 3";
+ ok my @actors = Actor->salary_between(20, 30), "Range 20 - 20";
+ @actors = sort { $a->salary <=> $b->salary } @actors;
+ is @actors, 2, "Got 2";
+ is $actors[0]->name, $act[1]->name, "Actor 2";
+ is $actors[1]->name, $act[2]->name, "and Actor 3";
}
{
- ok my @actors = Actor->search(Film => $film), "Search by object";
- is @actors, 3, "3 actors in film 1";
+ ok my @actors = Actor->search(Film => $film), "Search by object";
+ is @actors, 3, "3 actors in film 1";
}
#----------------------------------------------------------------------
my $it_class = 'DBIx::Class::ResultSet';
sub test_normal_iterator {
- my $it = $film->actors;
- isa_ok $it, $it_class;
- is $it->count, 3, " - with 3 elements";
- my $i = 0;
- while (my $film = $it->next) {
- is $film->name, $act[ $i++ ]->name, "Get $i";
- }
- ok !$it->next, "No more";
- is $it->first->name, $act[0]->name, "Get first";
+ my $it = $film->actors;
+ isa_ok $it, $it_class;
+ is $it->count, 3, " - with 3 elements";
+ my $i = 0;
+ while (my $film = $it->next) {
+ is $film->name, $act[ $i++ ]->name, "Get $i";
+ }
+ ok !$it->next, "No more";
+ is $it->first->name, $act[0]->name, "Get first";
}
test_normal_iterator;
{
- Film->has_many(actor_ids => [ Actor => 'id' ]);
- my $it = $film->actor_ids;
- isa_ok $it, $it_class;
- is $it->count, 3, " - with 3 elements";
- my $i = 0;
- while (my $film_id = $it->next) {
- is $film_id, $act[ $i++ ]->id, "Get id $i";
- }
- ok !$it->next, "No more";
- is $it->first, $act[0]->id, "Get first";
+ Film->has_many(actor_ids => [ Actor => 'id' ]);
+ my $it = $film->actor_ids;
+ isa_ok $it, $it_class;
+ is $it->count, 3, " - with 3 elements";
+ my $i = 0;
+ while (my $film_id = $it->next) {
+ is $film_id, $act[ $i++ ]->id, "Get id $i";
+ }
+ ok !$it->next, "No more";
+ is $it->first, $act[0]->id, "Get first";
}
# make sure nothing gets clobbered;
{
- my @acts = $film->actors->slice(1, 2);
- is @acts, 2, "Slice gives 2 actor";
- is $acts[0]->name, "Actor 2", "Actor 2";
- is $acts[1]->name, "Actor 3", "and actor 3";
+ my @acts = $film->actors->slice(1, 2);
+ is @acts, 2, "Slice gives 2 actor";
+ is $acts[0]->name, "Actor 2", "Actor 2";
+ is $acts[1]->name, "Actor 3", "and actor 3";
}
{
- my @acts = $film->actors->slice(1);
- is @acts, 1, "Slice of 1 actor";
- is $acts[0]->name, "Actor 2", "Actor 2";
+ my @acts = $film->actors->slice(1);
+ is @acts, 1, "Slice of 1 actor";
+ is $acts[0]->name, "Actor 2", "Actor 2";
}
{
- my @acts = $film->actors->slice(2, 8);
- is @acts, 1, "Slice off the end";
- is $acts[0]->name, "Actor 3", "Gets last actor only";
+ my @acts = $film->actors->slice(2, 8);
+ is @acts, 1, "Slice off the end";
+ is $acts[0]->name, "Actor 3", "Gets last actor only";
}
package Class::DBI::My::Iterator;
delete $film->{related_resultsets};
{
- my @acts = $film->actors->slice(1, 2);
- is @acts, 2, "Slice gives 2 results";
- ok eq_set(\@acts, [qw/fred barney/]), "Fred and Barney";
+ my @acts = $film->actors->slice(1, 2);
+ is @acts, 2, "Slice gives 2 results";
+ ok eq_set(\@acts, [qw/fred barney/]), "Fred and Barney";
- ok $film->actors->delete_all, "Can delete via iterator";
- is $film->actors, 0, "no actors left";
+ ok $film->actors->delete_all, "Can delete via iterator";
+ is $film->actors, 0, "no actors left";
- eval { $film->actors->delete_all };
- is $@, '', "Deleting again does no harm";
+ eval { $film->actors->delete_all };
+ is $@, '', "Deleting again does no harm";
}
} # end SKIP block
Film->create_test_film;
{
- ok my $bt = Film->retrieve('Bad Taste'), "Get Film";
- isa_ok $bt, "Film";
- is $bt->info, undef, "No blurb yet";
- # bug where we couldn't write a class with a might_have that didn't_have
- $bt->rating(16);
- eval { $bt->update };
- is $@, '', "No problems updating when don't have";
- is $bt->rating, 16, "Updated OK";
+ ok my $bt = Film->retrieve('Bad Taste'), "Get Film";
+ isa_ok $bt, "Film";
+ is $bt->info, undef, "No blurb yet";
+ # bug where we couldn't write a class with a might_have that didn't_have
+ $bt->rating(16);
+ eval { $bt->update };
+ is $@, '', "No problems updating when don't have";
+ is $bt->rating, 16, "Updated OK";
- is $bt->blurb, undef, "Bad taste has no blurb";
- $bt->blurb("Wibble bar");
- $bt->update;
- is $bt->blurb, "Wibble bar", "And we can write the info";
+ is $bt->blurb, undef, "Bad taste has no blurb";
+ $bt->blurb("Wibble bar");
+ $bt->update;
+ is $bt->blurb, "Wibble bar", "And we can write the info";
}
{
- my $bt = Film->retrieve('Bad Taste');
- my $info = $bt->info;
- isa_ok $info, 'Blurb';
+ my $bt = Film->retrieve('Bad Taste');
+ my $info = $bt->info;
+ isa_ok $info, 'Blurb';
- is $bt->blurb, $info->blurb, "Blurb is the same as fetching the long way";
- ok $bt->blurb("New blurb"), "We can set the blurb";
- $bt->update;
- is $bt->blurb, $info->blurb, "Blurb has been set";
+ is $bt->blurb, $info->blurb, "Blurb is the same as fetching the long way";
+ ok $bt->blurb("New blurb"), "We can set the blurb";
+ $bt->update;
+ is $bt->blurb, $info->blurb, "Blurb has been set";
- $bt->rating(18);
- eval { $bt->update };
- is $@, '', "No problems updating when do have";
- is $bt->rating, 18, "Updated OK";
+ $bt->rating(18);
+ eval { $bt->update };
+ is $@, '', "No problems updating when do have";
+ is $bt->rating, 18, "Updated OK";
- # cascade delete?
- {
- my $blurb = Blurb->retrieve('Bad Taste');
- isa_ok $blurb => "Blurb";
- $bt->delete;
- $blurb = Blurb->retrieve('Bad Taste');
- is $blurb, undef, "Blurb has gone";
- }
-
+ # cascade delete?
+ {
+ my $blurb = Blurb->retrieve('Bad Taste');
+ isa_ok $blurb => "Blurb";
+ $bt->delete;
+ $blurb = Blurb->retrieve('Bad Taste');
+ is $blurb, undef, "Blurb has gone";
+ }
+
}
{
my $data = { %$data };
$data->{NumExplodingSheep} = 1;
ok my $bt = Film->find_or_create($data),
- "find_or_create Modified accessor - find with column name";
+ "find_or_create Modified accessor - find with column name";
isa_ok $bt, "Film";
is $bt->sheep, 1, 'sheep bursting violently';
};
my $data = { %$data };
$data->{sheep} = 1;
ok my $bt = Film->find_or_create($data),
- "find_or_create Modified accessor - find with accessor";
+ "find_or_create Modified accessor - find with accessor";
isa_ok $bt, "Film";
is $bt->sheep, 1, 'sheep bursting violently';
};
my $data = { %$data };
$data->{NumExplodingSheep} = 3;
ok my $bt = Film->find_or_create($data),
- "find_or_create Modified accessor - create with column name";
+ "find_or_create Modified accessor - create with column name";
isa_ok $bt, "Film";
is $bt->sheep, 3, 'sheep bursting violently';
};
my $data = { %$data };
$data->{sheep} = 4;
ok my $bt = Film->find_or_create($data),
- "find_or_create Modified accessor - create with accessor";
+ "find_or_create Modified accessor - create with accessor";
isa_ok $bt, "Film";
is $bt->sheep, 4, 'sheep bursting violently';
};
ok(Film->has_a('Director' => 'Director'), "Link Director table");
ok(
- Director->create({
- Name => 'Peter Jackson',
- Birthday => -300000000,
- IsInsane => 1
- }
- ),
- 'create Director'
+ Director->create({
+ Name => 'Peter Jackson',
+ Birthday => -300000000,
+ IsInsane => 1
+ }
+ ),
+ 'create Director'
);
{
- ok $btaste = Film->retrieve('Bad Taste'), "Reretrieve Bad Taste";
- ok $pj = $btaste->Director, "Bad taste now hasa() director";
- isa_ok $pj => 'Director';
- {
- no warnings qw(redefine once);
- local *Ima::DBI::st::execute =
- sub { ::fail("Shouldn't need to query db"); };
- is $pj->id, 'Peter Jackson', 'ID already stored';
- }
- ok $pj->IsInsane, "But we know he's insane";
+ ok $btaste = Film->retrieve('Bad Taste'), "Reretrieve Bad Taste";
+ ok $pj = $btaste->Director, "Bad taste now hasa() director";
+ isa_ok $pj => 'Director';
+ {
+ no warnings qw(redefine once);
+ local *Ima::DBI::st::execute =
+ sub { ::fail("Shouldn't need to query db"); };
+ is $pj->id, 'Peter Jackson', 'ID already stored';
+ }
+ ok $pj->IsInsane, "But we know he's insane";
}
# Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him.
my $sj = Director->create({
- Name => 'Skippy Jackson',
- Birthday => (-300000000 + 60),
- IsInsane => 1,
- });
+ Name => 'Skippy Jackson',
+ Birthday => (-300000000 + 60),
+ IsInsane => 1,
+ });
{
- eval { $btaste->Director($btaste) };
- like $@, qr/Director/, "Can't set film as director";
- is $btaste->Director->id, $pj->id, "PJ still the director";
+ eval { $btaste->Director($btaste) };
+ like $@, qr/Director/, "Can't set film as director";
+ is $btaste->Director->id, $pj->id, "PJ still the director";
- # drop from cache so that next retrieve() is from db
- $btaste->remove_from_object_index;
+ # drop from cache so that next retrieve() is from db
+ $btaste->remove_from_object_index;
}
{ # Still inflated after update
- my $btaste = Film->retrieve('Bad Taste');
- isa_ok $btaste->Director, "Director";
- $btaste->numexplodingsheep(17);
- $btaste->update;
- isa_ok $btaste->Director, "Director";
-
- $btaste->Director('Someone Else');
- $btaste->update;
- isa_ok $btaste->Director, "Director";
- is $btaste->Director->id, "Someone Else", "Can change director";
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste->Director, "Director";
+ $btaste->numexplodingsheep(17);
+ $btaste->update;
+ isa_ok $btaste->Director, "Director";
+
+ $btaste->Director('Someone Else');
+ $btaste->update;
+ isa_ok $btaste->Director, "Director";
+ is $btaste->Director->id, "Someone Else", "Can change director";
}
is $sj->id, 'Skippy Jackson', 'Create new director - Skippy';
Film->has_a('CoDirector' => 'Director');
{
- eval { $btaste->CoDirector("Skippy Jackson") };
- is $@, "", "Auto inflates";
- isa_ok $btaste->CoDirector, "Director";
- is $btaste->CoDirector->id, $sj->id, "To skippy";
+ eval { $btaste->CoDirector("Skippy Jackson") };
+ is $@, "", "Auto inflates";
+ isa_ok $btaste->CoDirector, "Director";
+ is $btaste->CoDirector->id, $sj->id, "To skippy";
}
$btaste->CoDirector($sj);
$btaste->update;
is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed');
is(
- $btaste->Director->Name,
- 'Peter Jackson',
- "Didnt interfere with each other"
+ $btaste->Director->Name,
+ 'Peter Jackson',
+ "Didnt interfere with each other"
);
{ # Inheriting hasa
- my $btaste = YA::Film->retrieve('Bad Taste');
- is(ref($btaste->Director), 'Director', 'inheriting hasa()');
- is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()');
- is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
+ my $btaste = YA::Film->retrieve('Bad Taste');
+ is(ref($btaste->Director), 'Director', 'inheriting hasa()');
+ is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()');
+ is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly');
}
{
- $sj = Director->retrieve('Skippy Jackson');
- $pj = Director->retrieve('Peter Jackson');
-
- my $fail;
- eval {
- $fail = YA::Film->create({
- Title => 'Tastes Bad',
- Director => $sj,
- codirector => $btaste,
- Rating => 'R',
- NumExplodingSheep => 23
- });
- };
- ok $@, "Can't have film as codirector: $@";
- is $fail, undef, "We didn't get anything";
-
- my $tastes_bad = YA::Film->create({
- Title => 'Tastes Bad',
- Director => $sj,
- codirector => $pj,
- Rating => 'R',
- NumExplodingSheep => 23
- });
- is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director');
- is(
- $tastes_bad->_director_accessor->Name,
- 'Skippy Jackson',
- 'director_accessor'
- );
- is($tastes_bad->codirector->Name, 'Peter Jackson', 'codirector');
- is(
- $tastes_bad->_codirector_accessor->Name,
- 'Peter Jackson',
- 'codirector_accessor'
- );
+ $sj = Director->retrieve('Skippy Jackson');
+ $pj = Director->retrieve('Peter Jackson');
+
+ my $fail;
+ eval {
+ $fail = YA::Film->create({
+ Title => 'Tastes Bad',
+ Director => $sj,
+ codirector => $btaste,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ });
+ };
+ ok $@, "Can't have film as codirector: $@";
+ is $fail, undef, "We didn't get anything";
+
+ my $tastes_bad = YA::Film->create({
+ Title => 'Tastes Bad',
+ Director => $sj,
+ codirector => $pj,
+ Rating => 'R',
+ NumExplodingSheep => 23
+ });
+ is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director');
+ is(
+ $tastes_bad->_director_accessor->Name,
+ 'Skippy Jackson',
+ 'director_accessor'
+ );
+ is($tastes_bad->codirector->Name, 'Peter Jackson', 'codirector');
+ is(
+ $tastes_bad->_codirector_accessor->Name,
+ 'Peter Jackson',
+ 'codirector_accessor'
+ );
}
SKIP: {
skip "Non-standard CDBI relationships not supported by compat", 9;
- {
-
- YA::Film->add_relationship_type(has_a => "YA::HasA");
-
- package YA::HasA;
- #use base 'Class::DBI::Relationship::HasA';
-
- sub _inflator {
- my $self = shift;
- my $col = $self->accessor;
- my $super = $self->SUPER::_inflator($col);
-
- return $super
- unless $col eq $self->class->find_column('Director');
-
- return sub {
- my $self = shift;
- $self->_attribute_store($col, 'Ghostly Peter')
- if $self->_attribute_exists($col)
- and not defined $self->_attrs($col);
- return &$super($self);
- };
- }
- }
- {
-
- package Rating;
-
- sub new {
- my ($class, $mpaa, @details) = @_;
- bless {
- MPAA => $mpaa,
- WHY => "@details"
- }, $class;
- }
- sub mpaa { shift->{MPAA}; }
- sub why { shift->{WHY}; }
- }
- local *Director::mapme = sub {
- my ($class, $val) = @_;
- $val =~ s/Skippy/Peter/;
- $val;
- };
- no warnings 'once';
- local *Director::sanity_check = sub { $_[0]->IsInsane ? undef: $_[0] };
- YA::Film->has_a(
- director => 'Director',
- inflate => 'mapme',
- deflate => 'sanity_check'
- );
- YA::Film->has_a(
- rating => 'Rating',
- inflate => sub {
- my ($val, $parent) = @_;
- my $sheep = $parent->find_column('NumexplodingSheep');
- if ($parent->_attrs($sheep) || 0 > 20) {
- return new Rating 'NC17', 'Graphic ovine violence';
- } else {
- return new Rating $val, 'Just because';
- }
- },
- deflate => sub {
- shift->mpaa;
- });
-
- my $tbad = YA::Film->retrieve('Tastes Bad');
-
- isa_ok $tbad->Director, 'Director';
- is $tbad->Director->Name, 'Peter Jackson', 'Director shuffle';
- $tbad->Director('Skippy Jackson');
- $tbad->update;
- is $tbad->Director, 'Ghostly Peter', 'Sanity checked';
-
- isa_ok $tbad->Rating, 'Rating';
- is $tbad->Rating->mpaa, 'NC17', 'Rating bumped';
- $tbad->Rating(new Rating 'NS17', 'Shaken sheep');
- no warnings 'redefine';
- local *Director::mapme = sub {
- my ($class, $obj) = @_;
- $obj->isa('Film') ? $obj->Director : $obj;
- };
-
- $pj->IsInsane(0);
- $pj->update; # Hush warnings
-
- ok $tbad->Director($btaste), 'Cross-class mapping';
- is $tbad->Director, 'Peter Jackson', 'Yields PJ';
- $tbad->update;
-
- $tbad = Film->retrieve('Tastes Bad');
- ok !ref($tbad->Rating), 'Unmagical rating';
- is $tbad->Rating, 'NS17', 'but prior change stuck';
+ {
+
+ YA::Film->add_relationship_type(has_a => "YA::HasA");
+
+ package YA::HasA;
+ #use base 'Class::DBI::Relationship::HasA';
+
+ sub _inflator {
+ my $self = shift;
+ my $col = $self->accessor;
+ my $super = $self->SUPER::_inflator($col);
+
+ return $super
+ unless $col eq $self->class->find_column('Director');
+
+ return sub {
+ my $self = shift;
+ $self->_attribute_store($col, 'Ghostly Peter')
+ if $self->_attribute_exists($col)
+ and not defined $self->_attrs($col);
+ return &$super($self);
+ };
+ }
+ }
+ {
+
+ package Rating;
+
+ sub new {
+ my ($class, $mpaa, @details) = @_;
+ bless {
+ MPAA => $mpaa,
+ WHY => "@details"
+ }, $class;
+ }
+ sub mpaa { shift->{MPAA}; }
+ sub why { shift->{WHY}; }
+ }
+ local *Director::mapme = sub {
+ my ($class, $val) = @_;
+ $val =~ s/Skippy/Peter/;
+ $val;
+ };
+ no warnings 'once';
+ local *Director::sanity_check = sub { $_[0]->IsInsane ? undef: $_[0] };
+ YA::Film->has_a(
+ director => 'Director',
+ inflate => 'mapme',
+ deflate => 'sanity_check'
+ );
+ YA::Film->has_a(
+ rating => 'Rating',
+ inflate => sub {
+ my ($val, $parent) = @_;
+ my $sheep = $parent->find_column('NumexplodingSheep');
+ if ($parent->_attrs($sheep) || 0 > 20) {
+ return new Rating 'NC17', 'Graphic ovine violence';
+ } else {
+ return new Rating $val, 'Just because';
+ }
+ },
+ deflate => sub {
+ shift->mpaa;
+ });
+
+ my $tbad = YA::Film->retrieve('Tastes Bad');
+
+ isa_ok $tbad->Director, 'Director';
+ is $tbad->Director->Name, 'Peter Jackson', 'Director shuffle';
+ $tbad->Director('Skippy Jackson');
+ $tbad->update;
+ is $tbad->Director, 'Ghostly Peter', 'Sanity checked';
+
+ isa_ok $tbad->Rating, 'Rating';
+ is $tbad->Rating->mpaa, 'NC17', 'Rating bumped';
+ $tbad->Rating(new Rating 'NS17', 'Shaken sheep');
+ no warnings 'redefine';
+ local *Director::mapme = sub {
+ my ($class, $obj) = @_;
+ $obj->isa('Film') ? $obj->Director : $obj;
+ };
+
+ $pj->IsInsane(0);
+ $pj->update; # Hush warnings
+
+ ok $tbad->Director($btaste), 'Cross-class mapping';
+ is $tbad->Director, 'Peter Jackson', 'Yields PJ';
+ $tbad->update;
+
+ $tbad = Film->retrieve('Tastes Bad');
+ ok !ref($tbad->Rating), 'Unmagical rating';
+ is $tbad->Rating, 'NS17', 'but prior change stuck';
}
{ # Broken has_a declaration
- eval { Film->has_a(driector => "Director") };
- like $@, qr/driector/, "Sensible error from has_a with incorrect column: $@";
+ eval { Film->has_a(driector => "Director") };
+ like $@, qr/driector/, "Sensible error from has_a with incorrect column: $@";
}
use Actor;
{ # Check __ESSENTIAL__ expansion (RT#13038)
- 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 @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' });
my $f5 = Film->create({ title => 'E', director => 'AA', rating => '18' });
Film->set_sql(
- pgs => qq{
- SELECT __ESSENTIAL__
- FROM __TABLE__
- WHERE __TABLE__.rating = 'PG'
- ORDER BY title DESC
+ pgs => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE __TABLE__.rating = 'PG'
+ ORDER BY title DESC
}
);
{
- (my $sth = Film->sql_pgs())->execute;
- my @pgs = Film->sth_to_objects($sth);
- is @pgs, 2, "Execute our own SQL";
- is $pgs[0]->id, $f2->id, "get F2";
- is $pgs[1]->id, $f1->id, "and F1";
+ (my $sth = Film->sql_pgs())->execute;
+ my @pgs = Film->sth_to_objects($sth);
+ is @pgs, 2, "Execute our own SQL";
+ is $pgs[0]->id, $f2->id, "get F2";
+ is $pgs[1]->id, $f1->id, "and F1";
}
{
- my @pgs = Film->search_pgs;
- is @pgs, 2, "SQL creates search() method";
- is $pgs[0]->id, $f2->id, "get F2";
- is $pgs[1]->id, $f1->id, "and F1";
+ my @pgs = Film->search_pgs;
+ is @pgs, 2, "SQL creates search() method";
+ is $pgs[0]->id, $f2->id, "get F2";
+ is $pgs[1]->id, $f1->id, "and F1";
};
Film->set_sql(
- rating => qq{
- SELECT __ESSENTIAL__
- FROM __TABLE__
- WHERE rating = ?
- ORDER BY title DESC
+ rating => qq{
+ SELECT __ESSENTIAL__
+ FROM __TABLE__
+ WHERE rating = ?
+ ORDER BY title DESC
}
);
{
- my @pgs = Film->search_rating('18');
- is @pgs, 2, "Can pass parameters to created search()";
- is $pgs[0]->id, $f5->id, "F5";
- is $pgs[1]->id, $f4->id, "and F4";
+ my @pgs = Film->search_rating('18');
+ is @pgs, 2, "Can pass parameters to created search()";
+ is $pgs[0]->id, $f5->id, "F5";
+ is $pgs[1]->id, $f4->id, "and F4";
};
{
{
- Actor->has_a(film => "Film");
- Film->set_sql(
- namerate => qq{
- SELECT __ESSENTIAL(f)__
- FROM __TABLE(=f)__, __TABLE(Actor=a)__
- WHERE __JOIN(a f)__
- AND a.name LIKE ?
- AND f.rating = ?
- ORDER BY title
- }
- );
-
- my $a1 = Actor->create({ name => "A1", film => $f1 });
- my $a2 = Actor->create({ name => "A2", film => $f2 });
- my $a3 = Actor->create({ name => "B1", film => $f1 });
-
- my @apg = Film->search_namerate("A_", "PG");
- is @apg, 2, "2 Films with A* that are PG";
- is $apg[0]->title, "A", "A";
- is $apg[1]->title, "B", "and B";
+ Actor->has_a(film => "Film");
+ Film->set_sql(
+ namerate => qq{
+ SELECT __ESSENTIAL(f)__
+ FROM __TABLE(=f)__, __TABLE(Actor=a)__
+ WHERE __JOIN(a f)__
+ AND a.name LIKE ?
+ AND f.rating = ?
+ ORDER BY title
+ }
+ );
+
+ my $a1 = Actor->create({ name => "A1", film => $f1 });
+ my $a2 = Actor->create({ name => "A2", film => $f2 });
+ my $a3 = Actor->create({ name => "B1", film => $f1 });
+
+ my @apg = Film->search_namerate("A_", "PG");
+ is @apg, 2, "2 Films with A* that are PG";
+ is $apg[0]->title, "A", "A";
+ is $apg[1]->title, "B", "and B";
}
{ # join in reverse
- Actor->has_a(film => "Film");
- Film->set_sql(
- ratename => qq{
- SELECT __ESSENTIAL(f)__
- FROM __TABLE(=f)__, __TABLE(Actor=a)__
- WHERE __JOIN(f a)__
- AND f.rating = ?
- AND a.name LIKE ?
- ORDER BY title
- }
- );
-
- my @apg = Film->search_ratename(PG => "A_");
- is @apg, 2, "2 Films with A* that are PG";
- is $apg[0]->title, "A", "A";
- is $apg[1]->title, "B", "and B";
+ Actor->has_a(film => "Film");
+ Film->set_sql(
+ ratename => qq{
+ SELECT __ESSENTIAL(f)__
+ FROM __TABLE(=f)__, __TABLE(Actor=a)__
+ WHERE __JOIN(f a)__
+ AND f.rating = ?
+ AND a.name LIKE ?
+ ORDER BY title
+ }
+ );
+
+ my @apg = Film->search_ratename(PG => "A_");
+ is @apg, 2, "2 Films with A* that are PG";
+ is $apg[0]->title, "A", "A";
+ is $apg[1]->title, "B", "and B";
}
my $it_class = "DBIx::Class::ResultSet";
my @film = (
- Film->create({ Title => 'Film 1' }),
- Film->create({ Title => 'Film 2' }),
- Film->create({ Title => 'Film 3' }),
- Film->create({ Title => 'Film 4' }),
- Film->create({ Title => 'Film 5' }),
- Film->create({ Title => 'Film 6' }),
+ Film->create({ Title => 'Film 1' }),
+ Film->create({ Title => 'Film 2' }),
+ Film->create({ Title => 'Film 3' }),
+ Film->create({ Title => 'Film 4' }),
+ Film->create({ Title => 'Film 5' }),
+ Film->create({ Title => 'Film 6' }),
);
{
- my $it1 = Film->retrieve_all;
- isa_ok $it1, $it_class;
+ my $it1 = Film->retrieve_all;
+ isa_ok $it1, $it_class;
- my $it2 = Film->retrieve_all;
- isa_ok $it2, $it_class;
+ my $it2 = Film->retrieve_all;
+ isa_ok $it2, $it_class;
- while (my $from1 = $it1->next) {
- my $from2 = $it2->next;
- is $from1->id, $from2->id, "Both iterators get $from1";
- }
+ while (my $from1 = $it1->next) {
+ my $from2 = $it2->next;
+ is $from1->id, $from2->id, "Both iterators get $from1";
+ }
}
{
- my $it = Film->retrieve_all;
- is $it->first->title, "Film 1", "Film 1 first";
- is $it->next->title, "Film 2", "Film 2 next";
- is $it->first->title, "Film 1", "First goes back to 1";
- is $it->next->title, "Film 2", "With 2 still next";
- $it->reset;
- is $it->next->title, "Film 1", "Reset brings us to film 1 again";
- is $it->next->title, "Film 2", "And 2 is still next";
+ my $it = Film->retrieve_all;
+ is $it->first->title, "Film 1", "Film 1 first";
+ is $it->next->title, "Film 2", "Film 2 next";
+ is $it->first->title, "Film 1", "First goes back to 1";
+ is $it->next->title, "Film 2", "With 2 still next";
+ $it->reset;
+ is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+ is $it->next->title, "Film 2", "And 2 is still next";
}
{
- my $it = Film->retrieve_all;
- my @slice = $it->slice(2,4);
- is @slice, 3, "correct slice size (array)";
- is $slice[0]->title, "Film 3", "Film 3 first";
- is $slice[2]->title, "Film 5", "Film 5 last";
+ my $it = Film->retrieve_all;
+ my @slice = $it->slice(2,4);
+ is @slice, 3, "correct slice size (array)";
+ is $slice[0]->title, "Film 3", "Film 3 first";
+ is $slice[2]->title, "Film 5", "Film 5 last";
}
{
- my $it = Film->retrieve_all;
- my $slice = $it->slice(2,4);
- isa_ok $slice, $it_class, "slice as iterator";
- is $slice->count, 3,"correct slice size (array)";
- is $slice->first->title, "Film 3", "Film 3 first";
- is $slice->next->title, "Film 4", "Film 4 next";
- is $slice->first->title, "Film 3", "First goes back to 3";
- is $slice->next->title, "Film 4", "With 4 still next";
- $slice->reset;
- is $slice->next->title, "Film 3", "Reset brings us to film 3 again";
- is $slice->next->title, "Film 4", "And 4 is still next";
+ my $it = Film->retrieve_all;
+ my $slice = $it->slice(2,4);
+ isa_ok $slice, $it_class, "slice as iterator";
+ is $slice->count, 3,"correct slice size (array)";
+ is $slice->first->title, "Film 3", "Film 3 first";
+ is $slice->next->title, "Film 4", "Film 4 next";
+ is $slice->first->title, "Film 3", "First goes back to 3";
+ is $slice->next->title, "Film 4", "With 4 still next";
+ $slice->reset;
+ is $slice->next->title, "Film 3", "Reset brings us to film 3 again";
+ is $slice->next->title, "Film 4", "And 4 is still next";
- # check if the original iterator still works
- is $it->count, 6, "back to the original iterator, is of right size";
- is $it->first->title, "Film 1", "Film 1 first";
- is $it->next->title, "Film 2", "Film 2 next";
- is $it->first->title, "Film 1", "First goes back to 1";
- is $it->next->title, "Film 2", "With 2 still next";
- is $it->next->title, "Film 3", "Film 3 is still in original Iterator";
- $it->reset;
- is $it->next->title, "Film 1", "Reset brings us to film 1 again";
- is $it->next->title, "Film 2", "And 2 is still next";
+ # check if the original iterator still works
+ is $it->count, 6, "back to the original iterator, is of right size";
+ is $it->first->title, "Film 1", "Film 1 first";
+ is $it->next->title, "Film 2", "Film 2 next";
+ is $it->first->title, "Film 1", "First goes back to 1";
+ is $it->next->title, "Film 2", "With 2 still next";
+ is $it->next->title, "Film 3", "Film 3 is still in original Iterator";
+ $it->reset;
+ is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+ is $it->next->title, "Film 2", "And 2 is still next";
}
{
next;
}
+plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
+ unless ($ENV{DBICTEST_MYSQL_DSN} && $ENV{DBICTEST_MYSQL_USER});
+
eval { require Time::Piece::MySQL };
plan skip_all => "Need Time::Piece::MySQL for this test" if $@;
-use lib 't/cdbi/testlib';
-eval { require 't/cdbi/testlib/Log.pm' };
-plan skip_all => "Need MySQL for this test" if $@;
+plan tests => 3;
-plan tests => 2;
+use lib 't/cdbi/testlib';
+use_ok ('Log');
package main;
}
BEGIN {
- eval "use DBD::SQLite";
- plan $@
- ? (skip_all => 'needs DBD::SQLite for testing')
- : (tests => 6);
+ eval "use DBD::SQLite";
+ plan $@
+ ? (skip_all => 'needs DBD::SQLite for testing')
+ : (tests => 6);
}
use lib 't/cdbi/testlib';
require Film;
sub Film::accessor_name_for {
- my ($class, $col) = @_;
- return "sheep" if lc $col eq "numexplodingsheep";
- return $col;
+ my ($class, $col) = @_;
+ return "sheep" if lc $col eq "numexplodingsheep";
+ return $col;
}
my $data = {
- Title => 'Bad Taste',
- Director => 'Peter Jackson',
- Rating => 'R',
+ 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
+ my $data = $data;
+ $data->{sheep} = 1;
+ ok $bt = Film->insert($data), "Modified accessor - with
accessor";
- isa_ok $bt, "Film";
+ isa_ok $bt, "Film";
};
is $@, '', "No errors";
eval {
- ok $bt->sheep(2), 'Modified accessor, set';
- ok $bt->update, 'Update';
+ ok $bt->sheep(2), 'Modified accessor, set';
+ ok $bt->update, 'Update';
};
is $@, '', "No errors";
use Film;
my @film = (
- Film->create({ Title => 'Film 1' }),
- Film->create({ Title => 'Film 2' }),
- Film->create({ Title => 'Film 3' }),
- Film->create({ Title => 'Film 4' }),
- Film->create({ Title => 'Film 5' }),
+ Film->create({ Title => 'Film 1' }),
+ Film->create({ Title => 'Film 2' }),
+ Film->create({ Title => 'Film 3' }),
+ Film->create({ Title => 'Film 4' }),
+ Film->create({ Title => 'Film 5' }),
);
# first page
Film->create_test_film;
{
- my $btaste = Film->retrieve('Bad Taste');
- isa_ok $btaste, 'Film', "We have Bad Taste";
- {
- no warnings 'redefine';
- local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
- eval { $btaste->delete };
- ::like $@, qr/Database died/s, "We failed";
- }
- my $still = Film->retrieve('Bad Taste');
- isa_ok $btaste, 'Film', "We still have Bad Taste";
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We have Bad Taste";
+ {
+ no warnings 'redefine';
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ eval { $btaste->delete };
+ ::like $@, qr/Database died/s, "We failed";
+ }
+ my $still = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We still have Bad Taste";
}
{
- my $btaste = Film->retrieve('Bad Taste');
- isa_ok $btaste, 'Film', "We have Bad Taste";
- $btaste->numexplodingsheep(10);
- {
- no warnings 'redefine';
- local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
- eval { $btaste->update };
- ::like $@, qr/Database died/s, "We failed";
- }
- $btaste->discard_changes;
- my $still = Film->retrieve('Bad Taste');
- isa_ok $btaste, 'Film', "We still have Bad Taste";
- is $btaste->numexplodingsheep, 1, "with 1 sheep";
+ my $btaste = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We have Bad Taste";
+ $btaste->numexplodingsheep(10);
+ {
+ no warnings 'redefine';
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ eval { $btaste->update };
+ ::like $@, qr/Database died/s, "We failed";
+ }
+ $btaste->discard_changes;
+ my $still = Film->retrieve('Bad Taste');
+ isa_ok $btaste, 'Film', "We still have Bad Taste";
+ is $btaste->numexplodingsheep, 1, "with 1 sheep";
}
if (0) {
- my $sheep = Film->maximum_value_of('numexplodingsheep');
- is $sheep, 1, "1 exploding sheep";
- {
- local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
- my $sheep = eval { Film->maximum_value_of('numexplodingsheep') };
- ::like $@, qr/select.*Database died/s,
- "Handle database death in single value select";
- }
+ my $sheep = Film->maximum_value_of('numexplodingsheep');
+ is $sheep, 1, "1 exploding sheep";
+ {
+ local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
+ my $sheep = eval { Film->maximum_value_of('numexplodingsheep') };
+ ::like $@, qr/select.*Database died/s,
+ "Handle database death in single value select";
+ }
}
}
INIT {
- use lib 't/cdbi/testlib';
- use Film;
+ use lib 't/cdbi/testlib';
+ use Film;
}
sub mutator_name_for { "set_$_[1]" }
sub create_sql {
- return qq{
- id INTEGER PRIMARY KEY,
- name CHAR(40),
- film VARCHAR(255),
- salary INT
- }
+ return qq{
+ id INTEGER PRIMARY KEY,
+ name CHAR(40),
+ film VARCHAR(255),
+ salary INT
+ }
}
1;
__PACKAGE__->has_a( alias => 'Actor' );
sub create_sql {
- return qq{
- id INTEGER PRIMARY KEY,
- actor INTEGER,
- alias INTEGER
- }
+ return qq{
+ id INTEGER PRIMARY KEY,
+ actor INTEGER,
+ alias INTEGER
+ }
}
1;
__PACKAGE__->columns('Blurb', qw/ blurb/);
sub create_sql {
- return qq{
- title VARCHAR(255) PRIMARY KEY,
- blurb VARCHAR(255) NOT NULL
+ return qq{
+ title VARCHAR(255) PRIMARY KEY,
+ blurb VARCHAR(255) NOT NULL
}
}
__PACKAGE__->columns('All' => qw/ Name Birthday IsInsane /);
sub create_sql {
- return qq{
- name VARCHAR(80),
- birthday INTEGER,
- isinsane INTEGER
- };
+ return qq{
+ name VARCHAR(80),
+ birthday INTEGER,
+ isinsane INTEGER
+ };
}
1;
__PACKAGE__->columns('Other', qw( Rating NumExplodingSheep HasVomit ));
sub create_sql {
- return qq{
- title VARCHAR(255),
- director VARCHAR(80),
- codirector VARCHAR(80),
- rating CHAR(5),
- numexplodingsheep INTEGER,
- hasvomit CHAR(1)
+ return qq{
+ title VARCHAR(255),
+ director VARCHAR(80),
+ codirector VARCHAR(80),
+ rating CHAR(5),
+ numexplodingsheep INTEGER,
+ hasvomit CHAR(1)
}
}
sub create_test_film {
- return shift->create({
- Title => 'Bad Taste',
- Director => 'Peter Jackson',
- Rating => 'R',
- NumExplodingSheep => 1,
- });
+ return shift->create({
+ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 1,
+ });
}
package DeletingFilm;
__PACKAGE__->columns('vertical', qw(oop opop));
sub create_sql {
- return qq{
- this INTEGER,
- that INTEGER,
- eep INTEGER,
- orp INTEGER,
- oop INTEGER,
- opop INTEGER
- };
+ return qq{
+ this INTEGER,
+ that INTEGER,
+ eep INTEGER,
+ orp INTEGER,
+ oop INTEGER,
+ opop INTEGER
+ };
}
1;
__PACKAGE__->set_table();
__PACKAGE__->columns(All => qw/id message datetime_stamp/);
__PACKAGE__->has_a(
- datetime_stamp => 'Time::Piece',
- inflate => 'from_mysql_datetime',
- deflate => 'mysql_datetime'
+ datetime_stamp => 'Time::Piece',
+ inflate => 'from_mysql_datetime',
+ deflate => 'mysql_datetime'
);
__PACKAGE__->add_trigger(before_create => \&set_dts);
__PACKAGE__->add_trigger(before_update => \&set_dts);
sub set_dts {
- shift->datetime_stamp(
- POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime(time)));
+ shift->datetime_stamp(
+ POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime(time)));
}
sub create_sql {
- return qq{
+ return qq{
id INT UNSIGNED AUTO_INCREMENT PRIMARY KEY,
message VARCHAR(255),
datetime_stamp DATETIME
__PACKAGE__->connection(@connect);
sub set_table {
- my $class = shift;
- $class->table($class->create_test_table);
+ my $class = shift;
+ $class->table($class->create_test_table);
}
sub create_test_table {
- my $self = shift;
- my $table = $self->next_available_table;
- my $create = sprintf "CREATE TABLE $table ( %s )", $self->create_sql;
- push @table, $table;
- $dbh->do($create);
- return $table;
+ my $self = shift;
+ my $table = $self->next_available_table;
+ my $create = sprintf "CREATE TABLE $table ( %s )", $self->create_sql;
+ push @table, $table;
+ $dbh->do($create);
+ return $table;
}
sub next_available_table {
- my $self = shift;
- my @tables = sort @{
- $dbh->selectcol_arrayref(
- qq{
+ my $self = shift;
+ my @tables = sort @{
+ $dbh->selectcol_arrayref(
+ qq{
SHOW TABLES
}
- )
- };
- my $table = $tables[-1] || "aaa";
- return "z$table";
+ )
+ };
+ my $table = $tables[-1] || "aaa";
+ return "z$table";
}
1;
sub stars { map $_->star, shift->_stars }
sub create_sql {
- return qq{
+ return qq{
filmid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY,
title VARCHAR(255)
};
__PACKAGE__->set_table();
__PACKAGE__->columns(All => qw/myid name val tdate/);
__PACKAGE__->has_a(
- tdate => 'Date::Simple',
- inflate => sub { Date::Simple->new(shift) },
- deflate => 'format',
+ tdate => 'Date::Simple',
+ inflate => sub { Date::Simple->new(shift) },
+ deflate => 'format',
);
#__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)");
sub create_sql {
- return qq{
+ return qq{
myid mediumint not null auto_increment primary key,
name varchar(50) not null default '',
val char(1) default 'A',
# sub films { map $_->film, shift->_films }
sub create_sql {
- return qq{
- starid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY,
- name VARCHAR(255)
- };
+ return qq{
+ starid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY,
+ name VARCHAR(255)
+ };
}
1;
__PACKAGE__->has_a(star => 'MyStar');
sub create_sql {
- return qq{
+ return qq{
linkid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY,
film TINYINT NOT NULL,
star TINYINT NOT NULL
__PACKAGE__->has_a(star => 'MyStar');
sub create_sql {
- return qq{
+ return qq{
film INTEGER NOT NULL,
star INTEGER NOT NULL,
PRIMARY KEY (film, star)
__PACKAGE__->columns(Others => qw/orders/);
sub create_sql {
- return qq{
- film VARCHAR(255),
- orders INTEGER
- };
+ return qq{
+ film VARCHAR(255),
+ orders INTEGER
+ };
}
1;
-package # hide from PAUSE
+package # hide from PAUSE
OtherFilm;
use strict;
__PACKAGE__->set_table('Different_Film');
sub create_sql {
- return qq{
- title VARCHAR(255),
- director VARCHAR(80),
- codirector VARCHAR(80),
- rating CHAR(5),
- numexplodingsheep INTEGER,
- hasvomit CHAR(1)
- };
+ return qq{
+ title VARCHAR(255),
+ director VARCHAR(80),
+ codirector VARCHAR(80),
+ rating CHAR(5),
+ numexplodingsheep INTEGER,
+ hasvomit CHAR(1)
+ };
}
1;
FROM cd me
JOIN track tracks ON tracks.cd = me.cdid
JOIN cd disc ON disc.cdid = tracks.cd
- LEFT JOIN lyrics lyrics ON lyrics.track_id = tracks.trackid
WHERE ( ( position = ? OR position = ? ) )
',
[ qw/'1' '2'/ ],
FROM cd me
JOIN track tracks ON tracks.cd = me.cdid
JOIN cd disc ON disc.cdid = tracks.cd
- LEFT JOIN lyrics lyrics ON lyrics.track_id = tracks.trackid
WHERE ( ( position = ? OR position = ? ) )
LIMIT 3 OFFSET 8
) count_subq
# collapsing prefetch with distinct
{
- my $first_cd = $schema->resultset('Artist')->first->cds->first;
- $first_cd->update ({
- genreid => $first_cd->create_related (
- genre => ({ name => 'vague genre' })
- )->id
- });
-
my $rs = $schema->resultset("Artist")->search(undef, {distinct => 1})
->search_related('cds')->search_related('genre',
- { 'genre.name' => { '!=', 'foo' } },
+ { 'genre.name' => 'emo' },
{ prefetch => q(cds) },
);
is ($rs->all, 1, 'Correct number of objects');
SELECT COUNT( * )
FROM (
SELECT genre.genreid
- FROM artist me
+ FROM (
+ SELECT me.artistid, me.name, me.rank, me.charfield
+ FROM artist me
+ GROUP BY me.artistid, me.name, me.rank, me.charfield
+ ) me
JOIN cd cds ON cds.artist = me.artistid
JOIN genre genre ON genre.genreid = cds.genreid
- LEFT JOIN cd cds_2 ON cds_2.genreid = genre.genreid
- WHERE ( genre.name != ? )
+ WHERE ( genre.name = ? )
GROUP BY genre.genreid
- ) count_subq
+ )
+ count_subq
)',
- [ [ 'genre.name' => 'foo' ] ],
+ [ [ 'genre.name' => 'emo' ] ],
);
}
{
my $rs = $schema->resultset("CD")
->search_related('tracks',
- { position => [1,2] },
+ { position => [1,2], 'lyrics.lyric_id' => undef },
{ prefetch => [qw/disc lyrics/] },
);
is ($rs->all, 10, 'Correct number of objects');
JOIN track tracks ON tracks.cd = me.cdid
JOIN cd disc ON disc.cdid = tracks.cd
LEFT JOIN lyrics lyrics ON lyrics.track_id = tracks.trackid
- WHERE position = ? OR position = ?
+ WHERE lyrics.lyric_id IS NULL AND (position = ? OR position = ?)
)',
[ map { [ position => $_ ] } (1, 2) ],
);
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+my $cd_rs = $schema->resultset('CD')->search ({}, { rows => 1, order_by => 'cdid' });
+
+my $track_count = $cd_rs->first->tracks->count;
+
+cmp_ok ($track_count, '>', 1, 'First CD has several tracks');
+
+is ($cd_rs->search_related ('tracks')->count, $track_count, 'related->count returns correct number chained off a limited rs');
+is (scalar ($cd_rs->search_related ('tracks')->all), $track_count, 'related->all returns correct number of objects chained off a limited rs');
+
+
+my $joined_cd_rs = $cd_rs->search ({}, {
+ join => 'tracks', rows => 2, distinct => 1, having => \ 'count(tracks.trackid) > 2',
+});
+
+my $multiple_track_count = $schema->resultset('Track')->search ({
+ cd => { -in => $joined_cd_rs->get_column ('cdid')->as_query }
+})->count;
+
+
+is (
+ $joined_cd_rs->search_related ('tracks')->count,
+ $multiple_track_count,
+ 'related->count returns correct number chained off a grouped rs',
+);
+is (
+ scalar ($joined_cd_rs->search_related ('tracks')->all),
+ $multiple_track_count,
+ 'related->all returns correct number of objects chained off a grouped rs',
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+my $artist_rs = $schema->resultset ('Artist');
+
+my $init_count = $artist_rs->count;
+ok ($init_count, 'Some artists is database');
+
+$artist_rs->populate ([
+ {
+ name => 'foo',
+ },
+ {
+ name => 'bar',
+ }
+]);
+
+is ($artist_rs->count, $init_count + 2, '2 Artists created');
+
+$artist_rs->search ({
+ -and => [
+ { 'me.artistid' => { '!=', undef } },
+ [ { 'me.name' => 'foo' }, { 'me.name' => 'bar' } ],
+ ],
+})->delete;
+
+is ($artist_rs->count, $init_count, 'Correct amount of artists deleted');
+
+done_testing;
+
use strict;
-use warnings FATAL => 'all';
+use warnings;
use Test::More;
is_same_sql_bind(
$cdrs2->as_query,
- "(SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ))",
+ "(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ))",
[],
);
}
is_same_sql_bind(
$rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE ( id > ? ) ) cd2)",
+ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( id > ? )
+ ) cd2)",
[
[ 'id', 20 ]
],
is_same_sql_bind(
$rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
- FROM
- (SELECT cd3.cdid,cd3.artist,cd3.title,cd3.year,cd3.genreid,cd3.single_track
- FROM
- (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track
+ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
+ FROM
+ (SELECT cd3.cdid, cd3.artist, cd3.title, cd3.year, cd3.genreid, cd3.single_track
+ FROM
+ (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me WHERE ( id < ? ) ) cd3
WHERE ( id > ? ) ) cd2)",
[
is_same_sql_bind(
$rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE ( title = ? ) ) cd2)",
+ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( title = ? )
+ ) cd2)",
[ [ 'title', 'Thriller' ] ],
);
}
deflate => sub { shift->year } }
);
+my $rs = $schema->resultset('CD');
+
# inflation test
-my $cd = $schema->resultset("CD")->find(3);
+my $cd = $rs->find(3);
is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
$cd->year( $now );
$cd->update;
-$cd = $schema->resultset("CD")->find(3);
+$cd = $rs->find(3);
is( $cd->year->year, $now->year, 'deflate ok' );
# set_inflated_column test
ok(!$@, 'set_inflated_column with DateTime object');
$cd->update;
-$cd = $schema->resultset("CD")->find(3);
+$cd = $rs->find(3);
is( $cd->year->year, $now->year, 'deflate ok' );
-$cd = $schema->resultset("CD")->find(3);
+$cd = $rs->find(3);
my $before_year = $cd->year->year;
eval { $cd->set_inflated_column('year', \'year + 1') };
ok(!$@, 'set_inflated_column to "year + 1"');
$cd->update;
-TODO: {
- local $TODO = 'this was left in without a TODO - should it work?';
-
- lives_ok (sub {
- $cd->store_inflated_column('year', \'year + 1');
- is_deeply( $cd->year, \'year + 1', 'deflate ok' );
- }, 'store_inflated_column to "year + 1"');
-}
+$cd->store_inflated_column('year', \'year + 1');
+is_deeply( $cd->year, \'year + 1', 'scalarref deflate passthrough ok' );
-$cd = $schema->resultset("CD")->find(3);
+$cd = $rs->find(3);
is( $cd->year->year, $before_year+1, 'deflate ok' );
# store_inflated_column test
-$cd = $schema->resultset("CD")->find(3);
+$cd = $rs->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);
+$cd = $rs->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);
+$cd = $rs->find(3);
$before_year = $cd->year->year;
eval { $cd->update({'year' => \'year + 1'}) };
ok(!$@, 'update using scalarref ok');
-$cd = $schema->resultset("CD")->find(3);
+$cd = $rs->find(3);
is($cd->year->year, $before_year + 1, 'deflate ok');
# discard_changes test
-$cd = $schema->resultset("CD")->find(3);
+$cd = $rs->find(3);
# inflate the year
$before_year = $cd->year->year;
$cd->update({ year => \'year + 1'});
my $copy = $cd->copy({ year => $now, title => "zemoose" });
-isnt( $copy->year->year, $before_year, "copy" );
+is( $copy->year->year, $now->year, "copy" );
+
+
+
+my $artist = $cd->artist;
+my $sval = \ '2012';
+
+$cd = $rs->create ({
+ artist => $artist,
+ year => $sval,
+ title => 'create with scalarref',
+});
+
+is ($cd->year, $sval, 'scalar value retained');
+my $cd2 = $cd->copy ({ title => 'copy with scalar in coldata' });
+is ($cd2->year, $sval, 'copied scalar value retained');
+
+$cd->discard_changes;
+is ($cd->year->year, 2012, 'infation upon reload');
+
+$cd2->discard_changes;
+is ($cd2->year->year, 2012, 'infation upon reload of copy');
+
+
+my $precount = $rs->count;
+$cd = $rs->update_or_create ({artist => $artist, title => 'nonexisting update/create test row', year => $sval });
+is ($rs->count, $precount + 1, 'Row created');
+
+is ($cd->year, $sval, 'scalar value retained on creating update_or_create');
+$cd->discard_changes;
+is ($cd->year->year, 2012, 'infation upon reload');
+
+my $sval2 = \ '2013';
+
+$cd = $rs->update_or_create ({artist => $artist, title => 'nonexisting update/create test row', year => $sval2 });
+is ($rs->count, $precount + 1, 'No more rows created');
+
+is ($cd->year, $sval2, 'scalar value retained on updating update_or_create');
+$cd->discard_changes;
+is ($cd->year->year, 2013, 'infation upon reload');
done_testing;
if ($@) {
plan skip_all => 'needs DateTime and DateTime::Format::Sybase for testing';
}
- else {
- plan tests => (4 * 2 * 2) + 2; # (tests * dt_types * storage_types) + storage_tests
- }
}
my @storage_types = (
- 'DBI::Sybase',
- 'DBI::Sybase::NoBindVars',
+ 'DBI::Sybase::ASE',
+ 'DBI::Sybase::ASE::NoBindVars',
);
my $schema;
for my $storage_type (@storage_types) {
$schema = DBICTest::Schema->clone;
- unless ($storage_type eq 'DBI::Sybase') { # autodetect
+ unless ($storage_type eq 'DBI::Sybase::ASE') { # autodetect
$schema->storage_type("::$storage_type");
}
$schema->connection($dsn, $user, $pass, {
$schema->storage->dbh->do(<<"SQL");
CREATE TABLE track (
trackid INT IDENTITY PRIMARY KEY,
- cd INT,
- position INT,
- $col $type,
+ cd INT NULL,
+ position INT NULL,
+ $col $type NULL
)
SQL
ok(my $dt = DateTime::Format::Sybase->parse_datetime($sample_dt));
);
is( $row->$col, $dt, 'DateTime roundtrip' );
}
+
+ # test a computed datetime column
+ eval { $schema->storage->dbh->do("DROP TABLE track") };
+ $schema->storage->dbh->do(<<"SQL");
+CREATE TABLE track (
+ trackid INT IDENTITY PRIMARY KEY,
+ cd INT NULL,
+ position INT NULL,
+ title VARCHAR(100) NULL,
+ last_updated_on DATETIME NULL,
+ last_updated_at AS getdate(),
+ small_dt SMALLDATETIME NULL
+)
+SQL
+
+ my $now = DateTime->now;
+ sleep 1;
+ my $new_row = $schema->resultset('Track')->create({});
+ $new_row->discard_changes;
+
+ lives_and {
+ cmp_ok (($new_row->last_updated_at - $now)->seconds, '>=', 1)
+ } 'getdate() computed column works';
}
+done_testing;
+
# clean up our mess
END {
if (my $dbh = eval { $schema->storage->_dbh }) {
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_ASA_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SYBASE_ASA_ODBC_${_}" } qw/DSN USER PASS/};
+
+if (not ($dsn || $dsn2)) {
+ plan skip_all => <<'EOF';
+Set $ENV{DBICTEST_SYBASE_ASA_DSN} and/or $ENV{DBICTEST_SYBASE_ASA_ODBC_DSN}
+_USER and _PASS to run this test'.
+Warning: This test drops and creates a table called 'track'";
+EOF
+} else {
+ eval "use DateTime; use DateTime::Format::Strptime;";
+ if ($@) {
+ plan skip_all => 'needs DateTime and DateTime::Format::Strptime for testing';
+ }
+}
+
+my @info = (
+ [ $dsn, $user, $pass ],
+ [ $dsn2, $user2, $pass2 ],
+);
+
+my @handles_to_clean;
+
+foreach my $info (@info) {
+ my ($dsn, $user, $pass) = @$info;
+
+ next unless $dsn;
+
+ my $schema = DBICTest::Schema->clone;
+
+ $schema->connection($dsn, $user, $pass, {
+ on_connect_call => [ 'datetime_setup' ],
+ });
+
+ push @handles_to_clean, $schema->storage->dbh;
+
+# coltype, col, date
+ my @dt_types = (
+ ['TIMESTAMP', 'last_updated_at', '2004-08-21 14:36:48.080444'],
+# date only (but minute precision according to ASA docs)
+ ['DATE', 'small_dt', '2004-08-21 00:00:00.000000'],
+ );
+
+ for my $dt_type (@dt_types) {
+ my ($type, $col, $sample_dt) = @$dt_type;
+
+ eval { $schema->storage->dbh->do("DROP TABLE track") };
+ $schema->storage->dbh->do(<<"SQL");
+ CREATE TABLE track (
+ trackid INT IDENTITY PRIMARY KEY,
+ cd INT,
+ position INT,
+ $col $type,
+ )
+SQL
+ ok(my $dt = $schema->storage->datetime_parser->parse_datetime($sample_dt));
+
+ my $row;
+ ok( $row = $schema->resultset('Track')->create({
+ $col => $dt,
+ cd => 1,
+ }));
+ ok( $row = $schema->resultset('Track')
+ ->search({ trackid => $row->trackid }, { select => [$col] })
+ ->first
+ );
+ is( $row->$col, $dt, 'DateTime roundtrip' );
+ }
+}
+
+done_testing;
+
+# clean up our mess
+END {
+ foreach my $dbh (@handles_to_clean) {
+ eval { $dbh->do("DROP TABLE $_") } for qw/track/;
+ }
+}
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use IO::File;
use File::Compare;
use Path::Class qw/file/;
use strict;
-use warnings;
+use warnings;
-use Test::More qw(no_plan);
+use Test::More;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
# Under some versions of SQLite if the $rs is left hanging around it will lock
# So we create a scope here cos I'm lazy
{
- my $rs = $schema->resultset('CD');
+ my $rs = $schema->resultset('CD')->search ({}, { order_by => 'cdid' });
# get the defined columns
my @dbic_cols = sort $rs->result_source->columns;
my @hashref_cols = sort keys %$datahashref1;
is_deeply( \@dbic_cols, \@hashref_cols, 'returned columns' );
-}
+ my $cd1 = $rs->find ({cdid => 1});
+ is_deeply ( $cd1, $datahashref1, 'first/find return the same thing');
+}
sub check_cols_of {
my ($dbic_obj, $datahashref) = @_;
-
+
foreach my $col (keys %$datahashref) {
# plain column
if (not ref ($datahashref->{$col}) ) {
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');
+
+ is (scalar @dbic_reltable, scalar @hashref_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);
}
}
[{ $artist->get_columns, cds => [] }],
'nested has_many prefetch without entries'
);
+
+done_testing;
+
package DBICNSTest::Bogus::A;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+use base qw/DBIx::Class::Core/;
__PACKAGE__->table('a');
__PACKAGE__->add_columns('a');
1;
package DBICNSTest::Result::B;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+use base qw/DBIx::Class::Core/;
__PACKAGE__->table('b');
__PACKAGE__->add_columns('b');
1;
package DBICNSTest::OtherRslt::D;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+use base qw/DBIx::Class::Core/;
__PACKAGE__->table('d');
__PACKAGE__->add_columns('d');
1;
package DBICNSTest::Result::A;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+use base qw/DBIx::Class::Core/;
__PACKAGE__->table('a');
__PACKAGE__->add_columns('a');
1;
package DBICNSTest::Result::B;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+use base qw/DBIx::Class::Core/;
__PACKAGE__->table('b');
__PACKAGE__->add_columns('b');
1;
package DBICNSTest::Rslt::A;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+use base qw/DBIx::Class::Core/;
__PACKAGE__->table('a');
__PACKAGE__->add_columns('a');
1;
package DBICNSTest::Rslt::B;
-use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/PK::Auto Core/);
+use base qw/DBIx::Class::Core/;
__PACKAGE__->table('b');
__PACKAGE__->add_columns('b');
1;
package DBICNSTest::RtBug41083::Schema::Foo;
use strict;
use warnings;
-use base 'DBIx::Class';
-__PACKAGE__->load_components('Core');
+use base 'DBIx::Class::Core';
__PACKAGE__->table('foo');
__PACKAGE__->add_columns('foo');
1;
package DBICNSTest::RtBug41083::Schema_A::A;
use strict;
use warnings;
-use base 'DBIx::Class';
-__PACKAGE__->load_components('Core');
+use base 'DBIx::Class::Core';
__PACKAGE__->table('a');
__PACKAGE__->add_columns('a');
1;
no_populate=>1,
storage_type=>'::DBI::Replicated',
storage_type_args=>{
- balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
+ balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
},
);
=cut
sub has_custom_dsn {
- return $ENV{"DBICTEST_DSN"} ? 1:0;
+ return $ENV{"DBICTEST_DSN"} ? 1:0;
}
sub _sqlite_dbfilename {
my $self = shift;
my %args = @_;
return $self->_sqlite_dbfilename if $args{sqlite_use_file} or $ENV{"DBICTEST_SQLITE_USE_FILE"};
- return ":memory:";
+ return ":memory:";
}
sub _database {
my %args = @_;
my $schema;
-
+
if ($args{compose_connection}) {
$schema = DBICTest::Schema->compose_connection(
'DBICTest', $self->_database(%args)
$schema = DBICTest::Schema->compose_namespace('DBICTest');
}
if( $args{storage_type}) {
- $schema->storage_type($args{storage_type});
- }
+ $schema->storage_type($args{storage_type});
+ }
if ( !$args{no_connect} ) {
$schema = $schema->connect($self->_database(%args));
$schema->storage->on_connect_do(['PRAGMA synchronous = OFF'])
my $args = shift || {};
if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
- $schema->deploy($args);
+ $schema->deploy($args);
} else {
open IN, "t/lib/sqlite.sql";
my $sql;
my $self = shift;
my $schema = shift;
+ $schema->populate('Genre', [
+ [qw/genreid name/],
+ [qw/1 emo /],
+ ]);
+
$schema->populate('Artist', [
[ qw/artistid name/ ],
[ 1, 'Caterwauler McCrae' ],
]);
$schema->populate('CD', [
- [ qw/cdid artist title year/ ],
- [ 1, 1, "Spoonful of bees", 1999 ],
+ [ qw/cdid artist title year genreid/ ],
+ [ 1, 1, "Spoonful of bees", 1999, 1 ],
[ 2, 1, "Forkful of bees", 2001 ],
[ 3, 1, "Caterwaulin' Blues", 1997 ],
[ 4, 2, "Generic Manufactured Singles", 2001 ],
$schema->populate('TreeLike', [
[ qw/id parent name/ ],
- [ 1, undef, 'root' ],
+ [ 1, undef, 'root' ],
[ 2, 1, 'foo' ],
[ 3, 2, 'bar' ],
[ 6, 2, 'blop' ],
use strict;
use warnings;
-use base qw/DBIx::Class/;
+use base qw/DBIx::Class::Core/;
use DBICTest::BaseResultSet;
-__PACKAGE__->load_components (qw/Core/);
__PACKAGE__->table ('bogus');
__PACKAGE__->resultset_class ('DBICTest::BaseResultSet');
package # hide from PAUSE
DBICTest::ResultSetManager::Foo;
-use base 'DBIx::Class';
+use base 'DBIx::Class::Core';
-__PACKAGE__->load_components(qw/ ResultSetManager Core /);
+__PACKAGE__->load_components(qw/ ResultSetManager /);
__PACKAGE__->table('foo');
sub bar : ResultSet { 'good' }
__PACKAGE__->has_many(
cds_unordered => 'DBICTest::Schema::CD'
);
+__PACKAGE__->has_many(
+ cds_very_very_very_long_relationship_name => 'DBICTest::Schema::CD'
+);
__PACKAGE__->has_many( twokeys => 'DBICTest::Schema::TwoKeys' );
__PACKAGE__->has_many( onekeys => 'DBICTest::Schema::OneKey' );
'genreid' => {
data_type => 'integer',
is_nullable => 1,
+ accessor => undef,
},
'single_track' => {
data_type => 'integer',
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::ComputedColumn;
+
+# for sybase and mssql computed column tests
+
+use base qw/DBICTest::BaseResult/;
+
+__PACKAGE__->table('computed_column_test');
+
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'a_computed_column' => {
+ data_type => undef,
+ is_nullable => 0,
+ default_value => \'getdate()',
+ },
+ 'a_timestamp' => {
+ data_type => 'timestamp',
+ is_nullable => 0,
+ },
+ 'charfield' => {
+ data_type => 'varchar',
+ size => 20,
+ default_value => 'foo',
+ is_nullable => 0,
+ }
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
__PACKAGE__->might_have( cd_single => 'DBICTest::Schema::CD', 'single_track' );
__PACKAGE__->might_have( lyrics => 'DBICTest::Schema::Lyrics', 'track_id' );
+__PACKAGE__->belongs_to(
+ "year1999cd",
+ "DBICTest::Schema::Year1999CDs",
+ { "foreign.cdid" => "self.cd" },
+ { join_type => 'left' }, # the relationship is of course optional
+);
+__PACKAGE__->belongs_to(
+ "year2000cd",
+ "DBICTest::Schema::Year2000CDs",
+ { "foreign.cdid" => "self.cd" },
+ { join_type => 'left' },
+);
+
1;
__PACKAGE__->table('year1999cds');
__PACKAGE__->result_source_instance->is_virtual(1);
__PACKAGE__->result_source_instance->view_definition(
- "SELECT cdid, artist, title FROM cd WHERE year ='1999'"
+ "SELECT cdid, artist, title, single_track FROM cd WHERE year ='1999'"
);
__PACKAGE__->add_columns(
'cdid' => {
data_type => 'varchar',
size => 100,
},
-
+ 'single_track' => {
+ data_type => 'integer',
+ is_nullable => 1,
+ is_foreign_key => 1,
+ },
);
__PACKAGE__->set_primary_key('cdid');
__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
+__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' );
+__PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track',
+ { "foreign.cd" => "self.cdid" });
+
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Year2000CDs;
-## Used in 104view.t
-use base qw/DBICTest::BaseResult/;
+use base qw/DBICTest::Schema::CD/;
__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
-
__PACKAGE__->table('year2000cds');
-__PACKAGE__->result_source_instance->view_definition(
- "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
-);
-__PACKAGE__->add_columns(
- 'cdid' => {
- data_type => 'integer',
- is_auto_increment => 1,
- },
- 'artist' => {
- data_type => 'integer',
- },
- 'title' => {
- data_type => 'varchar',
- size => 100,
- },
-);
-__PACKAGE__->set_primary_key('cdid');
-__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
+# need to operate on the instance for things to work
+__PACKAGE__->result_source_instance->view_definition( sprintf (
+ 'SELECT %s FROM cd WHERE year = "2000"',
+ join (', ', __PACKAGE__->columns),
+));
+
+__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' );
+__PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track',
+ { "foreign.cd" => "self.cdid" });
1;
package DBICVersion::Table;
-use base 'DBIx::Class';
+use base 'DBIx::Class::Core';
use strict;
use warnings;
-__PACKAGE__->load_components(qw/ Core/);
__PACKAGE__->table('TestVersion');
__PACKAGE__->add_columns
return 't/var/';
}
+sub ordered_schema_versions {
+ return('1.0','2.0','3.0');
+}
+
1;
package DBICVersion::Table;
-use base 'DBIx::Class';
+use base 'DBIx::Class::Core';
use strict;
use warnings;
-__PACKAGE__->load_components(qw/ Core/);
__PACKAGE__->table('TestVersion');
__PACKAGE__->add_columns
package DBICVersion::Table;
-use base 'DBIx::Class';
+use base 'DBIx::Class::Core';
use strict;
use warnings;
-__PACKAGE__->load_components(qw/ Core/);
__PACKAGE__->table('TestVersion');
__PACKAGE__->add_columns
'is_foreign_key' => 0,
'is_nullable' => 1,
'size' => '20'
+ },
+ 'ExtraColumn' => {
+ 'data_type' => 'VARCHAR',
+ 'is_auto_increment' => 0,
+ 'default_value' => undef,
+ 'is_foreign_key' => 0,
+ 'is_nullable' => 1,
+ 'size' => '20'
}
);
use strict;
use warnings;
-our $VERSION = '2.0';
+our $VERSION = '3.0';
__PACKAGE__->register_class('Table', 'DBICVersion::Table');
__PACKAGE__->load_components('+DBIx::Class::Schema::Versioned');
__PACKAGE__->upgrade_directory('t/var/');
__PACKAGE__->backup_directory('t/var/backup/');
-#sub upgrade_directory
-#{
-# return 't/var/';
-#}
-
1;
--- Created on Tue Aug 25 12:34:34 2009
--
-
-
-BEGIN TRANSACTION;
+-- Created by SQL::Translator::Producer::SQLite
+-- Created on Sat Jan 30 19:18:55 2010
+--
+;
--
-- Table: artist
cd integer NOT NULL
);
-CREATE INDEX forceforeign_idx_artist ON forceforeign (artist);
-
--
-- Table: self_ref_alias
--
cd_id INTEGER PRIMARY KEY NOT NULL
);
-CREATE INDEX cd_artwork_idx_cd_id ON cd_artwork (cd_id);
-
--
-- Table: liner_notes
--
notes varchar(100) NOT NULL
);
-CREATE INDEX liner_notes_idx_liner_id ON liner_notes (liner_id);
-
--
-- Table: lyric_versions
--
-- View: year2000cds
--
CREATE VIEW year2000cds AS
- SELECT cdid, artist, title FROM cd WHERE year ='2000';
-
-COMMIT;
+ SELECT cdid, artist, title, year, genreid, single_track FROM cd WHERE year = "2000"
\ No newline at end of file
],
});
},
- qr/Recursive update is not supported over relationships of type multi/,
+ qr/Recursive update is not supported over relationships of type 'multi'/,
'create via update of multi relationships throws an exception'
);
}, 'Nested find_or_create');
lives_ok ( sub {
- my $artist = $schema->resultset('Artist')->first;
-
- my $cd_result = $artist->create_related('cds', {
-
- title => 'TestOneCD1',
- year => 2007,
- tracks => [
- { title => 'TrackOne' },
- { title => 'TrackTwo' },
- ],
-
- });
-
- isa_ok( $cd_result, 'DBICTest::CD', "Got Good CD Class");
- ok( $cd_result->title eq "TestOneCD1", "Got Expected Title");
-
- my $tracks = $cd_result->tracks;
-
- isa_ok( $tracks, 'DBIx::Class::ResultSet', 'Got Expected Tracks ResultSet');
-
- foreach my $track ($tracks->all)
- {
- isa_ok( $track, 'DBICTest::Track', 'Got Expected Track Class');
- }
+ my $artist = $schema->resultset('Artist')->first;
+
+ my $cd_result = $artist->create_related('cds', {
+
+ title => 'TestOneCD1',
+ year => 2007,
+ tracks => [
+ { title => 'TrackOne' },
+ { title => 'TrackTwo' },
+ ],
+
+ });
+
+ isa_ok( $cd_result, 'DBICTest::CD', "Got Good CD Class");
+ ok( $cd_result->title eq "TestOneCD1", "Got Expected Title");
+
+ my $tracks = $cd_result->tracks;
+
+ isa_ok( $tracks, 'DBIx::Class::ResultSet', 'Got Expected Tracks ResultSet');
+
+ foreach my $track ($tracks->all)
+ {
+ isa_ok( $track, 'DBICTest::Track', 'Got Expected Track Class');
+ }
}, 'First create_related pass');
lives_ok ( sub {
- my $artist = $schema->resultset('Artist')->first;
-
- my $cd_result = $artist->create_related('cds', {
-
- title => 'TestOneCD2',
- year => 2007,
- tracks => [
- { title => 'TrackOne' },
- { title => 'TrackTwo' },
- ],
+ my $artist = $schema->resultset('Artist')->first;
+
+ my $cd_result = $artist->create_related('cds', {
+
+ title => 'TestOneCD2',
+ year => 2007,
+ tracks => [
+ { title => 'TrackOne' },
+ { title => 'TrackTwo' },
+ ],
liner_notes => { notes => 'I can haz liner notes?' },
- });
-
- isa_ok( $cd_result, 'DBICTest::CD', "Got Good CD Class");
- ok( $cd_result->title eq "TestOneCD2", "Got Expected Title");
+ });
+
+ isa_ok( $cd_result, 'DBICTest::CD', "Got Good CD Class");
+ ok( $cd_result->title eq "TestOneCD2", "Got Expected Title");
ok( $cd_result->notes eq 'I can haz liner notes?', 'Liner notes');
-
- my $tracks = $cd_result->tracks;
-
- isa_ok( $tracks, 'DBIx::Class::ResultSet', "Got Expected Tracks ResultSet");
-
- foreach my $track ($tracks->all)
- {
- isa_ok( $track, 'DBICTest::Track', 'Got Expected Track Class');
- }
+
+ my $tracks = $cd_result->tracks;
+
+ isa_ok( $tracks, 'DBIx::Class::ResultSet', "Got Expected Tracks ResultSet");
+
+ foreach my $track ($tracks->all)
+ {
+ isa_ok( $track, 'DBICTest::Track', 'Got Expected Track Class');
+ }
}, 'second create_related with same arguments');
lives_ok ( sub {
is($a->name, 'Kurt Cobain', 'Artist insertion ok');
is($a->cds && $a->cds->first && $a->cds->first->title,
- 'In Utero', 'CD insertion ok');
+ 'In Utero', 'CD insertion ok');
}, 'populate');
## Create foreign key col obj including PK
}, 'Create foreign key col obj including PK');
lives_ok ( sub {
- $schema->resultset("CD")->create({
+ $schema->resultset("CD")->create({
cdid => 28,
title => 'Boogie Wiggle',
year => '2007',
}
}
-plan tests => (scalar (keys %tests) * 3);
-
foreach my $name (keys %tests) {
foreach my $artwork ($tests{$name}->all()) {
is($artwork->id, 1, $name . ', correct artwork');
is($artwork->cd->artist->artistid, 1, $name . ', correct artist_id over cd');
is($artwork->artwork_to_artist->first->artist->artistid, 2, $name . ', correct artist_id over A2A');
}
-}
\ No newline at end of file
+}
+
+done_testing;
single_track_2.trackid, single_track_2.cd, single_track_2.position, single_track_2.title, single_track_2.last_updated_on, single_track_2.last_updated_at, single_track_2.small_dt,
cd.cdid, cd.artist, cd.title, cd.year, cd.genreid, cd.single_track
FROM artist me
- LEFT JOIN cd cds ON cds.artist = me.artistid
+ JOIN cd cds ON cds.artist = me.artistid
LEFT JOIN track single_track ON single_track.trackid = cds.single_track
LEFT JOIN track single_track_2 ON single_track_2.trackid = cds.single_track
LEFT JOIN cd cd ON cd.cdid = single_track_2.cd
'(
SELECT me.cd, me.track_count, cd.cdid, cd.artist, cd.title, cd.year, cd.genreid, cd.single_track
FROM (
- SELECT me.cd, COUNT (me.trackid) AS track_count,
+ SELECT me.cd, COUNT (me.trackid) AS track_count
FROM track me
JOIN cd cd ON cd.cdid = me.cd
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
GROUP BY me.cd
- ) as me
+ ) me
JOIN cd cd ON cd.cdid = me.cd
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
)',
FROM (
SELECT me.cdid
FROM cd me
- LEFT JOIN track tracks ON tracks.cd = me.cdid
- LEFT JOIN liner_notes liner_notes ON liner_notes.liner_id = me.cdid
WHERE ( me.cdid IS NOT NULL )
GROUP BY me.cdid
LIMIT 2
tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at, tracks.small_dt,
liner_notes.liner_id, liner_notes.notes
FROM (
- SELECT me.cdid, COUNT( tracks.trackid ) AS track_count, MAX( tracks.trackid ) AS maxtr,
+ SELECT me.cdid, COUNT( tracks.trackid ) AS track_count, MAX( tracks.trackid ) AS maxtr
FROM cd me
LEFT JOIN track tracks ON tracks.cd = me.cdid
WHERE ( me.cdid IS NOT NULL )
$rs->as_query,
'(
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
- tags.tagid, tags.cd, tags.tag
+ tags.tagid, tags.cd, tags.tag
FROM (
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me
- GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, cdid
ORDER BY cdid
) me
LEFT JOIN tags tags ON tags.cd = me.cdid
);
}
+{
+ my $rs = $schema->resultset('CD')->search({},
+ {
+ '+select' => [{ count => 'tags.tag' }],
+ '+as' => ['test_count'],
+ prefetch => ['tags'],
+ distinct => 1,
+ order_by => {'-asc' => 'tags.tag'},
+ rows => 1
+ }
+ );
+ is_same_sql_bind($rs->as_query, q{
+ (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, me.test_count, tags.tagid, tags.cd, tags.tag
+ FROM (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, COUNT( tags.tag ) AS test_count
+ FROM cd me LEFT JOIN tags tags ON tags.cd = me.cdid
+ GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, tags.tag
+ ORDER BY tags.tag ASC LIMIT 1)
+ me
+ LEFT JOIN tags tags ON tags.cd = me.cdid
+ ORDER BY tags.tag ASC, tags.cd, tags.tag
+ )
+ }, []);
+}
+
done_testing;
use DBICTest;
use IO::File;
-plan tests => 10;
-
my $schema = DBICTest->init_schema();
my $sdebug = $schema->storage->debug;
-
# once the following TODO is complete, remove the 2 warning tests immediately
# after the TODO block
# (the TODO block itself contains tests ensuring that the warns are removed)
is (@w, 1, 'warning on attempt prefetching several same level has_manys (M -> 1 -> M + M)');
}
-__END__
-The solution is to rewrite ResultSet->_collapse_result() and
-ResultSource->resolve_prefetch() to focus on the final results from the collapse
-of the data. Right now, the code doesn't treat the columns from the various
-tables as grouped entities. While there is a concept of hierarchy (so that
-prefetching down relationships does work as expected), there is no idea of what
-the final product should look like and how the various columns in the row would
-play together. So, the actual prefetch datastructure from the search would be
-very useful in working through this problem. We already have access to the PKs
-and sundry for those. So, when collapsing the search result, we know we are
-looking for 1 cd object. We also know we're looking for tracks and tags records
--independently- of each other. So, we can grab the data for tracks and data for
-tags separately, uniqueing on the PK as appropriate. Then, when we're done with
-the given cd object's datastream, we know we're good. This should work for all
-the various scenarios.
-
-My reccommendation is the row's data is preprocessed first, breaking it up into
-the data for each of the component tables. (This could be done in the single
-table case, too, but probably isn't necessary.) So, starting with something
-like:
- my $row = {
- t1.col1 => 1,
- t1.col2 => 2,
- t2.col1 => 3,
- t2.col2 => 4,
- t3.col1 => 5,
- t3.col2 => 6,
- };
-it is massaged to look something like:
- my $row_massaged = {
- t1 => { col1 => 1, col2 => 2 },
- t2 => { col1 => 3, col2 => 4 },
- t3 => { col1 => 5, col2 => 6 },
- };
-At this point, find the stuff that's different is easy enough to do and slotting
-things into the right spot is, likewise, pretty straightforward. Instead of
-storing things in a AoH, store them in a HoH keyed on the PKs of the the table,
-then convert to an AoH after all collapsing is done.
-
-This implies that the collapse attribute can probably disappear or, at the
-least, be turned into a boolean (which is how it's used in every other place).
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $artist = $schema->resultset ('Artist')->find ({artistid => 1});
+is ($artist->cds->count, 3, 'Correct number of CDs');
+is ($artist->cds->search_related ('genre')->count, 1, 'Only one of the cds has a genre');
+
+my $queries = 0;
+my $orig_cb = $schema->storage->debugcb;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+
+my $pref = $schema->resultset ('Artist')
+ ->search ({ 'me.artistid' => $artist->id }, { prefetch => { cds => 'genre' } })
+ ->next;
+
+is ($pref->cds->count, 3, 'Correct number of CDs prefetched');
+is ($pref->cds->search_related ('genre')->count, 1, 'Only one of the prefetched cds has a prefetched genre');
+
+
+is ($queries, 1, 'All happened within one query only');
+$schema->storage->debugcb($orig_cb);
+$schema->storage->debug(0);
+
+
+done_testing;
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
-use IO::File;
my $schema = DBICTest->init_schema();
my $orig_debug = $schema->storage->debug;
}, 'search_related prefetch with order_by works');
+TODO: { local $TODO = 'Unqualified columns in where clauses can not be fixed without an SQLA rewrite' if SQL::Abstract->VERSION < 2;
+lives_ok ( sub {
+ my $no_prefetch = $schema->resultset('Track')->search_related(cd =>
+ {
+ 'cd.year' => "2000",
+ 'tagid' => 1,
+ },
+ {
+ join => 'tags',
+ rows => 1,
+ }
+ );
+
+ my $use_prefetch = $no_prefetch->search(
+ undef,
+ {
+ prefetch => 'tags',
+ }
+ );
+
+ is(
+ scalar ($use_prefetch->all),
+ scalar ($no_prefetch->all),
+ "Amount of returned rows is right"
+ );
+ is($use_prefetch->count, $no_prefetch->count, 'counts with and without prefetch match');
+
+}, 'search_related prefetch with condition referencing unqualified column of a joined table works');
+}
+
lives_ok (sub {
my $rs = $schema->resultset("Artwork")->search(undef, {distinct => 1})
is($rs->search_related('cds')->count, 4, 'prefetch without distinct (count)');
- $rs = $artist_rs->search(undef, {distinct => 1})
- ->search_related('cds')->search_related('genre',
+ $rs = $artist_rs->search_related('cds', {}, { distinct => 1})->search_related('genre',
{ 'genre.name' => 'vague genre' },
);
+ is($rs->all, 2, 'distinct does not propagate over search_related (objects)');
+ is($rs->count, 2, 'distinct does not propagate over search_related (count)');
+
+ $rs = $rs->search ({}, { distinct => 1} );
is($rs->all, 1, 'distinct without prefetch (objects)');
is($rs->count, 1, 'distinct without prefetch (count)');
- $rs = $artist_rs->search({}, {distinct => 1})
- ->search_related('cds')->search_related('genre',
+ $rs = $artist_rs->search_related('cds')->search_related('genre',
{ 'genre.name' => 'vague genre' },
- { prefetch => 'cds' },
+ { prefetch => 'cds', distinct => 1 },
);
is($rs->all, 1, 'distinct with prefetch (objects)');
is($rs->count, 1, 'distinct with prefetch (count)');
+
+ TODO: {
+ local $TODO = "This makes another 2 trips to the database, it can't be right";
# artist -> 2 cds -> 2 genres -> 2 cds for each genre + distinct = 2
is($rs->search_related('cds')->all, 2, 'prefetched distinct with prefetch (objects)');
is($rs->search_related('cds')->count, 2, 'prefetched distinct with prefetch (count)');
-
-
+ }
}, 'distinct generally works with prefetch on deep search_related chains');
use lib qw(t/lib);
use DBICTest;
-plan tests => 9;
-
my $schema = DBICTest->init_schema();
my $use_prefetch = $no_prefetch->search(
{},
{
+ select => ['me.artistid', 'me.name'],
+ as => ['artistid', 'name'],
prefetch => 'cds',
order_by => { -desc => 'name' },
}
my $artist2 = $use_prefetch->search({'cds.title' => { '!=' => $artist_many_cds->cds->first->title } })->slice (0,0)->next;
is($artist2->cds->count, 2, "count on search limiting prefetched has_many");
+done_testing;
year => 2007,
} );
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' );
+is( $cd->in_storage, 0, 'find_or_new_related on a new record: not in_storage' );
$cd->artist(undef);
my $newartist = $cd->find_or_new_related( 'artist', {
'(
SELECT artist_undirected_maps.id1, artist_undirected_maps.id2
FROM artist me
- LEFT JOIN artist_undirected_map artist_undirected_maps
+ JOIN artist_undirected_map artist_undirected_maps
ON artist_undirected_maps.id1 = me.artistid OR artist_undirected_maps.id2 = me.artistid
WHERE ( artistid = ? )
)',
-#!/usr/bin/perl
-
use strict;
-use warnings FATAL => 'all';
+use warnings;
use Test::More;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+
+my $new_rs = $schema->resultset('Artist')->search({
+ 'artwork_to_artist.artist_id' => 1
+}, {
+ join => 'artwork_to_artist'
+});
+lives_ok { $new_rs->count } 'regular search works';
+lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->count }
+ '... and chaining off that using join works';
+lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->as_subselect_rs->count }
+ '... and chaining off the virtual view works';
+dies_ok { $new_rs->as_subselect_rs->search({'artwork_to_artist.artwork_cd_id'=> 1})->count }
+ q{... but chaining off of a virtual view using join doesn't work};
+done_testing;
ok $paginated->is_paged, 'resultset is paginated now';
done_testing;
-
--- /dev/null
+use strict;
+use warnings;
+
+use lib qw(t/lib);
+use Test::More;
+use Test::Exception;
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+
+my $cd_rs = $schema->resultset('CD')->search ({ genreid => undef }, { columns => [ 'genreid' ]} );
+my $count = $cd_rs->count;
+cmp_ok ( $count, '>', 1, 'several CDs with no genre');
+
+my @objects = $cd_rs->all;
+is (scalar @objects, $count, 'Correct amount of objects without limit');
+isa_ok ($_, 'DBICTest::CD') for @objects;
+
+is_deeply (
+ [ map { values %{{$_->get_columns}} } (@objects) ],
+ [ (undef) x $count ],
+ 'All values are indeed undef'
+);
+
+
+isa_ok ($cd_rs->search ({}, { rows => 1 })->single, 'DBICTest::CD');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $cd_rs = $schema->resultset('CD')->search ({genreid => { '!=', undef } }, { order_by => 'cdid' });
+my $track_cnt = $cd_rs->search({}, { rows => 1 })->search_related ('tracks')->count;
+
+my %basecols = $cd_rs->first->get_columns;
+
+# the current implementation of get_inflated_columns will "inflate"
+# relationships by simply calling the accessor, when you have
+# identically named columns and relationships (you shouldn't anyway)
+# I consider this wrong, but at the same time appreciate the
+# ramifications of changing this. Thus the value override and the
+# TODO to go with it. Delete all of this if ever resolved.
+my %todo_rel_inflation_override = ( artist => $basecols{artist} );
+TODO: {
+ local $TODO = 'Treating relationships as inflatable data is wrong - see comment in ' . __FILE__;
+ ok (! keys %todo_rel_inflation_override);
+}
+
+my $plus_rs = $cd_rs->search (
+ {},
+ { join => 'tracks', distinct => 1, '+select' => { count => 'tracks.trackid' }, '+as' => 'tr_cnt' },
+);
+
+is_deeply (
+ { $plus_rs->first->get_columns },
+ { %basecols, tr_cnt => $track_cnt },
+ 'extra columns returned by get_columns',
+);
+
+is_deeply (
+ { $plus_rs->first->get_inflated_columns, %todo_rel_inflation_override },
+ { %basecols, tr_cnt => $track_cnt },
+ 'extra columns returned by get_inflated_columns without inflatable columns',
+);
+
+SKIP: {
+ eval { require DateTime };
+ skip "Need DateTime for +select/get_inflated_columns tests", 1 if $@;
+
+ $schema->class('CD')->inflate_column( 'year',
+ { inflate => sub { DateTime->new( year => shift ) },
+ deflate => sub { shift->year } }
+ );
+
+ $basecols{year} = DateTime->new ( year => $basecols{year} );
+
+ is_deeply (
+ { $plus_rs->first->get_inflated_columns, %todo_rel_inflation_override },
+ { %basecols, tr_cnt => $track_cnt },
+ 'extra columns returned by get_inflated_columns',
+ );
+}
+
+done_testing;
);
# grouping on PKs only should pass
-$sub_rs->search ({}, { group_by => [ reverse $sub_rs->result_source->primary_columns ] }) # reverse to make sure the comaprison works
- ->update ({ pilot_sequence => \ 'pilot_sequence + 1' });
+$sub_rs->search (
+ {},
+ {
+ group_by => [ reverse $sub_rs->result_source->primary_columns ], # reverse to make sure the PK-list comaprison works
+ },
+)->update ({ pilot_sequence => \ 'pilot_sequence + 1' });
is_deeply (
[ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' })
'Only two rows incremented',
);
+# also make sure weird scalarref usage works (RT#51409)
+$tkfks->search (
+ \ 'pilot_sequence BETWEEN 11 AND 21',
+)->update ({ pilot_sequence => \ 'pilot_sequence + 1' });
+
+is_deeply (
+ [ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' })
+ ->get_column ('pilot_sequence')->all
+ ],
+ [qw/12 22 30 40/],
+ 'Only two rows incremented (where => scalarref works)',
+);
+
$sub_rs->delete;
is ($tkfks->count, $tkfk_cnt -= 2, 'Only two rows deleted');
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+lives_ok (sub {
+ DBICTest->init_schema()->resultset('Artist')->find({artistid => 1 })->update({name => 'anon test'});
+}, 'Schema object not lost in chaining');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $clone = $schema->clone;
+cmp_ok ($clone->storage, 'eq', $schema->storage, 'Storage copied into new schema (not a new instance)');
+
+done_testing;
is_same_sql_bind ($rs->as_query, $q{$s}{query}, "$s resultset unmodified (as_query matches)" );
}
-
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $rs = $schema->resultset('CD')->search (
+ { 'tracks.id' => { '!=', 666 }},
+ { join => 'artist', prefetch => 'tracks', rows => 2 }
+);
+
+my $rel_rs = $rs->search_related ('tags', { 'tags.tag' => { '!=', undef }}, { distinct => 1});
+
+is_same_sql_bind (
+ $rel_rs->as_query,
+ '(
+ SELECT tags.tagid, tags.cd, tags.tag
+ FROM (
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM cd me
+ JOIN artist artist ON artist.artistid = me.artist
+ LEFT JOIN track tracks ON tracks.cd = me.cdid
+ WHERE ( tracks.id != ? )
+ LIMIT 2
+ ) me
+ JOIN artist artist ON artist.artistid = me.artist
+ JOIN tags tags ON tags.cd = me.cdid
+ WHERE ( tags.tag IS NOT NULL )
+ GROUP BY tags.tagid, tags.cd, tags.tag
+ )',
+
+ [ [ 'tracks.id' => 666 ] ],
+ 'Prefetch spec successfully stripped on search_related'
+);
+
+done_testing;
search => \[ "title = ? AND year LIKE ?", 'buahaha', '20%' ],
attrs => { rows => 5 },
sqlbind => \[
- "( SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE (title = ? AND year LIKE ?) LIMIT 5)",
+ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE (title = ? AND year LIKE ?) LIMIT 5)",
'buahaha',
'20%',
],
artist_id => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'id' )->as_query },
},
sqlbind => \[
- "( SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ) )",
+ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ) )",
],
},
],
},
sqlbind => \[
- "( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE id > ?) cd2 )",
+ "( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE id > ?
+ ) cd2
+ )",
[ 'id', 20 ]
],
},
{
rs => $art_rs,
attrs => {
- from => [ { 'me' => 'artist' },
- [ { 'cds' => $cdrs->search({},{ 'select' => [\'me.artist as cds_artist' ]})->as_query },
- { 'me.artistid' => 'cds_artist' } ] ]
+ from => [
+ { 'me' => 'artist' },
+ [
+ { 'cds' => $cdrs->search({}, { 'select' => [\'me.artist as cds_artist' ]})->as_query },
+ { 'me.artistid' => 'cds_artist' }
+ ]
+ ]
},
sqlbind => \[
"( SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me JOIN (SELECT me.artist as cds_artist FROM cd me) cds ON me.artistid = cds_artist )"
sqlbind => \[
"( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
FROM
- (SELECT cd3.cdid,cd3.artist,cd3.title,cd3.year,cd3.genreid,cd3.single_track
+ (SELECT cd3.cdid, cd3.artist, cd3.title, cd3.year, cd3.genreid, cd3.single_track
FROM
- (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track
+ (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me WHERE id < ?) cd3
WHERE id > ?) cd2
)",
],
},
sqlbind => \[
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE title = ?) cd2)",
+ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE title = ?
+ ) cd2
+ )",
[ 'title',
'Thriller'
]
{
order_by => [ qw{ foo bar} ],
order_req => 'foo, bar',
- order_inner => 'foo ASC,bar ASC',
+ order_inner => 'foo ASC, bar ASC',
order_outer => 'foo DESC, bar DESC',
},
{
use warnings;
use Test::More;
-use IO::File;
use lib qw(t/lib);
use DBIC::SqlMakerTest;
use warnings;
use Test::More;
-use IO::File;
use lib qw(t/lib);
use DBIC::SqlMakerTest;
}
# Make sure the carp/croak override in SQLA works (via SQLAHacks)
-my $file = __FILE__;
-$file = "\Q$file\E";
+my $file = quotemeta (__FILE__);
throws_ok (sub {
$schema->resultset ('Artist')->search ({}, { order_by => { -asc => 'stuff', -desc => 'staff' } } )->as_query;
}, qr/$file/, 'Exception correctly croak()ed');
use lib qw(t/lib);
use DBIC::SqlMakerTest;
-BEGIN {
- eval "use DBD::SQLite";
- plan $@
- ? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 12 );
-}
-
use_ok('DBICTest');
my $schema = DBICTest->init_schema();
);
+($sql, @bind) = $sql_maker->select(
+ [ { me => 'cd' } ],
+ [qw/ me.cdid me.artist me.title /],
+ { cdid => \['rlike ?', [cdid => 'X'] ] },
+ { group_by => 'title', having => \['count(me.artist) > ?', [ cnt => 2] ] },
+);
+
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title` FROM `cd` `me` WHERE ( `cdid` rlike ? ) GROUP BY `title` HAVING count(me.artist) > ?/,
+ [ [ cdid => 'X'], ['cnt' => '2'] ],
+ 'Quoting works with where/having arrayrefsrefs',
+);
+
+
+($sql, @bind) = $sql_maker->select(
+ [ { me => 'cd' } ],
+ [qw/ me.cdid me.artist me.title /],
+ { cdid => \'rlike X' },
+ { group_by => 'title', having => \'count(me.artist) > 2' },
+);
+
+is_same_sql_bind(
+ $sql, \@bind,
+ q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title` FROM `cd` `me` WHERE ( `cdid` rlike X ) GROUP BY `title` HAVING count(me.artist) > 2/,
+ [],
+ 'Quoting works with where/having scalarrefs',
+);
+
+
($sql, @bind) = $sql_maker->update(
'group',
{
q/UPDATE [group] SET [name] = ?, [order] = ?/, [ ['name' => 'Bill'], ['order' => '12'] ],
'bracket quoted table names for UPDATE'
);
+
+done_testing;
use DBICTest;
use DBIC::DebugObj;
use DBIC::SqlMakerTest;
+use Path::Class qw/file/;
my $schema = DBICTest->init_schema();
-plan tests => 7;
ok ( $schema->storage->debug(1), 'debug' );
-ok ( defined(
- $schema->storage->debugfh(
- IO::File->new('t/var/sql.log', 'w')
- )
- ),
- 'debugfh'
- );
+$schema->storage->debugfh(file('t/var/sql.log')->openw);
$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 $log = file('t/var/sql.log')->openr;
my $line = <$log>;
$log->close();
ok($line =~ /^SELECT COUNT/, 'Log success');
$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($!);
+$log = file('t/var/foo.log')->openr;
$line = <$log>;
$log->close();
ok($line =~ /^SELECT COUNT/, 'Log success');
my @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
is_same_sql_bind(
$sql, \@bind,
- "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND (cdid BETWEEN ? AND ?) ): '1', '1', '3'",
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND (cdid BETWEEN ? AND ?) )",
[qw/'1' '1' '3'/],
'got correct SQL with all bind parameters (debugcb)'
);
);
}
-1;
+done_testing;
projects / dbsrgits/DBIx-Class.git / commitdiff