From: Rafael Kitover Date: Fri, 5 Aug 2011 06:34:28 +0000 (-0400) Subject: some changes to filter code X-Git-Tag: 0.07011~56 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Schema-Loader.git;a=commitdiff_plain;h=7dc01f79973f1c9fd78f713b8c5e0d001358cded some changes to filter code Renames filter_generated_text => filter_generated_code. Changes the filter coderef signature to take the type of file being filtered, 'schema' or 'result'. Adds support for setting the option to a string which is used as an external filter program. Updates Changes. --- diff --git a/Changes b/Changes index 13536ac..e8f10ca 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,6 @@ Revision history for Perl extension DBIx::Class::Schema::Loader + - added filter_generated_code option (RT#53841) - generic table and column comments support - MySQL table and column comments support - support DOS line endings on *nix and *nix line ending on Win32 diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm index 2a67684..e854e51 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -21,8 +21,10 @@ use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_packag use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); -use Encode qw/encode/; +use Encode qw/encode decode/; use List::MoreUtils 'all'; +use IPC::Open2; +use Symbol 'gensym'; use namespace::clean; our $VERSION = '0.07010'; @@ -77,8 +79,6 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ class_to_table uniq_to_primary quiet - - filter_generated_text /); @@ -104,6 +104,7 @@ __PACKAGE__->mk_group_accessors('simple', qw/ datetime_undef_if_invalid _result_class_methods naming_set + filter_generated_code /); my $CURRENT_V = 'v7'; @@ -114,6 +115,7 @@ my @CLASS_ARGS = qw( result_roles ); +my $CR = "\x0d"; my $LF = "\x0a"; my $CRLF = "\x0d\x0a"; @@ -684,19 +686,24 @@ Automatically promotes the largest unique constraints with non-nullable columns on tables to primary keys, assuming there is only one largest unique constraint. -=head2 filter_generated_text +=head2 filter_generated_code + +An optional hook that lets you filter the generated text for various classes +through a function that change it in any way that you want. The function will +receive the type of file, C or C, class and code; and returns +the new code to use instead. For instance you could add custom comments, or do +anything else that you want. -An optional hook that lets you filter the generated text for various classes through -a function that change it in any way that you want. The function will receive the class -and text, and returns the new text to use instead. For instance you could add -custom comment, run C, or do anything else that you want. +The option can also be set to a string, which is then used as a filter program, +e.g. C. -If this exists but fails to return text matching C, no file will be generated. +If this exists but fails to return text matching C, no file will +be generated. - filter_generated_base => sub { - my ($class, $text) = @_; + filter_generated_code => sub { + my ($type, $class, $text) = @_; ... - return $new_text; + return $new_code; } =head1 METHODS @@ -911,6 +918,13 @@ sub new { } } + if (defined(my $filter = $self->filter_generated_code)) { + my $reftype = ref $filter; + if ($reftype && $reftype ne 'CODE') { + croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference"; + } + } + $self; } @@ -1672,9 +1686,39 @@ sub _write_classfile { $text .= qq|$_\n| for @{$self->{_dump_storage}->{$class} || []}; - if ($self->{filter_generated_text}) { - $text = $self->{filter_generated_text}->($class, $text); - if (not $text or not $text =~ /package/) { + if ($self->filter_generated_code) { + my $filter = $self->filter_generated_code; + + if (ref $filter eq 'CODE') { + $text = $filter->( + ($is_schema ? 'schema' : 'result'), + $class, + $text + ); + } + else { + my ($out, $in) = (gensym, gensym); + + my $pid = open2($out, $in, $filter) + or croak "Could not open pipe to $filter: $!"; + + print $in $text; + + close $in; + + $text = decode('UTF-8', do { local $/; <$out> }); + + $text =~ s/$CR?$LF/\n/g; + + waitpid $pid, 0; + + my $exit_code = $? >> 8; + + if ($exit_code != 0) { + croak "filter '$filter' exited non-zero: $exit_code"; + } + } + if (not $text or not $text =~ /\bpackage\b/) { warn("$class skipped due to filter") if $self->debug; return; } diff --git a/t/27filter_generated.t b/t/27filter_generated.t index 22eb772..20b45f2 100644 --- a/t/27filter_generated.t +++ b/t/27filter_generated.t @@ -1,40 +1,79 @@ use strict; -use File::Slurp qw(slurp); +use DBIx::Class::Schema::Loader; +use DBIx::Class::Schema::Loader::Utils 'slurp_file'; use File::Path; -use Test::More tests => 4; +use Test::More tests => 19; use Test::Exception; use lib qw(t/lib); use make_dbictest_db; use dbixcsl_test_dir qw/$tdir/; -use DBIx::Class::Schema::Loader; - my $dump_path = "$tdir/dump"; my %original_class_data; +my ($schema_file_count, $result_file_count); + { package DBICTest::Schema::1; - use base qw/ DBIx::Class::Schema::Loader /; + use Test::More; + use base 'DBIx::Class::Schema::Loader'; __PACKAGE__->loader_options( dump_directory => $dump_path, - filter_generated_text => sub { - my ($class, $text) = @_; + quiet => 1, + filter_generated_code => sub { + my ($type, $class, $text) = @_; + + like $type, qr/^(?:schema|result)\z/, + 'got correct file type'; + + if ($type eq 'schema') { + $schema_file_count++; + is $class, 'DBICTest::Schema::1', + 'correct class for schema type file passed to filter'; + } + elsif ($type eq 'result') { + $result_file_count++; + like $class, qr/^DBICTest::Schema::1::Result::(?:Foo|Bar)\z/, + 'correct class for result type file passed to filter'; + } + else { + die 'invalid file type passed to filter'; + } + $original_class_data{$class} = $text; if ($class =~ /::1$/) { $text = "No Gotcha!"; } else { - $text .= q{"Kilroy was here";}; + $text .= q{my $foo = "Kilroy was here";}; } return $text; }, ); } +{ + package DBICTest::Schema::2; + use base 'DBIx::Class::Schema::Loader'; + __PACKAGE__->loader_options( + dump_directory => $dump_path, + quiet => 1, + filter_generated_code => "$^X t/bin/simple_filter", + ); +} + DBICTest::Schema::1->connect($make_dbictest_db::dsn); -my $foo = slurp("$dump_path/DBICTest/Schema/1/Result/Foo.pm"); +# schema is generated in 2 passes + +is $schema_file_count, 2, + 'correct number of schema files passed to filter'; + +is $result_file_count, 4, + 'correct number of result files passed to filter'; + +my $foo = slurp_file "$dump_path/DBICTest/Schema/1/Result/Foo.pm"; ok(! -e "$dump_path/DBICTest/Schema/1.pm", "No package means no file written"); ok($original_class_data{"DBICTest::Schema::1"}, @@ -43,4 +82,11 @@ like($foo, qr/# Created by .* THE FIRST PART/s, "We get the whole autogenerated text"); like($foo, qr/Kilroy was here/, "Can insert text"); +DBICTest::Schema::2->connect($make_dbictest_db::dsn); + +$foo = slurp_file "$dump_path/DBICTest/Schema/2/Result/Foo.pm"; + +like $foo, qr/Kilroy was here/, + "Can insert text via command filter"; + END { rmtree($dump_path, 1, 1); } diff --git a/t/bin/simple_filter b/t/bin/simple_filter new file mode 100755 index 0000000..f8d6f6c --- /dev/null +++ b/t/bin/simple_filter @@ -0,0 +1,10 @@ +#!perl + +use strict; +use warnings; + +while () { + print; +} + +print q{my $foo = "Kilroy was here";}, "\n";