New tool for creating db migration scripts

* update/mkdbmig: New file.

1 files changed, 309 insertions, 0 deletions

diff --git a/update/mkdbmig b/update/mkdbmig
new file mode 100755
index 0000000..19eff3a
--- /dev/null
+++ b/update/mkdbmig
@@ -0,0 +1,309 @@
+eval '(exit $?0)' && eval 'exec perl -wS "$0" "$@"'
+      & eval 'exec perl -wS "$0" $argv:q'
+    if 0;
+
+use strict;
+use warnings;
+use Getopt::Long qw(:config gnu_getopt no_ignore_case);
+use Savane;
+use File::Basename;
+use Pod::Usage;
+use Pod::Man;
+use Data::Dumper;
+
+my $progname = basename($0);
+my $progdescr = 'Create database migration script';
+my $directory;
+my $split;
+my $output;
+
+sub open_output {
+    my $name = shift;
+    open(my $fd, '>', $name)
+	or die "can't open output file $name: $!";
+    select($fd);
+}
+
+sub open_split_output {
+    my $table = shift;
+
+    return unless $split;
+    my $name = $output;
+    $name =~ s/%T/$table/g;
+    open_output($name);
+}
+
+sub close_split_output {
+    return unless $split;
+    close(select(STDOUT));
+}
+
+my $table;
+my @commit_range;
+my @create;
+my @remlines;
+my @addlines;
+my %addidx;
+
+sub table_start {
+    $table = shift;
+}
+
+sub qualcmp {
+    my ($a, $b) = @_;
+    if (defined($a)) {
+	return $a eq $b if defined($b);
+    } elsif (!defined($b)) {
+	return 1;
+    }
+    return 0;
+}
+
+sub table_forget {
+    $table = undef;
+    @commit_range = ();
+    @create = ();
+    @remlines = ();
+    @addlines = ();
+    %addidx = ();
+}    
+
+sub alter_table {
+    foreach my $line (@remlines) {
+	if (exists($addidx{$line->{name}})
+	    && $addlines[$addidx{$line->{name}}]->{obj} eq $line->{obj}
+	    && $addlines[$addidx{$line->{name}}]->{defn} eq $line->{defn}
+	    && qualcmp($addlines[$addidx{$line->{name}}]->{qual},
+		       $line->{qual})) {
+	    # skip
+	    splice @addlines, $addidx{$line->{name}}, 1;
+	    delete $addidx{$line->{name}};
+	    next;
+	}
+	
+	print "ALTER TABLE $table ";
+	if ($line->{obj} eq 'COLUMN'
+	    && exists($addidx{$line->{name}})
+	    && $addlines[$addidx{$line->{name}}]->{obj} eq $line->{obj}) {
+	    print "CHANGE COLUMN $line->{name} ";
+	    print "$line->{name} $addlines[$addidx{$line->{name}}]->{defn}";
+	    splice @addlines, $addidx{$line->{name}}, 1;
+	    delete $addidx{$line->{name}};
+	} else {
+	    print "DROP $line->{obj} $line->{name}";
+	}
+	print ";\n";
+    }
+
+    foreach my $line (@addlines) {
+	print "ALTER TABLE $table ADD ";
+	if ($line->{qual}) {
+	    print "$line->{qual} ";
+	}
+	print "$line->{obj} $line->{name} $line->{defn}";
+	if ($line->{obj} eq 'COLUMN') {
+	    if (defined($line->{anchor})) {
+		print " AFTER $line->{anchor}";
+	    } else {
+		print " FIRST";
+	    }
+	}
+	print ";\n";	
+    }
+    print "\n";
+}    
+
+sub table_end {
+    return unless defined $table;
+#    print Dumper([$table, \@remlines, \@addlines, \%addidx]);
+
+    open_split_output($table);
+    print "-- Changes in table $table";
+    if (@commit_range == 2) {
+	print " between commits $commit_range[0]..$commit_range[1]";
+    } elsif (@commit_range == 1) {
+	print " since commit $commit_range[0]";
+    }
+    print "\n";
+
+    if (@create) {
+	for (@create) {
+	    print "$_\n";
+	}
+	print "\n";
+    } else {
+	alter_table();
+    }
+    
+    close_split_output();
+
+    table_forget();
+}
+
+my $rx = q{(?:(?:(?:(?<qual>PRIMARY|UNIQUE)\s+)?(?<obj>KEY)\s+)?(?<name>\S+)\s+(?<defn>.*?))};
+
+my $hexrx = q{[0-9a-fA-F]+};
+
+sub git_diff {
+    open(my $fd, '-|', "git diff -p -D @_")
+	or die "can't run git: $!";
+    my $anchor;
+    
+    while (<$fd>) {
+	chomp;
+#	print STDERR "> $_\n";
+
+	if (m{^diff --git}) {
+	    table_end();
+	    $anchor = undef;
+	}
+	
+	if (m{^diff --git a/(?:\S+/)?table_(\S+)\.structure\s}) {
+	    table_start($1);
+	} elsif ($table) {
+	    if (/^deleted file/) {
+		push @create, "DROP TABLE IF EXISTS $table;";
+	    } elsif (/^index (${hexrx})\.\.(${hexrx})/) {
+		push @commit_range, $1;
+		push @commit_range, $2 unless $2 =~ /^0+$/;
+	    } elsif (/^\+(DROP TABLE.*)$/) {
+		push @create, $1;
+	    } elsif (/^\+(CREATE TABLE (.*))$/) {
+		push @create, $1;
+	    } elsif (@create) {
+		if (/^\+(.*)$/) {
+		    push @create, $1;
+		} elsif (/^\-/) {
+		    warn "$table: unhandled input line: $_";
+		    table_forget();
+		}
+	    } elsif (/^-\s+$rx,?$/) {
+		push @remlines, {
+		    obj => $+{obj} || 'COLUMN',
+		    qual => $+{qual},
+		    name => $+{name},
+		    defn => $+{defn}
+		};
+	    } elsif (/^\+\s+$rx,?$/) {
+		my %d = (
+		    obj => $+{obj} || 'COLUMN',
+		    qual => $+{qual},
+		    name => $+{name},
+		    defn => $+{defn}
+		);
+		if ($d{obj} eq 'COLUMN') {
+		    if (defined($anchor)) {
+			$d{anchor} = $anchor;
+		    }
+		    $anchor = $+{name};
+		}
+		push @addlines, \%d;
+		$addidx{$+{name}} = $#addlines;
+	    } elsif (/^\s*$rx,?$/) {
+		if (!defined($+{obj})) {
+		    $anchor = $+{name};
+		}
+	    } elsif (/^[-+]\s*\)/ || /^[-+]--/ || /^[-+]?\s*$/) {
+		next;
+	    } else {
+		print STDERR "warning: unhandled line: $_\n";
+	    }
+	}
+    }
+    close($fd);
+    table_end();
+}
+
+GetOptions("h" => sub {
+               pod2usage(-message => "$progname: $progdescr",
+			 -exitstatus => 0);
+           },
+           "help" => sub {
+	       pod2usage(-exitstatus => 0, -verbose => 2);
+           },
+           "usage" => sub {
+	       pod2usage(-exitstatus => 0, -verbose => 0);
+           },
+	   "directory|C=s" => \$directory,
+	   "split" => \$split,
+	   "output|o=s" => \$output
+    ) or exit(1);
+
+if ($directory) {
+    chdir $directory
+	or die "can't change to $directory: $!";
+}
+
+if ($split) {
+    $output = '%T.sql' unless defined($output);
+    die "--output argument must contain %T" unless $output =~ /%T/;
+} elsif ($output) {
+    open_output($output) unless $split;
+}
+
+git_diff(@ARGV);
+
+=head1 NAME
+
+mkdbmig - create migration script for Savane database
+
+=head1 SYNOPSIS
+
+B<mkdbmig>
+[B<-h>]
+[B<-C> I<DIR>]
+[B<-o> I<NAME>]
+[B<--directory=>I<DIR>]
+[B<--help>]
+[B<--output=>I<NAME>]
+[B<--split>]
+[B<--usage>]
+[I<COMMIT>]    
+
+=head1 DESCRIPTION
+
+Creates a sequence of B<ALTER TABLE> commands for the given range of commits.
+It works by running B<git diff> and analyzing its output. To siplify the logic
+of the program, Savane file layout is assumed, where the structure for each
+table is saved in file B<table_>I<tabname>B<.structure>.
+
+By default, commands are printed to the standard output. This can be changed
+using the B<--output> and B<--split> options.    
+    
+=head1 OPTIONS
+
+=over 4
+
+=item B<-C>, B<--directory=>I<DIR>
+
+Change to the directory I<DIR> prior to starting operation.
+    
+=item B<-o>, B<--output=>I<NAME>
+
+Write output to file I<NAME>.
+
+=item B<--split>
+
+Write commands for each table into a separate file. The name of the file
+is derived from the argument to B<--output>, by replacing the sequence B<%T>
+with the name of the table. In the absence of the B<--output> option, B<%T.sql>
+is assumed.    
+
+=item B<-h>
+
+=item B<--help>
+
+=item B<--usage>
+
+=back    
+
+=head1 BUGS
+
+Supports a limited set of table modifications: deletion, addition and
+modification of table columns and keys.
+    
+=cut
+
+# Local variables:
+# mode: perl
+# End: