2 package Module::Install::Substitute;
6 use 5.008; # I don't care much about earlier versions
8 use Module::Install::Base;
9 our @ISA = qw(Module::Install::Base);
11 our $VERSION = '0.03';
22 $self->{__subst} = shift;
23 $self->{__option} = {};
24 if( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
26 while( my ($k,$v) = each( %$opts ) ) {
27 $self->{__option}->{ lc( $k ) } = $v || '';
30 $self->_parse_options;
33 foreach my $f (@file) {
34 $self->_rewrite_file( $f );
43 my $cwd = Cwd::getcwd();
44 foreach my $t ( qw(from to) ) {
45 $self->{__option}->{$t} = $cwd unless $self->{__option}->{$t};
46 my $d = $self->{__option}->{$t};
47 die "Couldn't read directory '$d'" unless -d $d && -r _;
53 my ($self, $file) = @_;
54 my $source = File::Spec->catfile( $self->{__option}{from}, $file );
55 $source .= $self->{__option}{sufix} if $self->{__option}{sufix};
56 unless( -f $source && -r _ ) {
57 print STDERR "Couldn't find file '$source'\n";
60 my $dest = File::Spec->catfile( $self->{__option}{to}, $file );
61 return $self->__rewrite_file( $source, $dest );
66 my ($self, $source, $dest) = @_;
68 my $mode = (stat($source))[2];
70 open my $sfh, "<$source" or die "Couldn't open '$source' for read";
71 print "Open input '$source' file for substitution\n";
73 my ($tmpfh, $tmpfname) = File::Temp::tempfile('mi-subst-XXXX', UNLINK => 1);
74 $self->__process_streams( $sfh, $tmpfh, ($source eq $dest)? 1: 0 );
77 seek $tmpfh, 0, 0 or die "Couldn't seek in tmp file";
79 open my $dfh, ">$dest" or die "Couldn't open '$dest' for write";
80 print "Open output '$dest' file for substitution\n";
86 chmod $mode, $dest or "Couldn't change mode on '$dest'";
91 my ($self, $in, $out, $replace) = @_;
94 my $subst = $self->{'__subst'};
95 my $re_subst = join('|', map {"\Q$_"} keys %{ $subst } );
97 while( my $str = <$in> ) {
98 if( $str =~ /^###\s*(before|replace|after)\:\s?(.*)$/s ) {
99 my ($action, $nstr) = ($1,$2);
100 $nstr =~ s/\@($re_subst)\@/$subst->{$1}/ge;
102 die "Replace action is bad idea for situations when dest is equal to source"
103 if $replace && $action eq 'replace';
104 if( $action eq 'before' ) {
105 die "no line before 'before' action" unless @queue;
106 # overwrite prev line;
110 } elsif( $action eq 'replace' ) {
112 } elsif( $action eq 'after' ) {
121 while( @queue > 3 ) {
122 print $out shift(@queue);
125 while( scalar @queue ) {
126 print $out shift(@queue);