"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:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Substitute.pm" see the Fossies "Dox" file reference documentation.

    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