"Fossies" - the Fresh Open Source Software Archive

Member "RT-Extension-Assets-1.05/inc/Module/Install/Substitute.pm" (6 May 2015, 2962 Bytes) of package /linux/misc/RT-Extension-Assets-1.05.tar.gz:

    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