From: Michael G Schwern Date: Tue, 12 Feb 2008 08:32:29 +0000 (-0800) Subject: Merge HasA, HasMany and MightHave into one file, Relationships, for easier X-Git-Tag: v0.08240~541^2~37 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a9c8094b88e8802b1508c46512ded65fe8cdc16f;hp=68199af3904ee69a4ba7c53ba60c3716f10e1c5a;p=dbsrgits%2FDBIx-Class.git Merge HasA, HasMany and MightHave into one file, Relationships, for easier development. Implement meta_info() and emulate the basic CDBI::Relationship object. --- diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm index 74504b6..1115eab 100644 --- a/lib/DBIx/Class/CDBICompat.pm +++ b/lib/DBIx/Class/CDBICompat.pm @@ -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 index 647674f..0000000 --- a/lib/DBIx/Class/CDBICompat/HasA.pm +++ /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 index 6438e43..0000000 --- a/lib/DBIx/Class/CDBICompat/HasMany.pm +++ /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 index 519c6fe..0000000 --- a/lib/DBIx/Class/CDBICompat/MightHave.pm +++ /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 index 0000000..ba84843 --- /dev/null +++ b/lib/DBIx/Class/CDBICompat/Relationship.pm @@ -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. + +=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 index 0000000..559a624 --- /dev/null +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -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, C, C and C. + +=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 index 0000000..b7301f9 --- /dev/null +++ b/t/cdbi-t/24-meta_info.t @@ -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'; +}