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
+ - Fix ResultSetColumn improperly selecting more than the requested
+ column when +columns/+select is present
- 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
- - Add mechanism for schema version to apply multiple step upgrades
+ - 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)
# when changing also adjust version in t/02pod.t
'Test::Pod' => '1.26',
+ # when changing also adjust version in t/06notabs.t
+# 'Test::NoTabs' => '0.9',
+
+ # when changing also adjust version in t/07eol.t
+# 'Test::EOL' => '0.6',
+
# when changing also adjust version in t/03podcoverage.t
'Test::Pod::Coverage' => '1.08',
'Pod::Coverage' => '0.20',
# 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
# Re-write META.yml to _exclude_ all forced requires (we do not want to ship this)
if ($Module::Install::AUTHOR) {
- Meta->{values}{build_requires} = [ grep
+ Meta->{values}{build_requires} = [ grep
{ not exists $force_requires_if_author{$_->[0]} }
( @{Meta->{values}{build_requires}} )
];
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>
=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
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;
+ my $new_attrs = $new_parent_rs->{attrs} ||= {};
+
+ # since what we do is actually chain to the original resultset, we need to throw
+ # away all selectors (otherwise they'll chain)
+ delete $new_attrs->{$_} for (qw/columns +columns select +select as +as cols include_columns/);
# prefetch causes additional columns to be fetched, but we can not just make a new
# rs via the _resolved_attrs trick - we need to retain the separation between
# +select/+as and select/as. At the same time we want to preserve any joins that the
# prefetch would otherwise generate.
-
- 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;
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 {
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
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;
use XML::Parser;
my %month = qw(
- Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06
- Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12
+ Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06
+ Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12
);
$Text::Wrap::huge = "wrap";
GetOptions(
"age=s" => \$days_back,
"repo=s" => \$svn_repo,
- "help" => \$send_help,
+ "help" => \$send_help,
) or exit;
# Find the trunk for the current repository if one isn't specified.
unless (defined $svn_repo) {
- $svn_repo = `svn info . | grep '^URL: '`;
- if (length $svn_repo) {
- chomp $svn_repo;
- $svn_repo =~ s{^URL\:\s+(.+?)/trunk/?.*$}{$1};
- }
- else {
- $send_help = 1;
- }
+ $svn_repo = `svn info . | grep '^URL: '`;
+ if (length $svn_repo) {
+ chomp $svn_repo;
+ $svn_repo =~ s{^URL\:\s+(.+?)/trunk/?.*$}{$1};
+ }
+ else {
+ $send_help = 1;
+ }
}
die(
- "$0 usage:\n",
- " --repo REPOSITORY\n",
- " [--age DAYS]\n",
- "\n",
- "REPOSITORY must have a trunk subdirectory and a tags directory where\n",
- "release tags are kept.\n",
+ "$0 usage:\n",
+ " --repo REPOSITORY\n",
+ " [--age DAYS]\n",
+ "\n",
+ "REPOSITORY must have a trunk subdirectory and a tags directory where\n",
+ "release tags are kept.\n",
) if $send_help;
my $earliest_date = strftime "%F", gmtime(time() - $days_back * 86400);
open(TAG, "svn -v list $svn_repo/tags|") or die $!;
while (<TAG>) {
- # The date is unused, however.
- next unless (
- my ($rev, $date, $tag) = m{
- (\d+).*?(\S\S\S\s+\d\d\s+(?:\d\d\d\d|\d\d:\d\d))\s+(v[0-9_.]+)
- }x
- );
-
- my @tag_log = gather_log("$svn_repo/tags/$tag", "--stop-on-copy");
- die "Tag $tag has changes after tagging!\n" if @tag_log > 1;
-
- my $timestamp = $tag_log[0][LOG_DATE];
- $tag{$timestamp} = [
- $rev, # TAG_REV
- $tag, # TAG_TAG
- [ ], # TAG_LOG
- ];
+ # The date is unused, however.
+ next unless (
+ my ($rev, $date, $tag) = m{
+ (\d+).*?(\S\S\S\s+\d\d\s+(?:\d\d\d\d|\d\d:\d\d))\s+(v[0-9_.]+)
+ }x
+ );
+
+ my @tag_log = gather_log("$svn_repo/tags/$tag", "--stop-on-copy");
+ die "Tag $tag has changes after tagging!\n" if @tag_log > 1;
+
+ my $timestamp = $tag_log[0][LOG_DATE];
+ $tag{$timestamp} = [
+ $rev, # TAG_REV
+ $tag, # TAG_TAG
+ [ ], # TAG_LOG
+ ];
}
close TAG;
# Fictitious "HEAD" tag for revisions that came after the last tag.
$tag{+MAX_TIMESTAMP} = [
- "HEAD", # TAG_REV
- "(untagged)", # TAG_TAG
- undef, # TAG_LOG
+ "HEAD", # TAG_REV
+ "(untagged)", # TAG_TAG
+ undef, # TAG_LOG
];
### 2. Gather the log for the trunk. Place log entries under their
my @tag_dates = sort keys %tag;
while (my $date = pop(@tag_dates)) {
- # We're done if this date's before our earliest date.
- if ($date lt $earliest_date) {
- delete $tag{$date};
- next;
- }
+ # We're done if this date's before our earliest date.
+ if ($date lt $earliest_date) {
+ delete $tag{$date};
+ next;
+ }
- my $tag = $tag{$date}[TAG_TAG];
- #warn "Gathering information for tag $tag...\n";
+ my $tag = $tag{$date}[TAG_TAG];
+ #warn "Gathering information for tag $tag...\n";
- my $this_rev = $tag{$date}[TAG_REV];
- my $prev_rev;
- if (@tag_dates) {
- $prev_rev = $tag{$tag_dates[-1]}[TAG_REV];
- }
- else {
- $prev_rev = 0;
- }
+ my $this_rev = $tag{$date}[TAG_REV];
+ my $prev_rev;
+ if (@tag_dates) {
+ $prev_rev = $tag{$tag_dates[-1]}[TAG_REV];
+ }
+ else {
+ $prev_rev = 0;
+ }
- my @log = gather_log("$svn_repo/trunk", "-r", "$this_rev:$prev_rev");
+ my @log = gather_log("$svn_repo/trunk", "-r", "$this_rev:$prev_rev");
- $tag{$date}[TAG_LOG] = \@log;
+ $tag{$date}[TAG_LOG] = \@log;
}
### 3. PROFIT! No, wait... generate the nice log file.
foreach my $timestamp (sort { $b cmp $a } keys %tag) {
- my $tag_rec = $tag{$timestamp};
-
- # Skip this tag if there are no log entries.
- next unless @{$tag_rec->[TAG_LOG]};
-
- my $tag_line = "$timestamp $tag_rec->[TAG_TAG]";
- my $tag_bar = "=" x length($tag_line);
- print $tag_bar, "\n", $tag_line, "\n", $tag_bar, "\n\n";
-
- foreach my $log_rec (@{$tag_rec->[TAG_LOG]}) {
-
- my @paths = @{$log_rec->[LOG_PATHS]};
- if (@paths > 1) {
- @paths = grep {
- $_->[PATH_PATH] ne "/trunk" or $_->[PATH_ACTION] ne "M"
- } @paths;
- }
-
- my $time_line = wrap(
- " ", " ",
- join(
- "; ",
- "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]",
- map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
- )
- );
-
- if ($time_line =~ /\n/) {
- $time_line = wrap(
- " ", " ",
- "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]\n"
- ) .
- wrap(
- " ", " ",
- join(
- "; ",
- map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
- )
- );
- }
-
- print $time_line, "\n\n";
-
- # Blank lines should have the indent level of whitespace. This
- # makes it easier for other utilities to parse them.
-
- my @paragraphs = split /\n\s*\n/, $log_rec->[LOG_MESSAGE];
- foreach my $paragraph (@paragraphs) {
-
- # Trim off identical leading space from every line.
- my ($whitespace) = $paragraph =~ /^(\s*)/;
- if (length $whitespace) {
- $paragraph =~ s/^$whitespace//mg;
- }
-
- # Re-flow the paragraph if it isn't indented from the norm.
- # This should preserve indented quoted text, wiki-style.
- unless ($paragraph =~ /^\s/) {
- $paragraph = fill(" ", " ", $paragraph);
- }
- }
-
- print join("\n \n", @paragraphs), "\n\n";
- }
+ my $tag_rec = $tag{$timestamp};
+
+ # Skip this tag if there are no log entries.
+ next unless @{$tag_rec->[TAG_LOG]};
+
+ my $tag_line = "$timestamp $tag_rec->[TAG_TAG]";
+ my $tag_bar = "=" x length($tag_line);
+ print $tag_bar, "\n", $tag_line, "\n", $tag_bar, "\n\n";
+
+ foreach my $log_rec (@{$tag_rec->[TAG_LOG]}) {
+
+ my @paths = @{$log_rec->[LOG_PATHS]};
+ if (@paths > 1) {
+ @paths = grep {
+ $_->[PATH_PATH] ne "/trunk" or $_->[PATH_ACTION] ne "M"
+ } @paths;
+ }
+
+ my $time_line = wrap(
+ " ", " ",
+ join(
+ "; ",
+ "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]",
+ map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
+ )
+ );
+
+ if ($time_line =~ /\n/) {
+ $time_line = wrap(
+ " ", " ",
+ "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]\n"
+ ) .
+ wrap(
+ " ", " ",
+ join(
+ "; ",
+ map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
+ )
+ );
+ }
+
+ print $time_line, "\n\n";
+
+ # Blank lines should have the indent level of whitespace. This
+ # makes it easier for other utilities to parse them.
+
+ my @paragraphs = split /\n\s*\n/, $log_rec->[LOG_MESSAGE];
+ foreach my $paragraph (@paragraphs) {
+
+ # Trim off identical leading space from every line.
+ my ($whitespace) = $paragraph =~ /^(\s*)/;
+ if (length $whitespace) {
+ $paragraph =~ s/^$whitespace//mg;
+ }
+
+ # Re-flow the paragraph if it isn't indented from the norm.
+ # This should preserve indented quoted text, wiki-style.
+ unless ($paragraph =~ /^\s/) {
+ $paragraph = fill(" ", " ", $paragraph);
+ }
+ }
+
+ print join("\n \n", @paragraphs), "\n\n";
+ }
}
print(
- "==============\n",
- "End of Excerpt\n",
- "==============\n",
+ "==============\n",
+ "End of Excerpt\n",
+ "==============\n",
);
### Z. Helper functions.
sub gather_log {
- my ($url, @flags) = @_;
-
- my (@log, @stack);
-
- my $parser = XML::Parser->new(
- Handlers => {
- Start => sub {
- my ($self, $tag, %att) = @_;
- push @stack, [ $tag, \%att ];
- if ($tag eq "logentry") {
- push @log, [ ];
- $log[-1][LOG_WHO] = "(nobody)";
- }
- },
- Char => sub {
- my ($self, $text) = @_;
- $stack[-1][1]{0} .= $text;
- },
- End => sub {
- my ($self, $tag) = @_;
- die "close $tag w/out open" unless @stack;
- my ($pop_tag, $att) = @{pop @stack};
-
- die "$tag ne $pop_tag" if $tag ne $pop_tag;
-
- if ($tag eq "date") {
- my $timestamp = $att->{0};
- my ($date, $time) = split /[T.]/, $timestamp;
- $log[-1][LOG_DATE] = "$date $time";
- return;
- }
-
- if ($tag eq "logentry") {
- $log[-1][LOG_REV] = $att->{revision};
- return;
- }
-
- if ($tag eq "msg") {
- $log[-1][LOG_MESSAGE] = $att->{0};
- return;
- }
-
- if ($tag eq "author") {
- $log[-1][LOG_WHO] = $att->{0};
- return;
- }
-
- if ($tag eq "path") {
- my $path = $att->{0};
- $path =~ s{^/trunk/}{};
- push(
- @{$log[-1][LOG_PATHS]}, [
- $path, # PATH_PATH
- $att->{action}, # PATH_ACTION
- ]
- );
-
- $log[-1][LOG_PATHS][-1][PATH_CPF_PATH] = $att->{"copyfrom-path"} if (
- exists $att->{"copyfrom-path"}
- );
-
- $log[-1][LOG_PATHS][-1][PATH_CPF_REV] = $att->{"copyfrom-rev"} if (
- exists $att->{"copyfrom-rev"}
- );
- return;
- }
-
- }
- }
- );
-
- my $cmd = "svn -v --xml @flags log $url";
- #warn "Command: $cmd\n";
-
- open(LOG, "$cmd|") or die $!;
- $parser->parse(*LOG);
- close LOG;
-
- return @log;
+ my ($url, @flags) = @_;
+
+ my (@log, @stack);
+
+ my $parser = XML::Parser->new(
+ Handlers => {
+ Start => sub {
+ my ($self, $tag, %att) = @_;
+ push @stack, [ $tag, \%att ];
+ if ($tag eq "logentry") {
+ push @log, [ ];
+ $log[-1][LOG_WHO] = "(nobody)";
+ }
+ },
+ Char => sub {
+ my ($self, $text) = @_;
+ $stack[-1][1]{0} .= $text;
+ },
+ End => sub {
+ my ($self, $tag) = @_;
+ die "close $tag w/out open" unless @stack;
+ my ($pop_tag, $att) = @{pop @stack};
+
+ die "$tag ne $pop_tag" if $tag ne $pop_tag;
+
+ if ($tag eq "date") {
+ my $timestamp = $att->{0};
+ my ($date, $time) = split /[T.]/, $timestamp;
+ $log[-1][LOG_DATE] = "$date $time";
+ return;
+ }
+
+ if ($tag eq "logentry") {
+ $log[-1][LOG_REV] = $att->{revision};
+ return;
+ }
+
+ if ($tag eq "msg") {
+ $log[-1][LOG_MESSAGE] = $att->{0};
+ return;
+ }
+
+ if ($tag eq "author") {
+ $log[-1][LOG_WHO] = $att->{0};
+ return;
+ }
+
+ if ($tag eq "path") {
+ my $path = $att->{0};
+ $path =~ s{^/trunk/}{};
+ push(
+ @{$log[-1][LOG_PATHS]}, [
+ $path, # PATH_PATH
+ $att->{action}, # PATH_ACTION
+ ]
+ );
+
+ $log[-1][LOG_PATHS][-1][PATH_CPF_PATH] = $att->{"copyfrom-path"} if (
+ exists $att->{"copyfrom-path"}
+ );
+
+ $log[-1][LOG_PATHS][-1][PATH_CPF_REV] = $att->{"copyfrom-rev"} if (
+ exists $att->{"copyfrom-rev"}
+ );
+ return;
+ }
+
+ }
+ }
+ );
+
+ my $cmd = "svn -v --xml @flags log $url";
+ #warn "Command: $cmd\n";
+
+ open(LOG, "$cmd|") or die $!;
+ $parser->parse(*LOG);
+ close LOG;
+
+ return @log;
}
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use lib 't/lib';
+use DBICTest;
+
+my @MODULES = (
+ 'Test::NoTabs 0.9',
+);
+
+plan skip_all => 'Does not work with done_testing, temp disabled';
+
+# Don't run tests for installs
+unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
+ plan( skip_all => "Author tests not required for installation" );
+}
+# Load the testing modules
+foreach my $MODULE ( @MODULES ) {
+ eval "use $MODULE";
+ if ( $@ ) {
+ $ENV{RELEASE_TESTING}
+ ? die( "Failed to load required release-testing module $MODULE" )
+ : plan( skip_all => "$MODULE not available for testing" );
+ }
+}
+
+all_perl_files_ok(qw/t lib script maint/);
+
+done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use lib 't/lib';
+use DBICTest;
+
+my @MODULES = (
+ 'Test::EOL 0.6',
+);
+
+plan skip_all => 'Does not work with done_testing, temp disabled';
+
+# Don't run tests for installs
+unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
+ plan( skip_all => "Author tests not required for installation" );
+}
+# Load the testing modules
+foreach my $MODULE ( @MODULES ) {
+ eval "use $MODULE";
+ if ( $@ ) {
+ $ENV{RELEASE_TESTING}
+ ? die( "Failed to load required release-testing module $MODULE" )
+ : plan( skip_all => "$MODULE not available for testing" );
+ }
+}
+
+TODO: {
+ local $TODO = 'Do not fix those yet - we have way too many branches out there, merging will be hell';
+ all_perl_files_ok({ trailing_whitespace => 1}, qw/t lib script maint/);
+}
+
+done_testing;
## 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;
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;
+ 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;
- foreach my $type (qw( blob clob )) {
- foreach my $size (qw( small large )) {
- $id++;
+ foreach my $type (qw( blob clob )) {
+ foreach my $size (qw( small large )) {
+ $id++;
- lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
- "inserted $size $type without dying";
- ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
- }
- }
+ 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;
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
+# 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 LIMIT support
-my $it = $ars->search( {},
+# 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( $it->count, 3, "LIMIT count ok" );
+is( $lim->count, 2, 'LIMIT+OFFSET count ok' );
+is( $lim->all, 2, 'Number of ->all objects matches count' );
-my @all = $it->all;
-is (@all, 3, '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 = {
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 };
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/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::Exception;
use lib qw(t/lib);
use DBICTest;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
lives_ok(sub { $psrs->get_column('count')->next }, '+select/+as additional column "count" present (scalar)');
dies_ok(sub { $psrs->get_column('noSuchColumn')->next }, '+select/+as nonexistent column throws exception');
+# test +select/+as for overriding a column
+$psrs = $schema->resultset('CD')->search({},
+ {
+ 'select' => \"'The Final Countdown'",
+ 'as' => 'title'
+ }
+);
+is($psrs->get_column('title')->next, 'The Final Countdown', '+select/+as overridden column "title"');
+
+
# test +select/+as for multiple columns
$psrs = $schema->resultset('CD')->search({},
{
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');
-# test +select/+as for overriding a column
-$psrs = $schema->resultset('CD')->search({},
- {
- 'select' => \"'The Final Countdown'",
- 'as' => 'title'
- }
+# 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($psrs->get_column('title')->next, 'The Final Countdown', '+select/+as overridden column "title"');
+
+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('count')->as_query,
+ '(SELECT COUNT(*) FROM cd me)',
+ [],
+ 'Correct SQL for get_column/+as func'
+);
+
{
my $rs = $schema->resultset("CD")->search({}, { prefetch => 'artist' });
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";
}
{
}
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;
}, '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',
projects / dbsrgits/DBIx-Class.git / commitdiff