From: Matt S Trout Date: Tue, 19 Jul 2005 10:07:29 +0000 (+0000) Subject: Initial commit of DBIx::Class (experimental Class::DBI-inspired ORM) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ea2e61bf5bb7187dc5e56513cd66c272d71d5074;p=dbsrgits%2FDBIx-Class-Historic.git Initial commit of DBIx::Class (experimental Class::DBI-inspired ORM) --- ea2e61bf5bb7187dc5e56513cd66c272d71d5074 diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm new file mode 100644 index 0000000..43ce538 --- /dev/null +++ b/lib/DBIx/Class.pm @@ -0,0 +1,5 @@ +package DBIx::Class; + +use base qw/DBIx::Class::CDBICompat DBIx::Class::Core/; + +1; diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm new file mode 100644 index 0000000..22fd5e7 --- /dev/null +++ b/lib/DBIx/Class/CDBICompat.pm @@ -0,0 +1,10 @@ +package DBIx::Class::CDBICompat; + +use strict; +use warnings; + +use base qw/DBIx::Class::CDBICompat::AccessorMapping + DBIx::Class::CDBICompat::ColumnCase + DBIx::Class::CDBICompat::ColumnGroups/; + +1; diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm new file mode 100644 index 0000000..cdfd851 --- /dev/null +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -0,0 +1,29 @@ +package DBIx::Class::CDBICompat::AccessorMapping; + +use strict; +use warnings; + +use NEXT; + +sub _mk_column_accessors { + my ($class, @cols) = @_; + unless ($class->can('accessor_name') || $class->can('mutator_name')) { + return $class->NEXT::_mk_column_accessors(@cols); + } + foreach my $col (@cols) { + my $ro_meth = ($class->can('accessor_name') + ? $class->accessor_name($col) + : $col); + my $wo_meth = ($class->can('mutator_name') + ? $class->mutator_name($col) + : $col); + if ($ro_meth eq $wo_meth) { + $class->mk_accessors($col); + } else { + $class->mk_ro_accessors($ro_meth); + $class->mk_wo_accessors($wo_meth); + } + } +} + +1; diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm new file mode 100644 index 0000000..fe9084a --- /dev/null +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -0,0 +1,40 @@ +package DBIx::Class::CDBICompat::ColumnCase; + +use strict; +use warnings; +use NEXT; + +sub _register_column_group { + my ($class, $group, @cols) = @_; + return $class->NEXT::_register_column_group($group => map lc, @cols); +} + +sub _register_columns { + my ($class, @cols) = @_; + return $class->NEXT::_register_columns(map lc, @cols); +} + +sub get { + my ($class, $get, @rest) = @_; + return $class->NEXT::get(lc $get, @rest); +} + +sub set { + my ($class, $set, @rest) = @_; + return $class->NEXT::set(lc $set, @rest); +} + +sub find_column { + my ($class, $col) = @_; + return $class->NEXT::find_column(lc $col); +} + +sub _mk_accessors { + my ($class, $type, @fields) = @_; + my %fields; + $fields{$_} = 1 for @fields, + map lc, grep { !defined &{"${class}::${_}"} } @fields; + return $class->NEXT::_mk_accessors($type, keys %fields); +} + +1; diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm new file mode 100644 index 0000000..3bea78d --- /dev/null +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -0,0 +1,93 @@ +package DBIx::Class::CDBICompat::ColumnGroups; + +use strict; +use warnings; +use NEXT; + +use base qw/Class::Data::Inheritable/; + +__PACKAGE__->mk_classdata('_column_groups' => { }); + +sub table { + shift->_table_name(@_); +} + +sub columns { + my $proto = shift; + my $class = ref $proto || $proto; + my $group = shift || "All"; + $class->_set_column_group($group => @_) if @_; + return $class->all_columns if $group eq "All"; + return $class->primary_column if $group eq "Primary"; + return keys %{$class->_column_groups->{$group}}; +} + +sub _set_column_group { + my ($class, $group, @cols) = @_; + $class->_register_column_group($group => @cols); + $class->_register_columns(@cols); + $class->_mk_column_accessors(@cols); +} + +sub _register_column_group { + my ($class, $group, @cols) = @_; + if ($group eq 'Primary') { + my %pri; + $pri{$_} = {} for @cols; + $class->_primaries(\%pri); + } + + my $groups = { %{$class->_column_groups} }; + + if ($group eq 'All') { + unless ($class->_column_groups->{'Primary'}) { + $groups->{'Primary'}{$cols[0]} = {}; + $class->_primaries({ $cols[0] => {} }); + } + unless ($class->_column_groups->{'Essential'}) { + $groups->{'Essential'}{$cols[0]} = {}; + } + } + + $groups->{$group}{$_} ||= {} for @cols; + $class->_column_groups($groups); +} + +sub all_columns { return keys %{$_[0]->_columns}; } + +sub primary_column { + my ($class) = @_; + my @pri = keys %{$class->_primaries}; + return wantarray ? @pri : $pri[0]; +} + +sub find_column { + my ($class, $col) = @_; + return $col if $class->_columns->{$col}; +} + +sub __grouper { + my ($class) = @_; + return bless({ class => $class}, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim'); +} + +sub _find_columns { + my ($class, @col) = @_; + return map { $class->find_column($_) } @col; +} + +package DBIx::Class::CDBICompat::ColumnGroups::GrouperShim; + +sub groups_for { + my ($self, @cols) = @_; + my %groups; + foreach my $col (@cols) { + foreach my $group (keys %{$self->{class}->_column_groups}) { + $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col}; + } + } + return keys %groups; +} + + +1; diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm new file mode 100644 index 0000000..c90d7bc --- /dev/null +++ b/lib/DBIx/Class/Core.pm @@ -0,0 +1,8 @@ +package DBIx::Class::Core; + +use strict; +use warnings; + +use base qw/DBIx::Class::Table DBIx::Class::SQL DBIx::Class::DB/; + +1; diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm new file mode 100644 index 0000000..3fc3013 --- /dev/null +++ b/lib/DBIx/Class/DB.pm @@ -0,0 +1,29 @@ +package DBIx::Class::DB; + +use base qw/Class::Data::Inheritable/; + +__PACKAGE__->mk_classdata('_dbi_connect_info'); +__PACKAGE__->mk_classdata('_dbi_connect_package'); +__PACKAGE__->mk_classdata('_dbh'); + +sub _get_dbh { + my ($class) = @_; + unless ((my $dbh = $class->_dbh) && $dbh->FETCH('Active') && $dbh->ping) { + $class->_populate_dbh; + } + return $class->_dbh; +} + +sub _populate_dbh { + my ($class) = @_; + my @info = @{$class->_dbi_connect_info || []}; + my $pkg = $class->_dbi_connect_package || $class; + $pkg->_dbh($class->_dbi_connect(@info)); +} + +sub _dbi_connect { + my ($class, @info) = @_; + return DBI->connect_cached(@info); +} + +1; diff --git a/lib/DBIx/Class/SQL.pm b/lib/DBIx/Class/SQL.pm new file mode 100644 index 0000000..2f6326e --- /dev/null +++ b/lib/DBIx/Class/SQL.pm @@ -0,0 +1,41 @@ +package DBIx::Class::SQL; + +use strict; +use warnings; + +use base qw/Class::Data::Inheritable/; + +use constant COLS => 0; +use constant FROM => 1; +use constant COND => 2; + +__PACKAGE__->mk_classdata('_sql_statements', + { + 'select' => + sub { "SELECT ".join(', ', @$_[COLS])." FROM $_[FROM] WHERE $_[COND]"; }, + 'update' => + sub { "UPDATE $_[FROM] SET ".join(', ', map { "$_ = ?" } @$_[COLS]). + " WHERE $_[COND]"; }, + 'insert' => + 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); +} + +sub _sql_to_sth { + my ($class, $sql) = @_; + return $class->_get_dbh->prepare($sql); +} + +sub _get_sth { + my $class = shift; + return $class->_sql_to_sth($class->_get_sql(@_)); +} + +1; diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm new file mode 100644 index 0000000..9556eb9 --- /dev/null +++ b/lib/DBIx/Class/Table.pm @@ -0,0 +1,98 @@ +package DBIx::Class::Table; + +use strict; +use warnings; + +use base qw/Class::Data::Inheritable Class::Accessor DBIx::Class::SQL/; + +__PACKAGE__->mk_classdata('_columns' => {}); + +__PACKAGE__->mk_classdata('_primaries' => {}); + +__PACKAGE__->mk_classdata('_table_name'); + +sub new { + my ($class, $attrs) = @_; + $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'; + while (my ($k, $v) = each %{$attrs}) { + $new->set_column($k => $v); + } + } +} + +sub insert { + my ($self) = @_; + return if $self->{_in_database}; + my $sth = $self->_get_sth('insert', [ keys %{$self->{_column_data}} ], + $self->_table_name, undef); + $sth->execute(values %{$self->{_column_data}}); + $self->{_in_database} = 1; + return $self; +} + +sub create { + my ($class, $attrs) = @_; + return $class->new($attrs)->insert; +} + +sub update { + my ($self) = @_; + die "Not in database" unless $self->{_in_database}; + my @to_update = keys %{$self->{_dirty_columns} || {}}; + my $sth = $self->_get_sth('update', \@to_update, + $self->_table_name, $self->_ident_cond); + $sth->execute( (map { $self->{_column_data}{$_} } @to_update), + $self->_ident_values ); + $self->{_dirty_columns} = {}; + return $self; +} + +sub delete { + my ($self) = @_; + my $sth = $self->_get_sth('delete', undef, + $self->_table_name, $self->_ident_cond); + $sth->execute($self->_ident_values); + delete $self->{_in_database}; + return $self; +} + +sub get { + my ($self, $column) = @_; + die "No such column '${column}'" unless $self->_columns->{$column}; + return $self->{_column_data}{$column}; +} + +sub set { + my ($self, $column, $value) = @_; + die "No such column '${column}'" unless $self->_columns->{$column}; + die "set_column called for ${column} without value" if @_ < 3; + $self->{_dirty_columns}{$column} = 1; + 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} }; + $names->{$_} ||= {} for @cols; + $class->_columns($names); +} + +sub _mk_column_accessors { + my ($class, @cols) = @_; + $class->mk_accessors(@cols); +} + +1; diff --git a/lib/DBIx/Class/Test/SQLite.pm b/lib/DBIx/Class/Test/SQLite.pm new file mode 100644 index 0000000..02d300d --- /dev/null +++ b/lib/DBIx/Class/Test/SQLite.pm @@ -0,0 +1,87 @@ +package DBIx::Class::Test::SQLite; + +=head1 NAME + +DBIx::Class::Test::SQLite - Base class for DBIx::Class tests, shamelessly ripped from Class::DBI::Test::SQLite + +=head1 SYNOPSIS + + use base 'DBIx::Class::Test::SQLite'; + + __PACKAGE__->set_table('test'); + __PACKAGE__->columns(All => qw/id name film salary/); + + sub create_sql { + return q{ + id INTEGER PRIMARY KEY, + name CHAR(40), + film VARCHAR(255), + salary INT + } + } + +=head1 DESCRIPTION + +This provides a simple base class for DBIx::Class tests using SQLite. +Each class for the test should inherit from this, provide a create_sql() +method which returns a string representing the SQL used to create the +table for the class, and then call set_table() to create the table, and +tie it to the class. + +=cut + +use strict; + +use base 'DBIx::Class'; +use File::Temp qw/tempfile/; +my (undef, $DB) = tempfile(); +END { unlink $DB if -e $DB } + +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)'); + +=head1 METHODS + +=head2 set_table + + __PACKAGE__->set_table('test'); + +This combines creating the table with the normal DBIx::Class table() +call. + +=cut + +sub set_table { + my ($class, $table) = @_; + $class->table($table); + $class->_create_test_table; +} + +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; +} + +=head2 create_sql (abstract) + + sub create_sql { + return q{ + id INTEGER PRIMARY KEY, + name CHAR(40), + film VARCHAR(255), + salary INT + } + } + +This should return, as a text string, the schema for the table represented +by this class. + +=cut + +sub create_sql { die "create_sql() not implemented by $_[0]\n" } + +1; diff --git a/t/01-columns.t b/t/01-columns.t new file mode 100644 index 0000000..50d5831 --- /dev/null +++ b/t/01-columns.t @@ -0,0 +1,131 @@ +use strict; + +use Test::More tests => 25; + +#----------------------------------------------------------------------- +# Make sure that we can set up columns properly +#----------------------------------------------------------------------- +package State; + +use base 'DBIx::Class'; + +State->table('State'); +State->columns(Essential => qw/Abbreviation Name/); +State->columns(Primary => 'Name'); +State->columns(Weather => qw/Rain Snowfall/); +State->columns(Other => qw/Capital Population/); +#State->has_many(cities => "City"); + +sub accessor_name { + my ($class, $column) = @_; + my $return = $column eq "Rain" ? "Rainfall" : $column; + return $return; +} + +sub mutator_name { + my ($class, $column) = @_; + my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column"; + return $return; +} + +sub Snowfall { 1 } + + +package City; + +use base 'DBIx::Class'; + +City->table('City'); +City->columns(All => qw/Name State Population/); +#City->has_a(State => 'State'); + + +#------------------------------------------------------------------------- +package CD; +use base 'DBIx::Class'; + +CD->table('CD'); +CD->columns('All' => qw/artist title length/); + +#------------------------------------------------------------------------- + +package main; + +is(State->table, 'State', 'State table()'); +is(State->primary_column, 'name', 'State primary()'); +is_deeply [ State->columns('Primary') ] => [qw/name/], + 'State Primary:' . join ", ", State->columns('Primary'); +is_deeply [ sort State->columns('Essential') ] => [qw/abbreviation name/], + 'State Essential:' . join ", ", State->columns('Essential'); +is_deeply [ sort State->columns('All') ] => + [ sort qw/name abbreviation rain snowfall capital population/ ], + 'State All:' . join ", ", State->columns('All'); + +is(CD->primary_column, 'artist', 'CD primary()'); +is_deeply [ CD->columns('Primary') ] => [qw/artist/], + 'CD primary:' . join ", ", CD->columns('Primary'); +is_deeply [ sort CD->columns('All') ] => [qw/artist length title/], + 'CD all:' . join ", ", CD->columns('All'); +is_deeply [ sort CD->columns('Essential') ] => [qw/artist/], + 'CD essential:' . join ", ", CD->columns('Essential'); + +ok(State->find_column('Rain'), 'find_column Rain'); +ok(State->find_column('rain'), 'find_column rain'); +ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG'); + +{ + + can_ok +State => qw/Rainfall _Rainfall_accessor set_Rainfall + _set_Rainfall_accessor Snowfall _Snowfall_accessor set_Snowfall + _set_Snowfall_accessor/; + + foreach my $method (qw/Rain _Rain_accessor rain snowfall/) { + ok !State->can($method), "State can't $method"; + } + +} + +{ + SKIP: { + skip "Different error message", 1; + + eval { my @grps = State->__grouper->groups_for("Huh"); }; + ok $@, "Huh not in groups"; + } + + my @grps = sort State->__grouper->groups_for(State->_find_columns(qw/rain capital/)); + is @grps, 2, "Rain and Capital = 2 groups"; + my @grps = sort @grps; # Because DBIx::Class is hash-based + is $grps[0], 'Other', " - Other"; + is $grps[1], 'Weather', " - Weather"; +} + +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"; +} + +#----------------------------------------------------------------------- +# Make sure that columns inherit properly +#----------------------------------------------------------------------- +package State; + +package A; +@A::ISA = qw(DBIx::Class); +__PACKAGE__->columns(Primary => 'id'); + +package A::B; +@A::B::ISA = 'A'; +__PACKAGE__->columns(All => qw(id b1)); + +package A::C; +@A::C::ISA = 'A'; +__PACKAGE__->columns(All => qw(id c1 c2 c3)); + +package main; +is join (' ', sort A->columns), 'id', "A columns"; +is join (' ', sort A::B->columns), 'b1 id', "A::B columns"; +is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns"; + diff --git a/t/02-Film.t b/t/02-Film.t new file mode 100644 index 0000000..ea2b2d7 --- /dev/null +++ b/t/02-Film.t @@ -0,0 +1,370 @@ +use strict; +use Test::More; +$| = 1; + +BEGIN { + eval "use DBD::SQLite"; + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 93); +} + +INIT { + use lib 't/testlib'; + use Film; +} + +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"; + like $@, qr/./, "retrieve needs parameters"; # TODO fix this... +} + +{ + eval { my $id = Film->id }; + like $@, qr/class method/, "Can't get id with no object"; +} + +{ + eval { my $id = Film->title }; + like $@, qr/class method/, "Can't get title with no object"; +} + +eval { my $duh = Film->create; }; +like $@, qr/create needs a hashref/, "create needs a hashref"; + +} # End skip block + +ok +Film->create_test_film; + +my $btaste = Film->retrieve('Bad Taste'); +isa_ok $btaste, 'Film'; +is($btaste->Title, 'Bad Taste', 'Title() get'); +is($btaste->Director, 'Peter Jackson', 'Director() get'); +is($btaste->Rating, 'R', 'Rating() get'); +is($btaste->NumExplodingSheep, 1, 'NumExplodingSheep() get'); + +{ + my $bt2 = Film->find_or_create(Title => 'Bad Taste'); + is $bt2->Director, $btaste->Director, "find_or_create"; + my @bt = Film->search(Title => 'Bad Taste'); + is @bt, 1, " doesn't create a new one"; +} + +ok my $gone = Film->find_or_create( + { + Title => 'Gone With The Wind', + Director => 'Bob Baggadonuts', + Rating => 'PG', + NumExplodingSheep => 0 + } + ), + "Add Gone With The Wind"; +isa_ok $gone, 'Film'; +ok $gone = Film->retrieve(Title => 'Gone With The Wind'), + "Fetch it back again"; +isa_ok $gone, 'Film'; + +# Shocking new footage found reveals bizarre Scarlet/sheep scene! +is($gone->NumExplodingSheep, 0, 'NumExplodingSheep() get again'); +$gone->NumExplodingSheep(5); +is($gone->NumExplodingSheep, 5, 'NumExplodingSheep() set'); +is($gone->numexplodingsheep, 5, 'numexplodingsheep() set'); + +is($gone->Rating, 'PG', 'Rating() get again'); +$gone->Rating('NC-17'); +is($gone->Rating, 'NC-17', 'Rating() set'); +$gone->update; + +{ + my @films = eval { Film->retrieve_all }; + is(@films, 2, "We have 2 films in total"); +} + +my $gone_copy = Film->retrieve('Gone With The Wind'); +ok($gone->NumExplodingSheep == 5, 'update()'); +ok($gone->Rating eq 'NC-17', 'update() again'); + +# Grab the 'Bladerunner' entry. +Film->create( + { + Title => 'Bladerunner', + Director => 'Bob Ridley Scott', + Rating => 'R' + } +); + +my $blrunner = Film->retrieve('Bladerunner'); +is(ref $blrunner, 'Film', 'retrieve() again'); +is $blrunner->Title, 'Bladerunner', "Correct title"; +is $blrunner->Director, 'Bob Ridley Scott', " and Director"; +is $blrunner->Rating, 'R', " and Rating"; +is $blrunner->NumExplodingSheep, undef, " and sheep"; + +# Make a copy of 'Bladerunner' and create an entry of the directors cut +my $blrunner_dc = $blrunner->copy( + { + title => "Bladerunner: Director's Cut", + rating => "15", + } +); +is(ref $blrunner_dc, 'Film', "copy() produces a film"); +is($blrunner_dc->Title, "Bladerunner: Director's Cut", 'Title correct'); +is($blrunner_dc->Director, 'Bob Ridley Scott', 'Director correct'); +is($blrunner_dc->Rating, '15', 'Rating correct'); +is($blrunner_dc->NumExplodingSheep, undef, 'Sheep correct'); + +# Set up own SQL: +{ + Film->add_constructor(title_asc => "title LIKE ? ORDER BY title"); + Film->add_constructor(title_desc => "title LIKE ? ORDER BY title DESC"); + + { + my @films = Film->title_asc("Bladerunner%"); + is @films, 2, "We have 2 Bladerunners"; + is $films[0]->Title, $blrunner->Title, "Ordered correctly"; + } + { + my @films = Film->title_desc("Bladerunner%"); + is @films, 2, "We have 2 Bladerunners"; + is $films[0]->Title, $blrunner_dc->Title, "Ordered correctly"; + } +} + +# Multi-column search +{ + my @films = $blrunner->search_like(title => "Bladerunner%", rating => '15'); + is @films, 1, "Only one Bladerunner is a 15"; +} + +# Inline SQL +{ + my @films = Film->retrieve_from_sql("numexplodingsheep > 0 ORDER BY title"); + is @films, 2, "Inline SQL"; + is $films[0]->id, $btaste->id, "Correct film"; + is $films[1]->id, $gone->id, "Correct film"; +} + +# Inline SQL removes WHERE +{ + my @films = + Film->retrieve_from_sql(" WHErE numexplodingsheep > 0 ORDER BY title"); + is @films, 2, "Inline SQL"; + is $films[0]->id, $btaste->id, "Correct film"; + is $films[1]->id, $gone->id, "Correct film"; +} + +eval { + my $ishtar = Film->create({ Title => 'Ishtar', Director => 'Elaine May' }); + my $mandn = + Film->create({ Title => 'Mikey and Nicky', Director => 'Elaine May' }); + my $new_leaf = + Film->create({ Title => 'A New Leaf', Director => 'Elaine May' }); + is(Film->search(Director => 'Elaine May')->count, + 3, "3 Films by Elaine May"); + ok(Film->retrieve('Ishtar')->delete, + "Ishtar doesn't deserve an entry any more"); + ok(!Film->retrieve('Ishtar'), 'Ishtar no longer there'); + { + my $deprecated = 0; + local $SIG{__WARN__} = sub { $deprecated++ if $_[0] =~ /deprecated/ }; + ok( + Film->delete(Director => 'Elaine May'), + "In fact, delete all films by Elaine May" + ); + is(Film->search(Director => 'Elaine May')->count, + 0, "0 Films by Elaine May"); + is $deprecated, 1, "Got a deprecated warning"; + } +}; +is $@, '', "No problems with deletes"; + +# Find all films which have a rating of NC-17. +my @films = Film->search('Rating', 'NC-17'); +is(scalar @films, 1, ' search returns one film'); +is($films[0]->id, $gone->id, ' ... the correct one'); + +# Find all films which were directed by Bob +@films = Film->search_like('Director', 'Bob %'); +is(scalar @films, 3, ' search_like returns 3 films'); +ok( + eq_array( + [ sort map { $_->id } @films ], + [ sort map { $_->id } $blrunner_dc, $gone, $blrunner ] + ), + 'the correct ones' +); + +# Find Ridley Scott films which don't have vomit +@films = + Film->search(numExplodingSheep => undef, Director => 'Bob Ridley Scott'); +is(scalar @films, 2, ' search where attribute is null returns 2 films'); +ok( + eq_array( + [ sort map { $_->id } @films ], + [ sort map { $_->id } $blrunner_dc, $blrunner ] + ), + 'the correct ones' +); + +# Test that a disconnect doesnt harm anything. +Film->db_Main->disconnect; +@films = Film->search({ Rating => 'NC-17' }); +ok(@films == 1 && $films[0]->id eq $gone->id, 'auto reconnection'); + +# Test discard_changes(). +my $orig_director = $btaste->Director; +$btaste->Director('Lenny Bruce'); +is($btaste->Director, 'Lenny Bruce', 'set new Director'); +$btaste->discard_changes; +is($btaste->Director, $orig_director, 'discard_changes()'); + +{ + Film->autoupdate(1); + my $btaste2 = Film->retrieve($btaste->id); + $btaste->NumExplodingSheep(18); + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, @_; }; + { + + # unhook from live object cache, so next one is not from cache + $btaste2->remove_from_object_index; + my $btaste3 = Film->retrieve($btaste->id); + is $btaste3->NumExplodingSheep, 18, "Class based AutoCommit"; + $btaste3->autoupdate(0); # obj a/c should override class a/c + is @warnings, 0, "No warnings so far"; + $btaste3->NumExplodingSheep(13); + } + is @warnings, 1, "DESTROY without update warns"; + Film->autoupdate(0); +} + +{ # update unchanged object + my $film = Film->retrieve($btaste->id); + my $retval = $film->update; + is $retval, -1, "Unchanged object"; +} + +{ # update deleted object + my $rt = "Royal Tenenbaums"; + my $ten = Film->create({ title => $rt, Rating => "R" }); + $ten->rating(18); + Film->set_sql(drt => "DELETE FROM __TABLE__ WHERE title = ?"); + Film->sql_drt->execute($rt); + my @films = Film->search({ title => $rt }); + is @films, 0, "RT gone"; + my $retval = eval { $ten->update }; + like $@, qr/row not found/, "Update deleted object throws error"; + $ten->discard_changes; +} + +{ + $btaste->autoupdate(1); + $btaste->NumExplodingSheep(32); + my $btaste2 = Film->retrieve($btaste->id); + is $btaste2->NumExplodingSheep, 32, "Object based AutoCommit"; + $btaste->autoupdate(0); +} + +# Primary key of 0 +{ + my $zero = Film->create({ Title => 0, Rating => "U" }); + ok defined $zero, "Create 0"; + ok my $ret = Film->retrieve(0), "Retrieve 0"; + is $ret->Title, 0, "Title OK"; + is $ret->Rating, "U", "Rating OK"; +} + +# Change after_update policy +{ + my $bt = Film->retrieve($btaste->id); + $bt->autoupdate(1); + + $bt->rating("17"); + ok !$bt->_attribute_exists('rating'), "changed column needs reloaded"; + ok $bt->_attribute_exists('title'), "but we still have the title"; + + # Don't re-load + $bt->add_trigger( + after_update => sub { + my ($self, %args) = @_; + my $discard_columns = $args{discard_columns}; + @$discard_columns = qw/title/; + } + ); + $bt->rating("19"); + ok $bt->_attribute_exists('rating'), "changed column needs reloaded"; + ok !$bt->_attribute_exists('title'), "but no longer have the title"; +} + +# Make sure that we can have other accessors. (Bugfix in 0.28) +if (0) { + Film->mk_accessors(qw/temp1 temp2/); + my $blrunner = Film->retrieve('Bladerunner'); + $blrunner->temp1("Foo"); + $blrunner->NumExplodingSheep(2); + eval { $blrunner->update }; + ok(!$@, "Other accessors"); +} + +# overloading +{ + is "$blrunner", "Bladerunner", "stringify"; + + ok(Film->columns(Stringify => 'rating'), "Can change stringify column"); + is "$blrunner", "R", "And still stringifies correctly"; + + ok( + Film->columns(Stringify => qw/title rating/), + "Can have multiple stringify columns" + ); + is "$blrunner", "Bladerunner/R", "And still stringifies correctly"; + + no warnings 'once'; + local *Film::stringify_self = sub { join ":", $_[0]->title, $_[0]->rating }; + is "$blrunner", "Bladerunner:R", "Provide stringify_self()"; +} + +{ + { + ok my $byebye = DeletingFilm->create( + { + Title => 'Goodbye Norma Jean', + Rating => 'PG', + } + ), + "Add a deleting Film"; + + isa_ok $byebye, 'DeletingFilm'; + isa_ok $byebye, 'Film'; + ok(Film->retrieve('Goodbye Norma Jean'), "Fetch it back again"); + } + my $film; + eval { $film = Film->retrieve('Goodbye Norma Jean') }; + ok !$film, "It destroys itself"; +} + +SKIP: { + skip "Scalar::Util::weaken not available", 3 + #if !$Class::DBI::Weaken_Is_Available; + + # my bad taste is your bad taste + my $btaste = Film->retrieve('Bad Taste'); + my $btaste2 = Film->retrieve('Bad Taste'); + is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2), + "Retrieving twice gives ref to same object"; + + $btaste2->remove_from_object_index; + my $btaste3 = Film->retrieve('Bad Taste'); + isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste3), + "Removing from object_index and retrieving again gives new object"; + + $btaste3->clear_object_index; + my $btaste4 = Film->retrieve('Bad Taste'); + isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4), + "Clearing cache and retrieving again gives new object"; +} diff --git a/t/testlib/Actor.pm b/t/testlib/Actor.pm new file mode 100644 index 0000000..837b095 --- /dev/null +++ b/t/testlib/Actor.pm @@ -0,0 +1,29 @@ +package Actor; + +BEGIN { unshift @INC, './t/testlib'; } + +use strict; +use warnings; + +use base 'DBIx::Class::Test::SQLite'; + +__PACKAGE__->set_table('Actor'); + +__PACKAGE__->columns(Primary => 'id'); +__PACKAGE__->columns(All => qw/ Name Film Salary /); +__PACKAGE__->columns(TEMP => qw/ nonpersistent /); +__PACKAGE__->add_constructor(salary_between => 'salary >= ? AND salary <= ?'); + +sub mutator_name { "set_$_[1]" } + +sub create_sql { + return qq{ + id INTEGER PRIMARY KEY, + name CHAR(40), + film VARCHAR(255), + salary INT + } +} + +1; + diff --git a/t/testlib/Binary.pm b/t/testlib/Binary.pm new file mode 100644 index 0000000..d29849f --- /dev/null +++ b/t/testlib/Binary.pm @@ -0,0 +1,17 @@ +package Binary; + +BEGIN { unshift @INC, './t/testlib'; } + +use strict; +use base 'PgBase'; + +__PACKAGE__->table(cdbibintest => 'cdbibintest'); +__PACKAGE__->sequence('binseq'); +__PACKAGE__->columns(All => qw(id bin)); + +# __PACKAGE__->data_type(bin => DBI::SQL_BINARY); + +sub schema { "id INTEGER, bin BYTEA" } + +1; + diff --git a/t/testlib/Blurb.pm b/t/testlib/Blurb.pm new file mode 100644 index 0000000..8173cb8 --- /dev/null +++ b/t/testlib/Blurb.pm @@ -0,0 +1,20 @@ +package Blurb; + +BEGIN { unshift @INC, './t/testlib'; } + +use strict; +use base 'DBIx::Class::Test::SQLite'; + +__PACKAGE__->set_table('Blurbs'); +__PACKAGE__->columns('Primary', 'Title'); +__PACKAGE__->columns('Blurb', qw/ blurb/); + +sub create_sql { + return qq{ + title VARCHAR(255) PRIMARY KEY, + blurb VARCHAR(255) NOT NULL + } +} + +1; + diff --git a/t/testlib/CDBase.pm b/t/testlib/CDBase.pm new file mode 100644 index 0000000..0a9ecc0 --- /dev/null +++ b/t/testlib/CDBase.pm @@ -0,0 +1,14 @@ +package CDBase; + +use strict; +use base qw(DBIx::Class); + +use File::Temp qw/tempfile/; +my (undef, $DB) = tempfile(); +my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1 }); + +END { unlink $DB if -e $DB } + +__PACKAGE__->connection(@DSN); + +1; diff --git a/t/testlib/Director.pm b/t/testlib/Director.pm new file mode 100644 index 0000000..aa13661 --- /dev/null +++ b/t/testlib/Director.pm @@ -0,0 +1,20 @@ +package Director; + +BEGIN { unshift @INC, './t/testlib'; } + +use strict; +use base 'DBIx::Class::Test::SQLite'; + +__PACKAGE__->set_table('Directors'); +__PACKAGE__->columns('All' => qw/ Name Birthday IsInsane /); + +sub create_sql { + return qq{ + name VARCHAR(80), + birthday INTEGER, + isinsane INTEGER + }; +} + +1; + diff --git a/t/testlib/Film.pm b/t/testlib/Film.pm new file mode 100644 index 0000000..6747656 --- /dev/null +++ b/t/testlib/Film.pm @@ -0,0 +1,39 @@ +package Film; + +BEGIN { unshift @INC, './t/testlib'; } +use base 'DBIx::Class::Test::SQLite'; +use strict; + +__PACKAGE__->set_table('Movies'); +__PACKAGE__->columns('Primary', 'Title'); +__PACKAGE__->columns('Essential', qw( Title )); +__PACKAGE__->columns('Directors', qw( Director CoDirector )); +__PACKAGE__->columns('Other', qw( Rating NumExplodingSheep HasVomit )); + +sub create_sql { + return qq{ + title VARCHAR(255), + director VARCHAR(80), + codirector VARCHAR(80), + rating CHAR(5), + numexplodingsheep INTEGER, + hasvomit CHAR(1) + } +} + +sub create_test_film { + return shift->create({ + Title => 'Bad Taste', + Director => 'Peter Jackson', + Rating => 'R', + NumExplodingSheep => 1, + }); +} + +package DeletingFilm; + +use base 'Film'; +sub DESTROY { shift->delete } + +1; + diff --git a/t/testlib/Lazy.pm b/t/testlib/Lazy.pm new file mode 100644 index 0000000..74dc069 --- /dev/null +++ b/t/testlib/Lazy.pm @@ -0,0 +1,26 @@ +package Lazy; + +BEGIN { unshift @INC, './t/testlib'; } +use base 'DBIx::Class::Test::SQLite'; +use strict; + +__PACKAGE__->set_table("Lazy"); +__PACKAGE__->columns('Primary', qw(this)); +__PACKAGE__->columns('Essential', qw(opop)); +__PACKAGE__->columns('things', qw(this that)); +__PACKAGE__->columns('horizon', qw(eep orp)); +__PACKAGE__->columns('vertical', qw(oop opop)); + +sub create_sql { + return qq{ + this INTEGER, + that INTEGER, + eep INTEGER, + orp INTEGER, + oop INTEGER, + opop INTEGER + }; +} + +1; + diff --git a/t/testlib/Log.pm b/t/testlib/Log.pm new file mode 100644 index 0000000..af4c6f6 --- /dev/null +++ b/t/testlib/Log.pm @@ -0,0 +1,35 @@ +package Log; + +BEGIN { unshift @INC, './t/testlib'; } +use base 'MyBase'; + +use strict; +use Time::Piece::MySQL; +use POSIX; + +__PACKAGE__->set_table(); +__PACKAGE__->columns(All => qw/id message datetime_stamp/); +__PACKAGE__->has_a( + datetime_stamp => 'Time::Piece', + inflate => 'from_mysql_datetime', + deflate => 'mysql_datetime' +); + +__PACKAGE__->add_trigger(before_create => \&set_dts); +__PACKAGE__->add_trigger(before_update => \&set_dts); + +sub set_dts { + shift->datetime_stamp( + POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime(time))); +} + +sub create_sql { + return qq{ + id INT UNSIGNED AUTO_INCREMENT PRIMARY KEY, + message VARCHAR(255), + datetime_stamp DATETIME + }; +} + +1; + diff --git a/t/testlib/MyBase.pm b/t/testlib/MyBase.pm new file mode 100644 index 0000000..4950087 --- /dev/null +++ b/t/testlib/MyBase.pm @@ -0,0 +1,44 @@ +package MyBase; + +use strict; +use base qw(DBIx::Class); + +use vars qw/$dbh/; + +my @connect = ("dbi:mysql:test", "", ""); + +$dbh = DBI->connect(@connect) or die DBI->errstr; +my @table; + +END { $dbh->do("DROP TABLE $_") foreach @table } + +__PACKAGE__->connection(@connect); + +sub set_table { + my $class = shift; + $class->table($class->create_test_table); +} + +sub create_test_table { + my $self = shift; + my $table = $self->next_available_table; + my $create = sprintf "CREATE TABLE $table ( %s )", $self->create_sql; + push @table, $table; + $dbh->do($create); + return $table; +} + +sub next_available_table { + my $self = shift; + my @tables = sort @{ + $dbh->selectcol_arrayref( + qq{ + SHOW TABLES + } + ) + }; + my $table = $tables[-1] || "aaa"; + return "z$table"; +} + +1; diff --git a/t/testlib/MyFilm.pm b/t/testlib/MyFilm.pm new file mode 100644 index 0000000..676a4a9 --- /dev/null +++ b/t/testlib/MyFilm.pm @@ -0,0 +1,26 @@ +package MyFilm; + +BEGIN { unshift @INC, './t/testlib'; } +use base 'MyBase'; +use MyStarLink; + +use strict; + +__PACKAGE__->set_table(); +__PACKAGE__->columns(All => qw/filmid title/); +__PACKAGE__->has_many(_stars => 'MyStarLink'); +__PACKAGE__->columns(Stringify => 'title'); + +sub _carp { } + +sub stars { map $_->star, shift->_stars } + +sub create_sql { + return qq{ + filmid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, + title VARCHAR(255) + }; +} + +1; + diff --git a/t/testlib/MyFoo.pm b/t/testlib/MyFoo.pm new file mode 100644 index 0000000..4ed37d8 --- /dev/null +++ b/t/testlib/MyFoo.pm @@ -0,0 +1,27 @@ +package MyFoo; + +BEGIN { unshift @INC, './t/testlib'; } +use base 'MyBase'; + +use strict; + +__PACKAGE__->set_table(); +__PACKAGE__->columns(All => qw/myid name val tdate/); +__PACKAGE__->has_a( + tdate => 'Date::Simple', + inflate => sub { Date::Simple->new(shift) }, + deflate => 'format', +); +__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)"); + +sub create_sql { + return qq{ + myid mediumint not null auto_increment primary key, + name varchar(50) not null default '', + val char(1) default 'A', + tdate date not null + }; +} + +1; + diff --git a/t/testlib/MyStar.pm b/t/testlib/MyStar.pm new file mode 100644 index 0000000..e8e79b2 --- /dev/null +++ b/t/testlib/MyStar.pm @@ -0,0 +1,22 @@ +package MyStar; + +BEGIN { unshift @INC, './t/testlib'; } +use base 'MyBase'; + +use strict; + +__PACKAGE__->set_table(); +__PACKAGE__->columns(All => qw/starid name/); +__PACKAGE__->has_many(films => [ MyStarLink => 'film' ]); + +# sub films { map $_->film, shift->_films } + +sub create_sql { + return qq{ + starid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, + name VARCHAR(255) + }; +} + +1; + diff --git a/t/testlib/MyStarLink.pm b/t/testlib/MyStarLink.pm new file mode 100644 index 0000000..fe31e25 --- /dev/null +++ b/t/testlib/MyStarLink.pm @@ -0,0 +1,22 @@ +package MyStarLink; + +BEGIN { unshift @INC, './t/testlib'; } +use base 'MyBase'; + +use strict; + +__PACKAGE__->set_table(); +__PACKAGE__->columns(All => qw/linkid film star/); +__PACKAGE__->has_a(film => 'MyFilm'); +__PACKAGE__->has_a(star => 'MyStar'); + +sub create_sql { + return qq{ + linkid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, + film TINYINT NOT NULL, + star TINYINT NOT NULL + }; +} + +1; + diff --git a/t/testlib/MyStarLinkMCPK.pm b/t/testlib/MyStarLinkMCPK.pm new file mode 100644 index 0000000..f81292f --- /dev/null +++ b/t/testlib/MyStarLinkMCPK.pm @@ -0,0 +1,29 @@ +package MyStarLinkMCPK; + +BEGIN { unshift @INC, './t/testlib'; } +use base 'MyBase'; + +use MyStar; +use MyFilm; + +use strict; + +# This is a many-to-many mapping table that uses the two foreign keys +# as its own primary key - there's no extra 'auto-inc' column here + +__PACKAGE__->set_table(); +__PACKAGE__->columns(Primary => qw/film star/); +__PACKAGE__->columns(All => qw/film star/); +__PACKAGE__->has_a(film => 'MyFilm'); +__PACKAGE__->has_a(star => 'MyStar'); + +sub create_sql { + return qq{ + film INTEGER NOT NULL, + star INTEGER NOT NULL, + PRIMARY KEY (film, star) + }; +} + +1; + diff --git a/t/testlib/Order.pm b/t/testlib/Order.pm new file mode 100644 index 0000000..a48a135 --- /dev/null +++ b/t/testlib/Order.pm @@ -0,0 +1,21 @@ +package Order; + +BEGIN { unshift @INC, './t/testlib'; } + +use strict; +use base 'DBIx::Class::Test::SQLite'; + +__PACKAGE__->set_table('orders'); +__PACKAGE__->table_alias('orders'); +__PACKAGE__->columns(Primary => 'film'); +__PACKAGE__->columns(Others => qw/orders/); + +sub create_sql { + return qq{ + film VARCHAR(255), + orders INTEGER + }; +} + +1; + diff --git a/t/testlib/OtherFilm.pm b/t/testlib/OtherFilm.pm new file mode 100644 index 0000000..2e78316 --- /dev/null +++ b/t/testlib/OtherFilm.pm @@ -0,0 +1,20 @@ +package OtherFilm; + +use strict; +use base 'Film'; + +__PACKAGE__->set_table('Different_Film'); + +sub create_sql { + return qq{ + title VARCHAR(255), + director VARCHAR(80), + codirector VARCHAR(80), + rating CHAR(5), + numexplodingsheep INTEGER, + hasvomit CHAR(1) + }; +} + +1; + diff --git a/t/testlib/PgBase.pm b/t/testlib/PgBase.pm new file mode 100644 index 0000000..c75773b --- /dev/null +++ b/t/testlib/PgBase.pm @@ -0,0 +1,22 @@ +package PgBase; + +use strict; +use base 'DBIx::Class'; + +my $db = $ENV{DBD_PG_DBNAME} || 'template1'; +my $user = $ENV{DBD_PG_USER} || 'postgres'; +my $pass = $ENV{DBD_PG_PASSWD} || ''; + +__PACKAGE__->connection("dbi:Pg:dbname=$db", $user, $pass, + { AutoCommit => 1 }); + +sub CONSTRUCT { + my $class = shift; + my ($table, $sequence) = ($class->table, $class->sequence || ""); + my $schema = $class->schema; + $class->db_Main->do("CREATE TEMPORARY SEQUENCE $sequence") if $sequence; + $class->db_Main->do("CREATE TEMPORARY TABLE $table ( $schema )"); +} + +1; +