_build/
blib/
inc/
+lib/DBIx/Class/Optional/Dependencies.pod
pm_to_blib
t/var/
Revision history for DBIx::Class
+ - Add $rs->is_ordered to test for existing order_by on a resultset
+ - Add as_subselect_rs to DBIC::ResultSet from
+ DBIC::Helper::ResultSet::VirtualView::as_virtual_view
+ - New optional dependency manager to aid extension writers
+ - Depend on newest bugfixed Moose
+ - Make resultset chaining consistent wrt selection specification
+ - Storage::DBI::Replicated cleanup
+ - Fix autoinc PKs without an autoinc flag on Sybase ASA
+
+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)
- - Cookbook POD fix for add_drop_table instead of add_drop_tables
- 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
- - Schema POD improvement for dclone
+ - 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
- 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)
use 5.008001;
-# ****** DO NOT ADD OPTIONAL DEPENDENCIES. EVER. --mst ******
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+###
+### DO NOT ADD OPTIONAL DEPENDENCIES HERE, EVEN AS recommends()
+### All of them should go to DBIx::Class::Optional::Dependencies
+###
+
name 'DBIx-Class';
perl_version '5.008001';
all_from 'lib/DBIx/Class.pm';
+my $build_requires = {
+ 'DBD::SQLite' => '1.25',
+};
+
+my $test_requires = {
+ 'File::Temp' => '0.22',
+ 'Test::Builder' => '0.33',
+ 'Test::Deep' => '0',
+ 'Test::Exception' => '0',
+ 'Test::More' => '0.92',
+ 'Test::Warn' => '0.21',
+};
+
+my $runtime_requires = {
+ # Core
+ 'List::Util' => '0',
+ 'Scalar::Util' => '0',
+ 'Storable' => '0',
+
+ # Dependencies
+ 'Carp::Clan' => '6.0',
+ 'Class::Accessor::Grouped' => '0.09002',
+ 'Class::C3::Componentised' => '1.0005',
+ 'Class::Inspector' => '1.24',
+ 'Data::Page' => '2.00',
+ 'DBI' => '1.609',
+ 'JSON::Any' => '1.18',
+ 'MRO::Compat' => '0.09',
+ 'Module::Find' => '0.06',
+ 'Path::Class' => '0.16',
+ 'Scope::Guard' => '0.03',
+ 'SQL::Abstract' => '1.61',
+ 'SQL::Abstract::Limit' => '0.13',
+ 'Sub::Name' => '0.04',
+ 'Data::Dumper::Concise' => '1.000',
+};
+
+# this is so we can order requires alphabetically
+# copies are needed for author requires injection
+my $reqs = {
+ build_requires => { %$build_requires },
+ requires => { %$runtime_requires },
+ test_requires => { %$test_requires },
+};
+
+# re-build README and require extra modules for testing if we're in a checkout
+if ($Module::Install::AUTHOR) {
+
+ print "Regenerating README\n";
+ system('pod2text lib/DBIx/Class.pm > README');
+
+ if (-f 'MANIFEST') {
+ print "Removing MANIFEST\n";
+ unlink 'MANIFEST';
+ }
+
+ print "Regenerating Optional/Dependencies.pod\n";
+ require DBIx::Class::Optional::Dependencies;
+ DBIx::Class::Optional::Dependencies->_gen_pod;
+
+# FIXME Disabled due to unsolved issues, ask theorbtwo
+# require Module::Install::Pod::Inherit;
+# PodInherit();
+
+ warn <<'EOW';
+******************************************************************************
+******************************************************************************
+*** ***
+*** AUTHOR MODE: all optional test dependencies converted to hard requires ***
+*** ***
+******************************************************************************
+******************************************************************************
+
+EOW
+
+ $reqs->{test_requires} = {
+ %{$reqs->{test_requires}},
+ %{DBIx::Class::Optional::Dependencies->_all_optional_requirements},
+ };
+}
+
+# compose final req list, for alphabetical ordering
+my %final_req;
+for my $rtype (keys %$reqs) {
+ for my $mod (keys %{$reqs->{$rtype}} ) {
+
+ # sanity check req duplications
+ if ($final_req{$mod}) {
+ die "$mod specified as both a $rtype and a $final_req{$mod}[1]\n";
+ }
-test_requires 'Test::Builder' => '0.33';
-test_requires 'Test::Deep' => '0';
-test_requires 'Test::Exception' => '0';
-test_requires 'Test::More' => '0.92';
-test_requires 'Test::Warn' => '0.21';
-
-test_requires 'File::Temp' => '0.22';
-
-test_requires 'Module::Load' => '0.16';
-
-
-# Core
-requires 'List::Util' => '0';
-requires 'Scalar::Util' => '0';
-requires 'Storable' => '0';
-
-# Dependencies (keep in alphabetical order)
-requires 'Carp::Clan' => '6.0';
-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.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::Limit' => '0.13';
-requires 'Sub::Name' => '0.04';
-requires 'Data::Dumper::Concise' => '1.000';
-
-my %replication_requires = (
- 'Moose', => '0.90',
- 'MooseX::Types', => '0.16',
- 'namespace::clean' => '0.11',
- 'Hash::Merge', => '0.11',
-);
-
-my %admin_requires = (
- 'Moose', => '0.87',
- 'MooseX::Types', => '0.16',
- 'MooseX::Types::Path::Class' => '0.05',
- 'MooseX::Types::JSON' => '0.02',
- 'Try::Tiny' => '0.02',
- 'namespace::autoclean' => '0.09',
- 'parent' => '0.223',
- 'JSON::Any' => '0',
- 'Getopt::Long::Descriptive' => '0.081',
- 'Text::CSV_XS' => '0.70',
-);
-
-#************************************************************************#
-# Make *ABSOLUTELY SURE* that nothing on this list is a real require, #
-# since every module listed in %force_requires_if_author is deleted #
-# from the final META.yml (thus will never make it as a CPAN dependency) #
-#************************************************************************#
-my %force_requires_if_author = (
- %replication_requires,
- %admin_requires,
- # when changing also adjust $DBIx::Class::Storage::DBI::minimum_sqlt_version
- 'SQL::Translator' => '0.11002',
-
-# 'Module::Install::Pod::Inherit' => '0.01',
-
- # when changing also adjust version in t/02pod.t
- 'Test::Pod' => '1.26',
-
- # when changing also adjust version in t/03podcoverage.t
- 'Test::Pod::Coverage' => '1.08',
- 'Pod::Coverage' => '0.20',
-
- # CDBI-compat related
- 'DBIx::ContextualFetch' => '0',
- 'Class::DBI::Plugin::DeepAbstractSearch' => '0',
- 'Class::Trigger' => '0',
- 'Time::Piece::MySQL' => '0',
- 'Clone' => '0',
- 'Date::Simple' => '3.03',
-
- # t/52cycle.t
- 'Test::Memory::Cycle' => '0',
- 'Devel::Cycle' => '1.10',
-
- # t/36datetime.t
- # t/60core.t
- 'DateTime::Format::SQLite' => '0',
-
- # t/96_is_deteministic_value.t
- 'DateTime::Format::Strptime'=> '0',
-
- # database-dependent reqs
- #
- $ENV{DBICTEST_PG_DSN}
- ? (
- 'Sys::SigAction' => '0',
- 'DBD::Pg' => '2.009002',
- 'DateTime::Format::Pg' => '0',
- ) : ()
- ,
-
- $ENV{DBICTEST_MYSQL_DSN}
- ? (
- 'DateTime::Format::MySQL' => '0',
- ) : ()
- ,
-
- $ENV{DBICTEST_ORA_DSN}
- ? (
- 'DateTime::Format::Oracle' => '0',
- ) : ()
- ,
-
- $ENV{DBICTEST_SYBASE_DSN}
- ? (
- 'DateTime::Format::Sybase' => 0,
- ) : ()
- ,
-);
-#************************************************************************#
-# Make ABSOLUTELY SURE that nothing on the list above is a real require, #
-# since every module listed in %force_requires_if_author is deleted #
-# from the final META.yml (thus will never make it as a CPAN dependency) #
-#************************************************************************#
+ $final_req{$mod} = [ $rtype, $reqs->{$rtype}{$mod}||0 ],
+ }
+}
+# actual require
+for my $mod (sort keys %final_req) {
+ my ($rtype, $ver) = @{$final_req{$mod}};
+ no strict 'refs';
+ $rtype->($mod, $ver);
+}
install_script (qw|
script/dbicadmin
# Deprecated/internal modules need no exposure
no_index directory => $_ for (qw|
lib/DBIx/Class/SQLAHacks
- lib/DBIx/Class/PK/Auto
+ 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
-
-if ($Module::Install::AUTHOR) {
- warn <<'EOW';
-******************************************************************************
-******************************************************************************
-*** ***
-*** AUTHOR MODE: all optional test dependencies converted to hard requires ***
-*** ***
-******************************************************************************
-******************************************************************************
-
-EOW
-
- foreach my $module (sort keys %force_requires_if_author) {
- build_requires ($module => $force_requires_if_author{$module});
- }
-
- print "Regenerating README\n";
- system('pod2text lib/DBIx/Class.pm > README');
-
- if (-f 'MANIFEST') {
- print "Removing MANIFEST\n";
- unlink 'MANIFEST';
- }
-
-# require Module::Install::Pod::Inherit;
-# PodInherit();
-}
auto_install();
WriteAll();
+
# 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
- { not exists $force_requires_if_author{$_->[0]} }
- ( @{Meta->{values}{build_requires}} )
+ # FIXME test_requires is not yet part of META
+ my %original_build_requires = ( %$build_requires, %$test_requires );
+
+ print "Regenerating META with author requires excluded\n";
+ Meta->{values}{build_requires} = [ grep
+ { exists $original_build_requires{$_->[0]} }
+ ( @{Meta->{values}{build_requires}} )
];
Meta->write;
use MRO::Compat;
use mro 'c3';
+use DBIx::Class::Optional::Dependencies;
+
use vars qw($VERSION);
use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
use DBIx::Class::StartupCheck;
# 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.08115';
+$VERSION = '0.08118_01';
$VERSION = eval $VERSION; # numify for warning-free dev releases
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>
debolaz: Anders Nor Berle <berle@cpan.org>
+dew: Dan Thomas <dan@godders.org>
+
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
dnm: Justin Wheeler <jwheeler@datademons.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>
robkinyon: Rob Kinyon <rkinyon@cpan.org>
+Roman: Roman Filippov <romanf@cpan.org>
+
sc_: Just Another Perl Hacker
scotty: Scotty Allen <scotty@scottyallen.com>
no strict 'refs';
for my $comp (reverse @_) {
- if (
- $comp->isa ('DBIx::Class::UTF8Columns')
- and
- my @broken = grep { $_ ne 'DBIx::Class::Row' and defined ${"${_}::"}{store_column} } (@present_components)
- ) {
+
+ 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';
- }
- else {
- unshift @present_components, $comp;
+ .'). Refer to the documentation of DBIx::Class::UTF8Columns for more info'
+ if @broken;
}
+
+ unshift @present_components, $comp;
}
$class->next::method($target, @_);
use strict;
use warnings;
-no warnings 'qw';
use base qw/DBIx::Class/;
PK::Auto
PK
Row
- ResultSourceProxy::Table/);
+ ResultSourceProxy::Table
+/);
1;
$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;
}
}
}
- 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__
=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
--- /dev/null
+package DBIx::Class::Optional::Dependencies;
+
+use warnings;
+use strict;
+
+use Carp;
+
+# NO EXTERNAL NON-5.8.1 CORE DEPENDENCIES EVER (e.g. C::A::G)
+# This module is to be loaded by Makefile.PM on a pristine system
+
+# POD is generated automatically by calling _gen_pod from the
+# Makefile.PL in $AUTHOR mode
+
+my $reqs = {
+ dist => {
+ #'Module::Install::Pod::Inherit' => '0.01',
+ },
+
+ replicated => {
+ req => {
+ 'Moose' => '0.98',
+ 'MooseX::Types' => '0.21',
+ 'namespace::clean' => '0.11',
+ 'Hash::Merge' => '0.11',
+ },
+ pod => {
+ title => 'Storage::Replicated',
+ desc => 'Modules required for L<DBIx::Class::Storage::DBI::Replicated>',
+ },
+ },
+
+ admin => {
+ },
+
+ deploy => {
+ req => {
+ 'SQL::Translator' => '0.11002',
+ },
+ pod => {
+ title => 'Storage::DBI::deploy()',
+ desc => 'Modules required for L<DBIx::Class::Storage::DBI/deploy> and L<DBIx::Class::Storage::DBI/deploymen_statements>',
+ },
+ },
+
+ author => {
+ req => {
+ 'Test::Pod' => '1.26',
+ 'Test::Pod::Coverage' => '1.08',
+ 'Pod::Coverage' => '0.20',
+ #'Test::NoTabs' => '0.9',
+ #'Test::EOL' => '0.6',
+ },
+ },
+
+ core => {
+ req => {
+ # t/52cycle.t
+ 'Test::Memory::Cycle' => '0',
+ 'Devel::Cycle' => '1.10',
+
+ # t/36datetime.t
+ # t/60core.t
+ 'DateTime::Format::SQLite' => '0',
+
+ # t/96_is_deteministic_value.t
+ 'DateTime::Format::Strptime'=> '0',
+ },
+ },
+
+ cdbicompat => {
+ req => {
+ 'DBIx::ContextualFetch' => '0',
+ 'Class::DBI::Plugin::DeepAbstractSearch' => '0',
+ 'Class::Trigger' => '0',
+ 'Time::Piece::MySQL' => '0',
+ 'Clone' => '0',
+ 'Date::Simple' => '3.03',
+ },
+ },
+
+ rdbms_pg => {
+ req => {
+ $ENV{DBICTEST_PG_DSN}
+ ? (
+ 'Sys::SigAction' => '0',
+ 'DBD::Pg' => '2.009002',
+ 'DateTime::Format::Pg' => '0',
+ ) : ()
+ },
+ },
+
+ rdbms_mysql => {
+ req => {
+ $ENV{DBICTEST_MYSQL_DSN}
+ ? (
+ 'DateTime::Format::MySQL' => '0',
+ 'DBD::mysql' => '0',
+ ) : ()
+ },
+ },
+
+ rdbms_oracle => {
+ req => {
+ $ENV{DBICTEST_ORA_DSN}
+ ? (
+ 'DateTime::Format::Oracle' => '0',
+ ) : ()
+ },
+ },
+
+ rdbms_ase => {
+ req => {
+ $ENV{DBICTEST_SYBASE_DSN}
+ ? (
+ 'DateTime::Format::Sybase' => 0,
+ ) : ()
+ },
+ },
+
+ rdbms_asa => {
+ req => {
+ grep $_, @ENV{qw/DBICTEST_SYBASE_ASA_DSN DBICTEST_SYBASE_ASA_ODBC_DSN/}
+ ? (
+ 'DateTime::Format::Strptime' => 0,
+ ) : ()
+ },
+ },
+};
+
+
+sub _all_optional_requirements {
+ return { map { %{ $reqs->{$_}{req} || {} } } (keys %$reqs) };
+}
+
+sub req_list_for {
+ my ($class, $group) = @_;
+
+ croak "req_list_for() expects a requirement group name"
+ unless $group;
+
+ my $deps = $reqs->{$group}{req}
+ or croak "Requirement group '$group' does not exist";
+
+ return { %$deps };
+}
+
+
+our %req_availability_cache;
+sub req_ok_for {
+ my ($class, $group) = @_;
+
+ croak "req_ok_for() expects a requirement group name"
+ unless $group;
+
+ $class->_check_deps ($group) unless $req_availability_cache{$group};
+
+ return $req_availability_cache{$group}{status};
+}
+
+sub req_missing_for {
+ my ($class, $group) = @_;
+
+ croak "req_missing_for() expects a requirement group name"
+ unless $group;
+
+ $class->_check_deps ($group) unless $req_availability_cache{$group};
+
+ return $req_availability_cache{$group}{missing};
+}
+
+sub req_errorlist_for {
+ my ($class, $group) = @_;
+
+ croak "req_errorlist_for() expects a requirement group name"
+ unless $group;
+
+ $class->_check_deps ($group) unless $req_availability_cache{$group};
+
+ return $req_availability_cache{$group}{errorlist};
+}
+
+sub _check_deps {
+ my ($class, $group) = @_;
+
+ my $deps = $class->req_list_for ($group);
+
+ my %errors;
+ for my $mod (keys %$deps) {
+ if (my $ver = $deps->{$mod}) {
+ eval "use $mod $ver ()";
+ }
+ else {
+ eval "require $mod";
+ }
+
+ $errors{$mod} = $@ if $@;
+ }
+
+ if (keys %errors) {
+ my $missing = join (', ', map { $deps->{$_} ? "$_ >= $deps->{$_}" : $_ } (sort keys %errors) );
+ $missing .= " (see $class for details)" if $reqs->{$group}{pod};
+ $req_availability_cache{$group} = {
+ status => 0,
+ errorlist => { %errors },
+ missing => $missing,
+ };
+ }
+ else {
+ $req_availability_cache{$group} = {
+ status => 1,
+ errorlist => {},
+ missing => '',
+ };
+ }
+}
+
+sub _gen_pod {
+ my $class = shift;
+
+ my @chunks = (
+ '=head1 NAME',
+ "$class - Optional module dependency specifications",
+ '=head1 DESCRIPTION',
+ <<'EOD',
+Some of the less-frequently used features of L<DBIx::Class> have external
+module dependencies on their own. In order not to burden the average user
+with modules he will never use, these optional dependencies are not included
+in the base Makefile.PL. Instead an exception with a descriptive message is
+thrown when a specific feature is missing one or several modules required for
+its operation. This module is the central holding place for the current list
+of such dependencies.
+EOD
+ '=head1 CURRENT REQUIREMENT GROUPS',
+ <<'EOD',
+Dependencies are organized in C<groups> and each group can list one or more
+required modules, with an optional minimum version (or 0 for any version).
+The group name can be used in the
+EOD
+ );
+
+ for my $group (sort keys %$reqs) {
+ my $p = $reqs->{$group}{pod}
+ or next;
+
+ my $modlist = $reqs->{$group}{req}
+ or next;
+
+ next unless keys %$modlist;
+
+ push @chunks, (
+ "=head2 $p->{title}",
+ "$p->{desc}",
+ '=over',
+ ( map { "=item * $_" . ($modlist->{$_} ? " >= $modlist->{$_}" : '') } (sort keys %$modlist) ),
+ '=back',
+ "Requirement group: B<$group>",
+ );
+ }
+
+ push @chunks, (
+ '=head1 METHODS',
+ '=head2 req_list_for',
+ '=over',
+ '=item Arguments: $group_name',
+ '=item Returns: \%list_of_module_version_pairs',
+ '=back',
+ <<EOD,
+This method should be used by DBIx::Class extension authors, to determine the
+version of modules which a specific feature requires in the current version of
+DBIx::Class. For example if you write a module/extension that requires
+DBIx::Class and also requires the availability of
+L<DBIx::Class::Storage::DBI/deploy>, you can do the following in your
+C<Makefile.PL> or C<Build.PL>
+
+ require $class;
+ my \$dep_list = $class->req_list_for ('deploy');
+
+Which will give you a list of module/version pairs necessary for the particular
+feature to function with this version of DBIx::Class.
+EOD
+
+ '=head2 req_ok_for',
+ '=over',
+ '=item Arguments: $group_name',
+ '=item Returns: 1|0',
+ '=back',
+ 'Returns true or false depending on whether all modules required by $group_name are present on the system and loadable',
+
+ '=head2 req_missing_for',
+ '=over',
+ '=item Arguments: $group_name',
+ '=item Returns: $error_message_string',
+ '=back',
+ <<EOD,
+Returns a single line string suitable for inclusion in larger error messages.
+This method would normally be used by DBIx::Class core-module author, to
+indicate to the user that he needs to install specific modules before he will
+be able to use a specific feature.
+
+For example if the requirements for C<replicated> are not available, the
+returned string would look like:
+
+ Moose >= 0.98, MooseX::Types >= 0.21, namespace::clean (see $class for details)
+
+The author is expected to prepend the necessary text to this message before
+returning the actual error seen by the user.
+EOD
+
+ '=head2 req_errorlist_for',
+ '=over',
+ '=item Arguments: $group_name',
+ '=item Returns: \%list_of_loaderrors_per_module',
+ '=back',
+ <<'EOD',
+Returns a hashref containing the actual errors that occured while attempting
+to load each module in the requirement group.
+EOD
+
+ );
+
+ my $fn = __FILE__;
+ $fn =~ s/\.pm$/\.pod/;
+
+ open (my $fh, '>', $fn) or croak "Unable to write to $fn: $!";
+ print $fh join ("\n\n", @chunks);
+ close ($fh);
+}
+
+1;
__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;
}
$rows = $self->get_cache;
}
+ # reset the selector list
+ if (List::Util::first { exists $attrs->{$_} } qw{columns select as}) {
+ delete @{$our_attrs}{qw{select as columns +select +as +columns include_columns}};
+ }
+
my $new_attrs = { %{$our_attrs}, %{$attrs} };
# merge new attrs into inherited
- foreach my $key (qw/join prefetch +select +as bind/) {
+ foreach my $key (qw/join prefetch +select +as +columns include_columns bind/) {
next unless exists $attrs->{$key};
$new_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key});
}
# 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);
# this is so that the query can be simplified e.g.
- # * non-limiting joins can be pruned
# * ordering can be thrown away in things like Top limit
$sub_attrs->{-for_count_only} = 1;
return !!$self->{attrs}{page};
}
+=head2 is_ordered
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: true, if the resultset has been ordered with C<order_by>.
+
+=back
+
+=cut
+
+sub is_ordered {
+ my ($self) = @_;
+ return scalar $self->result_source->storage->_parse_order_by($self->{attrs}{order_by});
+}
+
=head2 related_resultset
=over 4
->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
+ # (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);
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
# we consider the last one thus reverse
for my $j (reverse @requested_joins) {
- if ($rel eq $j->[0]{-join_path}[-1]) {
+ 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}++;
-# $already_joined++;
-# last;
-# }
-# }
unless ($already_joined) {
push @$from, $source->_resolve_join(
# build columns (as long as select isn't set) into a set of as/select hashes
unless ( $attrs->{select} ) {
- my @cols = ( ref($attrs->{columns}) eq 'ARRAY' )
- ? @{ delete $attrs->{columns}}
- : (
- ( delete $attrs->{columns} )
- ||
- $source->columns
- )
- ;
+ my @cols;
+ if ( ref $attrs->{columns} eq 'ARRAY' ) {
+ @cols = @{ delete $attrs->{columns}}
+ } elsif ( defined $attrs->{columns} ) {
+ @cols = delete $attrs->{columns}
+ } else {
+ @cols = $source->columns
+ }
- @colbits = map {
- ( ref($_) eq 'HASH' )
- ? $_
- : {
- (
- /^\Q${alias}.\E(.+)$/
- ? "$1"
- : "$_"
- )
- =>
- (
- /\./
- ? "$_"
- : "${alias}.$_"
- )
- }
- } @cols;
+ for (@cols) {
+ if ( ref $_ eq 'HASH' ) {
+ push @colbits, $_
+ } else {
+ my $key = /^\Q${alias}.\E(.+)$/
+ ? "$1"
+ : "$_";
+ my $value = /\./
+ ? "$_"
+ : "${alias}.$_";
+ push @colbits, { $key => $value };
+ }
+ }
}
# add the additional columns on
- foreach ( 'include_columns', '+columns' ) {
- push @colbits, map {
- ( ref($_) eq 'HASH' )
- ? $_
- : { ( split( /\./, $_ ) )[-1] => ( /\./ ? $_ : "${alias}.$_" ) }
- } ( ref($attrs->{$_}) eq 'ARRAY' ) ? @{ delete $attrs->{$_} } : delete $attrs->{$_} if ( $attrs->{$_} );
+ foreach (qw{include_columns +columns}) {
+ if ( $attrs->{$_} ) {
+ my @list = ( ref($attrs->{$_}) eq 'ARRAY' )
+ ? @{ delete $attrs->{$_} }
+ : delete $attrs->{$_};
+ for (@list) {
+ if ( ref($_) eq 'HASH' ) {
+ push @colbits, $_
+ } else {
+ my $key = ( split /\./, $_ )[-1];
+ my $value = ( /\./ ? $_ : "$alias.$_" );
+ push @colbits, { $key => $value };
+ }
+ }
+ }
}
# start with initial select items
( ref $attrs->{select} eq 'ARRAY' )
? [ @{ $attrs->{select} } ]
: [ $attrs->{select} ];
- $attrs->{as} = (
- $attrs->{as}
- ? (
- ref $attrs->{as} eq 'ARRAY'
- ? [ @{ $attrs->{as} } ]
- : [ $attrs->{as} ]
+
+ if ( $attrs->{as} ) {
+ $attrs->{as} =
+ (
+ ref $attrs->{as} eq 'ARRAY'
+ ? [ @{ $attrs->{as} } ]
+ : [ $attrs->{as} ]
)
- : [ map { m/^\Q${alias}.\E(.+)$/ ? $1 : $_ } @{ $attrs->{select} } ]
- );
+ } else {
+ $attrs->{as} = [ map {
+ m/^\Q${alias}.\E(.+)$/
+ ? $1
+ : $_
+ } @{ $attrs->{select} }
+ ]
+ }
}
else {
}
# now add colbits to select/as
- push( @{ $attrs->{select} }, map { values( %{$_} ) } @colbits );
- push( @{ $attrs->{as} }, map { keys( %{$_} ) } @colbits );
+ push @{ $attrs->{select} }, map values %{$_}, @colbits;
+ push @{ $attrs->{as} }, map keys %{$_}, @colbits;
- my $adds;
- if ( $adds = delete $attrs->{'+select'} ) {
+ if ( my $adds = delete $attrs->{'+select'} ) {
$adds = [$adds] unless ref $adds eq 'ARRAY';
- push(
- @{ $attrs->{select} },
- map { /\./ || ref $_ ? $_ : "${alias}.$_" } @$adds
- );
+ push @{ $attrs->{select} },
+ map { /\./ || ref $_ ? $_ : "$alias.$_" } @$adds;
}
- if ( $adds = delete $attrs->{'+as'} ) {
+ if ( my $adds = delete $attrs->{'+as'} ) {
$adds = [$adds] unless ref $adds eq 'ARRAY';
- push( @{ $attrs->{as} }, @$adds );
+ push @{ $attrs->{as} }, @$adds;
}
- $attrs->{from} ||= [ {
+ $attrs->{from} ||= [{
-source_handle => $source->handle,
-alias => $self->{attrs}{alias},
$self->{attrs}{alias} => $source->from,
- } ];
+ }];
if ( $attrs->{join} || $attrs->{prefetch} ) {
$join,
$alias,
{ %{ $attrs->{seen_join} || {} } },
- ($attrs->{seen_join} && keys %{$attrs->{seen_join}})
+ ( $attrs->{seen_join} && keys %{$attrs->{seen_join}})
? $attrs->{from}[-1][0]{-join_path}
: []
,
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});
- my @chunks = $storage->sql_maker->_order_by_chunks ($attrs->{order_by});
- for my $chunk (map { ref $_ ? @$_ : $_ } (@chunks) ) {
- $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+ 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 ($cur_depth % 2) {
- $self->throw_exception ("-relation_chain_depth is not even, 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/2 .. $#$jpath]; #only even depths are actual jpath boundaries
- push @{$p->{-join_aliases} }, $j->[0]{-alias};
- }
-
- return $paths;
-}
-
sub _rollout_attr {
my ($self, $attr) = @_;
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} ||= {};
+
+ # 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 $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 ();
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
)
);
}
? '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,
},
}
}
-# 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));
$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)) {
for my $col (keys %loaded_colinfo) {
if (exists $loaded_colinfo{$col}{accessor}) {
my $acc = $loaded_colinfo{$col}{accessor};
- if (defined $acc) {
- $inflated{$col} = $self->$acc;
- }
+ $inflated{$col} = $self->$acc if defined $acc;
}
else {
$inflated{$col} = $self->$col;
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
$row->set_column($col => $val);
$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);
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 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 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
## 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,
);
$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;
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..
return;
}
- $self->throw_exception($self->storage->_sqlt_version_error)
- if (not $self->storage->_sqlt_version_ok);
+ unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) {
+ $self->throw_exception("Unable to proceed without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+ }
my $db_tr = SQL::Translator->new({
add_drop_table => 1,
$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 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
-my $minimum_sqlt_version = '0.11002';
-
-
__PACKAGE__->mk_group_accessors('simple' =>
qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
_conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints/
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];
}
- $info{arguments} = \@args;
+ $info{arguments} = \@args;
my @storage_opts = grep exists $attrs{$_},
@storage_options, 'cursor_class';
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;
);
}
+ # 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) = @_;
my $bind_attrs = $self->source_bind_attributes($source);
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 )
: ()
,
&&
(ref $ident eq 'ARRAY' && @$ident > 1) # indicates a join
&&
- scalar $sql_maker->_order_by_chunks ($attrs->{order_by})
+ 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, $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
=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) };
-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
+ return $id if defined $id;
+
+ 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 {
%{$sqltargs || {}}
};
- $self->throw_exception("Can't create a ddl file without SQL::Translator: " . $self->_sqlt_version_error)
- if !$self->_sqlt_version_ok;
+ unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) {
+ $self->throw_exception("Can't create a ddl file without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+ }
my $sqlt = SQL::Translator->new( $sqltargs );
return join('', @rows);
}
- $self->throw_exception("Can't deploy without either SQL::Translator or a ddl_dir: " . $self->_sqlt_version_error )
- if !$self->_sqlt_version_ok;
+ unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') ) {
+ $self->throw_exception("Can't deploy without a ddl_dir or " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+ }
# sources needs to be a parser arg, but for simplicty allow at top level
# coming in
return;
}
-# SQLT version handling
-{
- my $_sqlt_version_ok; # private
- my $_sqlt_version_error; # private
-
- sub _sqlt_version_ok {
- if (!defined $_sqlt_version_ok) {
- eval "use SQL::Translator $minimum_sqlt_version";
- if ($@) {
- $_sqlt_version_ok = 0;
- $_sqlt_version_error = $@;
- }
- else {
- $_sqlt_version_ok = 1;
- }
- }
- return $_sqlt_version_ok;
- }
-
- sub _sqlt_version_error {
- shift->_sqlt_version_ok unless defined $_sqlt_version_ok;
- return $_sqlt_version_error;
- }
-
- sub _sqlt_minimum_version { $minimum_sqlt_version };
-}
-
=head2 relname_to_table_alias
=over 4
# 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 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
# see if this is an ordered subquery
my $attrs = $_[3];
- if ( scalar $self->sql_maker->_order_by_chunks ($attrs->{order_by}) ) {
+ 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};
}
}
-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
--- /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
my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
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"
+ );
+ }
+
$column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
? DBD::Oracle::ORA_CLOB()
: DBD::Oracle::ORA_BLOB()
BEGIN {
use Carp::Clan qw/^DBIx::Class/;
-
- ## Modules required for Replication support not required for general DBIC
- ## use, so we explicitly test for these.
-
- my %replication_required = (
- 'Moose' => '0.90',
- 'MooseX::Types' => '0.16',
- 'namespace::clean' => '0.11',
- 'Hash::Merge' => '0.11'
- );
-
- my @didnt_load;
-
- for my $module (keys %replication_required) {
- eval "use $module $replication_required{$module}";
- push @didnt_load, "$module $replication_required{$module}"
- if $@;
- }
-
- croak("@{[ join ', ', @didnt_load ]} are missing and are required for Replication")
- if @didnt_load;
+ use DBIx::Class;
+ croak('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') )
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
}
use Moose;
use MooseX::Types::Moose qw/ClassName HashRef Object/;
use Scalar::Util 'reftype';
use Hash::Merge 'merge';
+use List::Util qw/min max/;
use namespace::clean -except => 'meta';
=head1 REQUIREMENTS
-Replicated Storage has additional requirements not currently part of L<DBIx::Class>
-
- Moose => '0.90',
- MooseX::Types => '0.16',
- namespace::clean => '0.11',
- Hash::Merge => '0.11'
-
-You will need to install these modules manually via CPAN or make them part of the
-Makefile for your distribution.
+Replicated Storage has additional requirements not currently part of
+L<DBIx::Class>. See L<DBIx::Class::Optional::Dependencies> for more details.
=head1 ATTRIBUTES
select
select_single
columns_info_for
+ _dbh_columns_info_for
+ _select
/],
);
=head2 write_handler
-Defines an object that implements the write side of L<BIx::Class::Storage::DBI>.
+Defines an object that implements the write side of L<BIx::Class::Storage::DBI>,
+as well as methods that don't write or read that can be called on only one
+storage, methods that return a C<$dbh>, and any methods that don't make sense to
+run on a replicant.
=cut
handles=>[qw/
on_connect_do
on_disconnect_do
+ on_connect_call
+ on_disconnect_call
connect_info
+ _connect_info
throw_exception
sql_maker
sqlt_type
svp_rollback
svp_begin
svp_release
+ relname_to_table_alias
+ _straight_join_to_node
+ _dbh_last_insert_id
+ _fix_bind_params
+ _default_dbi_connect_attributes
+ _dbi_connect_info
+ auto_savepoint
+ _sqlt_version_ok
+ _query_end
+ bind_attribute_by_data_type
+ transaction_depth
+ _dbh
+ _select_args
+ _dbh_execute_array
+ _sql_maker_args
+ _sql_maker
+ _query_start
+ _sqlt_version_error
+ _per_row_update_delete
+ _dbh_begin_work
+ _dbh_execute_inserts_with_no_binds
+ _select_args_to_query
+ _svp_generate_name
+ _multipk_update_delete
+ source_bind_attributes
+ _normalize_connect_info
+ _parse_connect_do
+ _dbh_commit
+ _execute_array
+ _placeholders_supported
+ _verify_pid
+ savepoints
+ _sqlt_minimum_version
+ _sql_maker_opts
+ _conn_pid
+ _typeless_placeholders_supported
+ _conn_tid
+ _dbh_autocommit
+ _native_data_type
+ _get_dbh
+ sql_maker_class
+ _dbh_rollback
+ _adjust_select_args_for_complex_prefetch
+ _resolve_ident_sources
+ _resolve_column_info
+ _prune_unused_joins
+ _strip_cond_qualifiers
+ _parse_order_by
+ _resolve_aliastypes_from_select_args
+ _execute
+ _do_query
+ _dbh_sth
+ _dbh_execute
/],
);
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;
};
=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
$self->master->cursor_class;
}
+=head2 cursor
+
+set cursor class on all storages, or return master's, alias for L</cursor_class>
+above.
+
+=cut
+
+sub cursor {
+ my ($self, $cursor_class) = @_;
+
+ if ($cursor_class) {
+ $_->cursor($cursor_class) for $self->all_storages;
+ }
+ $self->master->cursor;
+}
+
+=head2 unsafe
+
+sets the L<DBIx::Class::Storage::DBI/unsafe> option on all storages or returns
+master's current setting
+
+=cut
+
+sub unsafe {
+ my $self = shift;
+
+ if (@_) {
+ $_->unsafe(@_) for $self->all_storages;
+ }
+
+ return $self->master->unsafe;
+}
+
+=head2 disable_sth_caching
+
+sets the L<DBIx::Class::Storage::DBI/disable_sth_caching> option on all storages
+or returns master's current setting
+
+=cut
+
+sub disable_sth_caching {
+ my $self = shift;
+
+ if (@_) {
+ $_->disable_sth_caching(@_) for $self->all_storages;
+ }
+
+ return $self->master->disable_sth_caching;
+}
+
+=head2 lag_behind_master
+
+returns the highest Replicant L<DBIx::Class::Storage::DBI/lag_behind_master>
+setting
+
+=cut
+
+sub lag_behind_master {
+ my $self = shift;
+
+ return max map $_->lag_behind_master, $self->replicants;
+}
+
+=head2 is_replicating
+
+returns true if all replicants return true for
+L<DBIx::Class::Storage::DBI/is_replicating>
+
+=cut
+
+sub is_replicating {
+ my $self = shift;
+
+ return (grep $_->is_replicating, $self->replicants) == ($self->replicants);
+}
+
+=head2 connect_call_datetime_setup
+
+calls L<DBIx::Class::Storage::DBI/connect_call_datetime_setup> for all storages
+
+=cut
+
+sub connect_call_datetime_setup {
+ my $self = shift;
+ $_->connect_call_datetime_setup for $self->all_storages;
+}
+
+sub _populate_dbh {
+ my $self = shift;
+ $_->_populate_dbh for $self->all_storages;
+}
+
+sub _connect {
+ my $self = shift;
+ $_->_connect for $self->all_storages;
+}
+
+sub _rebless {
+ my $self = shift;
+ $_->_rebless for $self->all_storages;
+}
+
+sub _determine_driver {
+ my $self = shift;
+ $_->_determine_driver for $self->all_storages;
+}
+
+sub _driver_determined {
+ my $self = shift;
+
+ if (@_) {
+ $_->_driver_determined(@_) for $self->all_storages;
+ }
+
+ return $self->master->_driver_determined;
+}
+
+sub _init {
+ my $self = shift;
+
+ $_->_init for $self->all_storages;
+}
+
+sub _run_connection_actions {
+ my $self = shift;
+
+ $_->_run_connection_actions for $self->all_storages;
+}
+
+sub _do_connection_actions {
+ my $self = shift;
+
+ if (@_) {
+ $_->_do_connection_actions(@_) for $self->all_storages;
+ }
+}
+
+sub connect_call_do_sql {
+ my $self = shift;
+ $_->connect_call_do_sql(@_) for $self->all_storages;
+}
+
+sub disconnect_call_do_sql {
+ my $self = shift;
+ $_->disconnect_call_do_sql(@_) for $self->all_storages;
+}
+
+sub _seems_connected {
+ my $self = shift;
+
+ return min map $_->_seems_connected, $self->all_storages;
+}
+
+sub _ping {
+ my $self = shift;
+
+ return min map $_->_ping, $self->all_storages;
+}
+
=head1 GOTCHAS
Due to the fact that replicants can lag behind a master, you must take care to
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';
},
);
+=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;
}
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'"
+ );
+}
+
+sub _svp_begin {
+ my ($self, $name) = @_;
+
+ $self->_get_dbh->do("SAVEPOINT $name");
+}
+
+# can't release savepoints that have been rolled back
+sub _svp_release { 1 }
+
+sub _svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
+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) = @_;
# check for empty insert
# INSERT INTO foo DEFAULT VALUES -- does not work with Sybase
- # try to insert explicit 'DEFAULT's instead (except for identity)
+ # 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';
}
}
=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/
+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
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
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 ...
#
];
}
-
# 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
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) {
+ # 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);
- # 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];
+ # 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_from,
$inner_select,
$where,
$inner_attrs,
my $subq_joinspec = {
-alias => $attrs->{alias},
- -source_handle => $inner_from[0]{-source_handle},
+ -source_handle => $inner_from->[0]{-source_handle},
$attrs->{alias} => $subq,
};
# - 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) {
}
}
+ # 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 ($select_aliases->{$alias} || $prefetch_aliases->{$alias}) {
+ if ($outer_aliastypes->{select}{$alias}) {
push @outer_from, $j;
}
- elsif ($restrict_aliases->{$alias}) {
+ elsif ($outer_aliastypes->{restrict}{$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;
- # }
+ $outer_attrs->{group_by} ||= $outer_select unless $j->[0]{-is_single};
}
}
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) = @_;
# 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 { $_ => 1 } @$switch_branch };
+ my $sw_idx = { map { values %$_ => 1 } @$switch_branch };
for my $j (@{$from}[1 .. $#$from]) {
my $jalias = $j->[0]{-alias};
for (my $i = 0; $i < @cond; $i++) {
my $entry = $cond[$i];
my $hash;
- if (ref $entry eq 'HASH') {
+ my $ref = ref $entry;
+ if ($ref eq 'HASH' or $ref eq 'ARRAY') {
$hash = $self->_strip_cond_qualifiers($entry);
}
- else {
+ 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;
}
}
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 strict;
use warnings;
use base qw/DBIx::Class/;
-use utf8;
__PACKAGE__->mk_classdata( '_utf8_columns' );
# override this if you want to force everything to be encoded/decoded
sub _is_utf8_column {
- return (shift->utf8_columns || {})->{shift};
+ # my ($self, $col) = @_;
+ return ($_[0]->utf8_columns || {})->{$_[1]};
}
=head1 AUTHORS
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;
}
/]
},
+ 'DBIx::Class::Storage::DBI::Replicated*' => {
+ ignore => [ qw/
+ connect_call_do_sql
+ disconnect_call_do_sql
+ /]
+ },
+
'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 },
'DBIx::Class::Componentised' => { skip => 1 },
'DBIx::Class::Relationship::*' => { skip => 1 },
'DBIx::Class::Storage::DBI::Replicated::Types' => { skip => 1 },
# test some specific components whose parents are exempt below
- 'DBIx::Class::Storage::DBI::Replicated*' => {},
'DBIx::Class::Relationship::Base' => {},
# internals
--- /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;
## 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});
+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");
}
[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) = $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';
cmp_ok $cooler->rank, '==', 42, 'Correct Rank';
ARRAY_CONTEXT_WITH_COND_FROM_RS: {
-
+
my ($mega_lamer) = $restricted_art_rs->populate([
{
name => 'Mega Lamer',
}
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 Test::More;
-use IO::File;
use Data::Dumper;
$Data::Dumper::Sortkeys = 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");
}
}
is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
SKIP: {
- skip 'buggy BLOB support in DBD::Oracle 1.23', 8
- if $DBD::Oracle::VERSION == 1.23;
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
- 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;
+ 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';
- foreach my $type (qw( blob clob )) {
- foreach my $size (qw( small large )) {
- $id++;
+ 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";
- 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" );
- }
- }
+ ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
+ }
+ }
}
done_testing;
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 };
having => \['1 = ?', [ test => 1 ] ], #test having propagation
prefetch => 'owner',
rows => 2, # 3 results total
- order_by => { -desc => 'owner' },
+ order_by => { -desc => 'me.owner' },
unsafe_subselect_ok => 1,
},
);
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 =>
'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_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, {
+ auto_savepoint => 1
+ });
+
+ my $dbh = $schema->storage->dbh;
+
+ push @handles_to_clean, $dbh;
+
+ eval { $dbh->do("DROP TABLE artist") };
+
+ $dbh->do(<<EOF);
+ CREATE TABLE artist (
+ artistid INT IDENTITY PRIMARY KEY,
+ name VARCHAR(255) NULL,
+ charfield CHAR(10) NULL,
+ rank INT DEFAULT 13
+ )
+EOF
+
+ my $ars = $schema->resultset('Artist');
+ is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+ my $new = $ars->create({ name => 'foo' });
+ ok($new->artistid, "Auto-PK worked");
+
+# test explicit key spec
+ $new = $ars->create ({ name => 'bar', artistid => 66 });
+ is($new->artistid, 66, 'Explicit PK worked');
+ $new->discard_changes;
+ is($new->artistid, 66, 'Explicit PK assigned');
+
+# test savepoints
+ eval {
+ $schema->txn_do(sub {
+ eval {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_savepoint' });
+ die "rolling back savepoint";
+ });
+ };
+ ok ((not $ars->search({ name => 'in_savepoint' })->first),
+ 'savepoint rolled back');
+ $ars->create({ name => 'in_outer_txn' });
+ die "rolling back outer txn";
+ });
+ };
+
+ like $@, qr/rolling back outer txn/,
+ 'correct exception for rollback';
+
+ ok ((not $ars->search({ name => 'in_outer_txn' })->first),
+ 'outer txn rolled back');
+
+# test populate
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+ });
+
+# test populate with explicit key
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+ });
+
+# count what we did so far
+ is ($ars->count, 6, 'Simple count works');
+
+# test LIMIT support
+ my $lim = $ars->search( {},
+ {
+ rows => 3,
+ offset => 4,
+ order_by => 'artistid'
+ }
+ );
+ is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+ is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+ $lim->reset;
+ is( $lim->next->artistid, 101, "iterator->next ok" );
+ is( $lim->next->artistid, 102, "iterator->next ok" );
+ is( $lim->next, undef, "next past end of resultset ok" );
+
+# test empty insert
+ {
+ local $ars->result_source->column_info('artistid')->{is_auto_increment} = 0;
+
+ lives_ok { $ars->create({}) }
+ 'empty insert works';
+ }
+
+# test blobs (stolen from 73oracle.t)
+ eval { $dbh->do('DROP TABLE bindtype_test') };
+ $dbh->do(qq[
+ CREATE TABLE bindtype_test
+ (
+ id INT NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob LONG BINARY NULL,
+ clob LONG VARCHAR NULL
+ )
+ ],{ RaiseError => 1, PrintError => 1 });
+
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
+
+ my $maxloblen = length $binstr{'large'};
+ local $dbh->{'LongReadLen'} = $maxloblen;
+
+ my $rs = $schema->resultset('BindType');
+ my $id = 0;
+
+ foreach my $type (qw( blob clob )) {
+ foreach my $size (qw( small large )) {
+ $id++;
+
+# turn off horrendous binary DBIC_TRACE output
+ local $schema->storage->{debug} = 0;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying";
+
+ ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
+ }
+ }
+}
+
+done_testing;
+
+# clean up our mess
+END {
+ foreach my $dbh (@handles_to_clean) {
+ eval { $dbh->do("DROP TABLE $_") } for qw/artist bindtype_test/;
+ }
+}
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,
- track_position => 2,
- tracks =>
- {
- trackid => 17,
- title => 'Apiary',
- },
+ artist => 1,
+ tracks => {
+ title => 'Apiary',
+ trackid => 17,
+ },
},
'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;
# 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 Test::Warn;
use lib qw(t/lib);
use DBICTest;
-use utf8;
-
-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/ );
+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(! utf8::is_utf8( $cd->year ), 'got year without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{year} ), 'store year without utf8' );
-utf8::decode($utf8_char);
-$cd->title($utf8_char);
+$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' );
use DBICTest;
BEGIN {
- require DBIx::Class::Storage::DBI;
+ require DBIx::Class;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
- if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
+ 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
}
my $schema = DBICTest->init_schema (no_deploy => 1);
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
# 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)
)',
|| plan skip_all => 'Test needs Time::HiRes';
Time::HiRes->import(qw/time sleep/);
- require DBIx::Class::Storage::DBI;
+ require DBIx::Class;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
- if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
+ 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
}
+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 = dir ('t', 'var');
+mkdir ($ddl_dir) unless -d $ddl_dir;
+
my $fn = {
v1 => $ddl_dir->file ('DBICVersion-Schema-1.0-MySQL.sql'),
v2 => $ddl_dir->file ('DBICVersion-Schema-2.0-MySQL.sql'),
- trans => $ddl_dir->file ('DBICVersion-Schema-1.0-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});
+ unlink($fn->{trans_v12});
- 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');
+ 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');
- sleep 1; # remove this when TODO below is completed
warnings_like (
- sub { $schema_upgrade->upgrade() },
+ sub { $schema_v2->upgrade() },
qr/DB version .+? is lower than the schema version/,
'Warn before upgrade',
);
- is($schema_upgrade->get_db_version(), '2.0', 'db version number upgraded');
+ is($schema_v2->get_db_version(), '2.0', 'db version number upgraded');
lives_ok ( sub {
- $schema_upgrade->storage->dbh->do('select NewVersionName from TestVersion');
+ $schema_v2->storage->dbh->do('select NewVersionName from TestVersion');
}, 'new column created' );
warnings_exist (
- sub { $schema_upgrade->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0') },
+ 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}/,
+ qr/Overwriting existing diff file - $fn->{trans_v12}/,
],
'An overwrite warning generated for both the DDL and the diff',
);
}
+# 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 $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
}
# 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";
use Scalar::Util ();
BEGIN {
- require DBIx::Class::Storage::DBI;
+ require DBIx::Class;
plan skip_all =>
- 'Test needs SQL::Translator ' . DBIx::Class::Storage::DBI->_sqlt_minimum_version
- if not DBIx::Class::Storage::DBI->_sqlt_version_ok;
+ 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
}
# Test for SQLT-related leaks
->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
SELECT genre.genreid
FROM (
SELECT me.artistid, me.name, me.rank, me.charfield
- FROM artist me GROUP BY 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 = ? ) GROUP BY genre.genreid
+ WHERE ( genre.name = ? )
+ GROUP BY genre.genreid
)
count_subq
)',
{
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 $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;
+
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' ] ],
);
}
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 = (
$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.080445'],
+# date only (but minute precision according to ASA docs)
+ ['DATE', 'small_dt', '2004-08-21 00:00:00.000000'],
+ );
+
+ for my $dt_type (@dt_types) {
+ my ($type, $col, $sample_dt) = @$dt_type;
+
+ eval { $schema->storage->dbh->do("DROP TABLE track") };
+ $schema->storage->dbh->do(<<"SQL");
+ CREATE TABLE track (
+ trackid INT IDENTITY PRIMARY KEY,
+ cd INT,
+ position INT,
+ $col $type,
+ )
+SQL
+ ok(my $dt = $schema->storage->datetime_parser->parse_datetime($sample_dt));
+
+ my $row;
+ ok( $row = $schema->resultset('Track')->create({
+ $col => $dt,
+ cd => 1,
+ }));
+ ok( $row = $schema->resultset('Track')
+ ->search({ trackid => $row->trackid }, { select => [$col] })
+ ->first
+ );
+ is( $row->$col, $dt, 'DateTime roundtrip' );
+
+ is $row->$col->nanosecond, $dt->nanosecond,
+ 'nanoseconds survived' if 0+$dt->nanosecond;
+ }
+}
+
+done_testing;
+
+# clean up our mess
+END {
+ foreach my $dbh (@handles_to_clean) {
+ eval { $dbh->do("DROP TABLE $_") } for qw/track/;
+ }
+}
use Test::More;
use lib qw(t/lib);
use DBICTest;
-use IO::File;
use File::Compare;
use Path::Class qw/file/;
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 @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);
}
}
);
done_testing;
+
--- /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;
return 't/var/';
}
+sub ordered_schema_versions {
+ return('1.0','2.0','3.0');
+}
+
1;
'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 by SQL::Translator::Producer::SQLite
--- Created on Tue Jan 19 12:46:12 2010
+-- Created on Sat Jan 30 19:18:55 2010
--
-
-
-BEGIN TRANSACTION;
+;
--
-- Table: artist
-- View: year2000cds
--
CREATE VIEW year2000cds AS
- SELECT cdid, artist, title, year, genreid, single_track 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;
'(
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 )
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;
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;
--- /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;
--- /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 $rs = $schema->resultset('Artist');
+
+ok !$rs->is_ordered, 'vanilla resultset is not ordered';
+
+# Simple ordering with a single column
+{
+ my $ordered = $rs->search(undef, { order_by => 'artistid' });
+ ok $ordered->is_ordered, 'Simple column ordering detected by is_ordered';
+}
+
+# Hashref order direction
+{
+ my $ordered = $rs->search(undef, { order_by => { -desc => 'artistid' } });
+ ok $ordered->is_ordered, 'resultset with order direction is_ordered';
+}
+
+# Column ordering with literal SQL
+{
+ my $ordered = $rs->search(undef, { order_by => \'artistid DESC' });
+ ok $ordered->is_ordered, 'resultset with literal SQL is_ordered';
+}
+
+# Multiple column ordering
+{
+ my $ordered = $rs->search(undef, { order_by => ['artistid', 'name'] });
+ ok $ordered->is_ordered, 'ordering with multiple columns as arrayref is ordered';
+}
+
+# More complicated ordering
+{
+ my $ordered = $rs->search(undef, {
+ order_by => [
+ { -asc => 'artistid' },
+ { -desc => 'name' },
+ ]
+ });
+ ok $ordered->is_ordered, 'more complicated resultset ordering is_ordered';
+}
+
+# Empty multi-column ordering arrayref
+{
+ my $ordered = $rs->search(undef, { order_by => [] });
+ ok !$ordered->is_ordered, 'ordering with empty arrayref is not ordered';
+}
+
+# Multi-column ordering syntax with empty hashref
+{
+ my $ordered = $rs->search(undef, { order_by => [{}] });
+ ok !$ordered->is_ordered, 'ordering with [{}] is not ordered';
+}
+
+# Remove ordering after being set
+{
+ my $ordered = $rs->search(undef, { order_by => 'artistid' });
+ ok $ordered->is_ordered, 'resultset with ordering applied works..';
+ my $unordered = $ordered->search(undef, { order_by => undef });
+ ok !$unordered->is_ordered, '..and is not ordered with ordering removed';
+}
+
+# Search without ordering
+{
+ my $ordered = $rs->search({ name => 'We Are Goth' }, { join => 'cds' });
+ ok !$ordered->is_ordered, 'WHERE clause but no order_by is not ordered';
+}
+
+# Other functions without ordering
+{
+ # Join
+ my $joined = $rs->search(undef, { join => 'cds' });
+ ok !$joined->is_ordered, 'join but no order_by is not ordered';
+
+ # Group By
+ my $grouped = $rs->search(undef, { group_by => 'rank' });
+ ok !$grouped->is_ordered, 'group_by but no order_by is not ordered';
+
+ # Paging
+ my $paged = $rs->search(undef, { page=> 5 });
+ ok !$paged->is_ordered, 'paging but no order_by is not ordered';
+}
+
+done_testing;
is_same_sql_bind ($rs->as_query, $q{$s}{query}, "$s resultset unmodified (as_query matches)" );
}
-
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
+ LEFT JOIN track tracks ON tracks.cd = me.cdid
WHERE ( tracks.id != ? )
LIMIT 2
) me
JOIN artist artist ON artist.artistid = me.artist
- LEFT JOIN track tracks ON tracks.cd = me.cdid
JOIN tags tags ON tags.cd = me.cdid
WHERE ( tags.tag IS NOT NULL )
GROUP BY tags.tagid, tags.cd, tags.tag
--- /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 @chain = (
+ {
+ columns => [ 'cdid' ],
+ '+columns' => [ { title_lc => { lower => 'title' } } ],
+ '+select' => [ 'genreid' ],
+ '+as' => [ 'genreid' ],
+ } => 'SELECT me.cdid, LOWER( title ), me.genreid FROM cd me',
+
+ {
+ '+columns' => [ { max_year => { max => 'me.year' }}, ],
+ '+select' => [ { count => 'me.cdid' }, ],
+ '+as' => [ 'cnt' ],
+ } => 'SELECT me.cdid, LOWER( title ), MAX( me.year ), me.genreid, COUNT( me.cdid ) FROM cd me',
+
+ {
+ select => [ { min => 'me.cdid' }, ],
+ as => [ 'min_id' ],
+ } => 'SELECT MIN( me.cdid ) FROM cd me',
+
+ {
+ '+columns' => [ { cnt => { count => 'cdid' } } ],
+ } => 'SELECT MIN( me.cdid ), COUNT ( cdid ) FROM cd me',
+
+ {
+ columns => [ 'year' ],
+ } => 'SELECT me.year FROM cd me',
+);
+
+my $rs = $schema->resultset('CD');
+
+my $testno = 1;
+while (@chain) {
+ my $attrs = shift @chain;
+ my $sql = shift @chain;
+
+ $rs = $rs->search ({}, $attrs);
+
+ is_same_sql_bind (
+ $rs->as_query,
+ "($sql)",
+ [],
+ "Test $testno of SELECT assembly ok",
+ );
+
+ $testno++;
+}
+
+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;
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;
use IO::Handle;
BEGIN {
- eval "use DBIx::Class::Storage::DBI::Replicated; use Test::Moose";
- plan skip_all => "Deps not installed: $@" if $@;
+ eval { require Test::Moose; Test::Moose->import() };
+ plan skip_all => "Need Test::Moose to run this test" if $@;
+ require DBIx::Class;
+
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
}
use_ok 'DBIx::Class::Storage::DBI::Replicated::Pool';
=> 'configured balancer_type';
}
+### check that all Storage::DBI methods are handled by ::Replicated
+{
+ my @storage_dbi_methods = Class::MOP::Class
+ ->initialize('DBIx::Class::Storage::DBI')->get_all_method_names;
+
+ my @replicated_methods = DBIx::Class::Storage::DBI::Replicated->meta
+ ->get_all_method_names;
+
+# remove constants and OTHER_CRAP
+ @storage_dbi_methods = grep !/^[A-Z_]+\z/, @storage_dbi_methods;
+
+# remove CAG accessors
+ @storage_dbi_methods = grep !/_accessor\z/, @storage_dbi_methods;
+
+# remove DBIx::Class (the root parent, with CAG and stuff) methods
+ my @root_methods = Class::MOP::Class->initialize('DBIx::Class')
+ ->get_all_method_names;
+ my %count;
+ $count{$_}++ for (@storage_dbi_methods, @root_methods);
+
+ @storage_dbi_methods = grep $count{$_} != 2, @storage_dbi_methods;
+
+# make hashes
+ my %storage_dbi_methods;
+ @storage_dbi_methods{@storage_dbi_methods} = ();
+ my %replicated_methods;
+ @replicated_methods{@replicated_methods} = ();
+
+# remove ::Replicated-specific methods
+ for my $method (@replicated_methods) {
+ delete $replicated_methods{$method}
+ unless exists $storage_dbi_methods{$method};
+ }
+ @replicated_methods = keys %replicated_methods;
+
+# check that what's left is implemented
+ %count = ();
+ $count{$_}++ for (@storage_dbi_methods, @replicated_methods);
+
+ if ((grep $count{$_} == 2, @storage_dbi_methods) == @storage_dbi_methods) {
+ pass 'all DBIx::Class::Storage::DBI methods implemented';
+ }
+ else {
+ my @unimplemented = grep $count{$_} == 1, @storage_dbi_methods;
+
+ fail 'the following DBIx::Class::Storage::DBI methods are unimplemented: '
+ . "@unimplemented";
+ }
+}
+
ok $replicated->schema->storage->meta
=> 'has a meta object';
projects / dbsrgits/DBIx-Class.git / commitdiff