use base qw/DBIx::Class::Row/;
-__PACKAGE__->mk_classdata('_primaries' => {});
-
=head1 NAME
DBIx::Class::PK - Primary Key class
sub _ident_cond {
my ($class) = @_;
- return join(" AND ", map { "$_ = ?" } keys %{$class->_primaries});
+ return join(" AND ", map { "$_ = ?" } $class->primary_columns);
}
sub _ident_values {
my ($self) = @_;
- return (map { $self->{_column_data}{$_} } keys %{$self->_primaries});
-}
-
-=head2 set_primary_key(@cols)
-
-Defines one or more columns as primary key for this class. Should be
-called after C<columns>.
-
-=cut
-
-sub set_primary_key {
- my ($class, @cols) = @_;
- # check if primary key columns are valid columns
- for (@cols) {
- $class->throw( "Column $_ can't be used as primary key because it isn't defined in $class" )
- unless $class->has_column($_);
- }
- my %pri;
- tie %pri, 'Tie::IxHash', map { $_ => {} } @cols;
- $class->_primaries(\%pri);
-}
-
-=head2 find(@colvalues), find(\%cols)
-
-Finds a row based on its primary key(s).
-
-=cut
-
-sub find {
- my ($class, @vals) = @_;
- my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
- my @pk = keys %{$class->_primaries};
- $class->throw( "Can't find unless primary columns are defined" )
- unless @pk;
- my $query;
- if (ref $vals[0] eq 'HASH') {
- $query = $vals[0];
- } elsif (@pk == @vals) {
- $query = {};
- @{$query}{@pk} = @vals;
- #my $ret = ($class->search_literal($class->_ident_cond, @vals, $attrs))[0];
- #warn "$class: ".join(', ', %{$ret->{_column_data}});
- #return $ret;
- } else {
- $query = {@vals};
- }
- $class->throw( "Can't find 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)->next;
- #my @cols = $class->_select_columns;
- #my @row = $class->storage->select_single($class->_table_name, \@cols, $query);
- #return (@row ? $class->_row_to_object(\@cols, \@row) : ());
+ return (map { $self->{_column_data}{$_} } $self->primary_columns);
}
=head2 discard_changes
return (wantarray ? @pk : $pk[0]);
}
-=head2 primary_columns
-
-Read-only accessor which returns the list of primary keys for a class
-(in scalar context, only returns the first primary key).
-
-=cut
-
-sub primary_columns {
- return keys %{shift->_primaries};
-}
-
=head2 ID
Returns a unique id string identifying a row object by primary key.
my ($self) = @_;
$self->throw( "Can't call ID() as a class method" ) unless ref $self;
return undef unless $self->in_storage;
- return $self->_create_ID(map { $_ => $self->{_column_data}{$_} } keys %{$self->_primaries});
+ return $self->_create_ID(map { $_ => $self->{_column_data}{$_} } $self->primary_columns);
}
sub _create_ID {
sub search_like { shift->resultset_instance->search_like(@_); }
sub count { shift->resultset_instance->count(@_); }
sub count_literal { shift->resultset_instance->count_literal(@_); }
+sub find { shift->resultset_instance->find(@_); }
1;
my ($self) = @_;
return $self if $self->in_storage;
#use Data::Dumper; warn Dumper($self);
- my %in;
- $in{$_} = $self->get_column($_)
- for grep { defined $self->get_column($_) } $self->columns;
- my %out = %{ $self->storage->insert($self->_table_name, \%in) };
- $self->store_column($_, $out{$_})
- for grep { $self->get_column($_) ne $out{$_} } keys %out;
+ $self->storage->insert($self->_table_name, { $self->get_columns });
$self->in_storage(1);
$self->{_dirty_columns} = {};
return $self;
sub update {
my ($self, $upd) = @_;
$self->throw( "Not in database" ) unless $self->in_storage;
- my %to_update;
- $to_update{$_} = $self->get_column($_) for $self->is_changed;
+ my %to_update = $self->get_dirty_columns;
return -1 unless keys %to_update;
my $rows = $self->storage->update($self->_table_name, \%to_update,
$self->ident_condition);
sub get_column {
my ($self, $column) = @_;
$self->throw( "Can't fetch data as class method" ) unless ref $self;
- $self->throw( "No such column '${column}'" ) unless $self->has_column($column);
return $self->{_column_data}{$column}
if exists $self->{_column_data}{$column};
+ $self->throw( "No such column '${column}'" ) unless $self->has_column($column);
return undef;
}
sub get_columns {
my $self = shift;
- return map { $_ => $self->get_column($_) } $self->columns;
+ return return %{$self->{_column_data}};
+}
+
+=head2 get_dirty_columns
+
+ my %data = $obj->get_dirty_columns;
+
+Identical to get_columns but only returns those that have been changed.
+
+=cut
+
+sub get_dirty_columns {
+ my $self = shift;
+ return map { $_ => $self->{_column_data}{$_} }
+ keys %{$self->{_dirty_columns}};
}
=head2 set_column
sub store_column {
my ($self, $column, $value) = @_;
$self->throw( "No such column '${column}'" )
- unless $self->has_column($column);
+ unless exists $self->{_column_data}{$column} || $self->has_column($column);
$self->throw( "set_column called for ${column} without value" )
if @_ < 3;
return $self->{_column_data}{$column} = $value;
__PACKAGE__->load_components(qw/Exception/);
__PACKAGE__->mk_classdata('class_registrations' => {});
+__PACKAGE__->mk_classdata('storage_type' => 'DBI');
+__PACKAGE__->mk_classdata('storage');
=head1 NAME
__PACKAGE__->load_components(qw/AccessorGroup/);
__PACKAGE__->mk_group_accessors('simple' =>
- qw/_columns name resultset_class result_class storage/);
+ qw/_columns _primaries name resultset_class result_class storage/);
=head1 NAME
sub add_columns {
my ($self, @cols) = @_;
while (my $col = shift @cols) {
- $self->add_column($col => (ref $cols[0] ? shift : {}));
+ $self->_columns->{$col} = (ref $cols[0] ? shift : {});
}
}
-sub add_column {
- my ($self, $col, $info) = @_;
- $self->_columns->{$col} = $info || {};
-}
+*add_column = \&add_columns;
=head2 add_columns
Adds columns to the table object. If supplied key => hashref pairs uses
the hashref as the column_info for that column.
+=head2 add_column
+
+ $table->add_column('col' => \%info?);
+
+Convenience alias to add_columns
+
=cut
sub resultset {
return $self->_columns->{$column};
}
-=head2 columns
-
+=head2 columns
+
my @column_names = $obj->columns;
=cut
return keys %{shift->_columns};
}
+=head2 set_primary_key(@cols)
+
+Defines one or more columns as primary key for this table. Should be
+called after C<add_columns>.
+
+=cut
+
+sub set_primary_key {
+ my ($self, @cols) = @_;
+ # check if primary key columns are valid columns
+ for (@cols) {
+ $self->throw("No such column $_ on table ".$self->name)
+ unless $self->has_column($_);
+ }
+ $self->_primaries(\@cols);
+}
+
+=head2 primary_columns
+
+Read-only accessor which returns the list of primary keys.
+
+=cut
+
+sub primary_columns {
+ return @{shift->_primaries||[]};
+}
+
+
1;
=head1 AUTHORS
return $self->table_instance->column_info($column);
}
-=head2 columns
-
+=head2 columns
+
my @column_names = $obj->columns;
=cut
return shift->table_instance(@_);
}
+sub set_primary_key { shift->table_instance->set_primary_key(@_); }
+sub primary_columns { shift->table_instance->primary_columns(@_); }
+
1;
=head1 AUTHORS
use strict;
-use Test::More tests => 25;
+use Test::More tests => 24;
#-----------------------------------------------------------------------
# Make sure that we can set up columns properly
is $grps[1], 'Weather', " - Weather";
}
-{
- package DieTest;
- @DieTest::ISA = qw(DBIx::Class);
- DieTest->load_components(qw/CDBICompat::Retrieve Core/);
- package main;
- local $SIG{__WARN__} = sub { };
- eval { DieTest->retrieve(1) };
- like $@, qr/unless primary columns are defined/, "Need primary key for retrieve";
-}
+#{
+#
+# package DieTest;
+# @DieTest::ISA = qw(DBIx::Class);
+# DieTest->load_components(qw/CDBICompat::Retrieve Core/);
+# package main;
+# local $SIG{__WARN__} = sub { };
+# eval { DieTest->retrieve(1) };
+# like $@, qr/unless primary columns are defined/, "Need primary key for retrieve";
+#}
#-----------------------------------------------------------------------
# Make sure that columns inherit properly
projects / dbsrgits/DBIx-Class.git / commitdiff