use strict;
use warnings;
-use base qw/DBIx::Class::CDBICompat::AccessorMapping
+use base qw/DBIx::Class::CDBICompat::Convenience
+ DBIx::Class::CDBICompat::AccessorMapping
DBIx::Class::CDBICompat::ColumnCase
- DBIx::Class::CDBICompat::ColumnGroups/;
+ DBIx::Class::CDBICompat::ColumnGroups
+ DBIx::Class::CDBICompat::ImaDBI/;
1;
sub _set_column_group {
my ($class, $group, @cols) = @_;
$class->_register_column_group($group => @cols);
- $class->_register_columns(@cols);
- $class->_mk_column_accessors(@cols);
+ #$class->_register_columns(@cols);
+ #$class->_mk_column_accessors(@cols);
+ $class->set_columns(@cols);
}
sub _register_column_group {
my ($class, $group, @cols) = @_;
if ($group eq 'Primary') {
- my %pri;
- $pri{$_} = {} for @cols;
- $class->_primaries(\%pri);
+ $class->set_primary(@cols);
}
my $groups = { %{$class->_column_groups} };
use strict;
use warnings;
-use base qw/DBIx::Class::Table DBIx::Class::SQL DBIx::Class::DB/;
+use base qw/DBIx::Class::PK
+ DBIx::Class::Table
+ DBIx::Class::SQL
+ DBIx::Class::DB/;
1;
sub _get_dbh {
my ($class) = @_;
- unless ((my $dbh = $class->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
+ my $dbh;
+ unless (($dbh = $class->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
$class->_populate_dbh;
}
return $class->_dbh;
sub _dbi_connect {
my ($class, @info) = @_;
- return DBI->connect_cached(@info);
+ return DBI->connect(@info);
+}
+
+sub connection {
+ my ($class, @info) = @_;
+ $class->_dbi_connect_package($class);
+ $class->_dbi_connect_info(\@info);
}
1;
__PACKAGE__->mk_classdata('_sql_statements',
{
'select' =>
- sub { "SELECT ".join(', ', @$_[COLS])." FROM $_[FROM] WHERE $_[COND]"; },
+ sub { "SELECT ".join(', ', @{$_[COLS]})." FROM $_[FROM] WHERE $_[COND]"; },
'update' =>
- sub { "UPDATE $_[FROM] SET ".join(', ', map { "$_ = ?" } @$_[COLS]).
+ sub { "UPDATE $_[FROM] SET ".join(', ', map { "$_ = ?" } @{$_[COLS]}).
" WHERE $_[COND]"; },
'insert' =>
- sub { "INSERT INTO $_[FROM] (".join(', ', @$_[COLS]).") VALUES (".
- join(', ', map { '?' } @$_[COLS]).")"; },
+ sub { "INSERT INTO $_[FROM] (".join(', ', @{$_[COLS]}).") VALUES (".
+ join(', ', map { '?' } @{$_[COLS]}).")"; },
'delete' =>
sub { "DELETE FROM $_[FROM] WHERE $_[COND]"; },
} );
sub _get_sql {
my ($class, $name, $cols, $from, $cond) = @_;
- return $class->_sql_statements->{$name}->($cols, $from, $cond);
+ my $sql = $class->_sql_statements->{$name}->($cols, $from, $cond);
+ #warn $sql;
+ return $sql;
}
sub _sql_to_sth {
__PACKAGE__->mk_classdata('_columns' => {});
-__PACKAGE__->mk_classdata('_primaries' => {});
-
__PACKAGE__->mk_classdata('_table_name');
sub new {
$class = ref $class if ref $class;
my $new = bless({ _column_data => { } }, $class);
if ($attrs) {
- die "Attrs must be a hashref" unless ref($attrs) eq 'HASH';
+ die "attrs must be a hashref" unless ref($attrs) eq 'HASH';
while (my ($k, $v) = each %{$attrs}) {
- $new->set_column($k => $v);
+ $new->set($k => $v);
}
}
+ return $new;
}
sub insert {
$self->_table_name, undef);
$sth->execute(values %{$self->{_column_data}});
$self->{_in_database} = 1;
+ $self->{_dirty_columns} = {};
return $self;
}
sub create {
my ($class, $attrs) = @_;
+ die "create needs a hashref" unless ref $attrs eq 'HASH';
return $class->new($attrs)->insert;
}
sub get {
my ($self, $column) = @_;
+ die "Can't fetch data as class method" unless ref $self;
die "No such column '${column}'" unless $self->_columns->{$column};
return $self->{_column_data}{$column};
}
return $self->{_column_data}{$column} = $value;
}
-sub _ident_cond {
- my ($class) = @_;
- return join(" AND ", map { "$_ = ?" } keys %{$class->_primaries});
-}
-
-sub _ident_values {
- my ($self) = @_;
- return (map { $self->{_column_data}{$_} } keys %{$self->_primaries});
-}
-
sub _register_columns {
my ($class, @cols) = @_;
my $names = { %{$class->_columns} };
$class->mk_accessors(@cols);
}
+sub set_columns {
+ my ($class, @cols) = @_;
+ $class->_register_columns(@cols);
+ $class->_mk_column_accessors(@cols);
+}
+
+sub retrieve_from_sql {
+ my ($class, $cond, @vals) = @_;
+ $cond =~ s/^\s*WHERE//;
+ my @cols = $class->_select_columns;
+ my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond);
+ $sth->execute(@vals);
+ my @found;
+ while (my @row = $sth->fetchrow_array) {
+ my $new = $class->new;
+ $new->set($_, shift @row) for @cols;
+ $new->{_in_database} = 1;
+ push(@found, $new);
+ }
+ return @found;
+}
+
+sub search {
+ my $class = shift;
+ my $where = ref $_[0] eq "HASH" ? shift: {@_};
+ my $cond = join(' AND ', map { "$_ = ?" } keys %$where);
+ return $class->retrieve_from_sql($cond, values %$where);
+}
+
+sub _select_columns {
+ return keys %{$_[0]->_columns};
+}
+
+sub copy {
+ my ($self, $changes) = @_;
+ my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
+ $new->set($_ => $changes->{$_}) for keys %$changes;
+ return $new;
+}
+
1;
my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1 });
__PACKAGE__->connection(@DSN);
-__PACKAGE__->set_sql(_table_pragma => 'PRAGMA table_info(__TABLE__)');
-__PACKAGE__->set_sql(_create_me => 'CREATE TABLE __TABLE__ (%s)');
+#__PACKAGE__->set_sql(_table_pragma => 'PRAGMA table_info(__TABLE__)');
+#__PACKAGE__->set_sql(_create_me => 'CREATE TABLE __TABLE__ (%s)');
=head1 METHODS
sub _create_test_table {
my $class = shift;
- my @vals = $class->sql__table_pragma->select_row;
- $class->sql__create_me($class->create_sql)->execute unless @vals;
+ my @vals = $class->_sql_to_sth(
+ 'PRAGMA table_info(__TABLE__)')->select_row;
+ $class->_sql_to_sth(
+ 'CREATE TABLE '.$class->table.' ('.$class->create_sql.')'
+ )->execute unless @vals;
}
=head2 create_sql (abstract)
{
SKIP: {
- skip "Different error message", 1;
+ skip "No column objects", 1;
eval { my @grps = State->__grouper->groups_for("Huh"); };
ok $@, "Huh not in groups";
}
SKIP: {
- skip "->retrieve not yet supported by CDBI compat", 1;
local $SIG{__WARN__} = sub { };
eval { DBIx::Class->retrieve(1) };
like $@, qr/Can't retrieve unless primary columns are defined/, "Need primary key for retrieve";
ok(Film->can('db_Main'), 'set_db()');
is(Film->__driver, "SQLite", "Driver set correctly");
-SKIP: {
- skip "Bunch of slightly different error messages", 5;
-
{
my $nul = eval { Film->retrieve() };
is $nul, undef, "Can't retrieve nothing";
}
eval { my $duh = Film->create; };
-like $@, qr/create needs a hashref/, "create needs a hashref";
-
-} # End skip block
+like $@, qr/create needs a hashref/, "needs a hashref";
ok +Film->create_test_film;
}
SKIP: {
- skip "Scalar::Util::weaken not available", 3
+ skip "Scalar::Util::weaken not available", 3;
#if !$Class::DBI::Weaken_Is_Available;
# my bad taste is your bad taste
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff