inc/Module/Install/Substitute.pm

   1 #line 1
   2 package Module::Install::Substitute;
   3
   4 use strict;
   5 use warnings;
   6 use 5.008; # I don't care much about earlier versions
   7
   8 use Module::Install::Base;
   9 our @ISA = qw(Module::Install::Base);
  10
  11 our $VERSION = '0.03';
  12
  13 require File::Temp;
  14 require File::Spec;
  15 require Cwd;
  16
  17 #line 89
  18
  19 sub substitute
  20 {
  21         my $self = shift;
  22         $self->{__subst} = shift;
  23         $self->{__option} = {};
  24         if( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
  25                 my $opts = shift;
  26                 while( my ($k,$v) = each( %$opts ) ) {
  27                         $self->{__option}->{ lc( $k ) } = $v || '';
  28                 }
  29         }
  30         $self->_parse_options;
  31
  32         my @file = @_;
  33         foreach my $f (@file) {
  34                 $self->_rewrite_file( $f );
  35         }
  36
  37         return;
  38 }
  39
  40 sub _parse_options
  41 {
  42         my $self = shift;
  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 _;
  48         }
  49 }
  50
  51 sub _rewrite_file
  52 {
  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";
  58                 return;
  59         }
  60         my $dest = File::Spec->catfile( $self->{__option}{to}, $file );
  61         return $self->__rewrite_file( $source, $dest );
  62 }
  63
  64 sub __rewrite_file
  65 {
  66         my ($self, $source, $dest) = @_;
  67
  68         my $mode = (stat($source))[2];
  69
  70         open my $sfh, "<$source" or die "Couldn't open '$source' for read";
  71         print "Open input '$source' file for substitution\n";
  72
  73         my ($tmpfh, $tmpfname) = File::Temp::tempfile('mi-subst-XXXX', UNLINK => 1);
  74         $self->__process_streams( $sfh, $tmpfh, ($source eq $dest)? 1: 0 );
  75         close $sfh;
  76
  77         seek $tmpfh, 0, 0 or die "Couldn't seek in tmp file";
  78
  79         open my $dfh, ">$dest" or die "Couldn't open '$dest' for write";
  80         print "Open output '$dest' file for substitution\n";
  81
  82         while( <$tmpfh> ) {
  83                 print $dfh $_;
  84         }
  85         close $dfh;
  86         chmod $mode, $dest or "Couldn't change mode on '$dest'";
  87 }
  88
  89 sub __process_streams
  90 {
  91         my ($self, $in, $out, $replace) = @_;
  92
  93         my @queue = ();
  94         my $subst = $self->{'__subst'};
  95         my $re_subst = join('|', map {"\Q$_"} keys %{ $subst } );
  96
  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;
 101
 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;
 107                                 pop @queue;
 108                                 push @queue, $nstr;
 109                                 push @queue, $str;
 110                         } elsif( $action eq 'replace' ) {
 111                                 push @queue, $nstr;
 112                         } elsif( $action eq 'after' ) {
 113                                 push @queue, $str;
 114                                 push @queue, $nstr;
 115                                 # skip one line;
 116                                 <$in>;
 117                         }
 118                 } else {
 119                         push @queue, $str;
 120                 }
 121                 while( @queue > 3 ) {
 122                         print $out shift(@queue);
 123                 }
 124         }
 125         while( scalar @queue ) {
 126                 print $out shift(@queue);
 127         }
 128 }
 129
 130 1;
 131