From: Michael G Schwern <mschwern@cpan.org>
Date: Sun, 24 Feb 2008 17:13:43 +0000 (+0100)
Subject: Make meta_info() 'args' work.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1097f5e4f0e0a5fc2c30851cb9a0141712a85fcf;p=dbsrgits%2FDBIx-Class-Historic.git

Make meta_info() 'args' work.
---

diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm
index a702bd2..55fff10 100644
--- a/lib/DBIx/Class/CDBICompat/Relationship.pm
+++ b/lib/DBIx/Class/CDBICompat/Relationship.pm
@@ -13,8 +13,6 @@ DBIx::Class::CDBICompat::Relationship
 
 Emulate the Class::DBI::Relationship object returned from C<meta_info()>.
 
-The C<args()> method does not return any useful result as it's not clear what it should contain nor if any of the information is applicable to DBIx::Class.
-
 =cut
 
 my %method2key = (
@@ -22,6 +20,7 @@ my %method2key = (
     class           => 'self_class',
     accessor        => 'accessor',
     foreign_class   => 'class',
+    args            => 'args',
 );
 
 sub new {
@@ -40,10 +39,4 @@ for my $method (keys %method2key) {
     *{$method} = $code;
 }
 
-sub args {
-    warn "args() is unlikely to ever work";
-    return undef;
-}
-
-
 1;
diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm
index f410976..77bc788 100644
--- a/lib/DBIx/Class/CDBICompat/Relationships.pm
+++ b/lib/DBIx/Class/CDBICompat/Relationships.pm
@@ -27,7 +27,7 @@ sub has_a {
   $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col);
   $self->ensure_class_loaded($f_class);
   
-  my $rel;
+  my $rel_info;
 
   if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
     if (!ref $args{'inflate'}) {
@@ -40,18 +40,20 @@ sub has_a {
     }
     $self->inflate_column($col, \%args);
     
-    $rel = {
+    $rel_info = {
         class => $f_class
     };
   }
   else {
     $self->belongs_to($col, $f_class);
-    $rel = $self->result_source_instance->relationship_info($col);
+    $rel_info = $self->result_source_instance->relationship_info($col);
   }
   
+  $rel_info->{args} = \%args;
+  
   $self->_extend_meta(
     has_a => $col,
-    $rel
+    $rel_info
   );
   
   return 1;
@@ -90,9 +92,14 @@ sub has_many {
 
   $class->next::method($rel, $f_class, $f_key, $args);
 
+  my $rel_info = $class->result_source_instance->relationship_info($rel);
+  $args->{mapping}      = \@f_method;
+  $args->{foreign_key}  = $f_key;
+  $rel_info->{args} = $args;
+
   $class->_extend_meta(
     has_many => $rel,
-    $class->result_source_instance->relationship_info($rel)
+    $rel_info
   );
 
   if (@f_method) {
@@ -121,10 +128,13 @@ sub might_have {
     $ret = $class->next::method($rel, $f_class, undef,
                                 { proxy => \@columns });
   }
-  
+
+  my $rel_info = $class->result_source_instance->relationship_info($rel);
+  $rel_info->{args}{import} = \@columns;
+
   $class->_extend_meta(
     might_have => $rel,
-    $class->result_source_instance->relationship_info($rel)
+    $rel_info
   );
   
   return $ret;
diff --git a/t/cdbi-t/24-meta_info.t b/t/cdbi-t/24-meta_info.t
index b7301f9..6236a17 100644
--- a/t/cdbi-t/24-meta_info.t
+++ b/t/cdbi-t/24-meta_info.t
@@ -7,9 +7,14 @@ use Test::Warn;
 package Temp::DBI;
 use base qw(DBIx::Class::CDBICompat);
 Temp::DBI->columns(All => qw(id date));
-Temp::DBI->has_a( date => 'Time::Piece', inflate => sub { 
-	Time::Piece->strptime(shift, "%Y-%m-%d") 
-});
+
+my $strptime_inflate = sub { 
+    Time::Piece->strptime(shift, "%Y-%m-%d") 
+};
+Temp::DBI->has_a(
+    date => 'Time::Piece',
+    inflate => $strptime_inflate
+);
 
 
 package Temp::Person;
@@ -47,15 +52,11 @@ package main;
 
 {
     my $owners = Temp::Pet->meta_info( has_many => 'owners' );
-    warning_like {
-        local $TODO = 'args is unlikely to ever work';
 
-        is_deeply $owners->args, {
-            foreign_key     => 'pet',
-            mapping         => [],
-            order_by        => undef
-        };
-    } qr/^\Qargs() is unlikely to ever work/;
+    is_deeply $owners->args, {
+        foreign_key     => 'pet',
+        mapping         => [],
+    };
 }
 
 {
@@ -63,4 +64,5 @@ package main;
     is $date->class,            'Temp::DBI';
     is $date->foreign_class,    'Time::Piece';
     is $date->accessor,         'date';
+    is $date->args->{inflate},  $strptime_inflate;
 }