use warnings;
sub has_a {
- my ($self, $col, $f_class) = @_;
+ my ($self, $col, $f_class, %args) = @_;
$self->throw( "No such column ${col}" ) unless $self->_columns->{$col};
eval "require $f_class";
+ if ($args{'inflate'} || $args{'deflate'}) {
+ 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;
+ }
my ($pri, $too_many) = keys %{ $f_class->_primaries };
$self->throw( "has_a only works with a single primary key; ${f_class} has more" )
if $too_many;
$self->add_relationship($col, $f_class,
{ "foreign.${pri}" => "self.${col}" },
- { _type => 'has_a' } );
- $self->inflate_column($col,
- { inflate => sub {
- my ($val, $self) = @_;
- return ($self->search_related($col, {}, {}))[0]
- || $f_class->new({ $pri => $val }); },
- deflate => sub {
- my ($val, $self) = @_;
- $self->throw("$val isn't a $f_class") unless $val->isa($f_class);
- return ($val->_ident_values)[0] } } );
+ { _type => 'has_a', accessor => 'filter' } );
return 1;
}
unless $f_key;
$class->throw( "No such column ${f_key} on foreign class ${f_class}" )
unless $f_class->_columns->{$f_key};
+ $args ||= {};
+ my $cascade = not (ref $args eq 'HAS' && delete $args->{no_cascade_delete});
$class->add_relationship($rel, $f_class,
{ "foreign.${f_key}" => "self.${self_key}" },
- { _type => 'has_many', %{$args || {}} } );
- {
- no strict 'refs';
- *{"${class}::${rel}"} = sub { shift->search_related($rel, @_); };
- *{"${class}::add_to_${rel}"} = sub { shift->create_related($rel, @_); };
- }
+ { accessor => 'multi',
+ ($cascade ? ('cascade_delete' => 1) : ()),
+ %$args } );
return 1;
}
-sub delete {
- my ($self, @rest) = @_;
- return $self->NEXT::ACTUAL::delete(@rest) unless ref $self;
- # I'm just ignoring this for class deletes because hell, the db should
- # be handling this anyway. Assuming we have joins we probably actually
- # *could* do them, but I'd rather not.
-
- my $ret = $self->NEXT::ACTUAL::delete(@rest);
-
- my %rels = %{ $self->_relationships };
- my @hm = grep { $rels{$_}{attrs}{_type}
- && $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels;
- foreach my $has_many (@hm) {
- unless ($rels{$has_many}->{attrs}{no_cascade_delete}) {
- $_->delete for $self->search_related($has_many)
- }
- }
- return $ret;
-}
1;
use strict;
use warnings;
-use base qw/DBIx::Class::Relationship
+use base qw/DBIx::Class::Relationship::Accessor
+ DBIx::Class::Relationship::CascadeActions
+ DBIx::Class::Relationship
DBIx::Class::InflateColumn
DBIx::Class::SQL::OrderBy
DBIx::Class::SQL::Abstract
$self->{live_sth} = 1;
}
my @row = $self->{sth}->fetchrow_array;
- return unless @row;
+ unless (@row) {
+ $self->{sth}->finish if $self->{sth}->{Active};
+ return;
+ }
$self->{pos}++;
return $self->{class}->_row_to_object($self->{cols}, \@row);
}
return 1;
}
-sub _inflate_column_value {
+sub _inflated_column {
my ($self, $col, $value) = @_;
return $value unless defined $value; # NULL is NULL is NULL
+ return $value unless exists $self->_columns->{$col}{_inflate_info};
return $value unless exists $self->_columns->{$col}{_inflate_info}{inflate};
my $inflate = $self->_columns->{$col}{_inflate_info}{inflate};
return $inflate->($value, $self);
}
-sub _deflate_column_value {
+sub _deflated_column {
my ($self, $col, $value) = @_;
return $value unless ref $value; # If it's not an object, don't touch it
+ return $value unless exists $self->_columns->{$col}{_inflate_info};
return $value unless exists $self->_columns->{$col}{_inflate_info}{deflate};
my $deflate = $self->_columns->{$col}{_inflate_info}{deflate};
return $deflate->($value, $self);
my ($self, $col) = @_;
$self->throw("$col is not an inflated column") unless
exists $self->_columns->{$col}{_inflate_info};
- #warn $rel;
- #warn join(', ', %{$self->{_column_data}});
+
return $self->{_inflated_column}{$col}
if exists $self->{_inflated_column}{$col};
- #my ($pri) = (keys %{$self->_relationships->{$rel}{class}->_primaries})[0];
return $self->{_inflated_column}{$col} =
- $self->_inflate_column_value($col, $self->get_column($col));
+ $self->_inflated_column($col, $self->get_column($col));
}
sub set_inflated_column {
delete $self->{_inflated_column}{$col};
return $self->store_column($col, $obj);
}
- my $deflated = $self->_deflate_column_value($col, $obj);
+
+ my $deflated = $self->_deflated_column($col, $obj);
# Do this now so we don't store if it's invalid
+
$self->{_inflated_column}{$col} = $obj;
#warn "Storing $obj: ".($obj->_ident_values)[0];
$self->store_column($col, $deflated);
my %deflated;
foreach my $key (keys %$attrs) {
if (exists $class->_columns->{$key}{_inflate_info}) {
- $deflated{$key} = $class->_deflate_column_value($key,
+ $deflated{$key} = $class->_deflated_column($key,
delete $attrs->{$key});
}
}
sub _cond_value {
my ($self, $attrs, $key, $value) = @_;
if (exists $self->_columns->{$key}) {
- $value = $self->_deflate_column_value($key, $value);
+ $value = $self->_deflated_column($key, $value);
}
return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value);
}
$self->in_database(0);
return $self;
}
- $self->store_column($_ => $reload->get_column($_))
- foreach keys %{$self->_columns};
+ delete @{$self}{keys %$self};
+ @{$self}{keys %$reload} = values %$reload;
+ #$self->store_column($_ => $reload->get_column($_))
+ # foreach keys %{$self->_columns};
return $self;
}
$attrs = { %{ pop(@_) } };
}
my $rel_obj = $self->_relationships->{$rel};
- $self->throw( "No such relationship ${rel}" ) unless $rel;
+ $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
$attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
my $s_cond;
if (@_) {
}
sub create_related {
+ my $class = shift;
+ return $class->new_related(@_)->insert;
+}
+
+sub new_related {
my ($self, $rel, $values, $attrs) = @_;
$self->throw( "Can't call create_related as class method" )
unless ref $self;
$self->throw( "create_related needs a hash" )
unless (ref $values eq 'HASH');
my $rel_obj = $self->_relationships->{$rel};
- $self->throw( "No such relationship ${rel}" ) unless $rel;
+ $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
$self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
unless ref $rel_obj->{cond} eq 'HASH';
$attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
$self->_cond_value($attrs, $k => $v);
$fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
}
- return $rel_obj->{class}->create(\%fields);
+ return $rel_obj->{class}->new(\%fields);
+}
+
+sub find_or_create_related {
+ my $self = shift;
+ return ($self->search_related(@_))[0] || $self->create_related(@_);
+}
+
+sub set_from_related {
+ my ($self, $rel, $f_obj) = @_;
+ my $rel_obj = $self->_relationships->{$rel};
+ $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
+ my $cond = $rel_obj->{cond};
+ $self->throw( "set_from_related can only handle a hash condition; the "
+ ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
+ unless ref $cond eq 'HASH';
+ $self->throw( "Object $f_obj isn't a ".$rel_obj->{class} )
+ unless $f_obj->isa($rel_obj->{class});
+ foreach my $key (keys %$cond) {
+ next if ref $cond->{$key}; # Skip literals and complex conditions
+ $self->throw("set_from_related can't handle $key as key")
+ unless $key =~ m/^foreign\.([^\.]+)$/;
+ my $val = $f_obj->get_column($1);
+ $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
+ unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
+ $self->set_column($1 => $val);
+ }
+ return 1;
+}
+
+sub update_from_related {
+ my $self = shift;
+ $self->set_from_related(@_);
+ $self->update;
}
1;
--- /dev/null
+package DBIx::Class::Relationship::Accessor;
+
+use strict;
+use warnings;
+
+sub add_relationship {
+ my ($class, $rel, @rest) = @_;
+ my $ret = $class->NEXT::ACTUAL::add_relationship($rel => @rest);
+ my $rel_obj = $class->_relationships->{$rel};
+ if (my $acc_type = $rel_obj->{attrs}{accessor}) {
+ $class->_add_relationship_accessor($rel => $acc_type);
+ }
+ return $ret;
+}
+
+sub _add_relationship_accessor {
+ my ($class, $rel, $acc_type) = @_;
+ my %meth;
+ if ($acc_type eq 'single') {
+ $meth{$rel} = sub {
+ my $self = shift;
+ if (@_) {
+ $self->set_from_related($rel, @_);
+ return $self->{_relationship_data}{$rel} = $_[0];
+ } elsif (exists $self->{_relationship_data}{$rel}) {
+ return $self->{_relationship_data}{$rel};
+ } else {
+ return $self->{_relationship_data}{$rel}
+ = $self->find_or_create_related($rel, {}, {});
+ }
+ };
+ } elsif ($acc_type eq 'filter') {
+ $class->throw("No such column $rel to filter")
+ unless exists $class->_columns->{$rel};
+ my $f_class = $class->_relationships->{$rel}{class};
+ $class->inflate_column($rel,
+ { inflate => sub {
+ my ($val, $self) = @_;
+ return $self->find_or_create_related($rel, {}, {});
+ },
+ deflate => sub {
+ my ($val, $self) = @_;
+ $self->throw("$val isn't a $f_class") unless $val->isa($f_class);
+ return ($val->_ident_values)[0];
+ # WARNING: probably breaks for multi-pri sometimes. FIXME
+ }
+ }
+ );
+ } elsif ($acc_type eq 'multi') {
+ $meth{$rel} = sub { shift->search_related($rel, @_) };
+ $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); };
+ } else {
+ $class->throw("No such relationship accessor type $acc_type");
+ }
+ {
+ no strict 'refs';
+ no warnings 'redefine';
+ foreach my $meth (keys %meth) {
+ *{"${class}::${meth}"} = $meth{$meth};
+ }
+ }
+}
+
+1;
--- /dev/null
+package DBIx::Class::Relationship::CascadeActions;
+
+sub delete {
+ my ($self, @rest) = @_;
+ return $self->NEXT::ACTUAL::delete(@rest) unless ref $self;
+ # I'm just ignoring this for class deletes because hell, the db should
+ # be handling this anyway. Assuming we have joins we probably actually
+ # *could* do them, but I'd rather not.
+
+ my $ret = $self->NEXT::ACTUAL::delete(@rest);
+
+ my %rels = %{ $self->_relationships };
+ my @cascade = grep { $rels{$_}{attrs}{cascade_delete} } keys %rels;
+ foreach my $rel (@cascade) {
+ $_->delete for $self->search_related($rel);
+ }
+ return $ret;
+}
+
+sub update {
+ my ($self, @rest) = @_;
+ return $self->NEXT::ACTUAL::update(@rest) unless ref $self;
+ # Because update cascades on a class *really* don't make sense!
+
+ my $ret = $self->NEXT::ACTUAL::update(@rest);
+
+ my %rels = %{ $self->_relationships };
+ my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
+ foreach my $rel (@cascade) {
+ $_->update for $self->$rel;
+ }
+ return $ret;
+}
+
+1;
sub sth_to_objects {
my ($class, $sth, $args, $cols, $attrs) = @_;
my @cols = ((ref $cols eq 'ARRAY') ? @$cols : @{$sth->{NAME_lc}} );
+ my @args = map { ref $_ ? ''.$_ : $_ } @$args; # Stringify objects
my $cursor_class = $class->_cursor_class;
eval "use $cursor_class;";
- my $cursor = $cursor_class->new($class, $sth, $args, \@cols, $attrs);
+ my $cursor = $cursor_class->new($class, $sth, \@args, \@cols, $attrs);
return (wantarray ? $cursor->all : $cursor);
}
--- /dev/null
+use Test::More;
+use DateTime;
+
+plan tests => 4;
+
+use lib qw(t/lib);
+
+use_ok('DBICTest');
+
+use DBIx::Class::CDBICompat::HasA;
+
+unshift(@DBICTest::ISA, 'DBIx::Class::CDBICompat::HasA');
+
+DBICTest::CD->has_a( 'year', 'DateTime',
+ inflate => sub { DateTime->new( year => shift ) },
+ deflate => sub { shift->year }
+);
+
+# inflation test
+my $cd = DBICTest::CD->retrieve(3);
+
+is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
+
+is( $cd->year->month, 1, 'inflated month ok' );
+
+# deflate test
+my $now = DateTime->now;
+$cd->year( $now );
+$cd->update;
+
+($cd) = DBICTest::CD->search( year => $now->year );
+is( $cd->year->year, $now->year, 'deflate ok' );
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff