Also look in the next-highest directory when detecting VCS; add SVN
[interchange.git] / 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 UserTag substitute_file Order      file
9 UserTag substitute_file addAttr
10 UserTag substitute_file hasEndTag
11 UserTag substitute_file Version    1.4
12 UserTag substitute_file Routine    <<EOR
13 ## This is a stupid thing to make 5.6.1 and File::Copy
14 ## compatible with Safe
15 require File::Copy;
16 package File::Copy;
17 require File::Basename;
18 import File::Basename 'basename';
19 package Vend::Interpolate;
20 require File::Temp;
21 sub {
22         my ($file, $opt, $replace) = @_;
23         my $die = sub {
24                 my @args = @_;
25                 $::Scratch->{ui_failure} = errmsg(@args);
26                 return undef;
27         };
28
29         return $die->("substitute_file - %s: file does not exist", $file)
30                 if ! -f $file;
31         return $die->("substitute_file - %s: file not writeable", $file)
32                 if ! -w $file;
33
34         if($opt->{content}) {
35                 $opt->{begin} = '<!--+\s*begin\s+content\s*--+>';
36                 $opt->{end} = '<!--+\s*end\s+content\s*--+>';
37                 $opt->{newline} = 1 if ! defined $opt->{newline};
38         }
39
40         if($opt->{scratch}) {
41                 $opt->{begin} = '\[(?:tmp|seti?)\s*' . $opt->{scratch} . '\]';
42                 $opt->{end} = '\[/(?:tmp|seti?)\]';
43                 $opt->{greedy} = 0 if ! defined $opt->{greedy};
44                 $opt->{newline} = 1 if ! defined $opt->{newline};
45         }
46
47         if (! length($opt->{begin}) or ! length($opt->{end})) {
48                 return $die->("missing begin or end marker");
49         }
50
51         my $bak = File::Temp::tmpnam();
52         File::Copy::copy($file, $bak)
53                 or return $die->(
54                                         "substitute_file - %s: unable to backup to %s",
55                                         $file, $bak,
56                                         );
57         my $data = Vend::Util::readfile($file);
58         return $die->("substitute_file - %s: file has no data", $file)
59                 unless length $data;
60
61         my $exist;
62         if(defined $opt->{greedy} and ! Vend::Util::is_yes($opt->{greedy}) ) {
63                 $exist = $opt->{newline} ? '[\s\S]*?' : '.*?';
64         }
65         else {
66                 $exist = $opt->{newline} ? '[\s\S]*' : '.*';
67         }
68         
69         my $begin = $opt->{begin};
70         my $end = $opt->{end};
71         my $subbed;
72
73         my $sub = sub {
74                         my ($begin, $replace, $end) = @_;
75                         return $replace if $opt->{replace};
76                         return $begin . $replace . $end;
77         };
78
79         if($opt->{case} and $opt->{global}) {
80                 $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ge;
81         }
82         elsif($opt->{global}) {
83                 $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ige;
84         }
85         elsif($opt->{case}) {
86                 $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}e;
87         }
88         else {
89                 $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ie;
90         }
91
92         if( $subbed ) {
93                 open(SUBFILE, ">$file")
94                         or return $die->(
95                                                 "substitute_file: cannot write %s, backup in %s",
96                                                 $file, $bak,
97                                                 );
98                 print SUBFILE $data
99                         or return $die->(
100                                                 "substitute_file: error writing %s, backup in %s",
101                                                 $file, $bak,
102                                                 );
103                 close SUBFILE
104                         or return $die->(
105                                                 "substitute_file: error closing %s, backup in %s",
106                                                 $file, $bak,
107                                                 );
108                 unlink $bak;
109         }
110         else {
111                 unlink $bak;
112                 return 0;
113         }
114 }
115 EOR