Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Import into git.

  • Loading branch information...
commit 6567256c858283ee4561c4c18d038ced201b5353 0 parents
@dsully authored
18 Build.PL
@@ -0,0 +1,18 @@
+use strict;
+use Module::Build;
+
+my $build = Module::Build->new(
+ create_makefile_pl => 'passthrough',
+ license => 'perl',
+ module_name => 'DBIx::Migration',
+ requires => {
+ 'File::Slurp' => 0,
+ 'File::Spec' => 0,
+ 'DBI' => 0,
+ 'Class::Accessor::Fast' => 0
+ },
+ create_readme => 1,
+ script_files => [ glob('script/*') ],
+ test_files => [ glob('t/*.t') ]
+);
+$build->create_build_script;
20 Changes
@@ -0,0 +1,20 @@
+Tis file documents the revision history for Perl extension DBIx::Migration.
+
+0.05 2006-06-06 12:44:12 PDT 2006
+
+ - Fixed to work on Win32 (remove glob calls)
+ - Use 'name' instead of 'key' for the dbix_migration table, as 'key'
+ is a reserved word in many/most databases.
+
+0.04 2005-11-18 00:00:00
+ - Fixed multi-digit revisions (David Christensen)
+ - Added sql comment support
+
+0.03 2005-10-26 00:00:00
+ - Fixed the multiple sql statement bug
+
+0.02 2005-10-24 01:00:00
+ - default to newest version
+
+0.01 2005-10-24 00:00:00
+ - first release
16 MANIFEST
@@ -0,0 +1,16 @@
+Build.PL
+Changes
+lib/DBIx/Migration.pm
+MANIFEST This list of files
+script/dbix-migration.pl
+t/01use.t
+t/02pod.t
+t/03podcoverage.t
+t/04sqlite.t
+t/sql/sqlite_1_down.sql
+t/sql/sqlite_1_up.sql
+t/sql/sqlite_2_down.sql
+t/sql/sqlite_2_up.sql
+META.yml
+Makefile.PL
+README
17 META.yml
@@ -0,0 +1,17 @@
+---
+name: DBIx-Migration
+version: 0.05
+author:
+ - 'Sebastian Riedel, C<sri@oook.de>'
+abstract: 'Seamless DB schema up- and downgrades'
+license: perl
+requires:
+ Class::Accessor::Fast: 0
+ DBI: 0
+ File::Slurp: 0
+ File::Spec: 0
+provides:
+ DBIx::Migration:
+ file: lib/DBIx/Migration.pm
+ version: 0.05
+generated_by: Module::Build version 0.2611
31 Makefile.PL
@@ -0,0 +1,31 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+
+ unless (eval "use Module::Build::Compat 0.02; 1" ) {
+ print "This module requires Module::Build to install itself.\n";
+
+ require ExtUtils::MakeMaker;
+ my $yn = ExtUtils::MakeMaker::prompt
+ (' Install Module::Build now from CPAN?', 'y');
+
+ unless ($yn =~ /^y/i) {
+ die " *** Cannot install without Module::Build. Exiting ...\n";
+ }
+
+ require Cwd;
+ require File::Spec;
+ require CPAN;
+
+ # Save this 'cause CPAN will chdir all over the place.
+ my $cwd = Cwd::cwd();
+ my $makefile = File::Spec->rel2abs($0);
+
+ CPAN::Shell->install('Module::Build::Compat')
+ or die " *** Cannot install without Module::Build. Exiting ...\n";
+
+ chdir $cwd or die "Cannot chdir() back to $cwd: $!";
+ }
+ eval "use Module::Build::Compat 0.02; 1" or die $@;
+ use lib '_build/lib';
+ Module::Build::Compat->run_build_pl(args => \@ARGV);
+ require Module::Build;
+ Module::Build::Compat->write_makefile(build_class => 'Module::Build');
65 README
@@ -0,0 +1,65 @@
+NAME
+ DBIx::Migration - Seamless DB schema up- and downgrades
+
+SYNOPSIS
+ # migrate.pl
+ my $m = DBIx::Migration->new(
+ {
+ dsn => 'dbi:SQLite:/Users/sri/myapp/db/sqlite/myapp.db',
+ dir => '/Users/sri/myapp/db/sqlite'
+ }
+ );
+
+ my $version = $m->version; # Get current version from database
+ $m->migrate(2); # Migrate database to version 2
+
+ # /Users/sri/myapp/db/sqlite/schema_1_up.sql
+ CREATE TABLE foo (
+ id INTEGER PRIMARY KEY,
+ bar TEXT
+ );
+
+ # /Users/sri/myapp/db/sqlite/schema_1_down.sql
+ DROP TABLE foo;
+
+ # /Users/sri/myapp/db/sqlite/schema_2_up.sql
+ CREATE TABLE bar (
+ id INTEGER PRIMARY KEY,
+ baz TEXT
+ );
+
+ # /Users/sri/myapp/db/sqlite/schema_2_down.sql
+ DROP TABLE bar;
+
+DESCRIPTION
+ Seamless DB schema up- and downgrades.
+
+METHODS
+ $self->debug($debug)
+ Enable/Disable debug messages.
+
+ $self->dir($dir)
+ Get/Set directory.
+
+ $self->dsn($dsn)
+ Get/Set dsn.
+
+ $self->migrate($version)
+ Migrate database to version.
+
+ $self->password
+ Get/Set database password.
+
+ $self->username($username)
+ Get/Set database username.
+
+ $self->version
+ Get migration version from database.
+
+AUTHOR
+ Sebastian Riedel, "sri@oook.de"
+
+COPYRIGHT
+ This program is free software, you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
253 lib/DBIx/Migration.pm
@@ -0,0 +1,253 @@
+package DBIx::Migration;
+
+use strict;
+use base qw/Class::Accessor::Fast/;
+use DBI;
+use File::Slurp;
+use File::Spec;
+
+our $VERSION = '0.05';
+
+__PACKAGE__->mk_accessors(qw/debug dir dsn password username/);
+
+=head1 NAME
+
+DBIx::Migration - Seamless DB schema up- and downgrades
+
+=head1 SYNOPSIS
+
+ # migrate.pl
+ my $m = DBIx::Migration->new(
+ {
+ dsn => 'dbi:SQLite:/Users/sri/myapp/db/sqlite/myapp.db',
+ dir => '/Users/sri/myapp/db/sqlite'
+ }
+ );
+
+ my $version = $m->version; # Get current version from database
+ $m->migrate(2); # Migrate database to version 2
+
+ # /Users/sri/myapp/db/sqlite/schema_1_up.sql
+ CREATE TABLE foo (
+ id INTEGER PRIMARY KEY,
+ bar TEXT
+ );
+
+ # /Users/sri/myapp/db/sqlite/schema_1_down.sql
+ DROP TABLE foo;
+
+ # /Users/sri/myapp/db/sqlite/schema_2_up.sql
+ CREATE TABLE bar (
+ id INTEGER PRIMARY KEY,
+ baz TEXT
+ );
+
+ # /Users/sri/myapp/db/sqlite/schema_2_down.sql
+ DROP TABLE bar;
+
+=head1 DESCRIPTION
+
+Seamless DB schema up- and downgrades.
+
+=head1 METHODS
+
+=over 4
+
+=item $self->debug($debug)
+
+Enable/Disable debug messages.
+
+=item $self->dir($dir)
+
+Get/Set directory.
+
+=item $self->dsn($dsn)
+
+Get/Set dsn.
+
+=item $self->migrate($version)
+
+Migrate database to version.
+
+=cut
+
+sub migrate {
+ my ( $self, $wanted ) = @_;
+ $self->_connect;
+ $wanted = $self->_newest unless defined $wanted;
+ my $version = $self->_version;
+ if ( defined $version && ( $wanted eq $version ) ) {
+ print "Database is already at version $wanted\n" if $self->debug;
+ return 1;
+ }
+
+ unless ( defined $version ) {
+ $self->_create_migration_table;
+ $version = 0;
+ }
+
+ # Up- or downgrade
+ my @need;
+ my $type = 'down';
+ if ( $wanted > $version ) {
+ $type = 'up';
+ $version += 1;
+ @need = $version .. $wanted;
+ }
+ else {
+ $wanted += 1;
+ @need = reverse( $wanted .. $version );
+ }
+ my $files = $self->_files( $type, \@need );
+ if ( defined $files ) {
+ for my $file (@$files) {
+ my $name = $file->{name};
+ my $ver = $file->{version};
+ print qq/Processing "$name"\n/ if $self->debug;
+ next unless $file;
+ my $text = read_file($name);
+ $text =~ s/\s*--.*$//g;
+ for my $sql ( split /;/, $text ) {
+ next unless $sql =~ /\w/;
+ print "$sql\n" if $self->debug;
+ $self->{_dbh}->do($sql);
+ if ( $self->{_dbh}->err ) {
+ die "Database error: " . $self->{_dbh}->errstr;
+ }
+ }
+ $ver -= 1 if ( ( $ver > 0 ) && ( $type eq 'down' ) );
+ $self->_update_migration_table($ver);
+ }
+ }
+ else {
+ my $newver = $self->_version;
+ print "Database is at version $newver, couldn't migrate to $wanted\n"
+ if ( $self->debug && ( $wanted != $newver ) );
+ return 0;
+ }
+ $self->_disconnect;
+ return 1;
+}
+
+=item $self->password
+
+Get/Set database password.
+
+=item $self->username($username)
+
+Get/Set database username.
+
+=item $self->version
+
+Get migration version from database.
+
+=cut
+
+sub version {
+ my $self = shift;
+ $self->_connect;
+ my $version = $self->_version;
+ $self->_disconnect;
+ return $version;
+}
+
+sub _connect {
+ my $self = shift;
+ $self->{_dbh} = DBI->connect(
+ $self->dsn,
+ $self->username,
+ $self->password,
+ {
+ RaiseError => 0,
+ PrintError => 0,
+ AutoCommit => 1
+ }
+ )
+ or die qq/Couldn't connect to database, "$!"/;
+}
+
+sub _create_migration_table {
+ my $self = shift;
+ $self->{_dbh}->do(<<"EOF");
+CREATE TABLE dbix_migration (
+ name CHAR(64) PRIMARY KEY,
+ value CHAR(64)
+);
+EOF
+ $self->{_dbh}->do(<<"EOF");
+ INSERT INTO dbix_migration ( name, value ) VALUES ( 'version', '0' );
+EOF
+}
+
+sub _disconnect {
+ my $self = shift;
+ $self->{_dbh}->disconnect;
+}
+
+sub _files {
+ my ( $self, $type, $need ) = @_;
+ my @files;
+ for my $i (@$need) {
+ opendir(DIR, $self->dir) or die $!;
+ while (my $file = readdir(DIR)) {
+ next unless $file =~ /${i}_$type\.sql$/;
+ $file = File::Spec->catdir($self->dir, $file);
+ push @files, { name => $file, version => $i };
+ }
+ closedir(DIR);
+ }
+ return undef unless @$need == @files;
+ return @files ? \@files : undef;
+}
+
+sub _newest {
+ my $self = shift;
+ my $newest = 0;
+
+ opendir(DIR, $self->dir) or die $!;
+ while (my $file = readdir(DIR)) {
+ next unless $file =~ /_up\.sql$/;
+ $file =~ /\D*(\d+)_up.sql$/;
+ $newest = $1 if $1 > $newest;
+ }
+ closedir(DIR);
+
+ return $newest;
+}
+
+sub _update_migration_table {
+ my ( $self, $version ) = @_;
+ $self->{_dbh}->do(<<"EOF");
+UPDATE dbix_migration SET value = '$version' WHERE name = 'version';
+EOF
+}
+
+sub _version {
+ my $self = shift;
+ my $version = undef;
+ eval {
+ my $sth = $self->{_dbh}->prepare(<<"EOF");
+SELECT value FROM dbix_migration WHERE name = ?;
+EOF
+ $sth->execute('version');
+ for my $val ( $sth->fetchrow_arrayref ) {
+ $version = $val->[0];
+ }
+ };
+ return $version;
+}
+
+=back
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@oook.de>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
90 script/dbix-migration.pl
@@ -0,0 +1,90 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Getopt::Long;
+use Pod::Usage;
+use DBIx::Migration;
+
+my $debug = 0;
+my $help = 0;
+my ( $username, $password );
+
+GetOptions(
+ 'debug' => \$debug,
+ 'help|?' => \$help,
+ 'password=s' => \$password,
+ 'username=s' => \$username
+);
+pod2usage(1) if ( $help || !$ARGV[0] );
+
+unless ( $ARGV[1] ) {
+ my $m = DBIx::Migration->new(
+ {
+ debug => $debug,
+ dsn => $ARGV[0],
+ password => $password,
+ username => $username
+ }
+ );
+ my $version = $m->version;
+ if ( defined $version ) { print "Database is at version $version\n" }
+ else { print "Database is not yet under DBIx::Migration management\n" }
+ exit;
+}
+
+pod2usage(1) if !$ARGV[1];
+
+my $m = DBIx::Migration->new(
+ {
+ debug => $debug,
+ dsn => $ARGV[0],
+ dir => $ARGV[1],
+ password => $password,
+ username => $username
+ }
+);
+$m->migrate( $ARGV[2] );
+
+1;
+__END__
+
+=head1 NAME
+
+dbix-migration - Seamless DB up- and downgrades
+
+=head1 SYNOPSIS
+
+dbix-migration.pl [options] dsn [directory version]
+
+ Options:
+ -debug enable debug messages
+ -help display this help and exits
+ -password database password
+ -username database username
+
+ Examples:
+ dbix-migration.pl dbi:SQLite:/some/dir/myapp.db
+ dbix-migration.pl dbi:SQLite:/some/dir/myapp.db/some/dir
+ dbix-migration.pl dbi:SQLite:/some/dir/myapp.db/some/dir 23
+
+=head1 DESCRIPTION
+
+Seamless DB up- and downgrades.
+
+=head1 SEE ALSO
+
+L<DBIx::Migration>
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@oook.de>
+
+=head1 COPYRIGHT
+
+Copyright 2004-2005 Sebastian Riedel. All rights reserved.
+
+This library is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
3  t/01use.t
@@ -0,0 +1,3 @@
+use Test::More tests => 1;
+
+use_ok('DBIx::Migration');
7 t/02pod.t
@@ -0,0 +1,7 @@
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => 'Test::Pod 1.14 required' if $@;
+plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
+
+all_pod_files_ok();
7 t/03podcoverage.t
@@ -0,0 +1,7 @@
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
+plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
+
+all_pod_coverage_ok();
35 t/04sqlite.t
@@ -0,0 +1,35 @@
+use strict;
+use Test::More tests => 7;
+
+use DBIx::Migration;
+use DBI;
+
+eval { require DBD::SQLite };
+my $class = $@ ? 'SQLite2' : 'SQLite';
+
+my $m = DBIx::Migration->new;
+$m->dsn("dbi:$class:dbname=./t/sqlite_test");
+$m->dir('./t/sql/');
+is( $m->version, undef );
+
+$m->migrate(1);
+is( $m->version, 1 );
+
+$m->migrate(2);
+is( $m->version, 2 );
+
+$m->migrate(1);
+is( $m->version, 1 );
+
+$m->migrate(0);
+is( $m->version, 0 );
+
+$m->migrate(2);
+is( $m->version, 2 );
+
+$m->migrate(0);
+is( $m->version, 0 );
+
+END {
+ unlink './t/sqlite_test';
+}
3  t/sql/sqlite_1_down.sql
@@ -0,0 +1,3 @@
+DROP TABLE test1;
+
+DROP TABLE test2;
12 t/sql/sqlite_1_up.sql
@@ -0,0 +1,12 @@
+create table test1 (
+ id INTEGER PRIMARY KEY,
+ something TEXT -- test1
+);
+
+-- test2
+-- test3
+create table test2 (
+ id INTEGER PRIMARY KEY, -- test4
+ -- test5
+ something TEXT
+);
1  t/sql/sqlite_2_down.sql
@@ -0,0 +1 @@
+DROP TABLE test3;
4 t/sql/sqlite_2_up.sql
@@ -0,0 +1,4 @@
+create table test3 (
+ id INTEGER PRIMARY KEY,
+ something TEXT
+);
Please sign in to comment.
Something went wrong with that request. Please try again.