1#!/usr/local/bin/perl -wT
2# Copyright Andru Luvisi, 1999
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, or (at your option)
6# any later version.
7#
8# This program is distributed in the hope that it will be useful,
9# but WITHOUT ANY WARRANTY; without even the implied warranty of
10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11# GNU General Public License for more details.
12#
13# You should have received a copy of the GNU General Public License
14# along with this program (see the file COPYING); if not, write to the
15# Free Software Foundation, Inc.,
16# 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
17
18$| = 1;
19
20open(STDERR, ">&STDOUT") || die "Can't redirect stderr";
21
22use CGI;
23use CGI::Carp qw(fatalsToBrowser);
24use POSIX qw(:fcntl_h);
25use English;
26use strict;
27
28use vars qw($query $fcnfile $query_dir $fcntext %handlers
29            $response $errortext $location $delim $tag);
30use vars qw($authorized_uid);
31
32
33# CONFIGURATION SECTION
34$authorized_uid = www;
35
36if(!$EFFECTIVE_USER_ID && $REAL_USER_ID != $authorized_uid) {
37  die("Unauthorized user $REAL_USER_ID");
38}
39
40
41# this handles all form data for us...
42$query = CGI->new;
43
44# untaint $fcnfile, since it's given to us by the web server.
45$ENV{"PATH_TRANSLATED"} =~ m/(.*)/;
46$fcnfile = $1;
47
48# if we are running as root, change both uid and euid to be that of
49# the owner of the fcnfile.
50if(!$EFFECTIVE_USER_ID) {
51 # stat the file...
52 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
53                      $atime,$mtime,$ctime,$blksize,$blocks)
54                          = stat($fcnfile);
55
56 if(!defined($uid)) {
57  print "Content-type: text/html\r\n\r\n";
58  print "<h1>Error stating fcnfile</h1>\n";
59  exit(1);
60 }
61
62 $REAL_USER_ID      = $uid;
63 $EFFECTIVE_USER_ID = $uid;
64}
65
66# get the name of the directory the fcnfile is in.
67# this is used in savecustom and savedata.
68$query_dir = $fcnfile;
69$query_dir =~ s/[^\/]+$//;
70
71# this is to untaint $ENV{"PATH"} so that exec below won't complain.
72$ENV{"PATH"} = "/bin:/usr/bin:/usr/local/bin";
73
74# slirp in the whole fcnfile into the string $fcntext.
75open(FCNFILEHANDLE, "$fcnfile") || die("Can't open $fcnfile");
76undef $INPUT_RECORD_SEPARATOR;
77$fcntext = <FCNFILEHANDLE>;
78$fcntext =~ s/\r\n/\n/g; # handle DOS text
79$fcntext =~ s/\r/\n/g;   # handle Mac text
80close(FCNFILEHANDLE);
81
82# used for looking up the handler for each tag.
83
84%handlers = (
85 "mail"       => \&mail,
86 "response"   => \&response,
87 "require"    => \&require,
88 "error"      => \&error,
89 "savecustom" => \&savecustom,
90 "savedata"   => \&savedata,
91 "redirectto" => \&redirectto,
92 "replace"    => \&replace,
93);
94
95# initialize variables...
96# this is appended to by the <response> container.  We send it
97# back to the user if everything works and there are no redirections.
98$response = "";
99
100# this is set by the <error> container.  We send it back to
101# the use of a <require ...> tag fails.
102$errortext = "";
103
104# if this is set when we finish, and everything works, we redirect
105# the user to this location.  it is set by the <redirectto ...> tag.
106$location = "";
107
108# this is used to delimit substitutions in the body of various containers.
109# it can be changed with the <replace> container.
110$delim = "%";
111
112# this is the main loop.  find a tag, and call the appropriate handler
113# if there is one.
114while( $fcntext =~ m/<(\w+)(.*?)>/gsci ) {
115 $tag = lc($1);
116 $handlers{$tag} && &{$handlers{$tag}}($tag, $2);
117}
118
119# finish up... if we are to redirect the user, send a Location header,
120# otherwise, send the response as text/html.
121if($location) {
122 print("Location: $location\r\n\r\n");
123} else {
124 print("Content-type: text/html\r\n\r\n");
125 print $response, "\n";
126}
127
128exit(0);
129
130
131# GENERIC SUBROUTINES
132
133# string getbody( string $tagname );
134# this is called to retrieve the body of a container by the handler
135# for that container.  $tagname is the name of the container, and is
136# used to find the closing tag.
137sub getbody {
138 my($tagname) = shift;
139 if( $fcntext =~ m/\G(.*?)(<\/$tagname>)/gsci ) {
140  return $1;
141 }
142
143 return "";
144
145}
146
147# string substitute( string $text );
148# this is used to replace all occurences of "%var%" in $text with
149# the value of the submitted form variable "var".
150sub substitute {
151 my($text) = $_[0];
152
153 $text =~ s/$delim(\w+)$delim/ $query->param($1) /ge;
154 return $text;
155
156}
157
158# typglob open_output( string $file [ , string $mode ] );
159# this is used by savecustom and savedata to open an output file.
160# $mode may be blank, "append", "new", or "unique".  if $mode is
161# blank or "append", $file is opened in append mode.  if $mode is
162# "new", $file is truncated and opened in write mode.  if $mode is
163# "unique", $file is used as the base name for a new file which doesn't
164# yet exist.  the return value is a typeglob containing the filehandle
165# which was opened.
166sub open_output {
167 my($file) = $query_dir . $_[0];
168 my($opened, $num) = (0, time() . $PROCESS_ID);
169 local($_) = $_[1];
170 local(*FILE);
171
172 # truncate the output file if $mode contains "new".
173 if(/new/i) {
174  $file = "> " . $file;
175  open(FILE, $file) || return undef;
176  return *FILE;
177 }
178
179 # this is the tricky one.  since we are in a multi-programmed environment,
180 # we can not check for the existance of a file and create it atomically.
181 # we must rely on the operating system to do this for us.  the O_CREAT
182 # flag tells the system to create the file if it does not exist, and the
183 # O_EXCL flag tells the system to fail to open the file if it already
184 # exists.  since $num is already almost guaranteed to be unique, we will
185 # "spin" in this loop very rarely and very briefly.
186 if(/unique/i) {
187  while(!$opened) {
188   if(sysopen(FILE, "$file.$num", O_WRONLY | O_CREAT | O_EXCL, 0666)) {
189    $opened = 1;
190   } else {
191    $num++;
192    next;
193   }
194  }
195  return *FILE;
196 }
197
198 # append if $mode contains "append" or is blank.
199 if(/append/i || /^\W*$/) {
200  $file = ">> " . $file;
201  open(FILE, $file) || return undef;
202  return *FILE;
203 }
204
205 die("Invalid argument to SAVECUSTOM or SAVEDATA");
206
207}
208
209# TAG AND CONTAINER HANDLERS.
210
211# <mail> container.  treat contents of the container as the full
212# message, including headers.  If there is no Return-Path, set
213# the Return-Path header from the From header, just to be sure it
214# will work with things like listbots.
215sub mail {
216 # get the body of the <mail> tag into $tagbody.
217 my($tagbody) = getbody("mail");
218
219 # split $tagbody into a header and a body.
220 my($mailhead, $mailbody) = ($tagbody =~ m/(.*?\n)\n(.*)/gs);
221 my(%headers);
222 my($name, $child_id);
223
224 # split up the headers and store them into the headers hash.
225 %headers = ($mailhead =~ m/^(\S+): (.*\n(?:[ \t].*\n)*)/mg);
226
227 # fork the child.
228 if(!defined($child_id = open(MAIL, "|-"))) {
229  die("Can't fork mail process!");
230 }
231
232 # the child runs sendmail.  the -t is so that it will take its
233 # destination addresses (To, Cc, Bcc) from the headers we feed it,
234 # thereby saving us from having to parse the headers ourselves.
235 if($child_id == 0) {
236  # without the if, perl warns that the exit is unlikely to be reached.
237  if(1) { exec("/usr/sbin/sendmail -t"); }
238  exit(1);
239 }
240
241 # we have to do the substitutions one header at a time so that form
242 # values containing multiple lines don't create new headers.
243 foreach $name (keys %headers) {
244  $headers{$name} =~ s/\n[ \t]/ /g;
245  $headers{$name} = substitute($headers{$name});
246  $headers{$name} =~ s/\n(?=.)/ /g;
247  $headers{$name} =~ s/\n$/\r\n/g;
248  print MAIL "$name: $headers{$name}"; # CRLF is already included.
249 }
250
251 # if no Return-Path was specified, set it from the From header, so
252 # that the envelope return address will also be the one specified
253 # in the fcnfile.
254 if(!$headers{"Return-Path"}) {
255  print MAIL "Return-Path: $headers{'From'}";
256 }
257
258 # print out the body of the message.  a single \r\n serves to terminate
259 # the headers since they each have their own \r\n at the end.
260 $mailbody =~ s/\n/\r\n/g;
261 print MAIL "\r\n", substitute($mailbody);
262 close(MAIL);
263
264}
265
266# handle the <response> container.  get the body, and do the substitutions.
267sub response {
268 $response .= substitute(getbody("response"));
269}
270
271# <require ...>
272# see if the user entered all of the form values which are required.
273# if any are missing, print out the current value of $errortext
274# (set with the <error> container) and don't process any more of the
275# fcnfile.
276sub require {
277 while($_[1] =~ m/(\w+)/g) {
278  if( ! $query->param($1) ) {
279   print "Content-type: text/html\r\n\r\n";
280   print "$errortext";
281   exit(0);
282  }
283 }
284}
285
286# <error>
287# assign (not append) the new value of $errortext.
288sub error {
289 $errortext = substitute(getbody("error"));
290}
291
292# <savecustom "<filename>" [ APPEND | NEW | UNIQUE ]>...</savecustom>
293# the body gets substituted in the same way as that of <response>
294# and <mail>.
295sub savecustom {
296 my($file, $junk, $arg) = ($_[1] =~ m/"([^"]+)"(\s+(\w+))?/g);
297 my($text) = substitute(getbody("savecustom"));
298
299 local(*OUTPUT_FILE) = open_output($file, $arg);
300 print OUTPUT_FILE $text;
301 close(OUTPUT_FILE);
302}
303
304# <savedata "<filename>" [ APPEND | NEW | UNIQUE ]>...</savecustom>
305# the output is tab delimited, and the body of this tag is just the
306# bare names of form fields to save.
307sub savedata {
308 my($file, $junk, $arg) = ($_[1] =~ m/"([^"]+)"(\s+(\w+))?/g);
309 my($text) = getbody("savedata");
310 my(@fields) = split(/\s+/, $text);
311
312 local(*OUTPUT_FILE) = open_output($file, $arg);
313 print OUTPUT_FILE join("\t", map { $query->param($_); } @fields), "\n";
314 close(OUTPUT_FILE);
315}
316
317# <redirectto href="http://www.example.com/">
318# set $location so that if we finish executing properly, the user
319# will be redirected to http://www.example.com/ .
320sub redirectto {
321 ($location) = ($_[1] =~ m/href="([^"]+)"/ig);
322}
323
324# <replace>...</replace>
325# change the delimiter to mark substitutions.
326sub replace {
327 my($body) = getbody("replace");
328 ($body) =~ m/(\S+)/g;
329 $delim = $body if $body;
330}
331
332