Upgrade Module::Install::RTx so static files are copied on RT 4.2.x

[manu/RT-Extension-UserDetails.git] / inc / Module / Install / Substitute.pm

diff --git a/inc/Module/Install/Substitute.pm b/inc/Module/Install/Substitute.pm
new file mode 100644 (file)
index 0000000..56af7fe
--- /dev/null
+++ b/inc/Module/Install/Substitute.pm
@@ -0,0 +1,131 @@
+#line 1
+package Module::Install::Substitute;
+
+use strict;
+use warnings;
+use 5.008; # I don't care much about earlier versions
+
+use Module::Install::Base;
+our @ISA = qw(Module::Install::Base);
+
+our $VERSION = '0.03';
+
+require File::Temp;
+require File::Spec;
+require Cwd;
+
+#line 89
+
+sub substitute
+{
+       my $self = shift;
+       $self->{__subst} = shift;
+       $self->{__option} = {};
+       if( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
+               my $opts = shift;
+               while( my ($k,$v) = each( %$opts ) ) {
+                       $self->{__option}->{ lc( $k ) } = $v || '';
+               }
+       }
+       $self->_parse_options;
+
+       my @file = @_;
+       foreach my $f (@file) {
+               $self->_rewrite_file( $f );
+       }
+
+       return;
+}
+
+sub _parse_options
+{
+       my $self = shift;
+       my $cwd = Cwd::getcwd();
+       foreach my $t ( qw(from to) ) {
+        $self->{__option}->{$t} = $cwd unless $self->{__option}->{$t};
+               my $d = $self->{__option}->{$t};
+               die "Couldn't read directory '$d'" unless -d $d && -r _;
+       }
+}
+
+sub _rewrite_file
+{
+       my ($self, $file) = @_;
+       my $source = File::Spec->catfile( $self->{__option}{from}, $file );
+       $source .= $self->{__option}{sufix} if $self->{__option}{sufix};
+       unless( -f $source && -r _ ) {
+               print STDERR "Couldn't find file '$source'\n";
+               return;
+       }
+       my $dest = File::Spec->catfile( $self->{__option}{to}, $file );
+       return $self->__rewrite_file( $source, $dest );
+}
+
+sub __rewrite_file
+{
+       my ($self, $source, $dest) = @_;
+
+       my $mode = (stat($source))[2];
+
+       open my $sfh, "<$source" or die "Couldn't open '$source' for read";
+       print "Open input '$source' file for substitution\n";
+
+       my ($tmpfh, $tmpfname) = File::Temp::tempfile('mi-subst-XXXX', UNLINK => 1);
+       $self->__process_streams( $sfh, $tmpfh, ($source eq $dest)? 1: 0 );
+       close $sfh;
+
+       seek $tmpfh, 0, 0 or die "Couldn't seek in tmp file";
+
+       open my $dfh, ">$dest" or die "Couldn't open '$dest' for write";
+       print "Open output '$dest' file for substitution\n";
+
+       while( <$tmpfh> ) {
+               print $dfh $_;
+       }
+       close $dfh;
+       chmod $mode, $dest or "Couldn't change mode on '$dest'";
+}
+
+sub __process_streams
+{
+       my ($self, $in, $out, $replace) = @_;
+       
+       my @queue = ();
+       my $subst = $self->{'__subst'};
+       my $re_subst = join('|', map {"\Q$_"} keys %{ $subst } );
+
+       while( my $str = <$in> ) {
+               if( $str =~ /^###\s*(before|replace|after)\:\s?(.*)$/s ) {
+                       my ($action, $nstr) = ($1,$2);
+                       $nstr =~ s/\@($re_subst)\@/$subst->{$1}/ge;
+
+                       die "Replace action is bad idea for situations when dest is equal to source"
+                if $replace && $action eq 'replace';
+                       if( $action eq 'before' ) {
+                               die "no line before 'before' action" unless @queue;
+                               # overwrite prev line;
+                               pop @queue;
+                               push @queue, $nstr;
+                               push @queue, $str;
+                       } elsif( $action eq 'replace' ) {
+                               push @queue, $nstr;
+                       } elsif( $action eq 'after' ) {
+                               push @queue, $str;
+                               push @queue, $nstr;
+                               # skip one line;
+                               <$in>;
+                       }
+               } else {
+                       push @queue, $str;
+               }
+               while( @queue > 3 ) {
+                       print $out shift(@queue);
+               }
+       }
+       while( scalar @queue ) {
+               print $out shift(@queue);
+       }
+}
+
+1;
+