r52343 - in /trunk/libdbix-class-perl: ./ debian/ 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:58:05 UTC 2010
Author: jawnsy-guest
Date: Mon Feb 8 22:57:59 2010
New Revision: 52343
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=52343
Log:
Some bugs from 0.08117 may have been fixed in this version,
but we are waiting to see if any new ones surface. Please
do not upload until further notice from upstream.
Added:
trunk/libdbix-class-perl/t/prefetch/one_to_many_to_one.t
- copied unchanged from r52342, branches/upstream/libdbix-class-perl/current/t/prefetch/one_to_many_to_one.t
trunk/libdbix-class-perl/t/resultset/as_subselect_rs.t
- copied unchanged from r52342, branches/upstream/libdbix-class-perl/current/t/resultset/as_subselect_rs.t
Modified:
trunk/libdbix-class-perl/Changes
trunk/libdbix-class-perl/MANIFEST
trunk/libdbix-class-perl/META.yml
trunk/libdbix-class-perl/debian/changelog
trunk/libdbix-class-perl/lib/DBIx/Class.pm
trunk/libdbix-class-perl/lib/DBIx/Class/InflateColumn.pm
trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/Base.pm
trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/CascadeActions.pm
trunk/libdbix-class-perl/lib/DBIx/Class/ResultSet.pm
trunk/libdbix-class-perl/lib/DBIx/Class/ResultSource.pm
trunk/libdbix-class-perl/lib/DBIx/Class/Row.pm
trunk/libdbix-class-perl/lib/DBIx/Class/UTF8Columns.pm
trunk/libdbix-class-perl/t/60core.t
trunk/libdbix-class-perl/t/85utf8.t
trunk/libdbix-class-perl/t/multi_create/standard.t
Modified: trunk/libdbix-class-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/Changes?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/Changes (original)
+++ trunk/libdbix-class-perl/Changes Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/MANIFEST?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/MANIFEST (original)
+++ trunk/libdbix-class-perl/MANIFEST Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/META.yml?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/META.yml (original)
+++ trunk/libdbix-class-perl/META.yml Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/debian/changelog?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/debian/changelog (original)
+++ trunk/libdbix-class-perl/debian/changelog Mon Feb 8 22:57:59 2010
@@ -1,13 +1,14 @@
-libdbix-class-perl (0.08117-1) UNRELEASED; urgency=low
-
- Some bugs have been reported in this version. Please do not
- upload until further notice from upstream.
+libdbix-class-perl (0.08118-1) UNRELEASED; urgency=low
+
+ Some bugs from 0.08117 may have been fixed in this version,
+ but we are waiting to see if any new ones surface. Please
+ do not upload until further notice from upstream.
Debian contact: Jonathan Yu <jawnsy at cpan.org>
Upstream contact: Peter Rabbitson <devel at rabbit.us>
* New upstream release
- -- Jonathan Yu <jawnsy at cpan.org> Fri, 05 Feb 2010 13:45:03 -0500
+ -- Jonathan Yu <jawnsy at cpan.org> Mon, 08 Feb 2010 17:58:54 -0500
libdbix-class-perl (0.08115-1) unstable; urgency=low
Modified: trunk/libdbix-class-perl/lib/DBIx/Class.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/lib/DBIx/Class.pm?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/lib/DBIx/Class.pm (original)
+++ trunk/libdbix-class-perl/lib/DBIx/Class.pm Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/lib/DBIx/Class/InflateColumn.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/lib/DBIx/Class/InflateColumn.pm?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/lib/DBIx/Class/InflateColumn.pm (original)
+++ trunk/libdbix-class-perl/lib/DBIx/Class/InflateColumn.pm Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/Base.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/Base.pm?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/Base.pm (original)
+++ trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/Base.pm Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/CascadeActions.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/CascadeActions.pm?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/CascadeActions.pm (original)
+++ trunk/libdbix-class-perl/lib/DBIx/Class/Relationship/CascadeActions.pm Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/lib/DBIx/Class/ResultSet.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/lib/DBIx/Class/ResultSet.pm?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/lib/DBIx/Class/ResultSet.pm (original)
+++ trunk/libdbix-class-perl/lib/DBIx/Class/ResultSet.pm Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/lib/DBIx/Class/ResultSource.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/lib/DBIx/Class/ResultSource.pm?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/lib/DBIx/Class/ResultSource.pm (original)
+++ trunk/libdbix-class-perl/lib/DBIx/Class/ResultSource.pm Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/lib/DBIx/Class/Row.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/lib/DBIx/Class/Row.pm?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/lib/DBIx/Class/Row.pm (original)
+++ trunk/libdbix-class-perl/lib/DBIx/Class/Row.pm Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/lib/DBIx/Class/UTF8Columns.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/lib/DBIx/Class/UTF8Columns.pm?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/lib/DBIx/Class/UTF8Columns.pm (original)
+++ trunk/libdbix-class-perl/lib/DBIx/Class/UTF8Columns.pm Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/t/60core.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/t/60core.t?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/t/60core.t (original)
+++ trunk/libdbix-class-perl/t/60core.t Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/t/85utf8.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/t/85utf8.t?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/t/85utf8.t (original)
+++ trunk/libdbix-class-perl/t/85utf8.t Mon Feb 8 22:57:59 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: trunk/libdbix-class-perl/t/multi_create/standard.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdbix-class-perl/t/multi_create/standard.t?rev=52343&op=diff
==============================================================================
--- trunk/libdbix-class-perl/t/multi_create/standard.t (original)
+++ trunk/libdbix-class-perl/t/multi_create/standard.t Mon Feb 8 22:57:59 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'
);
More information about the Pkg-perl-cvs-commits
mailing list