Merge HasA, HasMany and MightHave into one file, Relationships, for easier
Michael G Schwern [Tue, 12 Feb 2008 08:32:29 +0000 (00:32 -0800)]
development.

Implement meta_info() and emulate the basic CDBI::Relationship object.

lib/DBIx/Class/CDBICompat.pm
lib/DBIx/Class/CDBICompat/HasA.pm [deleted file]
lib/DBIx/Class/CDBICompat/HasMany.pm [deleted file]
lib/DBIx/Class/CDBICompat/MightHave.pm [deleted file]
lib/DBIx/Class/CDBICompat/Relationship.pm [new file with mode: 0644]
lib/DBIx/Class/CDBICompat/Relationships.pm [new file with mode: 0644]
t/cdbi-t/24-meta_info.t [new file with mode: 0644]

index 74504b6..1115eab 100644 (file)
@@ -22,9 +22,7 @@ __PACKAGE__->load_own_components(qw/
   Constructor
   AccessorMapping
   ColumnCase
-  HasA
-  HasMany
-  MightHave
+  Relationships
   Copy
   LazyLoading
   AutoUpdate
diff --git a/lib/DBIx/Class/CDBICompat/HasA.pm b/lib/DBIx/Class/CDBICompat/HasA.pm
deleted file mode 100644 (file)
index 647674f..0000000
+++ /dev/null
@@ -1,46 +0,0 @@
-package # hide from PAUSE
-    DBIx::Class::CDBICompat::HasA;
-
-use strict;
-use warnings;
-
-sub has_a {
-  my ($self, $col, $f_class, %args) = @_;
-  $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col);
-  $self->ensure_class_loaded($f_class);
-  if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
-    if (!ref $args{'inflate'}) {
-      my $meth = $args{'inflate'};
-      $args{'inflate'} = sub { $f_class->$meth(shift); };
-    }
-    if (!ref $args{'deflate'}) {
-      my $meth = $args{'deflate'};
-      $args{'deflate'} = sub { shift->$meth; };
-    }
-    $self->inflate_column($col, \%args);
-    return 1;
-  }
-
-  $self->belongs_to($col, $f_class);
-  return 1;
-}
-
-sub search {
-  my $self = shift;
-  my $attrs = {};
-  if (@_ > 1 && ref $_[$#_] eq 'HASH') {
-    $attrs = { %{ pop(@_) } };
-  }
-  my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
-                               : {@_})
-                  : undef());
-  if (ref $where eq 'HASH') {
-    foreach my $key (keys %$where) { # has_a deflation hack
-      $where->{$key} = ''.$where->{$key}
-        if eval { $where->{$key}->isa('DBIx::Class') };
-    }
-  }
-  $self->next::method($where, $attrs);
-}
-
-1;
diff --git a/lib/DBIx/Class/CDBICompat/HasMany.pm b/lib/DBIx/Class/CDBICompat/HasMany.pm
deleted file mode 100644 (file)
index 6438e43..0000000
+++ /dev/null
@@ -1,46 +0,0 @@
-package # hide from PAUSE
-    DBIx::Class::CDBICompat::HasMany;
-
-use strict;
-use warnings;
-
-sub has_many {
-  my ($class, $rel, $f_class, $f_key, $args) = @_;
-
-  my @f_method;
-
-  if (ref $f_class eq 'ARRAY') {
-    ($f_class, @f_method) = @$f_class;
-  }
-
-  if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
-
-  $args ||= {};
-  if (delete $args->{no_cascade_delete}) {
-    $args->{cascade_delete} = 0;
-  }
-
-  if( !$f_key and !@f_method ) {
-      my $f_source = $f_class->result_source_instance;
-      ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
-                      $f_source->relationships;
-  }
-
-  $class->next::method($rel, $f_class, $f_key, $args);
-
-  if (@f_method) {
-    no strict 'refs';
-    no warnings 'redefine';
-    my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
-    *{"${class}::${rel}"} =
-      sub {
-        my $rs = shift->search_related($rel => @_);
-        $rs->{attrs}{record_filter} = $post_proc;
-        return (wantarray ? $rs->all : $rs);
-      };
-    return 1;
-  }
-
-}
-
-1;
diff --git a/lib/DBIx/Class/CDBICompat/MightHave.pm b/lib/DBIx/Class/CDBICompat/MightHave.pm
deleted file mode 100644 (file)
index 519c6fe..0000000
+++ /dev/null
@@ -1,17 +0,0 @@
-package # hide from PAUSE
-    DBIx::Class::CDBICompat::MightHave;
-
-use strict;
-use warnings;
-
-sub might_have {
-  my ($class, $rel, $f_class, @columns) = @_;
-  if (ref $columns[0] || !defined $columns[0]) {
-    return $class->next::method($rel, $f_class, @columns);
-  } else {
-    return $class->next::method($rel, $f_class, undef,
-                                     { proxy => \@columns });
-  }
-}
-
-1;
diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm
new file mode 100644 (file)
index 0000000..ba84843
--- /dev/null
@@ -0,0 +1,47 @@
+package
+    DBIx::Class::CDBICompat::Relationship;
+
+use strict;
+use warnings;
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Relationship
+
+=head1 DESCRIPTION
+
+Emulate the Class::DBI::Relationship object returned from C<meta_info()>.
+
+=cut
+
+my %method2key = (
+    name            => 'type',
+    class           => 'self_class',
+    accessor        => 'accessor',
+    foreign_class   => 'class',
+);
+
+sub new {
+    my($class, $args) = @_;
+    
+    return bless $args, $class;
+}
+
+for my $method (keys %method2key) {
+    my $key = $method2key{$method};
+    my $code = sub {
+        $_[0]->{$key};
+    };
+    
+    no strict 'refs';
+    *{$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
new file mode 100644 (file)
index 0000000..559a624
--- /dev/null
@@ -0,0 +1,167 @@
+package # hide from PAUSE
+    DBIx::Class::CDBICompat::Relationships;
+
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+use Clone;
+use DBIx::Class::CDBICompat::Relationship;
+
+__PACKAGE__->mk_classdata('__meta_info' => {});
+
+
+=head1 NAME
+
+DBIx::Class::CDBICompat::Relationships
+
+=head1 DESCRIPTION
+
+Emulate C<has_a>, C<has_many>, C<might_have> and C<meta_info>.
+
+=cut
+
+sub has_a {
+  my ($self, $col, $f_class, %args) = @_;
+  $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col);
+  $self->ensure_class_loaded($f_class);
+  
+  my $rel;
+
+  if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
+    if (!ref $args{'inflate'}) {
+      my $meth = $args{'inflate'};
+      $args{'inflate'} = sub { $f_class->$meth(shift); };
+    }
+    if (!ref $args{'deflate'}) {
+      my $meth = $args{'deflate'};
+      $args{'deflate'} = sub { shift->$meth; };
+    }
+    $self->inflate_column($col, \%args);
+    
+    $rel = {
+        class => $f_class
+    };
+  }
+  else {
+    $self->belongs_to($col, $f_class);
+    $rel = $self->result_source_instance->relationship_info($col);
+  }
+  
+  $self->_extend_meta(
+    has_a => $col,
+    $rel
+  );
+  
+  return 1;
+}
+
+
+sub has_many {
+  my ($class, $rel, $f_class, $f_key, $args) = @_;
+
+  my @f_method;
+
+  if (ref $f_class eq 'ARRAY') {
+    ($f_class, @f_method) = @$f_class;
+  }
+
+  if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
+
+  $args ||= {};
+  if (delete $args->{no_cascade_delete}) {
+    $args->{cascade_delete} = 0;
+  }
+
+  if( !$f_key and !@f_method ) {
+      my $f_source = $f_class->result_source_instance;
+      ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
+                      $f_source->relationships;
+  }
+
+  $class->next::method($rel, $f_class, $f_key, $args);
+
+  $class->_extend_meta(
+    has_many => $rel,
+    $class->result_source_instance->relationship_info($rel)
+  );
+
+  if (@f_method) {
+    no strict 'refs';
+    no warnings 'redefine';
+    my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
+    *{"${class}::${rel}"} =
+      sub {
+        my $rs = shift->search_related($rel => @_);
+        $rs->{attrs}{record_filter} = $post_proc;
+        return (wantarray ? $rs->all : $rs);
+      };
+    return 1;
+  }
+
+}
+
+
+sub might_have {
+  my ($class, $rel, $f_class, @columns) = @_;
+  
+  my $ret;
+  if (ref $columns[0] || !defined $columns[0]) {
+    $ret = $class->next::method($rel, $f_class, @columns);
+  } else {
+    $ret = $class->next::method($rel, $f_class, undef,
+                                { proxy => \@columns });
+  }
+  
+  $class->_extend_meta(
+    might_have => $rel,
+    $class->result_source_instance->relationship_info($rel)
+  );
+  
+  return $ret;
+}
+
+
+sub _extend_meta {
+    my ($class, $type, $rel, $val) = @_;
+    my %hash = %{ Clone::clone($class->__meta_info || {}) };
+
+    $val->{self_class} = $class;
+    $val->{type}       = $type;
+    $val->{accessor}   = $rel;
+
+    $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val);
+    $class->__meta_info(\%hash);
+}
+
+sub meta_info {
+    my ($class, $type, $rel) = @_;
+    my $meta = $class->__meta_info;
+    return $meta unless $type;
+
+    my $type_meta = $meta->{$type};
+    return $type_meta unless $rel;
+    return $type_meta->{$rel};
+}
+
+
+sub search {
+  my $self = shift;
+  my $attrs = {};
+  if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+    $attrs = { %{ pop(@_) } };
+  }
+  my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
+                               : {@_})
+                  : undef());
+  if (ref $where eq 'HASH') {
+    foreach my $key (keys %$where) { # has_a deflation hack
+      $where->{$key} = ''.$where->{$key}
+        if eval { $where->{$key}->isa('DBIx::Class') };
+    }
+  }
+  $self->next::method($where, $attrs);
+}
+
+1;
diff --git a/t/cdbi-t/24-meta_info.t b/t/cdbi-t/24-meta_info.t
new file mode 100644 (file)
index 0000000..b7301f9
--- /dev/null
@@ -0,0 +1,66 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 12;
+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") 
+});
+
+
+package Temp::Person;
+use base 'Temp::DBI';
+Temp::Person->table('people');
+Temp::Person->columns(Info => qw(name pet));
+Temp::Person->has_a( pet => 'Temp::Pet' );
+
+package Temp::Pet;
+use base 'Temp::DBI';
+Temp::Pet->table('pets');
+Temp::Pet->columns(Info => qw(name));
+Temp::Pet->has_many(owners => 'Temp::Person');
+
+package main;
+
+{
+    my $pn_meta = Temp::Person->meta_info('has_a');
+    is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet";
+}
+
+{
+    my $pt_meta = Temp::Pet->meta_info;
+    is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date";
+    is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners";
+}
+
+{
+    my $pet = Temp::Person->meta_info( has_a => 'pet' );
+    is $pet->class,         'Temp::Person';
+    is $pet->foreign_class, 'Temp::Pet';
+    is $pet->accessor,      'pet';
+    is $pet->name,          'has_a';
+}
+
+{
+    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/;
+}
+
+{
+    my $date = Temp::Pet->meta_info( has_a => 'date' );
+    is $date->class,            'Temp::DBI';
+    is $date->foreign_class,    'Time::Piece';
+    is $date->accessor,         'date';
+}