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