--- /dev/null
+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;
--- /dev/null
+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;
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;
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);
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;
}
use_ok 'DBIx::Class::Admin';
+use_ok 'DBIx::Class::Admin::Diff';
done_testing;
projects / dbsrgits/DBIx-Class.git / commitdiff