added support for migrations

Changes

@@ -1,5 +1,7 @@
 
-0.04  2014-10-09
+0.04  2014-10-10
+  - Added support for migrations.
+  - Added Mojo::Pg::Migrations.
 
 0.03  2014-10-06
   - Improved non-blocking queries to be able to introspect the statement

lib/Mojo/Pg.pm

@@ -4,10 +4,17 @@ use Mojo::Base -base;
 use Carp 'croak';
 use DBI;
 use Mojo::Pg::Database;
+use Mojo::Pg::Migrations;
 use Mojo::URL;
+use Scalar::Util 'weaken';
 
 has dsn             => 'dbi:Pg:dbname=test';
 has max_connections => 5;
+has migrations      => sub {
+  my $migrations = Mojo::Pg::Migrations->new(pg => shift);
+  weaken $migrations->{pg};
+  return $migrations;
+};
 has options => sub { {AutoCommit => 1, PrintError => 0, RaiseError => 1} };
 has [qw(password username)] => '';
 
@@ -61,8 +68,9 @@ sub _dequeue {
 
 sub _enqueue {
   my ($self, $dbh) = @_;
-  push @{$self->{queue}}, $dbh if $dbh->{Active};
-  shift @{$self->{queue}} while @{$self->{queue}} > $self->max_connections;
+  my $queue = $self->{queue} ||= [];
+  push @$queue, $dbh if $dbh->{Active};
+  shift @$queue while @$queue > $self->max_connections;
 }
 
 1;
@@ -154,6 +162,13 @@ Data Source Name, defaults to C<dbi:Pg:dbname=test>.
 Maximum number of idle database handles to cache for future use, defaults to
 C<5>.
 
+=head2 migrations
+
+  my $migrations = $pg->migrations;
+  $pg            = $pg->migrations(Mojo::Pg::Migrations->new);
+
+L<Mojo::Pg::Migrations> object.
+
 =head2 options
 
   my $options = $pg->options;

lib/Mojo/Pg/Database.pm

@@ -23,6 +23,7 @@ sub commit { shift->dbh->commit }
 sub disconnect {
   my $self = shift;
   $self->_unwatch;
+  delete $self->{queue};
   $self->dbh->disconnect;
 }
 
@@ -34,9 +35,9 @@ sub listen {
   my ($self, $name) = @_;
 
   my $dbh = $self->dbh;
+  local $dbh->{AutoCommit} = 1;
   $dbh->do('listen ' . $dbh->quote_identifier($name))
     unless $self->{listen}{$name}++;
-  $dbh->commit unless $dbh->{AutoCommit};
   $self->_watch;
 
   return $self;
@@ -66,9 +67,9 @@ sub unlisten {
   my ($self, $name) = @_;
 
   my $dbh = $self->dbh;
+  local $dbh->{AutoCommit} = 1;
   $dbh->do('unlisten' . $dbh->quote_identifier($name));
   $name eq '*' ? delete($self->{listen}) : delete($self->{listen}{$name});
-  $dbh->commit unless $dbh->{AutoCommit};
   $self->_unwatch unless $self->backlog || $self->is_listening;
 
   return $self;

lib/Mojo/Pg/Migrations.pm

@@ -0,0 +1,187 @@
+package Mojo::Pg::Migrations;
+use Mojo::Base -base;
+
+use Carp 'croak';
+use Mojo::Loader;
+use Mojo::Util 'slurp';
+
+has name => 'migrations';
+has 'pg';
+
+sub active { $_[0]->_active($_[0]->pg->db) }
+
+sub from_class {
+  my ($self, $class) = @_;
+  $class //= caller;
+  return $self->from_string(Mojo::Loader->new->data($class, $self->name));
+}
+
+sub from_file { shift->from_string(slurp pop) }
+
+sub from_string {
+  my ($self, $sql) = @_;
+
+  my ($version, $way);
+  my $migrations = $self->{migrations} = {up => {}, down => {}};
+  for my $line (split "\n", $sql // '') {
+    ($version, $way) = ($1, lc $2) if $line =~ /^\s*--\s*(\d+)\s*(up|down)/i;
+    $migrations->{$way}{$version} .= "$line\n" if $version;
+  }
+
+  return $self;
+}
+
+sub latest { (sort keys %{shift->{migrations}{up}})[-1] }
+
+sub migrate {
+  my ($self, $target) = @_;
+  $target //= $self->latest;
+
+  # Already the right version
+  my $db = $self->pg->db;
+  return $self if (my $active = $self->_active($db)) == $target;
+
+  # Unknown version
+  my $up = $self->{migrations}{up};
+  croak "Version $target has no migration" if $target != 0 && !$up->{$target};
+
+  # Up
+  my $sql;
+  if ($active < $target) {
+    $sql = join '',
+      map { $up->{$_} } grep { $_ <= $target && $_ > $active } sort keys %$up;
+  }
+
+  # Down
+  else {
+    my $down = $self->{migrations}{down};
+    $sql = join '',
+      map { $down->{$_} }
+      grep { $_ > $target && $_ <= $active } reverse sort keys %$down;
+  }
+
+  local @{$db->dbh}{qw(RaiseError AutoCommit)} = (0, 1);
+  $sql .= ';update mojo_migrations set version = ? where name = ?;';
+  my $results = $db->begin->query($sql, $target, $self->name);
+  if ($results->sth->err) {
+    my $err = $results->sth->errstr;
+    $db->rollback;
+    croak $err;
+  }
+  $db->commit;
+
+  return $self;
+}
+
+sub _active {
+  my ($self, $db) = @_;
+
+  my $name = $self->name;
+  my $dbh  = $db->dbh;
+  local @$dbh{qw(AutoCommit RaiseError)} = (1, 0);
+  my $results
+    = $db->query('select version from mojo_migrations where name = ?', $name);
+  if (my $next = $results->array) { return $next->[0] }
+
+  local @$dbh{qw(AutoCommit RaiseError)} = (1, 1);
+  $db->query(
+    'create table if not exists mojo_migrations (
+       name    varchar(255),
+       version varchar(255)
+     );'
+  ) if $results->sth->err;
+  $db->query('insert into mojo_migrations values (?, ?);', $name, 0);
+
+  return 0;
+}
+
+1;
+
+=encoding utf8
+
+=head1 NAME
+
+Mojo::Pg::Migrations - Migrations
+
+=head1 SYNOPSIS
+
+  use Mojo::Pg::Migrations;
+
+  my $migrations = Mojo::Pg::Migrations->new(pg => $pg);
+
+=head1 DESCRIPTION
+
+L<Mojo::Pg::Migrations> performs database migrations for L<Mojo::Pg>.
+
+=head1 ATTRIBUTES
+
+L<Mojo::Pg::Migrations> implements the following attributes.
+
+=head2 name
+
+  my $name    = $migrations->name;
+  $migrations = $migrations->name('foo');
+
+Name for this set of migrations, defaults to C<migrations>.
+
+=head2 pg
+
+  my $pg      = $migrations->pg;
+  $migrations = $migrations->pg(Mojo::Pg->new);
+
+L<Mojo::Pg> object these migrations belong to.
+
+=head1 METHODS
+
+L<Mojo::Pg::Migrations> inherits all methods from L<Mojo::Base> and implements
+the following new ones.
+
+=head2 active
+
+  my $version = $migrations->active;
+
+Currently active version.
+
+=head2 from_class
+
+  $migrations = $migrations->from_class;
+  $migrations = $migrations->from_class('main');
+
+Extract migrations from a file in the DATA section of a class, defaults to
+using the caller class.
+
+=head2 from_file
+
+  $migrations = $migrations->from_file('/Users/sri/migrations.sql');
+
+Extract migrations from a file.
+
+=head2 from_string
+
+  $migrations = $migrations->from_string(
+    '-- 1 up
+     create table foo (bar varchar(255));
+     -- 1 down
+     drop table foo;'
+  );
+
+Extract migrations from string.
+
+=head2 latest
+
+  my $version = $migrations->latest;
+
+Latest version available.
+
+=head2 migrate
+
+  $migrations = $migrations->migrate;
+  $migrations = $migrations->migrate(3);
+
+Migrate to a different version, defaults to L</"latest">.
+
+=head1 SEE ALSO
+
+L<Mojo::Pg>, L<Mojolicious::Guides>, L<http://mojolicio.us>.
+
+=cut

t/migrations.t

@@ -0,0 +1,82 @@
+use Mojo::Base -strict;
+
+BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' }
+
+use Test::More;
+
+plan skip_all => 'set TEST_ONLINE to enable this test'
+  unless $ENV{TEST_ONLINE};
+
+use File::Spec::Functions 'catfile';
+use FindBin;
+use Mojo::Pg;
+
+my $pg = Mojo::Pg->new($ENV{TEST_ONLINE});
+
+# Different syntax variations
+$pg->migrations->from_string(<<EOF);
+-- 1 up
+create table if not exists migration_test_one (foo varchar(255));
+
+-- 1down
+
+  drop table if exists migration_test_one;
+
+  -- 2 up
+
+insert into migration_test_one values ('works');
+-- 2 down
+delete from migration_test_one where foo = 'works';
+--
+--  3 Up, create
+--        another
+--        table?
+create table if not exists migration_test_two (bar varchar(255));
+--3  DOWN
+drop table if exists migration_test_two;
+
+-- 4 up (not down)
+insert into migration_test_two values ('works too');
+-- 4 down (not up)
+delete from migration_test_two where bar = 'works too';
+EOF
+is $pg->migrations->latest, 4, 'latest version is 4';
+is $pg->migrations->active, 0, 'active version is 0';
+is $pg->migrations->migrate->active, 4, 'active version is 4';
+is_deeply $pg->db->query('select * from migration_test_one')->hash,
+  {foo => 'works'}, 'right structure';
+is $pg->migrations->migrate->active, 4, 'active version is 4';
+is $pg->migrations->migrate(1)->active, 1, 'active version is 1';
+is $pg->db->query('select * from migration_test_one')->hash, undef,
+  'no result';
+is $pg->migrations->migrate(3)->active, 3, 'active version is 3';
+is $pg->db->query('select * from migration_test_two')->hash, undef,
+  'no result';
+is $pg->migrations->migrate->active, 4, 'active version is 4';
+is_deeply $pg->db->query('select * from migration_test_two')->hash,
+  {bar => 'works too'}, 'right structure';
+is $pg->migrations->migrate(0)->active, 0, 'active version is 0';
+
+# Bad and concurrent migrations
+my $pg2 = Mojo::Pg->new($ENV{TEST_ONLINE});
+$pg2->migrations->name('migrations_test')
+  ->from_file(catfile($FindBin::Bin, 'migrations', 'test.sql'));
+is $pg2->migrations->latest, 3, 'latest version is 3';
+is $pg2->migrations->active, 0, 'active version is 0';
+eval { $pg2->migrations->migrate };
+like $@, qr/does_not_exist/, 'right error';
+is $pg2->migrations->migrate(2)->active, 2, 'active version is 2';
+is $pg->migrations->active, 0, 'active version is still 0';
+is $pg->migrations->migrate->active, 4, 'active version is 4';
+is_deeply [$pg2->db->query('select * from migration_test_three')->hashes->each
+], [{baz => 'just'}, {baz => 'works'}], 'right structure';
+is $pg->migrations->migrate(0)->active,  0, 'active version is 0';
+is $pg2->migrations->migrate(0)->active, 0, 'active version is 0';
+
+# Unknown version
+eval { $pg->migrations->migrate(23) };
+like $@, qr/Version 23 has no migration/, 'right error';
+
+$pg->db->do('drop table mojo_migrations');
+
+done_testing();

t/migrations/test.sql

@@ -0,0 +1,9 @@
+-- 1 up
+create table if not exists migration_test_three (baz varchar(255));
+-- 1 down
+drop table if exists migration_test_three;
+-- 2 up
+insert into migration_test_three values ('just');
+insert into migration_test_three values ('works');
+-- 3 up
+does_not_exist;

t/pg_lite_app.t

@@ -13,8 +13,7 @@ use Test::Mojo;
 
 helper pg => sub { state $pg = Mojo::Pg->new($ENV{TEST_ONLINE}) };
 
-app->pg->db->do('create table if not exists app_test (stuff varchar(255))')
-  ->do("insert into app_test values ('I ♥ Mojolicious!')");
+app->pg->migrations->name('app_test')->from_class->migrate;
 
 get '/blocking' => sub {
   my $c = shift;
@@ -39,6 +38,17 @@ $t->get_ok('/blocking')->status_is(200)->content_is('I ♥ Mojolicious!');
 
 # Non-blocking select
 $t->get_ok('/non-blocking')->status_is(200)->content_is('I ♥ Mojolicious!');
-$t->app->pg->db->do('drop table app_test');
+$t->app->pg->migrations->migrate(0);
 
 done_testing();
+
+__DATA__
+@@ app_test
+-- 1 up
+create table if not exists app_test (stuff varchar(255));
+
+-- 2 up
+insert into app_test values ('I ♥ Mojolicious!');
+
+-- 1 down
+drop table app_test;