Skip to content
Browse files

Add (nasty) code to support type flipping

Coerces InMemory to FromCode and vice versa.

Somewhat nasty and works by messing with the hashref directly, and
forging the conversion in-place with bless.

Probably as good as we're going to get without requring the user to
probe deep into Dzils guts to replace a file.
  • Loading branch information...
1 parent 3965eb9 commit 23ded32d0b38521d8b278bdb20f923612c008d55 @kentfredric committed Oct 9, 2011
Showing with 113 additions and 10 deletions.
  1. +19 −10 lib/Dist/Zilla/Util/SimpleMunge.pm
  2. +94 −0 t/02-coerce.t
View
29 lib/Dist/Zilla/Util/SimpleMunge.pm
@@ -88,11 +88,13 @@ something currently backed by code get munged "now", ( converting the file into
sub _fromcode_munge {
my ( $file, $config ) = @_;
if ( defined $config->{lazy} and $config->{lazy} == 0 ) {
- __PACKAGE__->_error(
- message => 'De-Lazifying a from-code file is not yet implemented',
- id => 'code_munge_no_downgrade',
- tags => [qw( downgrade fromcode toscalar nonlazy )],
- );
+ # This is a little bit nasty, but can you suggest a better way?
+ my $content = $file->content();
+ delete $file->{code};
+ require Dist::Zilla::File::InMemory;
+ bless $file, 'Dist::Zilla::File::InMemory';
+ $file->content( $config->{via}->( $file, $content ) );
+ return 1;
}
my $coderef = $file->code();
$file->code(
@@ -106,11 +108,18 @@ sub _fromcode_munge {
sub _scalar_munge {
my ( $file, $config ) = @_;
if ( defined $config->{lazy} and $config->{lazy} == 1 ) {
- __PACKAGE__->_error(
- message => 'Forced upgrade from scalar to coderef not yet implemented',
- id => 'scalar_munge_no_upgrade',
- tags => [qw( upgrade scalar tocoderef lazy )],
+
+ # This is a little bit nasty, but can you suggest a better way?
+ # TODO
+ my $content = delete $file->{content};
+ require Dist::Zilla::File::FromCode;
+ bless $file, 'Dist::Zilla::File::FromCode';
+ $file->code(
+ sub {
+ return $config->{via}->( $file, $content );
+ }
);
+ return 1;
}
$file->content( $config->{via}->( $file, $file->content ) );
return 1;
@@ -196,7 +205,7 @@ sub munge_files {
sub _error {
my ( $self, %config ) = @_;
require Carp;
- return Carp::carp( $config{message} );
+ return Carp::croak( $config{message} );
}
1;
View
94 t/02-coerce.t
@@ -0,0 +1,94 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+# FILENAME: 01-basic.t
+# CREATED: 08/10/11 07:21:37 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Test Basic Functionality of munging.
+
+use Dist::Zilla::Util::SimpleMunge qw( munge_file );
+use Dist::Zilla::File::InMemory;
+use Dist::Zilla::File::FromCode;
+
+my $in_memory = Dist::Zilla::File::InMemory->new(
+ name => 'in_memory.file',
+ content => "Initial Value",
+);
+
+my $v = 0;
+
+my $from_code = Dist::Zilla::File::FromCode->new(
+ name => 'from_code.file',
+ code => sub {
+ $v++;
+ return "$v";
+ }
+);
+
+pass("Initial setup is successful");
+
+munge_file(
+ $in_memory => {
+ via => sub {
+ my ( $file, $content ) = @_;
+ $content =~ s/initial/New/gi;
+ return $content;
+ },
+ lazy => 1,
+ },
+);
+
+munge_file(
+ $from_code => {
+ via => sub {
+ my ( $file, $content ) = @_;
+ $content =~ s/(\d+)/munged $1/g;
+ return $content;
+ },
+ lazy => 0,
+ }
+);
+
+is( $v, 1, 'from_code has been munged to a scalar already' );
+is( $in_memory->content, 'New Value', 'in_memory content has been munged properly' );
+is( $from_code->content, 'munged 1', 'from_code content has been munged to a scalar which doesn\'t change x1' );
+is( $from_code->content, 'munged 1', 'from_code content has been munged to a scalar which doesn\'t change x2' );
+is( $v, 1, 'from_code doesnt call the coderef to generate anymore' );
+
+my $x = 0;
+
+munge_file(
+ $in_memory => {
+ via => sub {
+ my ( $file, $content ) = @_;
+ $content =~ s/New/Second/gi;
+ return $content;
+ },
+ lazy => 0,
+ },
+);
+
+munge_file(
+ $from_code => {
+ via => sub {
+ my ( $file, $content ) = @_;
+ $content =~ s/munged/munged_level2 $x/g;
+ $x++;
+ return $content;
+ },
+ lazy => 1,
+ },
+);
+
+is( $v, 1, 'from_code->static->code doesnt generate from source' );
+is( $x, 0, 'from_code->static->code doesnt do last munge untill evaluated' );
+
+is( $in_memory->content, 'Second Value', 'static->code->static content has been re-munged properly' );
+is( $from_code->content, 'munged_level2 0 1', 'code->static->code has been re-munged properly x1' );
+is( $from_code->content, 'munged_level2 1 1', 'code->static->code has been re-munged properly x2' );
+is( $v, 1, 'code->static->code doesnt remunge old munges' );
+is( $x, 2, 'code->static->code remunges new munges' );
+
+done_testing;
+

0 comments on commit 23ded32

Please sign in to comment.
Something went wrong with that request. Please try again.