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