code/UI_Tag/substitute_file.coretag

   1 # Copyright 2002-2007 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7 #
   8 # $Id: substitute_file.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $
   9
  10 UserTag substitute_file Order      file
  11 UserTag substitute_file addAttr
  12 UserTag substitute_file hasEndTag
  13 UserTag substitute_file Version    $Revision: 1.4 $
  14 UserTag substitute_file Routine    <<EOR
  15 ## This is a stupid thing to make 5.6.1 and File::Copy
  16 ## compatible with Safe
  17 require File::Copy;
  18 package File::Copy;
  19 require File::Basename;
  20 import File::Basename 'basename';
  21 package Vend::Interpolate;
  22 sub {
  23         my ($file, $opt, $replace) = @_;
  24         my $die = sub {
  25                 my @args = @_;
  26                 $::Scratch->{ui_failure} = errmsg(@args);
  27                 return undef;
  28         };
  29
  30         return $die->("substitute_file - %s: file does not exist", $file)
  31                 if ! -f $file;
  32         return $die->("substitute_file - %s: file not writeable", $file)
  33                 if ! -w $file;
  34
  35         if($opt->{content}) {
  36                 $opt->{begin} = '<!--+\s*begin\s+content\s*--+>';
  37                 $opt->{end} = '<!--+\s*end\s+content\s*--+>';
  38                 $opt->{newline} = 1 if ! defined $opt->{newline};
  39         }
  40
  41         if($opt->{scratch}) {
  42                 $opt->{begin} = '\[(?:tmp|seti?)\s*' . $opt->{scratch} . '\]';
  43                 $opt->{end} = '\[/(?:tmp|seti?)\]';
  44                 $opt->{greedy} = 0 if ! defined $opt->{greedy};
  45                 $opt->{newline} = 1 if ! defined $opt->{newline};
  46         }
  47
  48         if (! length($opt->{begin}) or ! length($opt->{end})) {
  49                 return $die->("missing begin or end marker");
  50         }
  51
  52         my $bak = POSIX::tmpnam();
  53         File::Copy::copy($file, $bak)
  54                 or return $die->(
  55                                         "substitute_file - %s: unable to backup to %s",
  56                                         $file, $bak,
  57                                         );
  58         my $data = Vend::Util::readfile($file);
  59         return $die->("substitute_file - %s: file has no data", $file)
  60                 unless length $data;
  61
  62         my $exist;
  63         if(defined $opt->{greedy} and ! Vend::Util::is_yes($opt->{greedy}) ) {
  64                 $exist = $opt->{newline} ? '[\s\S]*?' : '.*?';
  65         }
  66         else {
  67                 $exist = $opt->{newline} ? '[\s\S]*' : '.*';
  68         }
  69
  70         my $begin = $opt->{begin};
  71         my $end = $opt->{end};
  72         my $subbed;
  73
  74         my $sub = sub {
  75                         my ($begin, $replace, $end) = @_;
  76                         return $replace if $opt->{replace};
  77                         return $begin . $replace . $end;
  78         };
  79
  80         if($opt->{case} and $opt->{global}) {
  81                 $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ge;
  82         }
  83         elsif($opt->{global}) {
  84                 $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ige;
  85         }
  86         elsif($opt->{case}) {
  87                 $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}e;
  88         }
  89         else {
  90                 $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ie;
  91         }
  92
  93         if( $subbed ) {
  94                 open(SUBFILE, ">$file")
  95                         or return $die->(
  96                                                 "substitute_file: cannot write %s, backup in %s",
  97                                                 $file, $bak,
  98                                                 );
  99                 print SUBFILE $data
 100                         or return $die->(
 101                                                 "substitute_file: error writing %s, backup in %s",
 102                                                 $file, $bak,
 103                                                 );
 104                 close SUBFILE
 105                         or return $die->(
 106                                                 "substitute_file: error closing %s, backup in %s",
 107                                                 $file, $bak,
 108                                                 );
 109                 unlink $bak;
 110         }
 111         else {
 112                 unlink $bak;
 113                 return 0;
 114         }
 115 }
 116 EOR