From: Matt S Trout <mst@shadowcat.co.uk>
Date: Tue, 19 Jul 2005 10:07:29 +0000 (+0000)
Subject: Initial commit of DBIx::Class (experimental Class::DBI-inspired ORM)
X-Git-Tag: v0.03001~144
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ea2e61bf;p=dbsrgits%2FDBIx-Class.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;
+