package DBIx::Class::AccessorGroup;
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+__PACKAGE__->mk_classdata('_accessor_group_deleted' => { });
+
sub mk_group_accessors {
my($self, $group, @fields) = @_;
{
no strict 'refs';
+ no warnings 'redefine';
sub _mk_group_accessors {
my($self, $maker, $group, @fields) = @_;
my $accessor = $self->$maker($group, $field);
my $alias = "_${field}_accessor";
- *{$class."\:\:$field"} = $accessor
- unless defined &{$class."\:\:$field"};
+ #warn "$class $group $field $alias";
- *{$class."\:\:$alias"} = $accessor
- unless defined &{$class."\:\:$alias"};
+ *{$class."\:\:$field"} = $accessor;
+ #unless defined &{$class."\:\:$field"}
+
+ *{$class."\:\:$alias"} = $accessor;
+ #unless defined &{$class."\:\:$alias"}
}
}
}
my $self = shift;
if(@_) {
- return $self->set($field, @_);
+ return $self->$set($field, @_);
}
else {
- return $self->get($field);
+ return $self->$get($field);
}
};
}
"objects of class '$class'");
}
else {
- return $self->get($field);
+ return $self->$get($field);
}
};
}
"objects of class '$class'");
}
else {
- return $self->set($field, @_);
+ return $self->$set($field, @_);
}
};
}
+sub delete_accessor {
+ my ($class, $accessor) = @_;
+ $class = ref $class if ref $class;
+ my $sym = "${class}::${accessor}";
+ undef &$sym;
+ delete $DB::sub{$sym};
+ #$class->_accessor_group_deleted->{"${class}::${accessor}"} = 1;
+}
+
1;
DBIx::Class::CDBICompat::Constructor
DBIx::Class::CDBICompat::AccessorMapping
DBIx::Class::CDBICompat::ColumnCase
+ DBIx::Class::CDBICompat::HasA
DBIx::Class::CDBICompat::LazyLoading
DBIx::Class::CDBICompat::AutoUpdate
DBIx::Class::CDBICompat::ColumnGroups
sub _register_column_group {
my ($class, $group, @cols) = @_;
- return $class->NEXT::_register_column_group($group => map lc, @cols);
+ return $class->NEXT::ACTUAL::_register_column_group($group => map lc, @cols);
}
sub _register_columns {
my ($class, @cols) = @_;
- return $class->NEXT::_register_columns(map lc, @cols);
+ return $class->NEXT::ACTUAL::_register_columns(map lc, @cols);
+}
+
+sub has_a {
+ my ($class, $col, @rest) = @_;
+ $class->NEXT::ACTUAL::has_a(lc($col), @rest);
+ $class->delete_accessor($col);
+ $class->mk_group_accessors('has_a' => $col);
+ return 1;
+}
+
+sub get_has_a {
+ my ($class, $get, @rest) = @_;
+ return $class->NEXT::ACTUAL::get_has_a(lc($get), @rest);
+}
+
+sub store_has_a {
+ my ($class, $set, @rest) = @_;
+ return $class->NEXT::ACTUAL::store_has_a(lc($set), @rest);
+}
+
+sub set_has_a {
+ my ($class, $set, @rest) = @_;
+ return $class->NEXT::ACTUAL::set_has_a(lc($set), @rest);
}
sub get_column {
my ($class, $get, @rest) = @_;
- return $class->NEXT::get_column(lc $get, @rest);
+ return $class->NEXT::ACTUAL::get_column(lc($get), @rest);
}
sub set_column {
my ($class, $set, @rest) = @_;
- return $class->NEXT::set_column(lc $set, @rest);
+ return $class->NEXT::ACTUAL::set_column(lc($set), @rest);
}
sub store_column {
my ($class, $set, @rest) = @_;
- return $class->NEXT::store_column(lc $set, @rest);
+ return $class->NEXT::ACTUAL::store_column(lc($set), @rest);
}
sub find_column {
my ($class, $col) = @_;
- return $class->NEXT::find_column(lc $col);
+ return $class->NEXT::ACTUAL::find_column(lc($col));
}
sub _mk_group_accessors {
my %fields;
$fields{$_} = 1 for @fields,
map lc, grep { !defined &{"${class}::${_}"} } @fields;
- return $class->NEXT::_mk_group_accessors($type, $group, keys %fields);
+ return $class->NEXT::ACTUAL::_mk_group_accessors($type, $group, keys %fields);
+}
+
+sub _cond_key {
+ my ($class, $attrs, $key, @rest) = @_;
+ return $class->NEXT::ACTUAL::_cond_key($attrs, lc($key), @rest);
+}
+
+sub _cond_value {
+ my ($class, $attrs, $key, @rest) = @_;
+ return $class->NEXT::ACTUAL::_cond_value($attrs, lc($key), @rest);
+}
+
+sub new {
+ my ($class, $attrs, @rest) = @_;
+ my %att;
+ $att{lc $_} = $attrs->{$_} for keys %$attrs;
+ return $class->NEXT::ACTUAL::new(\%att, @rest);
}
1;
use NEXT;
use base qw/Class::Data::Inheritable/;
+__PACKAGE__->mk_classdata('_transform_sql_handler_order'
+ => [ qw/TABLE ESSENTIAL JOIN/ ] );
+
__PACKAGE__->mk_classdata('_transform_sql_handlers' =>
{
- 'TABLE' => sub { return $_[0]->_table_name },
- 'ESSENTIAL' => sub { join(' ', $_[0]->columns('Essential')) },
+ 'TABLE' =>
+ sub {
+ my ($self, $class, $data) = @_;
+ return $class->_table_name unless $data;
+ my ($f_class, $alias) = split(/=/, $data);
+ $f_class ||= $class;
+ $self->{_aliases}{$alias} = $f_class;
+ return $f_class->_table_name." ${alias}";
+ },
+ 'ESSENTIAL' =>
+ sub {
+ my ($self, $class, $data) = @_;
+ return join(' ', $class->columns('Essential')) unless $data;
+ return join(' ', $self->{_aliases}{$data}->columns('Essential'));
+ },
+ 'JOIN' =>
+ sub {
+ my ($self, $class, $data) = @_;
+ my ($from, $to) = split(/ /, $data);
+ my ($from_class, $to_class) = @{$self->{_aliases}}{$from, $to};
+ my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
+ values %{ $from_class->_relationships };
+ unless ($rel_obj) {
+ ($from, $to) = ($to, $from);
+ ($from_class, $to_class) = ($to_class, $from_class);
+ ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
+ values %{ $from_class->_relationships };
+ }
+ die "No relationship to JOIN from ${from_class} to ${to_class}"
+ unless $rel_obj;
+ my $attrs = {
+ _aliases => { self => $from, foreign => $to },
+ _action => 'join',
+ };
+ my $join = $from_class->_cond_resolve($rel_obj->{cond}, $attrs);
+ return $join;
+ }
+
} );
sub db_Main {
sub transform_sql {
my ($class, $sql, @args) = @_;
my $table = $class->_table_name;
- foreach my $key (keys %{ $class->_transform_sql_handlers }) {
+ my $attrs = { };
+ foreach my $key (@{$class->_transform_sql_handler_order}) {
my $h = $class->_transform_sql_handlers->{$key};
- $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($class, $1)/eg;
+ $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg;
}
return sprintf($sql, @args);
}
my %want;
$want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups;
if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) {
+ #warn "@want";
my $sth = $self->_get_sth('select', \@want, $self->_table_name,
$self->_ident_cond);
$sth->execute($self->_ident_values);
sub insert {
my $self = shift;
$self->call_trigger('before_create');
- $self->NEXT::insert(@_);
+ $self->NEXT::ACTUAL::insert(@_);
$self->call_trigger('after_create');
return $self;
}
$self->call_trigger('before_update');
my @to_update = keys %{$self->{_dirty_columns} || {}};
return -1 unless @to_update;
- $self->NEXT::update(@_);
+ $self->NEXT::ACTUAL::update(@_);
$self->call_trigger('after_update');
return $self;
}
sub delete {
my $self = shift;
$self->call_trigger('before_delete') if ref $self;
- $self->NEXT::delete(@_);
+ $self->NEXT::ACTUAL::delete(@_);
$self->call_trigger('after_delete') if ref $self;
return $self;
}
use strict;
use warnings;
-use base qw/DBIx::Class::PK
+use base qw/DBIx::Class::Relationship
+ DBIx::Class::SQL::Abstract
+ DBIx::Class::PK
DBIx::Class::Table
DBIx::Class::SQL
DBIx::Class::DB
if (ref $vals[0] eq 'HASH') {
$query = $vals[0];
} elsif (@pk == @vals) {
- return ($class->retrieve_from_sql($class->_ident_cond, @vals))[0];
+ my $ret = ($class->retrieve_from_sql($class->_ident_cond, @vals))[0];
+ #warn "$class: ".join(', ', %{$ret->{_column_data}});
+ return $ret;
} else {
$query = {@vals};
}
die "Can't retrieve unless all primary keys are specified"
unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc
# column names etc. Not sure what to do yet
- return ($class->search($query))[0];
+ my $ret = ($class->search($query))[0];
+ #warn "$class: ".join(', ', %{$ret->{_column_data}});
+ return $ret;
}
sub discard_changes {
$sth->finish;
delete $self->{_in_database};
} else {
+ my $attrs = { };
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = { %{ pop(@_) } };
+ }
my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
- my ($cond, $param) = $self->_where_from_hash($query);
+ my ($cond, @param) = $self->_cond_resolve($query, $attrs);
my $sth = $self->_get_sth('delete', undef, $self->_table_name, $cond);
- $sth->execute(@$param);
+ $sth->execute(@param);
$sth->finish;
}
return $self;
}
sub search {
- my $class = shift;
- my $where = ref $_[0] eq "HASH" ? shift: {@_};
- my ($cond, $param) = $class->_where_from_hash($where);
- return $class->retrieve_from_sql($cond, @{$param});
+ my $class = shift;
+ my $attrs = { };
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = { %{ pop(@_) } };
+ }
+ my $query = ref $_[0] eq "HASH" ? shift: {@_};
+ my ($cond, @param) = $class->_cond_resolve($query, $attrs);
+ return $class->retrieve_from_sql($cond, @param);
}
sub search_like {
my $class = shift;
- my $where = ref $_[0] eq "HASH" ? shift: {@_};
- my ($cond, $param) = $class->_where_from_hash($where, { cmp => 'like' });
- return $class->retrieve_from_sql($cond, @{$param});
+ my $attrs = { };
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = pop(@_);
+ }
+ return $class->search(@_, { %$attrs, cmp => 'LIKE' });
}
sub _select_columns {
return $new->insert;
}
-sub _where_from_hash {
- my ($self, $query, $opts) = @_;
- my $op = $opts->{'cmp'} || '=';
+sub _cond_resolve {
+ my ($self, $query, $attrs) = @_;
+ my $op = $attrs->{'cmp'} || '=';
my $cond = join(' AND ',
map { (defined $query->{$_}
? "$_ $op ?"
: (do { delete $query->{$_}; "$_ IS NULL"; }));
} keys %$query);
- return ($cond, [ values %$query ]);
+ return ($cond, values %$query);
}
sub table {
City->table('City');
City->columns(All => qw/Name State Population/);
-#City->has_a(State => 'State');
+City->has_a(State => 'State');
#-------------------------------------------------------------------------
# Change after_update policy
SKIP: {
- skip "DBIx::Class compat doesn't handle triggers yet", 4;
+ skip "DBIx::Class compat doesn't handle the exists stuff quite right yet", 4;
my $bt = Film->retrieve($btaste->id);
$bt->autoupdate(1);
is $pgs[1]->id, $f4->id, "and F4";
};
-SKIP: {
- skip "DBIx::Class doesn't have has_a yet", 6;
+#SKIP: {
+# skip "DBIx::Class doesn't have has_a yet", 6;
{
Actor->has_a(film => "Film");
Film->set_sql(
is $apg[1]->title, "B", "and B";
}
-} # end SKIP block
+#} # end SKIP block
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff