Revision history for DBIx::Class
+ * New Features / Changes
+ - Add quote_names connection option. When set to true automatically
+ sets quote_char and name_sep appropriate for your RDBMS
+ - Support for MS Access databases via DBD::ODBC and DBD::ADO (only
+ Win32 support currently tested)
+ - IC::DateTime support for MSSQL over DBD::ADO
+ - Both the ::ODBC and ::ADO dispatchers now warn if a rdbms-specific
+ driver is not found for this connection before falling back to
+ plain ::Storage::DBI
+ - ::Storage::DBI::sth was mistakenly marked/documented as public,
+ privatize and warn on deprecated use
+ - Massive overhaul of bind values/attributes handling - slightly
+ changes the output of as_query (should not cause compat issues)
+ - Support ancient DB2 versions (5.4 and older), with proper limit
+ dialect
+
+ * Fixes
+ - Fix ::Storage::DBI::* MRO problems on 5.8.x perls
+ - Disable mysql_auto_reconnect for MySQL - depending on the ENV
+ it sometimes defaults to on and causes major borkage on older
+ DBD::mysql versions
+ - Fix dropped bind values in select/group_by on Oracle (omission
+ from 0542ec57 and 4c2b30d6)
+ - Fix remaining errors with Oracle and identifiers longer than the
+ Oracle-imposed maximum of 30 characters (RT#66390)
+ - Fix older oracle-specific "WhereJoins" to work properly with
+ name quoting
+ - Fix problems with M.A.D. under CGI::SpeedyCGI (RT#65131)
+ - Better error handling when prepare() fails silently
+ - Fixes skipped lines when a comment is followed by a statement
+ when deploying a schema via sql file
+ - Fix reverse_relationship_info on prototypical result sources
+ (sources not yet registered with a schema)
+ - Warn and skip relationships missing from a partial schema during
+ dbic cascade_delete
+ - Automatically require the requested cursor class before use
+ (RT#64795)
+ - Work around a Firebird ODBC driver bug exposed by DBD::ODBC 1.29
+ - Fix exiting via next warnings in ResultSource::sequence()
+ - Fix stripping of table qualifiers in update/delete in arrayref
+ condition elements
+ - Change SQLMaker carp-monkeypatch to be compatible with versions
+ of SQL::Abstract >= 1.73
+ - Fix using \[] literals in the from resultset attribute
+ - Fix populate() with \[], arrays (datatype) and other exotic values
+
+ * Misc
+ - Rewire all warnings to a new Carp-like implementation internal
+ to DBIx::Class, and remove the Carp::Clan dependency
+ - Only load Class::C3 and friends if necessary ($] < 5.010)
+ - Greatly reduced loading of non-essential modules to aid startup
+ time (mainly benefiting CGI users)
+ - Make sure all namespaces are clean of rogue imports
+
+ 0.08190-TRIAL 2011-01-24 15:35 (UTC)
+
+ * New Features / Changes
+ - Support for completely arbitrary SQL::Abstract-based conditions
+ in all types of relationships
+
0.08127 2011-01-19 16:40 (UTC)
* New Features / Changes
- Schema/resultsource instances are now crossreferenced via a new
use strict;
use warnings;
-use MRO::Compat;
+BEGIN {
+ package DBIx::Class::_ENV_;
+
+ if ($] < 5.009_005) {
+ require MRO::Compat;
+ *OLD_MRO = sub () { 1 };
+ }
+ else {
+ require mro;
+ *OLD_MRO = sub () { 0 };
+ }
+
+ # ::Runmode would only be loaded by DBICTest, which in turn implies t/
+ *DBICTEST = eval { DBICTest::RunMode->is_author }
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+
+ # During 5.13 dev cycle HELEMs started to leak on copy
+ *PEEPEENESS = (defined $ENV{DBICTEST_ALL_LEAKS}
+ # request for all tests would force "non-leaky" illusion and vice-versa
+ ? ! $ENV{DBICTEST_ALL_LEAKS}
+
+ # otherwise confess that this perl is busted ONLY on smokers
+ : do {
+ if (eval { DBICTest::RunMode->is_smoker }) {
+
+ # leaky 5.13.6 (fixed in blead/cefd5c7c)
+ if ($] == '5.013006') { 1 }
+
+ # not sure why this one leaks, but disable anyway - ANDK seems to make it weep
+ elsif ($] == '5.013005') { 1 }
+
+ else { 0 }
+ }
+ else { 0 }
+ }
+ ) ? sub () { 1 } : sub () { 0 };
+}
+
use mro 'c3';
use DBIx::Class::Optional::Dependencies;
use vars qw($VERSION);
-use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
+use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/;
use DBIx::Class::StartupCheck;
+__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
+__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny');
+
sub mk_classdata {
shift->mk_classaccessor(@_);
}
# Always remember to do all digits for the version even if they're 0
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
- $VERSION = '0.08127';
+ $VERSION = '0.08190';
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
gphat: Cory G Watson <gphat@cpan.org>
+Grant Street Group L<http://www.grantstreet.com/>
+
groditi: Guillermo Roditi <groditi@cpan.org>
Haarg: Graham Knop <haarg@haarg.org>
initself: Mike Baas <mike@initselftech.com>
+jawnsy: Jonathan Yu <jawnsy@cpan.org>
+
jasonmay: Jason May <jason.a.may@gmail.com>
jesper: Jesper Krogh
mattlaw: Matt Lawrence
+mattp: Matt Phillips <mattp@cpan.org>
+
michaelr: Michael Reddick <michael.reddick@gmail.com>
+milki: Jonathan Chu <milki@rescomp.berkeley.edu>
+
ned: Neil de Carteret
nigel: Nigel Metheringham <nigelm@cpan.org>
robkinyon: Rob Kinyon <rkinyon@cpan.org>
+Robert Olson <bob@rdolson.org>
+
Roman: Roman Filippov <romanf@cpan.org>
Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org>
talexb: Alex Beamish <talexb@gmail.com>
+tamias: Ronald J Kimball <rjk@tamias.net>
+
teejay : Aaron Trevena <teejay@cpan.org>
Todd Lipcon
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Try::Tiny;
use namespace::clean;
$cond = { "foreign.${f_key}" => "self.${pri}" };
}
$class->_validate_has_one_condition($cond);
+
+ my $default_cascade = ref $cond eq 'CODE' ? 0 : 1;
+
$class->add_relationship($rel, $f_class,
$cond,
{ accessor => 'single',
- cascade_update => 1, cascade_delete => 1,
+ cascade_update => $default_cascade,
+ cascade_delete => $default_cascade,
($join_type ? ('join_type' => $join_type) : ()),
%{$attrs || {}} });
1;
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Sub::Name qw/subname/;
use Scalar::Util qw/blessed/;
unless blessed ($obj);
my $rel_source = $self->search_related($rel)->result_source;
my $cond = $rel_source->relationship_info($f_rel)->{cond};
- my $link_cond = $rel_source->_resolve_condition(
- $cond, $obj, $f_rel
+ my ($link_cond, $crosstable) = $rel_source->_resolve_condition(
+ $cond, $obj, $f_rel, $f_rel
);
+
+ $self->throw_exception(
+ "Custom relationship '$rel' does not resolve to a join-free condition, "
+ ."unable to use with the ManyToMany helper '$f_rel'"
+ ) if $crosstable;
+
$self->search_related($rel, $link_cond)->delete;
};
use strict;
use warnings;
use base qw/DBIx::Class/;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use DBIx::Class::Exception;
-use Data::Page;
use DBIx::Class::ResultSetColumn;
-use DBIx::Class::ResultSourceHandle;
-use Hash::Merge ();
use Scalar::Util qw/blessed weaken/;
use Try::Tiny;
-use Storable qw/nfreeze thaw/;
# not importing first() as it will clash with our own method
use List::Util ();
-use namespace::clean;
-
-
BEGIN {
# De-duplication in _merge_attr() is disabled, but left in for reference
# (the merger is used for other things that ought not to be de-duped)
*__HM_DEDUP = sub () { 0 };
}
+use namespace::clean;
+
use overload
'0+' => "count",
'bool' => "_bool",
year => $request->param('year'),
});
- $self->apply_security_policy( $cd_rs );
+ $cd_rs = $self->apply_security_policy( $cd_rs );
return $cd_rs->all();
}
=cut
-my $callsites_warned;
sub search_rs {
my $self = shift;
} if @_;
if( @_ > 1 and ! $rsrc->result_class->isa('DBIx::Class::CDBICompat') ) {
- # determine callsite obeying Carp::Clan rules (fucking ugly but don't have better ideas)
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
- carp 'search( %condition ) is deprecated, use search( \%condition ) instead'
- unless $callsites_warned->{$callsite}++;
+ carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead';
}
for ($old_where, $call_cond) {
next if $keyref eq 'ARRAY'; # has_many for multi_create
my $rel_q = $rsrc->_resolve_condition(
- $relinfo->{cond}, $val, $key
+ $relinfo->{cond}, $val, $key, $key
);
die "Can't handle complex relationship conditions in find" if ref($rel_q) ne 'HASH';
@related{keys %$rel_q} = values %$rel_q;
return \%aliased;
}
-my $callsites_warned_ucond;
sub _build_unique_cond {
my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_;
and
my @undefs = grep { ! defined $final_cond->{$_} } (keys %$final_cond)
) {
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
-
- carp ( sprintf (
+ carp_unique ( sprintf (
"NULL/undef values supplied for requested unique constraint '%s' (NULL "
. 'values in column(s): %s). This is almost certainly not what you wanted, '
. 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.',
$constraint_name,
join (', ', map { "'$_'" } @undefs),
- )) unless $callsites_warned_ucond->{$callsite}++;
+ ));
}
return $final_cond;
sub search_like {
my $class = shift;
- carp (
+ carp_unique (
'search_like() is deprecated and will be removed in DBIC version 0.09.'
.' Instead use ->search({ x => { -like => "y%" } })'
.' (note the outer pair of {}s - they are important!)'
$reverse_relinfo->{cond},
$self,
$result,
+ $rel,
);
delete $data->[$index]->{$rel};
$rels->{$rel}{cond},
$child,
$main_row,
+ $rel,
);
my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
### necessary for future development of DBIx::DS. Do *NOT* change this code
### before talking to ribasushi/mst
+ require Data::Page;
my $pager = Data::Page->new(
0, #start with an empty set
$attrs->{rows},
while ( my($col, $value) = each %implied ) {
my $vref = ref $value;
- if ($vref eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '=') {
+ if (
+ $vref eq 'HASH'
+ and
+ keys(%$value) == 1
+ and
+ (keys %$value)[0] eq '='
+ ) {
$new_data{$col} = $value->{'='};
}
elsif( !$vref or $vref eq 'SCALAR' or blessed($value) ) {
# subquery (since a group_by is present)
if (delete $attrs->{distinct}) {
if ($attrs->{group_by}) {
- carp ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
+ carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
}
else {
# distinct affects only the main selection part, not what prefetch may
sub _merge_attr {
$hm ||= do {
+ require Hash::Merge;
my $hm = Hash::Merge->new;
$hm->specify_behavior({
# A cursor in progress can't be serialized (and would make little sense anyway)
delete $to_serialize->{cursor};
- nfreeze($to_serialize);
+ Storable::nfreeze($to_serialize);
}
# need this hook for symmetry
sub STORABLE_thaw {
my ($self, $cloning, $serialized) = @_;
- %$self = %{ thaw($serialized) };
+ %$self = %{ Storable::thaw($serialized) };
$self;
}
column (or relationship) accessor, and 'name' is the name of the column
accessor in the related table.
+B<NOTE:> You need to explicitly quote '+columns' when defining the attribute.
+Not doing so causes Perl to incorrectly interpret +columns as a bareword with a
+unary plus operator before it.
+
=head2 include_columns
=over 4
e.g. an C<ORDER BY> clause. This is done via the C<-as> B<select function
attribute> supplied as shown in the example above.
+B<NOTE:> You need to explicitly quote '+select'/'+as' when defining the attributes.
+Not doing so causes Perl to incorrectly interpret them as a bareword with a
+unary plus operator before it.
+
=head2 +select
=over 4
identical to creating a non-pages resultset and then calling ->page($page)
on it.
-If L<rows> attribute is not specified it defaults to 10 rows per page.
+If L</rows> attribute is not specified it defaults to 10 rows per page.
When you have a paged resultset, L</count> will only return the number
of rows in the page. To get the total, use the L</pager> and call
use DBIx::Class::ResultSourceHandle;
use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Try::Tiny;
use List::Util 'first';
- use Scalar::Util qw/weaken isweak/;
+ use Scalar::Util qw/blessed weaken isweak/;
-use Storable qw/nfreeze thaw/;
use namespace::clean;
use base qw/DBIx::Class/;
my $columns_info = $source->columns_info;
Like L</column_info> but returns information for the requested columns. If
-the optional column-list arrayref is ommitted it returns info on all columns
+the optional column-list arrayref is omitted it returns info on all columns
currently defined on the ResultSource via L</add_columns>.
=cut
my ($self,$seq) = @_;
my @pks = $self->primary_columns
- or next;
+ or return;
$_->{sequence} = $seq
for values %{ $self->columns_info (\@pks) };
sub reverse_relationship_info {
my ($self, $rel) = @_;
- my $rel_info = $self->relationship_info($rel);
+
+ my $rel_info = $self->relationship_info($rel)
+ or $self->throw_exception("No such relationship '$rel'");
+
my $ret = {};
return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
- my @cond = keys(%{$rel_info->{cond}});
- my @refkeys = map {/^\w+\.(\w+)$/} @cond;
- my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
+ my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
+
+ my $rsrc_schema_moniker = $self->source_name
+ if try { $self->schema };
- # Get the related result source for this relationship
- my $othertable = $self->related_source($rel);
+ # this may be a partial schema or something else equally esoteric
+ my $other_rsrc = try { $self->related_source($rel) }
+ or return $ret;
# Get all the relationships for that source that related to this source
# whose foreign column set are our self columns on $rel and whose self
- # columns are our foreign columns on $rel.
- my @otherrels = $othertable->relationships();
- my $otherrelationship;
- foreach my $otherrel (@otherrels) {
- # this may be a partial schema with the related source not being
- # available at all
- my $back = try { $othertable->related_source($otherrel) } or next;
-
- # did we get back to ourselves?
- next unless $back->source_name eq $self->source_name;
-
- my $otherrel_info = $othertable->relationship_info($otherrel);
- my @othertestconds;
-
- if (ref $otherrel_info->{cond} eq 'HASH') {
- @othertestconds = ($otherrel_info->{cond});
- }
- elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
- @othertestconds = @{$otherrel_info->{cond}};
+ # columns are our foreign columns on $rel
+ foreach my $other_rel ($other_rsrc->relationships) {
+
+ # only consider stuff that points back to us
+ # "us" here is tricky - if we are in a schema registration, we want
+ # to use the source_names, otherwise we will use the actual classes
+
+ # the schema may be partial
+ my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) }
+ or next;
+
+ if ($rsrc_schema_moniker and try { $roundtrip_rsrc->schema } ) {
+ next unless $rsrc_schema_moniker eq $roundtrip_rsrc->source_name;
}
else {
- next;
+ next unless $self->result_class eq $roundtrip_rsrc->result_class;
}
- foreach my $othercond (@othertestconds) {
- my @other_cond = keys(%$othercond);
- my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
- my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
- next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
- !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
- $ret->{$otherrel} = $otherrel_info;
- }
+ my $other_rel_info = $other_rsrc->relationship_info($other_rel);
+
+ # this can happen when we have a self-referential class
+ next if $other_rel_info eq $rel_info;
+
+ next unless ref $other_rel_info->{cond} eq 'HASH';
+ my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
+
+ $ret->{$other_rel} = $other_rel_info if (
+ $self->_compare_relationship_keys (
+ [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
+ )
+ and
+ $self->_compare_relationship_keys (
+ [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
+ )
+ );
}
+
return $ret;
}
+# all this does is removes the foreign/self prefix from a condition
+sub __strip_relcond {
+ +{
+ map
+ { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
+ keys %{$_[1]}
+ }
+}
+
sub compare_relationship_keys {
carp 'compare_relationship_keys is a private method, stop calling it';
my $self = shift;
# Returns true if both sets of keynames are the same, false otherwise.
sub _compare_relationship_keys {
- my ($self, $keys1, $keys2) = @_;
-
- # Make sure every keys1 is in keys2
- my $found;
- foreach my $key (@$keys1) {
- $found = 0;
- foreach my $prim (@$keys2) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
-
- # Make sure every key2 is in key1
- if ($found) {
- foreach my $prim (@$keys2) {
- $found = 0;
- foreach my $key (@$keys1) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
- }
-
- return $found;
+# my ($self, $keys1, $keys2) = @_;
+ return
+ join ("\x00", sort @{$_[1]})
+ eq
+ join ("\x00", sort @{$_[2]})
+ ;
}
# Returns the {from} structure used to express JOIN conditions
-alias => $as,
-relation_chain_depth => $seen->{-relation_chain_depth} || 0,
},
- $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
+ $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join)
+ ];
}
}
$self->_resolve_condition (@_);
}
- # Resolves the passed condition to a concrete query fragment. If given an alias,
- # returns a join condition; if given an object, inverts that object to produce
- # a related conditional from that object.
- our $UNRESOLVABLE_CONDITION = \'1 = 0';
+ our $UNRESOLVABLE_CONDITION = \ '1 = 0';
+ # Resolves the passed condition to a concrete query fragment and a flag
+ # indicating whether this is a cross-table condition. Also an optional
+ # list of non-triviail values (notmally conditions) returned as a part
+ # of a joinfree condition hash
sub _resolve_condition {
- my ($self, $cond, $as, $for) = @_;
- if (ref $cond eq 'HASH') {
+ my ($self, $cond, $as, $for, $relname) = @_;
+
+ my $obj_rel = !!blessed $for;
+
+ if (ref $cond eq 'CODE') {
+ my $relalias = $obj_rel ? 'me' : $as;
+
+ my ($crosstable_cond, $joinfree_cond) = $cond->({
+ self_alias => $obj_rel ? $as : $for,
+ foreign_alias => $relalias,
+ self_resultsource => $self,
+ foreign_relname => $relname || ($obj_rel ? $as : $for),
+ self_rowobj => $obj_rel ? $for : undef
+ });
+
+ my $cond_cols;
+ if ($joinfree_cond) {
+
+ # FIXME sanity check until things stabilize, remove at some point
+ $self->throw_exception (
+ "A join-free condition returned for relationship '$relname' whithout a row-object to chain from"
+ ) unless $obj_rel;
+
+ # FIXME another sanity check
+ if (
+ ref $joinfree_cond ne 'HASH'
+ or
+ first { $_ !~ /^\Q$relalias.\E.+/ } keys %$joinfree_cond
+ ) {
+ $self->throw_exception (
+ "The join-free condition returned for relationship '$relname' must be a hash "
+ .'reference with all keys being valid columns on the related result source'
+ );
+ }
+
+ # normalize
+ for (values %$joinfree_cond) {
+ $_ = $_->{'='} if (
+ ref $_ eq 'HASH'
+ and
+ keys %$_ == 1
+ and
+ exists $_->{'='}
+ );
+ }
+
+ # see which parts of the joinfree cond are conditionals
+ my $relcol_list = { map { $_ => 1 } $self->related_source($relname)->columns };
+
+ for my $c (keys %$joinfree_cond) {
+ my ($colname) = $c =~ /^ (?: \Q$relalias.\E )? (.+)/x;
+
+ unless ($relcol_list->{$colname}) {
+ push @$cond_cols, $colname;
+ next;
+ }
+
+ if (
+ ref $joinfree_cond->{$c}
+ and
+ ref $joinfree_cond->{$c} ne 'SCALAR'
+ and
+ ref $joinfree_cond->{$c} ne 'REF'
+ ) {
+ push @$cond_cols, $colname;
+ next;
+ }
+ }
+
+ return wantarray ? ($joinfree_cond, 0, $cond_cols) : $joinfree_cond;
+ }
+ else {
+ return wantarray ? ($crosstable_cond, 1) : $crosstable_cond;
+ }
+ }
+ elsif (ref $cond eq 'HASH') {
my %ret;
foreach my $k (keys %{$cond}) {
my $v = $cond->{$k};
} elsif (!defined $as) { # undef, i.e. "no reverse object"
$ret{$v} = undef;
} else {
- $ret{"${as}.${k}"} = "${for}.${v}";
+ $ret{"${as}.${k}"} = { -ident => "${for}.${v}" };
}
}
- return \%ret;
- } elsif (ref $cond eq 'ARRAY') {
- return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
- } else {
- die("Can't handle condition $cond yet :(");
+
+ return wantarray
+ ? ( \%ret, ($obj_rel || !defined $as || ref $as) ? 0 : 1 )
+ : \%ret
+ ;
+ }
+ elsif (ref $cond eq 'ARRAY') {
+ my (@ret, $crosstable);
+ for (@$cond) {
+ my ($cond, $crosstab) = $self->_resolve_condition($_, $as, $for, $relname);
+ push @ret, $cond;
+ $crosstable ||= $crosstab;
+ }
+ return wantarray ? (\@ret, $crosstable) : \@ret;
+ }
+ else {
+ $self->throw_exception ("Can't handle condition $cond for relationship '$relname' yet :(");
}
}
-
# Accepts one or more relationships for the current source and returns an
# array of column names for each of those relationships. Column names are
# prefixed relative to the current source, in accordance with where they appear
"Can't prefetch has_many ${pre} (join cond too complex)")
unless ref($rel_info->{cond}) eq 'HASH';
my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
+
if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
keys %{$collapse}) {
my ($last) = ($fail =~ /([^\.]+)$/);
. 'Use at your own risk.'
);
}
+
#my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
# values %{$rel_info->{cond}};
$collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ];
if( !$self->has_relationship( $rel ) ) {
$self->throw_exception("No such relationship '$rel' on " . $self->source_name);
}
- return $self->schema->source($self->relationship_info($rel)->{source});
+
+ # if we are not registered with a schema - just use the prototype
+ # however if we do have a schema - ask for the source by name (and
+ # throw in the process if all fails)
+ if (my $schema = try { $self->schema }) {
+ $schema->source($self->relationship_info($rel)->{source});
+ }
+ else {
+ my $class = $self->relationship_info($rel)->{class};
+ $self->ensure_class_loaded($class);
+ $class->result_source_instance;
+ }
}
=head2 related_class
{
my $global_phase_destroy;
- END { $global_phase_destroy++ }
+ # SpeedyCGI runs END blocks every cycle but keeps object instances
+ # hence we have to disable the globaldestroy hatch, and rely on the
+ # eval trap below (which appears to work, but is risky done so late)
+ END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy }
sub DESTROY {
return if $global_phase_destroy;
);
# weaken our schema hold forcing the schema to find somewhere else to live
- weaken $_[0]->{schema};
+ # during global destruction (if we have not yet bailed out) this will throw
+ # which will serve as a signal to not try doing anything else
+ local $@;
+ eval {
+ weaken $_[0]->{schema};
+ 1;
+ } or do {
+ $global_phase_destroy = 1;
+ return;
+ };
+
- # if schema is still there reintroduce ourselves with strong refs back
+ # if schema is still there reintroduce ourselves with strong refs back to us
if ($_[0]->{schema}) {
my $srcregs = $_[0]->{schema}->source_registrations;
for (keys %$srcregs) {
+ next unless $srcregs->{$_};
$srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
}
}
}
}
-sub STORABLE_freeze { nfreeze($_[0]->handle) }
+sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
sub STORABLE_thaw {
my ($self, $cloning, $ice) = @_;
- %$self = %{ (thaw $ice)->resolve };
+ %$self = %{ (Storable::thaw($ice))->resolve };
}
=head2 throw_exception
use DBIx::Class::Exception;
use Scalar::Util 'blessed';
use Try::Tiny;
-use namespace::clean;
###
### Internal method
: sub () { 0 };
}
+use namespace::clean;
+
=head1 NAME
DBIx::Class::Row - Basic row methods
next unless $rel_info->{attrs}{cascade_copy};
my $resolved = $self->result_source->_resolve_condition(
- $rel_info->{cond}, $rel, $new
+ $rel_info->{cond}, $rel, $new, $rel
);
my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
package DBIx::Class::SQLMaker;
+ use strict;
+ use warnings;
+
=head1 NAME
DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class
use base qw/
DBIx::Class::SQLMaker::LimitDialects
SQL::Abstract
- Class::Accessor::Grouped
+ DBIx::Class
/;
use mro 'c3';
- use strict;
- use warnings;
+
use Sub::Name 'subname';
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract|^Try::Tiny/;
+use DBIx::Class::Carp;
+use DBIx::Class::Exception;
use namespace::clean;
__PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
;
}
+# FIXME when we bring in the storage weaklink, check its schema
+# weaklink and channel through $schema->throw_exception
+sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
+
BEGIN {
- # reinstall the carp()/croak() functions imported into SQL::Abstract
- # as Carp and Carp::Clan do not like each other much
+ # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
+ # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
no warnings qw/redefine/;
- no strict qw/refs/;
- for my $f (qw/carp croak/) {
-
- my $orig = \&{"SQL::Abstract::$f"};
- my $clan_import = \&{$f};
- *{"SQL::Abstract::$f"} = subname "SQL::Abstract::$f" =>
- sub {
- if (Carp::longmess() =~ /DBIx::Class::SQLMaker::[\w]+ .+? called \s at/x) {
- goto $clan_import;
- }
- else {
- goto $orig;
- }
- };
- }
+
+ *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
+ my($func) = (caller(1))[3];
+ carp "[$func] Warning: ", @_;
+ };
+
+ *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
+ my($func) = (caller(1))[3];
+ __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_));
+ };
+
+ # Current SQLA pollutes its namespace - clean for the time being
+ namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/);
}
# the "oh noes offset/top without limit" constant
my $self = shift;
my ($op, $rhs) = splice @_, -2;
if (ref $rhs) {
- croak "-$op takes a single scalar argument (a quotable identifier)";
+ $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
}
# in case we are called as a top level special op (no '=')
my $lhs = shift;
my @bind = [
- ($lhs || $self->{_nested_func_lhs} || croak "Unable to find bindtype for -value $rhs"),
+ ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
$rhs
];
;
}
-my $callsites_warned;
sub _where_op_NEST {
- # determine callsite obeying Carp::Clan rules (fucking ugly but don't have better ideas)
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
-
- carp ("-nest in search conditions is deprecated, you most probably wanted:\n"
+ carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
.q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
- ) unless $callsites_warned->{$callsite}++;
+ );
shift->next::method(@_);
}
$fields = $self->_recurse_fields($fields);
if (defined $offset) {
- croak ('A supplied offset must be a non-negative integer')
+ $self->throw_exception('A supplied offset must be a non-negative integer')
if ( $offset =~ /\D/ or $offset < 0 );
}
$offset ||= 0;
if (defined $limit) {
- croak ('A supplied limit must be a positive integer')
+ $self->throw_exception('A supplied limit must be a positive integer')
if ( $limit =~ /\D/ or $limit <= 0 );
}
elsif ($offset) {
||
do {
my $dialect = $self->limit_dialect
- or croak "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found";
+ or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
$self->can ("_$dialect")
- or croak (__PACKAGE__ . " does not implement the requested dialect '$dialect'");
+ or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
}
;
};
sub _lock_select {
my ($self, $type) = @_;
- my $sql = $for_syntax->{$type} || croak "Unknown SELECT .. FOR type '$type' requested";
+ my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
return " $sql";
}
# there should be only one pair
if (@toomany) {
- croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
+ $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
}
if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
- croak (
+ $self->throw_exception (
'The select => { distinct => ... } syntax is not supported for multiple columns.'
.' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
.' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
return $$fields->[0];
}
else {
- croak($ref . qq{ unexpected in _recurse_fields()})
+ $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
}
}
elsif ($ref eq 'HASH') {
return $_[0]->_recurse_from($_[1]);
}
+ elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
+ my ($sql, @bind) = @{ ${$_[1]} };
+ push @{$_[0]->{from_bind}}, @bind;
+ return $sql
+ }
}
-
return $_[0]->next::method ($_[1]);
}
sub _generate_join_clause {
my ($self, $join_type) = @_;
+ $join_type = $self->{_default_jointype}
+ if ! defined $join_type;
+
return sprintf ('%s JOIN ',
- $join_type ? ' ' . $self->_sqlcase($join_type) : ''
+ $join_type ? $self->_sqlcase($join_type) : ''
);
}
sub _recurse_from {
- my ($self, $from, @join) = @_;
- my @sqlf;
- push @sqlf, $self->_from_chunk_to_sql($from);
+ my $self = shift;
+
+ return join (' ', $self->_gen_from_blocks(@_) );
+}
- for (@join) {
+sub _gen_from_blocks {
+ my ($self, $from, @joins) = @_;
+
+ my @fchunks = $self->_from_chunk_to_sql($from);
+
+ for (@joins) {
my ($to, $on) = @$_;
# check whether a join type exists
$join_type =~ s/^\s+ | \s+$//xg;
}
- $join_type = $self->{_default_jointype} if not defined $join_type;
-
- push @sqlf, $self->_generate_join_clause( $join_type );
+ my @j = $self->_generate_join_clause( $join_type );
if (ref $to eq 'ARRAY') {
- push(@sqlf, '(', $self->_recurse_from(@$to), ')');
- } else {
- push(@sqlf, $self->_from_chunk_to_sql($to));
+ push(@j, '(', $self->_recurse_from(@$to), ')');
+ }
+ else {
+ push(@j, $self->_from_chunk_to_sql($to));
}
- push(@j, ' ON ', $self->_join_condition($on));
+ my ($sql, @bind) = $self->_join_condition($on);
- push(@sqlf, ' ON ', $sql);
++ push(@j, ' ON ', $sql);
+ push @{$self->{from_bind}}, @bind;
+
+ push @fchunks, join '', @j;
}
- return join('', @sqlf);
+ return @fchunks;
}
sub _from_chunk_to_sql {
( grep { $_ !~ /^\-/ } keys %$fromspec )
);
- croak "Only one table/as pair expected in from-spec but an exra '$toomuch' key present"
+ $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
if defined $toomuch;
($self->_from_chunk_to_sql($table), $self->_quote($as) );
sub _join_condition {
my ($self, $cond) = @_;
- if (ref $cond eq 'HASH') {
- my %j;
- for (keys %$cond) {
- my $v = $cond->{$_};
- if (ref $v) {
- $self->throw_exception (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
- if ref($v) ne 'SCALAR';
- $j{$_} = $v;
- }
- else {
- my $x = '= '.$self->_quote($v); $j{$_} = \$x;
- }
- };
- return scalar($self->_recurse_where(\%j));
- } elsif (ref $cond eq 'ARRAY') {
- return join(' OR ', map { $self->_join_condition($_) } @$cond);
- } else {
- die "Can't handle this yet!";
+ # Backcompat for the old days when a plain hashref
+ # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
+ # Once things settle we should start warning here so that
+ # folks unroll their hacks
+ if (
+ ref $cond eq 'HASH'
+ and
+ keys %$cond == 1
+ and
+ (keys %$cond)[0] =~ /\./
+ and
+ ! ref ( (values %$cond)[0] )
+ ) {
+ $cond = { keys %$cond => { -ident => values %$cond } }
}
+ elsif ( ref $cond eq 'ARRAY' ) {
+ # do our own ORing so that the hashref-shim above is invoked
+ my @parts;
+ my @binds;
+ foreach my $c (@$cond) {
+ my ($sql, @bind) = $self->_join_condition($c);
+ push @binds, @bind;
+ push @parts, $sql;
+ }
+ return join(' OR ', @parts), @binds;
+ }
+
+ return $self->_recurse_where($cond);
}
1;
package # Hide from PAUSE
DBIx::Class::SQLMaker::OracleJoins;
+use warnings;
+use strict;
+
use base qw( DBIx::Class::SQLMaker::Oracle );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
sub select {
my ($self, $table, $fields, $where, $rs_attrs, @rest) = @_;
+ # pull out all join conds as regular WHEREs from all extra tables
if (ref($table) eq 'ARRAY') {
- $where = $self->_oracle_joins($where, @{ $table });
+ $where = $self->_oracle_joins($where, @{ $table }[ 1 .. $#$table ]);
}
- return $self->SUPER::select($table, $fields, $where, $rs_attrs, @rest);
+ return $self->next::method($table, $fields, $where, $rs_attrs, @rest);
}
sub _recurse_from {
}
sub _oracle_joins {
- my ($self, $where, $from, @join) = @_;
- my $join_where = {};
- $self->_recurse_oracle_joins($join_where, $from, @join);
+ my ($self, $where, @join) = @_;
+ my $join_where = $self->_recurse_oracle_joins(@join);
+
if (keys %$join_where) {
if (!defined($where)) {
$where = $join_where;
}
sub _recurse_oracle_joins {
- my ($self, $where, $from, @join) = @_;
+ my $self = shift;
- foreach my $j (@join) {
+ my @where;
+ for my $j (@_) {
my ($to, $on) = @{ $j };
- if (ref $to eq 'ARRAY') {
- $self->_recurse_oracle_joins($where, @{ $to });
- }
+ push @where, $self->_recurse_oracle_joins(@{ $to })
+ if (ref $to eq 'ARRAY');
- my $to_jt = ref $to eq 'ARRAY' ? $to->[0] : $to;
+ my $join_opts = ref $to eq 'ARRAY' ? $to->[0] : $to;
my $left_join = q{};
my $right_join = q{};
- if (ref $to_jt eq 'HASH' and exists $to_jt->{-join_type}) {
+ if (ref $join_opts eq 'HASH' and my $jt = $join_opts->{-join_type}) {
#TODO: Support full outer joins -- this would happen much earlier in
#the sequence since oracle 8's full outer join syntax is best
#described as INSANE.
- croak "Can't handle full outer joins in Oracle 8 yet!\n"
- if $to_jt->{-join_type} =~ /full/i;
+ $self->throw_exception("Can't handle full outer joins in Oracle 8 yet!\n")
+ if $jt =~ /full/i;
- $left_join = q{(+)} if $to_jt->{-join_type} =~ /left/i
- && $to_jt->{-join_type} !~ /inner/i;
+ $left_join = q{(+)} if $jt =~ /left/i
+ && $jt !~ /inner/i;
- $right_join = q{(+)} if $to_jt->{-join_type} =~ /right/i
- && $to_jt->{-join_type} !~ /inner/i;
+ $right_join = q{(+)} if $jt =~ /right/i
+ && $jt !~ /inner/i;
}
- foreach my $lhs (keys %{ $on }) {
- $where->{$lhs . $left_join} = \"= $on->{ $lhs }$right_join";
- }
++ # sadly SQLA treats where($scalar) as literal, so we need to jump some hoops
+ push @where, map { \sprintf ('%s%s = %s%s',
- $self->_quote($_),
++ ref $_ ? $self->_recurse_where($_) : $self->_quote($_),
+ $left_join,
- $self->_quote($on->{$_}),
++ ref $on->{$_} ? $self->_recurse_where($on->{$_}) : $self->_quote($on->{$_}),
+ $right_join,
+ )} keys %$on;
}
+
+ return { -and => \@where };
}
1;
=head1 PURPOSE
-This module was originally written to support Oracle < 9i where ANSI joins
-weren't supported at all, but became the module for Oracle >= 8 because
-Oracle's optimising of ANSI joins is horrible.
+This module is used with Oracle < 9.0 due to lack of support for standard
+ANSI join syntax.
=head1 SYNOPSIS
=over
-=item select ($\@$;$$@)
-
-Replaces DBIx::Class::SQLMaker's select() method, which calls _oracle_joins()
-to modify the column and table list before calling SUPER::select().
-
-=item _recurse_from ($$\@)
-
-Recursive subroutine that builds the table list.
-
-=item _oracle_joins ($$$@)
+=item select
-Creates the left/right relationship in the where query.
+Overrides DBIx::Class::SQLMaker's select() method, which calls _oracle_joins()
+to modify the column and table list before calling next::method().
=back
=head1 BUGS
-Does not support full outer joins.
-Probably lots more.
+Does not support full outer joins (however neither really does DBIC itself)
=head1 SEE ALSO
--- /dev/null
+ use strict;
+ use warnings;
+
+ use Test::More;
+ use Test::Exception;
+ use lib qw(t/lib);
+ use DBICTest;
+ use DBIC::SqlMakerTest;
+
+ my $schema = DBICTest->init_schema();
+
+ $schema->resultset('Artist')->delete;
+ $schema->resultset('CD')->delete;
+
+ my $artist = $schema->resultset("Artist")->create({ artistid => 21, name => 'Michael Jackson', rank => 20 });
+ my $artist2 = $schema->resultset("Artist")->create({ artistid => 22, name => 'Chico Buarque', rank => 1 }) ;
+ my $artist3 = $schema->resultset("Artist")->create({ artistid => 23, name => 'Ziraldo', rank => 1 });
+ my $artist4 = $schema->resultset("Artist")->create({ artistid => 24, name => 'Paulo Caruso', rank => 20 });
+
+ my @artworks;
+
+ foreach my $year (1975..1985) {
+ my $cd = $artist->create_related('cds', { year => $year, title => 'Compilation from ' . $year });
+ push @artworks, $cd->create_related('artwork', {});
+ }
+
+ foreach my $year (1975..1995) {
+ my $cd = $artist2->create_related('cds', { year => $year, title => 'Compilation from ' . $year });
+ push @artworks, $cd->create_related('artwork', {});
+ }
+
+ foreach my $artwork (@artworks) {
+ $artwork->create_related('artwork_to_artist', { artist => $_ }) for ($artist3, $artist4);
+ }
+
+
+ my $cds_80s_rs = $artist->cds_80s;
+ is_same_sql_bind(
+ $cds_80s_rs->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM cd me
+ WHERE ( ( me.artist = ? AND ( me.year < ? AND me.year > ? ) ) )
+ )',
+ [
- [ 'me.artist' => 21 ],
- [ 'me.year' => 1990 ],
- [ 'me.year' => 1979 ],
- ]
++ [
++ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
++ => 21
++ ],
++ [
++ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
++ => 1990
++ ],
++ [
++ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
++ => 1979
++ ],
++ ],
+ );
+ my @cds_80s = $cds_80s_rs->all;
+ is(@cds_80s, 6, '6 80s cds found (1980 - 1985)');
+ map { ok($_->year < 1990 && $_->year > 1979) } @cds_80s;
+
+
+ my $cds_90s_rs = $artist2->cds_90s;
+ is_same_sql_bind(
+ $cds_90s_rs->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM artist artist__row
+ JOIN cd me
+ ON ( me.artist = artist__row.artistid AND ( me.year < ? AND me.year > ? ) )
+ WHERE ( artist__row.artistid = ? )
+ )',
+ [
- [ 'me.year' => 2000 ],
- [ 'me.year' => 1989 ],
- [ 'artist__row.artistid' => 22 ],
++ [
++ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
++ => 2000
++ ],
++ [
++ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
++ => 1989
++ ],
++ [ { sqlt_datatype => 'integer', dbic_colname => 'artist__row.artistid' }
++ => 22
++ ],
+ ]
+ );
+ my @cds_90s = $cds_90s_rs->all;
+ is(@cds_90s, 6, '6 90s cds found (1990 - 1995) even with non-optimized search');
+ map { ok($_->year < 2000 && $_->year > 1989) } @cds_90s;
+
+ lives_ok {
+ my @cds_90s_95 = $artist2->cds_90s->search({ 'me.year' => 1995 });
+ is(@cds_90s_95, 1, '1 90s (95) cds found even with non-optimized search');
+ map { ok($_->year == 1995) } @cds_90s_95;
+ } 'should preserve chain-head "me" alias (API-consistency)';
+
+ # search for all artists prefetching published cds in the 80s...
+ my @all_artists_with_80_cds = $schema->resultset("Artist")->search
+ ({ 'cds_80s.cdid' => { '!=' => undef } }, { join => 'cds_80s', distinct => 1 });
+
+ is_deeply(
+ [ sort ( map { $_->year } map { $_->cds_80s->all } @all_artists_with_80_cds ) ],
+ [ sort (1980..1989, 1980..1985) ],
+ '16 correct cds found'
+ );
+
+ TODO: {
+ local $TODO = 'Prefetch on custom rels can not work until the collapse rewrite is finished '
+ . '(currently collapser requires a right-side (which is indeterministic) order-by)';
+ lives_ok {
+
+ my @all_artists_with_80_cds_pref = $schema->resultset("Artist")->search
+ ({ 'cds_80s.cdid' => { '!=' => undef } }, { prefetch => 'cds_80s' });
+
+ is_deeply(
+ [ sort ( map { $_->year } map { $_->cds_80s->all } @all_artists_with_80_cds_pref ) ],
+ [ sort (1980..1989, 1980..1985) ],
+ '16 correct cds found'
+ );
+
+ } 'prefetchy-fetchy-fetch';
+ } # end of TODO
+
+
+ # try to create_related a 80s cd
+ throws_ok {
+ $artist->create_related('cds_80s', { title => 'related creation 1' });
+ } qr/\QCustom relationship 'cds_80s' not definitive - returns conditions instead of values for column(s): 'year'/,
+ 'Create failed - complex cond';
+
+ # now supply an explicit arg overwriting the ambiguous cond
+ my $id_2020 = $artist->create_related('cds_80s', { title => 'related creation 2', year => '2020' })->id;
+ is(
+ $schema->resultset('CD')->find($id_2020)->title,
+ 'related creation 2',
+ '2020 CD created correctly'
+ );
+
+ # try a default year from a specific rel
+ my $id_1984 = $artist->create_related('cds_84', { title => 'related creation 3' })->id;
+ is(
+ $schema->resultset('CD')->find($id_1984)->title,
+ 'related creation 3',
+ '1984 CD created correctly'
+ );
+
+ # try a specific everything via a non-simplified rel
+ throws_ok {
+ $artist->create_related('cds_90s', { title => 'related_creation 4', year => '2038' });
+ } qr/\QCustom relationship 'cds_90s' does not resolve to a join-free condition fragment/,
+ 'Create failed - non-simplified rel';
+
+ # Do a self-join last-entry search
+ my @last_tracks;
+ for my $cd ($schema->resultset('CD')->search ({}, { order_by => 'cdid'})->all) {
+ push @last_tracks, $cd->tracks
+ ->search ({}, { order_by => { -desc => 'position'} })
+ ->next || ();
+ }
+
+ my $last_tracks_rs = $schema->resultset('Track')->search (
+ {'next_track.trackid' => undef},
+ { join => 'next_track', order_by => 'me.cd' },
+ );
+
+ is_deeply (
+ [$last_tracks_rs->get_column ('trackid')->all],
+ [ map { $_->trackid } @last_tracks ],
+ 'last group-entry via self-join works',
+ );
+
+ my $artwork = $schema->resultset('Artwork')->search({},{ order_by => 'cd_id' })->first;
+ my @artists = $artwork->artists->all;
+ is(scalar @artists, 2, 'the two artists are associated');
+
+ my @artwork_artists = $artwork->artwork_to_artist->all;
+ foreach (@artwork_artists) {
+ lives_ok {
+ my $artista = $_->artist;
+ my $artistb = $_->artist_test_m2m;
+ ok($artista->rank < 10 ? $artistb : 1, 'belongs_to with custom rel works.');
+ my $artistc = $_->artist_test_m2m_noopt;
+ ok($artista->rank < 10 ? $artistc : 1, 'belongs_to with custom rel works even in non-simplified.');
+ } 'belongs_to works with custom rels';
+ }
+
+ @artists = ();
+ lives_ok {
+ @artists = $artwork->artists_test_m2m2->all;
+ } 'manytomany with extended rels in the has many works';
+ is(scalar @artists, 2, 'two artists');
+
+ @artists = ();
+ lives_ok {
+ @artists = $artwork->artists_test_m2m->all;
+ } 'can fetch many to many with optimized version';
+ is(scalar @artists, 1, 'only one artist is associated');
+
+ @artists = ();
+ lives_ok {
+ @artists = $artwork->artists_test_m2m_noopt->all;
+ } 'can fetch many to many with non-optimized version';
+ is(scalar @artists, 1, 'only one artist is associated');
+
+
+ # Make a single for each last_track
+ my @singles = map {
+ $_->create_related('cd_single', {
+ title => $_->title . ' (the single)',
+ artist => $artist,
+ year => 1999,
+ }) } @last_tracks
+ ;
+
+ # See if chaining works
+ is_deeply (
+ [ map { $_->title } $last_tracks_rs->search_related('cd_single')->all ],
+ [ map { $_->title } @singles ],
+ 'Retrieved singles in proper order'
+ );
+
+ # See if prefetch works
+ is_deeply (
+ [ map { $_->cd_single->title } $last_tracks_rs->search({}, { prefetch => 'cd_single' })->all ],
+ [ map { $_->title } @singles ],
+ 'Prefetched singles in proper order'
+ );
+
+ done_testing;
projects / dbsrgits/DBIx-Class.git / commitdiff