From: Jan Henning Thorsen <jhthorsen@cpan.org>
Date: Thu, 12 Aug 2010 17:59:16 +0000 (+0200)
Subject: add Admin::Diff
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fpeople%2Fbatman%2Fschema_diff;p=dbsrgits%2FDBIx-Class.git

add Admin::Diff

This is copy/paste from: http://github.com/jhthorsen/dbix-class-schema-diff
---

diff --git a/lib/DBIx/Class/Admin/Diff.pm b/lib/DBIx/Class/Admin/Diff.pm
new file mode 100644
index 0000000..f2aafa2
--- /dev/null
+++ b/lib/DBIx/Class/Admin/Diff.pm
@@ -0,0 +1,204 @@
+package DBIx::Class::Admin::Diff;
+
+=head1 NAME
+
+DBIx::Class::Admin::Diff - Diff two schemas, regardless of version numbers
+
+=head1 DESCRIPTION
+
+    Is there a project which can check out two tags/commits from
+    git and make a diff between the two schemas? So instead of
+    having the version information in the database, I would like
+    to A) make a diff between database and the current checked out
+    version from the repo B) make a diff between two git-versions.
+
+=head1 SYNOPSIS
+
+From a module:
+
+    use DBIx::Class::Admin::Diff;
+
+    my $diff = DBIx::Class::Admin::Diff->new(
+                    from => $dsn,
+                    to => 'MyApp::Schema',
+                    databases => ['SQLite'],
+                );
+
+    # write "diff", "to" and "from" to disk
+    $diff->diff_ddl($directory);
+    $diff->to_ddl($directory);
+    $diff->from_ddl($directory);
+
+Using the script:
+
+    $ dbicadmin \
+        --from 'DBI:SQLite:t/db/one.sqlite' \
+        --to 'dbi:Pg:dbname=somedatabase&user&pass' \
+        --write-from \
+        --write-to \
+        --output - \
+        ;
+
+=cut
+
+use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class;
+use SQL::Translator::Diff;
+use DBIx::Class::Admin::Types qw/ DiffSource /;
+use Moose;
+
+=head1 ATTRIBUTES
+
+=head2 from
+
+Any source (module name, dbh or dsn) which has the old version of the schema.
+This attribute can coerce. See L<DBIx::Class::Schema::Diff::Types> for details.
+
+=cut
+
+has from => (
+    is => 'ro',
+    isa => DiffSource,
+    coerce => 1,
+    documentation => 'Source with old schema information (module name or dsn)',
+);
+
+=head2 to
+
+Any source (module name, dbh or dsn) which has the new version of the schema.
+This attribute can coerce. See L<DBIx::Class::Schema::Diff::Types> for details.
+
+=cut
+
+has to => (
+    is => 'ro',
+    isa => DiffSource,
+    coerce => 1,
+    documentation => 'Source with new schema information (module name or dsn)',
+);
+
+=head2 databases
+
+Which SQL language the output files should be in.
+
+=cut
+
+has databases => (
+    is => 'rw',
+    isa => 'ArrayRef',
+    documentation => 'MySQL, SQLite, PostgreSQL, ....',
+    default => sub { ['SQLite'] },
+);
+
+=head1 METHODS
+
+=head2 diff_ddl
+
+    $bool = $self->diff_ddl($directory, \%args);
+    $bool = $self->diff_ddl(\$text, \%args);
+
+Will write the diff (one file per each type in L</databases>) between
+L</from> and L</to> to a selected C<$directory>. C<%args> is passed
+on to L<SQL::Translator::Diff::new()>, but "output_db", "source_schema"
+and "target_schema" is set by this method.
+
+Will write DDL to C<$text> if given as a scalar reference. (This might
+not make much sense, if you have more than one type defined in
+L</databases>).
+
+=cut
+
+sub diff_ddl {
+    my $self = shift;
+    my $directory = shift;
+    my $args = shift || {};
+    my $from = $self->from;
+    my $to = $self->to;
+    my @tmp_files;
+
+    if($to->version == $from->version) {
+        return;
+    }
+
+    for my $db (@{ $self->databases }) {
+        my $file = ref $directory eq 'SCALAR' ? $directory : $to->filename($directory, $from->version);
+        my($diff_obj, $diff_text);
+
+        SOURCE:
+        for my $source ($from, $to) {
+            my $old_producer = $source->producer;
+
+            $source->producer($db);
+            $source->reset;
+            $source->translate;
+            $source->producer($old_producer);
+        }
+
+        $diff_obj = SQL::Translator::Diff->new({
+                        %$args,
+                        output_db => $db,
+                        source_schema => $self->from->schema,
+                        target_schema => $self->to->schema,
+                    });
+
+        $diff_text = $diff_obj->compute_differences->produce_diff_sql;
+        open my $DIFF, '>', $file or croak "Failed to open diff file ($file): $!";
+        print $DIFF $diff_text or croak "Failed to write to diff filehandle: $!";
+    }
+
+    return 1;
+}
+
+=head2 from_ddl
+
+=head2 to_ddl
+
+    $bool = $self->from_ddl($directory);
+    $bool = $self->from_ddl(\$text);
+    $bool = $self->to_ddl($directory);
+    $bool = $self->to_ddl(\$text);
+
+Will write L</from> or L</to> schemas as DDL to the given directory,
+with all the languages defined in L</databases>.
+
+Will write DDL to C<$text> if it is given as a scalar reference. (This
+might not make much sense, if you have more than one type defined in
+L</databases>.
+
+=cut
+
+sub from_ddl { shift->_ddl(from => @_) }
+sub to_ddl { shift->_ddl(to => @_) }
+
+sub _ddl {
+    my $self = shift;
+    my $attr_name = shift;
+    my $directory = shift;
+    my $args = shift || {};
+ 
+    for my $db (@{ $self->databases }) {
+        my $source = $self->$attr_name;
+        my $file = ref $directory eq 'SCALAR' ? $directory : $source->filename($directory);
+        my $old_producer = $source->producer;
+
+        $source->reset;
+        $source->producer($db);
+        $source->schema_to_file($file);
+        $source->producer($old_producer);
+    }
+    
+    return 1;
+}
+
+=head1 COPYRIGHT & LICENSE
+
+This library is free software. You can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Jan Henning Thorsen C<< jhthorsen at cpan.org >>
+
+=cut
+
+1;
diff --git a/lib/DBIx/Class/Admin/Diff/Source.pm b/lib/DBIx/Class/Admin/Diff/Source.pm
new file mode 100644
index 0000000..750a259
--- /dev/null
+++ b/lib/DBIx/Class/Admin/Diff/Source.pm
@@ -0,0 +1,189 @@
+package DBIx::Class::Schema::Diff::Source;
+
+=head1 NAME
+
+DBIx::Class::Schema::Diff::Source - Database schema sources
+
+=head1 SYNOPSIS
+
+    my $obj = DBIx::Class::Schema::Diff::Source->new(
+        class => $str,
+        sqltranslator => SQL::Translator->new(...),
+    );
+
+=cut
+
+use Carp::Clan qw/^DBIx::Class/;
+use SQL::Translator;
+use Moose;
+
+=head1 ATTRIBUTES
+
+=head2 class
+
+This attribute holds the classname of a L<DBIx::Class> schema.
+
+=cut
+
+has class => (
+    is => 'ro',
+    isa => 'Str', # Class?
+    required => 1,
+);
+
+=head2 sqltranslator
+
+Holds an L<SQL::Translator> object, either autobuilt or given when
+constructing the object.
+
+=cut
+
+has sqltranslator => (
+    is => 'ro',
+    isa => 'SQL::Translator',
+    lazy_build => 1,
+    handles => {
+        reset => 'reset',
+        schema => 'schema',
+    },
+);
+
+sub _build_sqltranslator {
+    return SQL::Translator->new(
+        add_drop_table => 1,
+        ignore_constraint_names => 1,
+        ignore_index_names => 1,
+        parser => 'SQL::Translator::Parser::DBIx::Class',
+        producer => $_[0]->producer,
+        # more args...?
+    );
+}
+
+=head2 version
+
+Holds the database schema. Either generated from L</class> or
+given in constructor.
+
+=cut
+
+has version => (
+    is => 'ro',
+    isa => 'Num',
+    lazy_build => 1,
+);
+
+sub _build_version {
+    my $class = shift->class;
+    my $version;
+
+    if($class->can('meta')) {
+        return $class->meta->version || '0';
+    }
+    elsif($version = eval "no strict; \$$class\::VERSION") {
+        return $version;
+    }
+
+    return 0;
+}
+
+=head2 producer
+
+Alias for L<SQL::Translator::producer()>, but will always return the
+producer as a string.
+
+=cut
+
+has producer => (
+    is => 'rw',
+    isa => 'Str',
+    default => 'SQLite',
+    trigger => sub { $_[0]->sqltranslator->producer($_[1]) },
+);
+
+=head2 schema
+
+Proxy for L<SQL::Translator::schema()>.
+
+=head1 METHODS
+
+=head2 translate
+
+    $text = $self->translate;
+
+Will return generated SQL.
+
+=cut
+
+sub translate {
+    my $self = shift;
+
+    return $self->sqltranslator->translate({ data => $self->class });
+}
+
+=head2 filename
+
+    $path = $self->filename($directory);
+    $path = $self->filename($directory, $preversion);
+
+Returns a filename relative to the given L<$directory>.
+
+=cut
+
+sub filename {
+    my $self = shift;
+    my $directory = shift;
+    my $preversion = shift;
+    my $class = $self->class;
+    my $version = $self->version;
+    my($obj, $filename);
+
+    # ddl_filename() does ref($obj) to find filename
+    $obj = bless {}, $class;
+
+    $filename = $obj->ddl_filename($self->producer, $version, $directory);
+    $filename =~ s/$version/$preversion\-$version/ if(defined $preversion);
+
+    return $filename;
+}
+
+=head2 schema_to_file
+
+    $bool = $self->schema_to_file($filename);
+    $bool = $self->schema_to_file($directory);
+
+Will dump schema as SQL to a given C<$filename> or use the L</filename>
+attribute by default.
+
+=cut
+
+sub schema_to_file {
+    my $self = shift;
+    my $file = shift or return;
+    my $text = $self->translate or return;
+    my $OUT;
+
+    if(ref $file eq '' and -d $file) {
+        $file = $self->filename($file) or return;
+    }
+
+    open $OUT, '>', $file or croak "Cannot write to ($file): $!";
+    print $OUT $text or croak "Cannot write to ($file) filehandle: $!";
+
+    return 1;
+}
+
+=head2 reset
+
+Proxy for L<SQL::Translator::reset()>.
+
+=head1 BUGS
+
+=head1 COPYRIGHT & LICENSE
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Diff>.
+
+=cut
+
+1;
diff --git a/lib/DBIx/Class/Admin/Types.pm b/lib/DBIx/Class/Admin/Types.pm
index cc2f20e..a736126 100644
--- a/lib/DBIx/Class/Admin/Types.pm
+++ b/lib/DBIx/Class/Admin/Types.pm
@@ -5,9 +5,11 @@ use MooseX::Types -declare => [qw(
     DBICConnectInfo
     DBICArrayRef
     DBICHashRef
+    DiffSource
 )];
-use MooseX::Types::Moose qw/Int HashRef ArrayRef Str Any Bool/;
+use MooseX::Types::Moose ':all';
 use MooseX::Types::JSON qw(JSON);
+use DBIx::Class::Admin::Diff::Source;
 
 subtype DBICArrayRef,
     as ArrayRef;
@@ -35,6 +37,17 @@ coerce DBICConnectInfo,
    via { [ $_ ] }
   ;
 
+subtype DiffSource,
+    as Object,
+      where { blessed $_ and $_->isa('DBIx::Class::Admin::Diff::Source') };
+
+coerce DiffSource,
+  from Str, via { _str_diff_source($_) },
+  from ArrayRef, via { _array_diff_source($_) },
+  from HashRef, via { _hash_diff_source($_) },
+  from Object, via { _object_diff_source($_) }
+  ;
+
 sub _json_to_data {
   my ($json_str) = @_;
   my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
@@ -42,4 +55,52 @@ sub _json_to_data {
   return $ret;
 }
 
+sub _str_diff_source {
+  my $str = $_;
+  my $input = _json_to_data($str);
+
+  return ref $input eq 'ARRAY' ? _array_diff_source($input)
+       : ref $input eq 'HASH'  ? _hash_diff_source($input)
+       :                         $str;
+}
+
+sub _array_diff_source {
+  my $args = $_;
+  my $class = _generate_classname();
+
+  DBIx::Class::Schema::Loader::make_schema_at($class,
+    { naming => 'v7', preserve_case => 1 },
+    $args,
+  );
+
+  return DBIx::Class::Admin::Diff::Source->new(class => $class);
+}
+
+sub _hash_diff_source {
+  return DBIx::Class::Admin::Diff::Source->new($_);
+}
+
+sub _object_diff_source {
+  my $dbh = $_;
+  my $class = _generate_classname();
+
+  unless(blessed $dbh eq 'DBI::db') {
+    return $dbh;
+  }
+
+  DBIx::Class::Schema::Loader::make_schema_at($class,
+    { naming => 'v7', preserve_case => 1 },
+    [ sub { $dbh } ],
+  );
+
+  return DBIx::Class::Admin::Diff::Source->new(class => $class);
+}
+
+{
+  my $generated = 0;
+  sub _generate_classname {
+    __PACKAGE__ .'::GEN' .(++$generated) .'::Schema'
+  }
+}
+
 1;
diff --git a/t/admin/01load.t b/t/admin/01load.t
index 2089607..d04faac 100644
--- a/t/admin/01load.t
+++ b/t/admin/01load.t
@@ -10,6 +10,7 @@ BEGIN {
 }
 
 use_ok 'DBIx::Class::Admin';
+use_ok 'DBIx::Class::Admin::Diff';
 
 
 done_testing;