UserDB: log timestamps to second granularity
[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 # $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