r52341 - in /branches/upstream/libdbix-class-perl/current: ./ lib/DBIx/ lib/DBIx/Class/ lib/DBIx/Class/Relationship/ t/ t/multi_create/ t/prefetch/ t/resultset/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Mon Feb 8 22:40:44 UTC 2010
Author: jawnsy-guest
Date: Mon Feb 8 22:40:38 2010
New Revision: 52341
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=52341
Log:
[svn-upgrade] Integrating new upstream version, libdbix-class-perl (0.08118)
Added:
branches/upstream/libdbix-class-perl/current/t/prefetch/one_to_many_to_one.t
branches/upstream/libdbix-class-perl/current/t/resultset/as_subselect_rs.t
Modified:
branches/upstream/libdbix-class-perl/current/Changes
branches/upstream/libdbix-class-perl/current/MANIFEST
branches/upstream/libdbix-class-perl/current/META.yml
branches/upstream/libdbix-class-perl/current/lib/DBIx/Class.pm
branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/InflateColumn.pm
branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/Base.pm
branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/CascadeActions.pm
branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSet.pm
branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSource.pm
branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Row.pm
branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/UTF8Columns.pm
branches/upstream/libdbix-class-perl/current/t/60core.t
branches/upstream/libdbix-class-perl/current/t/85utf8.t
branches/upstream/libdbix-class-perl/current/t/multi_create/standard.t
Modified: branches/upstream/libdbix-class-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/Changes?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/Changes (original)
+++ branches/upstream/libdbix-class-perl/current/Changes Mon Feb 8 22:40:38 2010
@@ -1,4 +1,9 @@
Revision history for DBIx::Class
+
+0.08118 2010-02-08 11:53:00 (UTC)
+ - Fix a bug causing UTF8 columns not to be decoded (RT#54395)
+ - Fix bug in One->Many->One prefetch-collapse handling (RT#54039)
+ - Cleanup handling of relationship accessor types
0.08117 2010-02-05 17:10:00 (UTC)
- Perl 5.8.1 is now the minimum supported version
Modified: branches/upstream/libdbix-class-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/MANIFEST?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/MANIFEST (original)
+++ branches/upstream/libdbix-class-perl/current/MANIFEST Mon Feb 8 22:40:38 2010
@@ -443,6 +443,7 @@
t/prefetch/incomplete.t
t/prefetch/join_type.t
t/prefetch/multiple_hasmany.t
+t/prefetch/one_to_many_to_one.t
t/prefetch/standard.t
t/prefetch/via_search_related.t
t/prefetch/with_limit.t
@@ -452,6 +453,7 @@
t/relationship/update_or_create_multi.t
t/relationship/update_or_create_single.t
t/resultset/as_query.t
+t/resultset/as_subselect_rs.t
t/resultset/is_paged.t
t/resultset/nulls_only.t
t/resultset/plus_select.t
Modified: branches/upstream/libdbix-class-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/META.yml?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/META.yml (original)
+++ branches/upstream/libdbix-class-perl/current/META.yml Mon Feb 8 22:40:38 2010
@@ -56,4 +56,4 @@
MailingList: http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class
license: http://dev.perl.org/licenses/
repository: http://dev.catalyst.perl.org/repos/bast/DBIx-Class/
-version: 0.08117
+version: 0.08118
Modified: branches/upstream/libdbix-class-perl/current/lib/DBIx/Class.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/lib/DBIx/Class.pm?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/lib/DBIx/Class.pm (original)
+++ branches/upstream/libdbix-class-perl/current/lib/DBIx/Class.pm Mon Feb 8 22:40:38 2010
@@ -25,7 +25,7 @@
# 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.08117';
+$VERSION = '0.08118';
$VERSION = eval $VERSION; # numify for warning-free dev releases
Modified: branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/InflateColumn.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/InflateColumn.pm?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/InflateColumn.pm (original)
+++ branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/InflateColumn.pm Mon Feb 8 22:40:38 2010
@@ -79,7 +79,8 @@
$self->throw_exception("inflate_column needs attr hashref")
unless ref $attrs eq 'HASH';
$self->column_info($col)->{_inflate_info} = $attrs;
- $self->mk_group_accessors('inflated_column' => [$self->column_info($col)->{accessor} || $col, $col]);
+ my $acc = $self->column_info($col)->{accessor};
+ $self->mk_group_accessors('inflated_column' => [ (defined $acc ? $acc : $col), $col]);
return 1;
}
Modified: branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/Base.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/Base.pm?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/Base.pm (original)
+++ branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/Base.pm Mon Feb 8 22:40:38 2010
@@ -29,6 +29,8 @@
=back
__PACKAGE__->add_relationship('relname', 'Foreign::Class', $cond, $attrs);
+
+=head3 condition
The condition needs to be an L<SQL::Abstract>-style representation of the
join between the tables. When resolving the condition for use in a C<JOIN>,
@@ -67,9 +69,18 @@
To add an C<OR>ed condition, use an arrayref of hashrefs. See the
L<SQL::Abstract> documentation for more details.
-In addition to the
-L<standard ResultSet attributes|DBIx::Class::ResultSet/ATTRIBUTES>,
-the following attributes are also valid:
+=head3 attributes
+
+The L<standard ResultSet attributes|DBIx::Class::ResultSet/ATTRIBUTES> may
+be used as relationship attributes. In particular, the 'where' attribute is
+useful for filtering relationships:
+
+ __PACKAGE__->has_many( 'valid_users', 'MyApp::Schema::User',
+ { 'foreign.user_id' => 'self.user_id' },
+ { where => { valid => 1 } }
+ );
+
+The following attributes are also valid:
=over 4
@@ -195,7 +206,7 @@
if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
my $reverse = $source->reverse_relationship_info($rel);
foreach my $rev_rel (keys %$reverse) {
- if ($reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
+ if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
$attrs->{related_objects}{$rev_rel} = [ $self ];
Scalar::Util::weaken($attrs->{related_object}{$rev_rel}[0]);
} else {
Modified: branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/CascadeActions.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/CascadeActions.pm?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/CascadeActions.pm (original)
+++ branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Relationship/CascadeActions.pm Mon Feb 8 22:40:38 2010
@@ -39,8 +39,11 @@
my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
foreach my $rel (@cascade) {
next if (
+ $rels{$rel}{attrs}{accessor}
+ &&
$rels{$rel}{attrs}{accessor} eq 'single'
- && !exists($self->{_relationship_data}{$rel})
+ &&
+ !exists($self->{_relationship_data}{$rel})
);
$_->update for grep defined, $self->$rel;
}
Modified: branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSet.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSet.pm?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSet.pm (original)
+++ branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSet.pm Mon Feb 8 22:40:38 2010
@@ -2502,7 +2502,7 @@
->relname_to_table_alias($rel, $join_count);
# since this is search_related, and we already slid the select window inwards
- # (the select/as attrs were deleted in the beginning), we need to flip all
+ # (the select/as attrs were deleted in the beginning), we need to flip all
# left joins to inner, so we get the expected results
# read the comment on top of the actual function to see what this does
$attrs->{from} = $rsrc->schema->storage->_straight_join_to_node ($attrs->{from}, $alias);
@@ -2586,6 +2586,68 @@
my ($self) = @_;
return ($self->{attrs} || {})->{alias} || 'me';
+}
+
+=head2 as_subselect_rs
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $resultset
+
+=back
+
+Act as a barrier to SQL symbols. The resultset provided will be made into a
+"virtual view" by including it as a subquery within the from clause. From this
+point on, any joined tables are inaccessible to ->search on the resultset (as if
+it were simply where-filtered without joins). For example:
+
+ my $rs = $schema->resultset('Bar')->search({'x.name' => 'abc'},{ join => 'x' });
+
+ # 'x' now pollutes the query namespace
+
+ # So the following works as expected
+ my $ok_rs = $rs->search({'x.other' => 1});
+
+ # But this doesn't: instead of finding a 'Bar' related to two x rows (abc and
+ # def) we look for one row with contradictory terms and join in another table
+ # (aliased 'x_2') which we never use
+ my $broken_rs = $rs->search({'x.name' => 'def'});
+
+ my $rs2 = $rs->as_subselect_rs;
+
+ # doesn't work - 'x' is no longer accessible in $rs2, having been sealed away
+ my $not_joined_rs = $rs2->search({'x.other' => 1});
+
+ # works as expected: finds a 'table' row related to two x rows (abc and def)
+ my $correctly_joined_rs = $rs2->search({'x.name' => 'def'});
+
+Another example of when one might use this would be to select a subset of
+columns in a group by clause:
+
+ my $rs = $schema->resultset('Bar')->search(undef, {
+ group_by => [qw{ id foo_id baz_id }],
+ })->as_subselect_rs->search(undef, {
+ columns => [qw{ id foo_id }]
+ });
+
+In the above example normally columns would have to be equal to the group by,
+but because we isolated the group by into a subselect the above works.
+
+=cut
+
+sub as_subselect_rs {
+ my $self = shift;
+
+ return $self->result_source->resultset->search( undef, {
+ alias => $self->current_source_alias,
+ from => [{
+ $self->current_source_alias => $self->as_query,
+ -alias => $self->current_source_alias,
+ -source_handle => $self->result_source->handle,
+ }]
+ });
}
# This code is called by search_related, and makes sure there
Modified: branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSource.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSource.pm?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSource.pm (original)
+++ branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/ResultSource.pm Mon Feb 8 22:40:38 2010
@@ -1188,12 +1188,6 @@
return $found;
}
-sub resolve_join {
- carp 'resolve_join is a private method, stop calling it';
- my $self = shift;
- $self->_resolve_join (@_);
-}
-
# Returns the {from} structure used to express JOIN conditions
sub _resolve_join {
my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
@@ -1262,7 +1256,11 @@
: $rel_info->{attrs}{join_type}
,
-join_path => [@$jpath, { $join => $as } ],
- -is_single => (List::Util::first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/) ),
+ -is_single => (
+ $rel_info->{attrs}{accessor}
+ &&
+ List::Util::first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
+ ),
-alias => $as,
-relation_chain_depth => $seen->{-relation_chain_depth} || 0,
},
@@ -1373,23 +1371,30 @@
}
}
-# Legacy code, needs to go entirely away (fully replaced by _resolve_prefetch)
-sub resolve_prefetch {
- carp 'resolve_prefetch is a private method, stop calling it';
-
- my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
- $seen ||= {};
- if( ref $pre eq 'ARRAY' ) {
+
+# Accepts one or more relationships for the current source and returns an
+# array of column names for each of those relationships. Column names are
+# prefixed relative to the current source, in accordance with where they appear
+# in the supplied relationships.
+
+sub _resolve_prefetch {
+ my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
+ $pref_path ||= [];
+
+ if (not defined $pre) {
+ return ();
+ }
+ elsif( ref $pre eq 'ARRAY' ) {
return
- map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
+ map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
@$pre;
}
elsif( ref $pre eq 'HASH' ) {
my @ret =
map {
- $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
- $self->related_source($_)->resolve_prefetch(
- $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
+ $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
+ $self->related_source($_)->_resolve_prefetch(
+ $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
} keys %$pre;
return @ret;
}
@@ -1398,16 +1403,23 @@
"don't know how to resolve prefetch reftype ".ref($pre));
}
else {
- my $count = ++$seen->{$pre};
- my $as = ($count > 1 ? "${pre}_${count}" : $pre);
+ my $p = $alias_map;
+ $p = $p->{$_} for (@$pref_path, $pre);
+
+ $self->throw_exception (
+ "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: "
+ . join (' -> ', @$pref_path, $pre)
+ ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
+
+ my $as = shift @{$p->{-join_aliases}};
+
my $rel_info = $self->relationship_info( $pre );
$self->throw_exception( $self->name . " has no such relationship '$pre'" )
unless $rel_info;
my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
my $rel_source = $self->related_source($pre);
- if (exists $rel_info->{attrs}{accessor}
- && $rel_info->{attrs}{accessor} eq 'multi') {
+ if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') {
$self->throw_exception(
"Can't prefetch has_many ${pre} (join cond too complex)")
unless ref($rel_info->{cond}) eq 'HASH';
@@ -1434,93 +1446,8 @@
keys %{$rel_info->{cond}};
my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
? @{$rel_info->{attrs}{order_by}}
- : (defined $rel_info->{attrs}{order_by}
- ? ($rel_info->{attrs}{order_by})
- : ()));
- push(@$order, map { "${as}.$_" } (@key, @ord));
- }
-
- return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
- $rel_source->columns;
- }
-}
-
-# Accepts one or more relationships for the current source and returns an
-# array of column names for each of those relationships. Column names are
-# prefixed relative to the current source, in accordance with where they appear
-# in the supplied relationships.
-
-sub _resolve_prefetch {
- my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
- $pref_path ||= [];
-
- if (not defined $pre) {
- return ();
- }
- elsif( ref $pre eq 'ARRAY' ) {
- return
- map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
- @$pre;
- }
- elsif( ref $pre eq 'HASH' ) {
- my @ret =
- map {
- $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
- $self->related_source($_)->_resolve_prefetch(
- $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
- } keys %$pre;
- return @ret;
- }
- elsif( ref $pre ) {
- $self->throw_exception(
- "don't know how to resolve prefetch reftype ".ref($pre));
- }
- else {
- my $p = $alias_map;
- $p = $p->{$_} for (@$pref_path, $pre);
-
- $self->throw_exception (
- "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: "
- . join (' -> ', @$pref_path, $pre)
- ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
-
- my $as = shift @{$p->{-join_aliases}};
-
- my $rel_info = $self->relationship_info( $pre );
- $self->throw_exception( $self->name . " has no such relationship '$pre'" )
- unless $rel_info;
- my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
- my $rel_source = $self->related_source($pre);
-
- if (exists $rel_info->{attrs}{accessor}
- && $rel_info->{attrs}{accessor} eq 'multi') {
- $self->throw_exception(
- "Can't prefetch has_many ${pre} (join cond too complex)")
- unless ref($rel_info->{cond}) eq 'HASH';
- my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
- if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
- keys %{$collapse}) {
- my ($last) = ($fail =~ /([^\.]+)$/);
- carp (
- "Prefetching multiple has_many rels ${last} and ${pre} "
- .(length($as_prefix)
- ? "at the same level (${as_prefix}) "
- : "at top level "
- )
- . 'will explode the number of row objects retrievable via ->next or ->all. '
- . 'Use at your own risk.'
- );
- }
- #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
- # values %{$rel_info->{cond}};
- $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
- # action at a distance. prepending the '.' allows simpler code
- # in ResultSet->_collapse_result
- my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
- keys %{$rel_info->{cond}};
- my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
- ? @{$rel_info->{attrs}{order_by}}
- : (defined $rel_info->{attrs}{order_by}
+
+ : (defined $rel_info->{attrs}{order_by}
? ($rel_info->{attrs}{order_by})
: ()));
push(@$order, map { "${as}.$_" } (@key, @ord));
Modified: branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Row.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Row.pm?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Row.pm (original)
+++ branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/Row.pm Mon Feb 8 22:40:38 2010
@@ -171,9 +171,8 @@
$new->throw_exception("Can't do multi-create without result source")
unless $source;
my $info = $source->relationship_info($key);
- if ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single')
- {
+ my $acc_type = $info->{attrs}{accessor} || '';
+ if ($acc_type eq 'single') {
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
@@ -188,9 +187,8 @@
$related->{$key} = $rel_obj;
next;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'multi'
- && ref $attrs->{$key} eq 'ARRAY') {
+ }
+ elsif ($acc_type eq 'multi' && ref $attrs->{$key} eq 'ARRAY' ) {
my $others = delete $attrs->{$key};
my $total = @$others;
my @objects;
@@ -210,9 +208,8 @@
}
$related->{$key} = \@objects;
next;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'filter')
- {
+ }
+ elsif ($acc_type eq 'filter') {
## 'filter' should disappear and get merged in with 'single' above!
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
@@ -763,9 +760,7 @@
for my $col (keys %loaded_colinfo) {
if (exists $loaded_colinfo{$col}{accessor}) {
my $acc = $loaded_colinfo{$col}{accessor};
- if (defined $acc) {
- $inflated{$col} = $self->$acc;
- }
+ $inflated{$col} = $self->$acc if defined $acc;
}
else {
$inflated{$col} = $self->$col;
@@ -917,21 +912,18 @@
foreach my $key (keys %$upd) {
if (ref $upd->{$key}) {
my $info = $self->relationship_info($key);
- if ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single')
- {
+ my $acc_type = $info->{attrs}{accessor} || '';
+ if ($acc_type eq 'single') {
my $rel = delete $upd->{$key};
$self->set_from_related($key => $rel);
$self->{_relationship_data}{$key} = $rel;
- } elsif ($info && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'multi') {
- $self->throw_exception(
- "Recursive update is not supported over relationships of type multi ($key)"
- );
}
- elsif ($self->has_column($key)
- && exists $self->column_info($key)->{_inflate_info})
- {
+ elsif ($acc_type eq 'multi') {
+ $self->throw_exception(
+ "Recursive update is not supported over relationships of type '$acc_type' ($key)"
+ );
+ }
+ elsif ($self->has_column($key) && exists $self->column_info($key)->{_inflate_info}) {
$self->set_inflated_column($key, delete $upd->{$key});
}
}
@@ -1070,9 +1062,10 @@
my ($source_handle) = $source;
if ($source->isa('DBIx::Class::ResultSourceHandle')) {
- $source = $source_handle->resolve
- } else {
- $source_handle = $source->handle
+ $source = $source_handle->resolve
+ }
+ else {
+ $source_handle = $source->handle
}
my $new = {
@@ -1081,17 +1074,29 @@
};
bless $new, (ref $class || $class);
- my $schema;
foreach my $pre (keys %{$prefetch||{}}) {
- my $pre_val = $prefetch->{$pre};
- my $pre_source = $source->related_source($pre);
- $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
- unless $pre_source;
- if (ref($pre_val->[0]) eq 'ARRAY') { # multi
- my @pre_objects;
-
- for my $me_pref (@$pre_val) {
-
+
+ my $pre_source = $source->related_source($pre)
+ or $class->throw_exception("Can't prefetch non-existent relationship ${pre}");
+
+ my $accessor = $source->relationship_info($pre)->{attrs}{accessor}
+ or $class->throw_exception("No accessor for prefetched $pre");
+
+ my @pre_vals;
+ if (ref $prefetch->{$pre}[0] eq 'ARRAY') {
+ @pre_vals = @{$prefetch->{$pre}};
+ }
+ elsif ($accessor eq 'multi') {
+ $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor 'multi'");
+ }
+ else {
+ @pre_vals = $prefetch->{$pre};
+ }
+
+ my @pre_objects;
+ for my $me_pref (@pre_vals) {
+
+ # FIXME - this should not be necessary
# the collapser currently *could* return bogus elements with all
# columns set to undef
my $has_def;
@@ -1106,29 +1111,16 @@
push @pre_objects, $pre_source->result_class->inflate_result(
$pre_source, @$me_pref
);
- }
-
- $new->related_resultset($pre)->set_cache(\@pre_objects);
- } elsif (defined $pre_val->[0]) {
- my $fetched;
- unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
- and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
- {
- $fetched = $pre_source->result_class->inflate_result(
- $pre_source, @{$pre_val});
- }
- my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
- $class->throw_exception("No accessor for prefetched $pre")
- unless defined $accessor;
- if ($accessor eq 'single') {
- $new->{_relationship_data}{$pre} = $fetched;
- } elsif ($accessor eq 'filter') {
- $new->{_inflated_column}{$pre} = $fetched;
- } else {
- $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor '$accessor'");
- }
- $new->related_resultset($pre)->set_cache([ $fetched ]);
- }
+ }
+
+ if ($accessor eq 'single') {
+ $new->{_relationship_data}{$pre} = $pre_objects[0];
+ }
+ elsif ($accessor eq 'filter') {
+ $new->{_inflated_column}{$pre} = $pre_objects[0];
+ }
+
+ $new->related_resultset($pre)->set_cache(\@pre_objects);
}
$new->in_storage (1);
Modified: branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/UTF8Columns.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/UTF8Columns.pm?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/UTF8Columns.pm (original)
+++ branches/upstream/libdbix-class-perl/current/lib/DBIx/Class/UTF8Columns.pm Mon Feb 8 22:40:38 2010
@@ -2,7 +2,6 @@
use strict;
use warnings;
use base qw/DBIx::Class/;
-use utf8;
__PACKAGE__->mk_classdata( '_utf8_columns' );
@@ -114,7 +113,7 @@
# override this if you want to force everything to be encoded/decoded
sub _is_utf8_column {
- return (shift->utf8_columns || {})->{shift};
+ return (shift->utf8_columns || {})->{shift @_};
}
=head1 AUTHORS
Modified: branches/upstream/libdbix-class-perl/current/t/60core.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/t/60core.t?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/t/60core.t (original)
+++ branches/upstream/libdbix-class-perl/current/t/60core.t Mon Feb 8 22:40:38 2010
@@ -421,9 +421,9 @@
# make sure we got rid of the compat shims
SKIP: {
- skip "Remove in 0.09", 5 if $DBIx::Class::VERSION < 0.09;
-
- for (qw/compare_relationship_keys pk_depends_on resolve_condition resolve_join resolve_prefetch/) {
+ skip "Remove in 0.082", 3 if $DBIx::Class::VERSION < 0.082;
+
+ for (qw/compare_relationship_keys pk_depends_on resolve_condition/) {
ok (! DBIx::Class::ResultSource->can ($_), "$_ no longer provided by DBIx::Class::ResultSource");
}
}
Modified: branches/upstream/libdbix-class-perl/current/t/85utf8.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/t/85utf8.t?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/t/85utf8.t (original)
+++ branches/upstream/libdbix-class-perl/current/t/85utf8.t Mon Feb 8 22:40:38 2010
@@ -5,7 +5,6 @@
use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-use utf8;
warning_like (
sub {
@@ -28,15 +27,16 @@
DBICTest::Schema::CD->utf8_columns('title');
Class::C3->reinitialize();
-my $cd = $schema->resultset('CD')->create( { artist => 1, title => 'øni', year => '2048' } );
-my $utf8_char = 'uniuni';
-
+my $cd = $schema->resultset('CD')->create( { artist => 1, title => "weird\x{466}stuff", year => '2048' } );
ok( utf8::is_utf8( $cd->title ), 'got title with utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store title without utf8' );
+
ok(! utf8::is_utf8( $cd->year ), 'got year without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{year} ), 'store year without utf8' );
-utf8::decode($utf8_char);
-$cd->title($utf8_char);
+$cd->title('nonunicode');
+ok(! utf8::is_utf8( $cd->title ), 'got title without utf8 flag' );
ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less chars' );
Modified: branches/upstream/libdbix-class-perl/current/t/multi_create/standard.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/t/multi_create/standard.t?rev=52341&op=diff
==============================================================================
--- branches/upstream/libdbix-class-perl/current/t/multi_create/standard.t (original)
+++ branches/upstream/libdbix-class-perl/current/t/multi_create/standard.t Mon Feb 8 22:40:38 2010
@@ -72,7 +72,7 @@
],
});
},
- qr/Recursive update is not supported over relationships of type multi/,
+ qr/Recursive update is not supported over relationships of type 'multi'/,
'create via update of multi relationships throws an exception'
);
Added: branches/upstream/libdbix-class-perl/current/t/prefetch/one_to_many_to_one.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/t/prefetch/one_to_many_to_one.t?rev=52341&op=file
==============================================================================
--- branches/upstream/libdbix-class-perl/current/t/prefetch/one_to_many_to_one.t (added)
+++ branches/upstream/libdbix-class-perl/current/t/prefetch/one_to_many_to_one.t Mon Feb 8 22:40:38 2010
@@ -1,0 +1,35 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $artist = $schema->resultset ('Artist')->find ({artistid => 1});
+is ($artist->cds->count, 3, 'Correct number of CDs');
+is ($artist->cds->search_related ('genre')->count, 1, 'Only one of the cds has a genre');
+
+my $queries = 0;
+my $orig_cb = $schema->storage->debugcb;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+
+my $pref = $schema->resultset ('Artist')
+ ->search ({ 'me.artistid' => $artist->id }, { prefetch => { cds => 'genre' } })
+ ->next;
+
+is ($pref->cds->count, 3, 'Correct number of CDs prefetched');
+is ($pref->cds->search_related ('genre')->count, 1, 'Only one of the prefetched cds has a prefetched genre');
+
+
+is ($queries, 1, 'All happened within one query only');
+$schema->storage->debugcb($orig_cb);
+$schema->storage->debug(0);
+
+
+done_testing;
Added: branches/upstream/libdbix-class-perl/current/t/resultset/as_subselect_rs.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdbix-class-perl/current/t/resultset/as_subselect_rs.t?rev=52341&op=file
==============================================================================
--- branches/upstream/libdbix-class-perl/current/t/resultset/as_subselect_rs.t (added)
+++ branches/upstream/libdbix-class-perl/current/t/resultset/as_subselect_rs.t Mon Feb 8 22:40:38 2010
@@ -1,0 +1,25 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+
+my $new_rs = $schema->resultset('Artist')->search({
+ 'artwork_to_artist.artist_id' => 1
+}, {
+ join => 'artwork_to_artist'
+});
+lives_ok { $new_rs->count } 'regular search works';
+lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->count }
+ '... and chaining off that using join works';
+lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->as_subselect_rs->count }
+ '... and chaining off the virtual view works';
+dies_ok { $new_rs->as_subselect_rs->search({'artwork_to_artist.artwork_cd_id'=> 1})->count }
+ q{... but chaining off of a virtual view using join doesn't work};
+done_testing;
More information about the Pkg-perl-cvs-commits
mailing list