Updated documentation
[CGIscriptor.git] / CGIscriptor.pl
blob5ac25d853dd320f1433e37e2d14cb12102aa072d
1 #! /usr/bin/perl
3 # (configure the first line to contain YOUR path to perl 5.000+)
5 # CGIscriptor.pl
6 # Version 2.3
7 # 15 January 2002
9 # YOU NEED:
11 # perl 5.0 or higher (see: "http://www.perl.org/")
13 # Notes:
15 if(grep(/\-\-help/i, @ARGV))
17 print << 'ENDOFPREHELPTEXT1';
18 # CGIscriptor.pl is a Perl program will run on any WWW server that
19 # runs Perl scripts, just add a line like the following to your
20 # httpd.conf file (Apache example):
22 # ScriptAlias /SHTML/ "/real-path/CGIscriptor.pl/"
24 # URL's that refer to http://www.your.address/SHTML/... will now be handled
25 # by CGIscriptor.pl, which can use a private directory tree (default is the
26 # DOCUMENT_ROOT directory tree, but it can be anywhere, see below).
27 # NOTE: if you cannot use a ScriptAlias, there is a way to use .htaccess
28 # instead. See below.
30 # This file contains all documentation as comments. These comments
31 # can be removed to speed up loading (e.g., `egrep -v '^#' CGIscriptor.pl` >
32 # leanScriptor.pl). A bare bones version of CGIscriptor.pl, lacking
33 # documentation, most comments, access control, example functions etc.
34 # (but still with the copyright notice and some minimal documentation)
35 # can be obtained by calling CGIscriptor.pl with the '-slim'
36 # command line argument, e.g.,
37 # >CGIscriptor.pl -slim >slimCGIscriptor.pl
39 # CGIscriptor.pl can be run from the command line as
40 # `CGIscriptor.pl <path> <query>`, inside a perl script with
41 # 'do CGIscriptor.pl' after setting $ENV{PATH_INFO} and $ENV{QUERY_STRING},
42 # or CGIscriptor.pl can be loaded with 'require "/real-path/CGIscriptor.pl"'.
43 # In the latter case, requests are processed by 'Handle_Request();'
44 # (again after setting $ENV{PATH_INFO} and $ENV{QUERY_STRING}).
46 # The --help command line switch will print the manual.
48 # Running demo's and more information can be found at
49 # http://www.fon.hum.uva.nl/rob/OSS/OSS.html
51 # A pocket-size HTTP daemon, CGIservlet.pl, is available from my web site
52 # or CPAN that can use CGIscriptor.pl as the base of a µWWW server and
53 # demonstrates its use.
55 ENDOFPREHELPTEXT1
57 # Configuration, copyright notice, and user manual follow the next
58 # (Changes) section.
60 ############################################################################
62 # Changes (document ALL changes with date, name and email here):
63 # 06 Jun 2012 - Added IP only session types after login.
64 # 31 May 2012 - Session ticket system added for handling login sessions.
65 # 29 May 2012 - CGIsafeFileName does not accept filenames starting with '.'
66 # 29 May 2012 - Added CGIscriptor::BrowseAllDirs to handle browsing directories
67 # correctly.
68 # 22 May 2012 - Added Access control with Session Tickets linked to
69 # IP Address and PATH_INFO.
70 # 21 May 2012 - Corrected the links generated by CGIscriptor::BrowseDirs
71 # Will link to current base URL when the HTTP server is '.' or '~'
72 # 29 Oct 2009 - Adapted David A. Wheeler's suggestion about filenames:
73 # CGIsafeFileName does not accept filenames starting with '-'
74 # (http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)
75 # 08 Oct 2009 - Some corrections in the README.txt file, eg, new email address
76 # 28 Jan 2005 - Added a file selector to performTranslation.
77 # Changed %TranslationTable to @TranslationTable
78 # and patterns to lists.
79 # 27 Jan 2005 - Added a %TranslationTable with associated
80 # performTranslation(\$text) function to allow
81 # run changes in the web pages. Say, to translate
82 # legacy pages with <%=...%> delimiters to the new
83 # <SCRIPT TYPE=..></SCRIPT> format.
84 # 27 Jan 2005 - Small bug of extra '\n' in output removed from the
85 # Other Languages Code.
86 # 10 May 2004 - Belated upload of latest version (2.3) to CPAN
87 # 07 Oct 2003 - Corrected error '\s' -> '\\s' in rebol scripting
88 # language call
89 # 07 Oct 2003 - Corrected omitted INS tags in <DIV><INS> handling
90 # 20 May 2003 - Added a --help switch to print the manual.
91 # 06 Mar 2003 - Adapted the blurb at the end of the file.
92 # 03 Mar 2003 - Added a user definable dieHandler function to catch all
93 # "die" calls. Also "enhanced" the STDERR printout.
94 # 10 Feb 2003 - Split off the reading of the POST part of a query
95 # from Initialize_output. This was suggested by Gerd Franke
96 # to allow for the catching of the file_path using a
97 # POST based lookup. That is, he needed the POST part
98 # to change the file_path.
99 # 03 Feb 2003 - %{$name}; => %{$name} = (); in defineCGIvariableHash.
100 # 03 Feb 2003 - \1 better written as $1 in
101 # $directive =~ s/[^\\\$]\#[^\n\f\r]*([\n\f\r])/$1/g
102 # 29 Jan 2003 - This makes "CLASS="ssperl" CSS-compatible Gerd Franke
103 # added:
104 # $ServerScriptContentClass = "ssperl";
105 # changed in ProcessFile():
106 # unless(($CurrentContentType =~
107 # 28 Jan 2003 - Added 'INS' Tag! Gerd Franke
108 # 20 Dec 2002 - Removed useless $Directoryseparator variable.
109 # Update comments and documentation.
110 # 18 Dec 2002 - Corrected bug in Accept/Reject processing.
111 # Files didn't work.
112 # 24 Jul 2002 - Added .htaccess documentation (from Gerd Franke)
113 # Also added a note that RawFilePattern can be a
114 # complete file name.
115 # 19 Mar 2002 - Added SRC pseudo-files PREFIX and POSTFIX. These
116 # switch to prepending or to appending the content
117 # of the SRC attribute. Default is prefixing. You
118 # can add as many of these switches as you like.
119 # 13 Mar 2002 - Do not search for tag content if a tag closes with
120 # />, i.e., <DIV ... /> will be handled the XML/XHTML way.
121 # 25 Jan 2002 - Added 'curl' and 'snarf' to SRC attribute URL handling
122 # (replaces wget).
123 # 25 Jan 2002 - Found a bug in SAFEqx, now executes qx() in a scalar context
124 # (i.o. a list context). This is necessary for binary results.
125 # 24 Jan 2002 - Disambiguated -T $SRCfile to -T "$SRCfile" (and -e) and
126 # changed the order of if/elsif to allow removing these
127 # conditions in systems with broken -T functions.
128 # (I also removed a spurious ')' bracket)
129 # 17 Jan 2002 - Changed DIV tag SRC from <SOURCE> to sysread(SOURCE,...)
130 # to support binary files.
131 # 17 Jan 2002 - Removed WhiteSpace from $FileAllowedCharacters.
132 # 17 Jan 2002 - Allow "file://" prefix in SRC attribute. It is simply
133 # stipped from the path.
134 # 15 Jan 2002 - Version 2.2
135 # 15 Jan 2002 - Debugged and completed URL support (including
136 # CGIscriptor::read_url() function)
137 # 07 Jan 2002 - Added automatic (magic) URL support to the SRC attribute
138 # with the main::GET_URL function. Uses wget -O underlying.
139 # 04 Jan 2002 - Added initialization of $NewDirective in InsertForeignScript
140 # (i.e., my $NewDirective = "";) to clear old output
141 # (this was a realy anoying bug).
142 # 03 Jan 2002 - Added a <DIV CLASS='text/ssperl' ID='varname'></DIV>
143 # tags that assign the body text as-is (literally)
144 # to $varname. Allows standard HTML-tools to handle
145 # Cascading Style Sheet templates. This implements a
146 # design by Gerd Franke (franke@roo.de).
147 # 03 Jan 2002 - I finaly gave in and allowed SRC files to expand ~/.
148 # 12 Oct 2001 - Normalized spelling of "CGIsafFileName" in documentation.
149 # 09 Oct 2001 - Added $ENV{'CGI_BINARY_FILE'} to log files to
150 # detect unwanted indexing of TAR files by webcrawlers.
151 # 10 Sep 2001 - Added $YOUR_SCRIPTS directory to @INC for 'require'.
152 # 22 Aug 2001 - Added .txt (Content-type: text/plain) as a default
153 # processed file type. Was processed via BinaryMapFile.
154 # 31 May 2001 - Changed =~ inside CGIsafeEmailAddress that was buggy.
155 # 29 May 2001 - Updated $CGI_HOME to point to $ENV{DOCUMENT_ROOT} io
156 # the root of PATH_TRANSLATED. DOCUMENT_ROOT can now
157 # be manipulated to achieve a "Sub Root".
158 # NOTE: you can have $YOUR_HTML_FILES != DOCUMENT_ROOT
159 # 28 May 2001 - Changed CGIscriptor::BrowsDirs function for security
160 # and debugging (it now works).
161 # 21 May 2001 - defineCGIvariableHash will ADD values to existing
162 # hashes,instead of replacing existing hashes.
163 # 17 May 2001 - Interjected a '&' when pasting POST to GET data
164 # 24 Apr 2001 - Blocked direct requests for BinaryMapFile.
165 # 16 Aug 2000 - Added hash table extraction for CGI parameters with
166 # CGIparseValueHash (used with structured parameters).
167 # Use: CGI='%<CGI-partial-name>' (fill in your name in <>)
168 # Will collect all <CGI-partial-name><key>=value pairs in
169 # $<CGI-partial-name>{<key>} = value;
170 # 16 Aug 2000 - Adapted SAFEqx to protect @PARAMETER values.
171 # 09 Aug 2000 - Added support for non-filesystem input by way of
172 # the CGI_FILE_CONTENTS and CGI_DATA_ACCESS_CODE
173 # environment variables.
174 # 26 Jul 2000 - On the command-line, file-path '-' indicates STDIN.
175 # This allows CGIscriptor to be used in pipes.
176 # Default, $BLOCK_STDIN_HTTP_REQUEST=1 will block this
177 # in an HTTP request (i.e., in a web server).
178 # 26 Jul 2000 - Blocked 'Content-type: text/html' if the SERVER_PROTOCOL
179 # is not HTTP or another protocol. Changed the default
180 # source directory to DOCUMENT_ROOT (i.o. the incorrect
181 # SERVER_ROOT).
182 # 24 Jul 2000 - -slim Command-line argument added to remove all
183 # comments, security, etc.. Updated documentation.
184 # 05 Jul 2000 - Added IF and UNLESS attributes to make the
185 # execution of all <META> and <SCRIPT> code
186 # conditional.
187 # 05 Jul 2000 - Rewrote and isolated the code for extracting
188 # quoted items from CGI and SRC attributes.
189 # Now all attributes expect the same set of
190 # quotes: '', "", ``, (), {}, [] and the same
191 # preceded by a \, e.g., "\((aap)\)" will be
192 # extracted as "(aap)".
193 # 17 Jun 2000 - Construct @ARGV list directly in CGIexecute
194 # name-space (i.o. by evaluation) from
195 # CGI attributes to prevent interference with
196 # the processing for non perl scripts.
197 # Changed CGIparseValueList to prevent runaway
198 # loops.
199 # 16 Jun 2000 - Added a direct (interpolated) display mode
200 # (text/ssdisplay) and a user log mode
201 # (text/sslogfile).
202 # 06 Jun 2000 - Replace "print $Result" with a syswrite loop to
203 # allow large string output.
204 # 02 Jun 2000 - Corrected shrubCGIparameter($CGI_VALUE) to realy
205 # remove all control characters. Changed Interpreter
206 # initialization to shrub interpolated CGI parameters.
207 # Added 'text/ssmailto' interpreter script.
208 # 22 May 2000 - Changed some of the comments
209 # 09 May 2000 - Added list extraction for CGI parameters with
210 # CGIparseValueList (used with multiple selections).
211 # Use: CGI='@<CGI-parameter>' (fill in your name in <>)
212 # 09 May 2000 - Added a 'Not Present' condition to CGIparseValue.
213 # 27 Apr 2000 - Updated documentation to reflect changes.
214 # 27 Apr 2000 - SRC attribute "cleaned". Supported for external
215 # interpreters.
216 # 27 Apr 2000 - CGI attribute can be used in <SCRIPT> tag.
217 # 27 Apr 2000 - Gprolog, M4 support added.
218 # 26 Apr 2000 - Lisp (rep) support added.
219 # 20 Apr 2000 - Use of external interpreters now functional.
220 # 20 Apr 2000 - Removed bug from extracting Content types (RegExp)
221 # 10 Mar 2000 - Qualified unconditional removal of '#' that preclude
222 # the use of $#foo, i.e., I changed
223 # s/[^\\]\#[^\n\f\r]*([\n\f\r])/\1/g
224 # to
225 # s/[^\\\$]\#[^\n\f\r]*([\n\f\r])/\1/g
226 # 03 Mar 2000 - Added a '$BlockPathAccess' variable to "hide"
227 # things like, e.g., CVS information in CVS subtrees
228 # 10 Feb 2000 - URLencode/URLdecode have been made case-insensitive
229 # 10 Feb 2000 - Added a BrowseDirs function (CGIscriptor package)
230 # 01 Feb 2000 - A BinaryMapFile in the ~/ directory has precedence
231 # over a "burried" BinaryMapFile.
232 # 04 Oct 1999 - Added two functions to check file names and email addresses
233 # (CGIscriptor::CGIsafeFileName and
234 # CGIscriptor::CGIsafeEmailAddress)
235 # 28 Sept 1999 - Corrected bug in sysread call for reading POST method
236 # to allow LONG posts.
237 # 28 Sept 1999 - Changed CGIparseValue to handle multipart/form-data.
238 # 29 July 1999 - Refer to BinaryMapFile from CGIscriptor directory, if
239 # this directory exists.
240 # 07 June 1999 - Limit file-pattern matching to LAST extension
241 # 04 June 1999 - Default text/html content type is printed only once.
242 # 18 May 1999 - Bug in replacement of ~/ and ./ removed.
243 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
244 # 15 May 1999 - Changed the name of the execute package to CGIexecute.
245 # Changed the processing of the Accept and Reject file.
246 # Added a full expression evaluation to Access Control.
247 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
248 # 27 Apr 1999 - Brought CGIscriptor under the GNU GPL. Made CGIscriptor
249 # Version 1.1 a module that can be called with 'require "CGIscriptor.pl"'.
250 # Requests are serviced by "Handle_Request()". CGIscriptor
251 # can still be called as a isolated perl script and a shell
252 # command.
253 # Changed the "factory default setting" so that it will run
254 # from the DOCUMENT_ROOT directory.
255 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
256 # 29 Mar 1999 - Remove second debugging STDERR switch. Moved most code
257 # to subroutines to change CGIscriptor into a module.
258 # Added mapping to process unsupported file types (e.g., binary
259 # pictures). See $BinaryMapFile.
260 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
261 # 24 Sept 1998 - Changed text of license (Rob van Son, R.J.J.H.vanSon@uva.nl)
262 # Removed a double setting of filepatterns and maximum query
263 # size. Changed email address. Removed some typos from the
264 # comments.
265 # 02 June 1998 - Bug fixed in URLdecode. Changing the foreach loop variable
266 # caused quiting CGIscriptor.(Rob van Son, R.J.J.H.vanSon@uva.nl)
267 # 02 June 1998 - $SS_PUB and $SS_SCRIPT inserted an extra /, removed.
268 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
271 # Known Bugs:
273 # 23 Mar 2000
274 # It is not possible to use operators or variables to construct variable names,
275 # e.g., $bar = \@{$foo}; won't work. However, eval('$bar = \@{'.$foo.'};');
276 # will indeed work. If someone could tell me why, I would be obliged.
279 ############################################################################
281 # OBLIGATORY USER CONFIGURATION
283 # Configure the directories where all user files can be found (this
284 # is the equivalent of the server root directory of a WWW-server).
285 # These directories can be located ANYWHERE. For security reasons, it is
286 # better to locate them outside the WWW-tree of your HTTP server, unless
287 # CGIscripter handles ALL requests.
289 # For convenience, the defaults are set to the root of the WWW server.
290 # However, this might not be safe!
292 # ~/ text files
293 # $YOUR_HTML_FILES = "/usr/pub/WWW/SHTML"; # or SS_PUB as environment var
294 # (patch to use the parent directory of CGIscriptor as document root, should be removed)
295 if($ENV{'SCRIPT_FILENAME'}) # && $ENV{'SCRIPT_FILENAME'} !~ /\Q$ENV{'DOCUMENT_ROOT'}\E/)
297 $ENV{'DOCUMENT_ROOT'} = $ENV{'SCRIPT_FILENAME'};
298 $ENV{'DOCUMENT_ROOT'} =~ s@/CGIscriptor.*$@@ig;
301 # Just enter your own directory path here
302 $YOUR_HTML_FILES = $ENV{'DOCUMENT_ROOT'}; # default is the DOCUMENT_ROOT
304 # ./ script files (recommended to be different from the previous)
305 # $YOUR_SCRIPTS = "/usr/pub/WWW/scripts"; # or SS_SCRIPT as environment var
306 $YOUR_SCRIPTS = $YOUR_HTML_FILES; # This might be a SECURITY RISK
308 # End of obligatory user configuration
309 # (note: there is more non-essential user configuration below)
311 ############################################################################
313 # OPTIONAL USER CONFIGURATION (all values are used CASE INSENSITIVE)
315 # Script content-types: TYPE="Content-type" (user defined mime-type)
316 $ServerScriptContentType = "text/ssperl"; # Server Side Perl scripts
317 # CSS require a simple class
318 $ServerScriptContentClass = $ServerScriptContentType =~ m!/! ?
319 $' : "ssperl"; # Server Side Perl CSS classes
321 $ShellScriptContentType = "text/osshell"; # OS shell scripts
322 # # (Server Side perl ``-execution)
324 # Accessible file patterns, block any request that doesn't match.
325 # Matches any file with the extension .(s)htm(l), .txt, or .xmr
326 # (\. is used in regexp)
327 # Note: die unless $PATH_INFO =~ m@($FilePattern)$@is;
328 $FilePattern = ".shtml|.htm|.html|.xml|.xmr|.txt";
330 # The table with the content type MIME types
331 # (allows to differentiate MIME types, if needed)
332 %ContentTypeTable =
334 '.html' => 'text/html',
335 '.shtml' => 'text/html',
336 '.htm' => 'text/html',
337 '.xml' => 'text/xml',
338 '.txt' => 'text/plain'
342 # File pattern post-processing
343 $FilePattern =~ s/([@.])/\\$1/g; # Convert . and @ to \. and \@
345 # SHAsum command needed for Authorization and Login
346 # (note, these have to be accessible in the HTML pages, ie, the CGIexecute environment)
347 my $shasum = qx{uname} =~ /Darwin/ ? "shasum-5.12" : "shasum";
348 my $SHASUMCMD = $shasum.' |cut -f 1 -d" "';
349 $ENV{"SHASUMCMD"} = $SHASUMCMD;
350 my $RANDOMHASHCMD = 'dd bs=32 count=1 if=/dev/urandom 2>/dev/null | '.$shasum.' -b |cut -f 1 -d" "';
351 $ENV{"RANDOMHASHCMD"} = $RANDOMHASHCMD;
353 # File patterns of files which are handled by session tickets.
354 %TicketRequiredPatterns = (
355 '^/Private(/|$)' => "Private/.Sessions\tPrivate/.Passwords\t/Private/Login.html\t+36000"
357 # Used to set cookies, only session cookies supported
358 my %SETCOOKIELIST = ();
359 # Session Ticket Directory: Private/.Sessions
360 # Password Directory: Private/.Passwords
361 # Login page (url path): /Private/Login.html
362 # Expiration time (s): +3600
363 # +<seconds> = relative time <seconds> is absolute date-time
365 # Raw files must contain their own Content-type (xmr <- x-multipart-replace).
366 # THIS IS A SUBSET OF THE FILES DEFINED IN $FilePattern
367 $RawFilePattern = ".xmr";
368 # (In principle, this could contain a full file specification, e.g.,
369 # ".xmr|relocated.html")
371 # Raw File pattern post-processing
372 $RawFilePattern =~ s/([@.])/\\$1/g; # Convert . and @ to \. and \@
374 # Server protocols for which "Content-type: text/html\n\n" should be printed
375 # (you should not bother with these, except for HTTP, they are mostly imaginary)
376 $ContentTypeServerProtocols = 'HTTP|MAIL|MIME';
378 # Block access to all (sub-) paths and directories that match the
379 # following (URL) path (is used as:
380 # 'die if $BlockPathAccess && $ENV{'PATH_INFO'} =~ m@$BlockPathAccess@;' )
381 $BlockPathAccess = '/(CVS|\.git)/'; # Protect CVS and .git information
383 # All (blocked) other file-types can be mapped to a single "binary-file"
384 # processor (a kind of pseudo-file path). This can either be an error
385 # message (e.g., "illegal file") or contain a script that serves binary
386 # files.
387 # Note: the real file path wil be stored in $ENV{CGI_BINARY_FILE}.
388 $BinaryMapFile = "/BinaryMapFile.xmr";
389 # Allow for the addition of a CGIscriptor directory
390 # Note that a BinaryMapFile in the root "~/" directory has precedence
391 $BinaryMapFile = "/CGIscriptor".$BinaryMapFile
392 if ! -e "$YOUR_HTML_FILES".$BinaryMapFile
393 && -e "$YOUR_HTML_FILES/CGIscriptor".$BinaryMapFile;
396 # List of all characters that are allowed in file names and paths.
397 # All requests containing illegal characters are blocked. This
398 # blocks most tricks (e.g., adding "\000", "\n", or other control
399 # characters, also blocks URI's using %FF)
400 # THIS IS A SECURITY FEATURE
401 # (this is also used to parse filenames in SRC= features, note the
402 # '-quotes, they are essential)
403 $FileAllowedChars = '\w\.\~\/\:\*\?\-'; # Covers Unix and Mac, but NO spaces
405 # Maximum size of the Query (number of characters clients can send
406 # covers both GET & POST combined)
407 $MaximumQuerySize = 2**20 - 1; # = 2**14 - 1
410 # Embeded URL get function used in SRC attributes and CGIscriptor::read_url
411 # (returns a string with the PERL code to transfer the URL contents, e.g.,
412 # "SAFEqx(\'curl \"http://www.fon.hum.uva.nl\"\')")
413 # "SAFEqx(\'wget --quiet --output-document=- \"http://www.fon.hum.uva.nl\"\')")
414 # Be sure to handle <BASE HREF='URL'> and allow BOTH
415 # direct printing GET_URL($URL [, 0]) and extracting the content of
416 # the $URL for post-processing GET_URL($URL, 1).
417 # You get the WHOLE file, including HTML header.
418 # The shell command Use $URL where the URL should go
419 # ('wget', 'snarf' or 'curl', uncomment the one you would like to use)
420 my $GET_URL_shell_command = 'wget --quiet --output-document=- $URL';
421 #my $GET_URL_shell_command = 'snarf $URL -';
422 #my $GET_URL_shell_command = 'curl $URL';
424 sub GET_URL # ($URL, $ValueNotPrint) -> content_of_url
426 my $URL = shift || return;
427 my $ValueNotPrint = shift || 0;
429 # Check URL for illegal characters
430 return "print '<h1>Illegal URL<h1>'\"\n\";" if $URL =~ /[^$FileAllowedChars\%]/;
432 # Include URL in final command
433 my $CurrentCommand = $GET_URL_shell_command;
434 $CurrentCommand =~ s/\$URL/$URL/g;
436 # Print to STDOUT or return a value
437 my $BlockPrint = "print STDOUT ";
438 $BlockPrint = "" if $ValueNotPrint;
440 my $Commands = <<"GETURLCODE";
441 # Get URL
443 my \$Page = "";
445 # Simple, using shell command
446 \$Page = SAFEqx('$CurrentCommand');
448 # Add a BASE tage to the header
449 \$Page =~ s!\\</head!\\<base href='$URL'\\>\\</head!ig unless \$Page =~ m!\\<base!;
451 # Print the URL value, or return it as a value
452 $BlockPrint\$Page;
454 GETURLCODE
455 return $Commands;
458 # As files can get rather large (and binary), you might want to use
459 # some more intelligent reading procedure, e.g.,
460 # Direct Perl
461 # # open(URLHANDLE, '/usr/bin/wget --quiet --output-document=- "$URL"|') || die "wget: \$!";
462 # #open(URLHANDLE, '/usr/bin/snarf "$URL" -|') || die "snarf: \$!";
463 # open(URLHANDLE, '/usr/bin/curl "$URL"|') || die "curl: \$!";
464 # my \$text = "";
465 # while(sysread(URLHANDLE,\$text, 1024) > 0)
467 # \$Page .= \$text;
468 # };
469 # close(URLHANDLE) || die "\$!";
470 # However, this doesn't work with the CGIexecute->evaluate() function.
471 # You get an error: 'No child processes at (eval 16) line 15, <file0> line 8.'
473 # You can forget the next two variables, they are only needed when
474 # you don't want to use a regular file system (i.e., with open)
475 # but use some kind of database/RAM image for accessing (generating)
476 # the data.
478 # Name of the environment variable that contains the file contents
479 # when reading directly from Database/RAM. When this environment variable,
480 # $ENV{$CGI_FILE_CONTENTS}, is not false, no real file will be read.
481 $CGI_FILE_CONTENTS = 'CGI_FILE_CONTENTS';
482 # Uncomment the following if you want to force the use of the data access code
483 # $ENV{$CGI_FILE_CONTENTS} = '-'; # Force use of $ENV{$CGI_DATA_ACCESS_CODE}
485 # Name of the environment variable that contains the RAM access perl
486 # code needed to read additional "files", i.e.,
487 # $ENV{$CGI_FILE_CONTENTS} = eval("\@_=('$file_path'); do{$ENV{$CGI_DATA_ACCESS_CODE}}");
488 # When $ENV{$CGI_FILE_CONTENTS} eq '-', this code is executed to generate the data.
489 $CGI_DATA_ACCESS_CODE = 'CGI_DATA_ACCESS_CODE';
491 # You can, of course, fill this yourself, e.g.,
492 # $ENV{$CGI_DATA_ACCESS_CODE} =
493 # 'open(INPUT, "<$_[0]"); while(<INPUT>){print;};close(INPUT);'
496 # DEBUGGING
498 # Suppress error messages, this can be changed for debugging or error-logging
499 #open(STDERR, "/dev/null"); # (comment out for use in debugging)
501 # SPECIAL: Remove Comments, security, etc. if the command line is
502 # '>CGIscriptor.pl -slim >slimCGIscriptor.pl'
503 $TrimDownCGIscriptor = 1 if $ARGV[0] =~ /^\-slim/i;
505 # If CGIscriptor is used from the command line, the command line
506 # arguments are interpreted as the file (1st) and the Query String (rest).
507 # Get the arguments
508 $ENV{'PATH_INFO'} = shift(@ARGV) unless exists($ENV{'PATH_INFO'}) || grep(/\-\-help/i, @ARGV);
509 $ENV{'QUERY_STRING'} = join("&", @ARGV) unless exists($ENV{'QUERY_STRING'});
512 # Handle bail-outs in a user definable way.
513 # Catch Die and replace it with your own function.
514 # Ends with a call to "die $_[0];"
516 sub dieHandler # ($ErrorCode, "Message", @_) -> DEAD
518 my $ErrorCode = shift;
519 my $ErrorMessage = shift;
521 # Place your own reporting functions here
523 # Now, kill everything (default)
524 print STDERR "$ErrorCode: $ErrorMessage\n";
525 die $ErrorMessage;
529 # End of optional user configuration
530 # (note: there is more non-essential user configuration below)
532 if(grep(/\-\-help/i, @ARGV))
534 print << 'ENDOFPREHELPTEXT2';
536 ###############################################################################
538 # Author and Copyright (c):
539 # Rob van Son, © 1995,1996,1997,1998,1999,2000,2001,2002-2012
540 # NKI-AVL Amsterdam
541 # r.v.son@nki.nl
542 # Institute of Phonetic Sciences & IFOTT/ACLS
543 # University of Amsterdam
544 # Email: R.J.J.H.vanSon@gmail.com
545 # Email: R.J.J.H.vanSon@uva.nl
546 # WWW : http://www.fon.hum.uva.nl/rob/
548 # License for use and disclaimers
550 # CGIscriptor merges plain ASCII HTML files transparantly
551 # with CGI variables, in-line PERL code, shell commands,
552 # and executable scripts in other scripting languages.
554 # This program is free software; you can redistribute it and/or
555 # modify it under the terms of the GNU General Public License
556 # as published by the Free Software Foundation; either version 2
557 # of the License, or (at your option) any later version.
559 # This program is distributed in the hope that it will be useful,
560 # but WITHOUT ANY WARRANTY; without even the implied warranty of
561 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
562 # GNU General Public License for more details.
564 # You should have received a copy of the GNU General Public License
565 # along with this program; if not, write to the Free Software
566 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
569 # Contributors:
570 # Rob van Son (R.J.J.H.vanSon@uva.nl)
571 # Gerd Franke franke@roo.de (designed the <DIV> behaviour)
573 #######################################################
574 ENDOFPREHELPTEXT2
576 #######################################################>>>>>>>>>>Start Remove
578 # You can skip the following code, it is an auto-splice
579 # procedure.
581 # Construct a slimmed down version of CGIscriptor
582 # (i.e., CGIscriptor.pl -slim > slimCGIscriptor.pl)
584 if($TrimDownCGIscriptor)
586 open(CGISCRIPTOR, "<CGIscriptor.pl")
587 || dieHandler(1, "<CGIscriptor.pl not slimmed down: $!\n");
588 my $SKIPtext = 0;
589 my $SKIPComments = 0;
591 while(<CGISCRIPTOR>)
593 my $SKIPline = 0;
595 ++$LineCount;
597 # Start of SKIP text
598 $SKIPtext = 1 if /[\>]{10}Start Remove/;
599 $SKIPComments = 1 if $SKIPtext == 1;
601 # Skip this line?
602 $SKIPline = 1 if $SKIPtext || ($SKIPComments && /^\s*\#/);
604 ++$PrintCount unless $SKIPline;
606 print STDOUT $_ unless $SKIPline;
608 # End of SKIP text ?
609 $SKIPtext = 0 if /[\<]{10}End Remove/;
611 # Ready!
612 print STDERR "\# Printed $PrintCount out of $LineCount lines\n";
613 exit;
616 #######################################################
618 if(grep(/\-\-help/i, @ARGV))
620 print << 'ENDOFHELPTEXT';
622 # HYPE
624 # CGIscriptor merges plain ASCII HTML files transparantly and safely
625 # with CGI variables, in-line PERL code, shell commands, and executable
626 # scripts in many languages (on-line and real-time). It combines the
627 # "ease of use" of HTML files with the versatillity of specialized
628 # scripts and PERL programs. It hides all the specifics and
629 # idiosyncrasies of correct output and CGI coding and naming. Scripts
630 # do not have to be aware of HTML, HTTP, or CGI conventions just as HTML
631 # files can be ignorant of scripts and the associated values. CGIscriptor
632 # complies with the W3C HTML 4.0 recommendations.
633 # In addition to its use as a WWW embeded CGI processor, it can
634 # be used as a command-line document preprocessor (text-filter).
636 # THIS IS HOW IT WORKS
638 # The aim of CGIscriptor is to execute "plain" scripts inside a text file
639 # using any required CGIparameters and environment variables. It
640 # is optimized to transparantly process HTML files inside a WWW server.
641 # The native language is Perl, but many other scripting languages
642 # can be used.
644 # CGIscriptor reads text files from the requested input file (i.e., from
645 # $YOUR_HTML_FILES$PATH_INFO) and writes them to <STDOUT> (i.e., the
646 # client requesting the service) preceded by the obligatory
647 # "Content-type: text/html\n\n" or "Content-type: text/plain\n\n" string
648 # (except for "raw" files which supply their own Content-type message
649 # and only if the SERVER_PROTOCOL supports HTTP, MAIL, or MIME).
651 # When CGIscriptor encounters an embedded script, indicated by an HTML4 tag
653 # <SCRIPT TYPE="text/ssperl" [CGI="$VAR='default value'"] [SRC="ScriptSource"]>
654 # PERL script
655 # </SCRIPT>
657 # or
659 # <SCRIPT TYPE="text/osshell" [CGI="$name='default value'"] [SRC="ScriptSource"]>
660 # OS Shell script
661 # </SCRIPT>
663 # construct (anything between []-brackets is optional, other MIME-types
664 # and scripting languages are supported), the embedded script is removed
665 # and both the contents of the source file (i.e., "do 'ScriptSource'")
666 # AND the script are evaluated as a PERL program (i.e., by eval()),
667 # shell script (i.e., by a "safe" version of `Command`, qx) or an external
668 # interpreter. The output of the eval() function takes the place of the
669 # original <SCRIPT></SCRIPT> construct in the output string. Any CGI
670 # parameters declared by the CGI attribute are available as simple perl
671 # variables, and can subsequently be made available as variables to other
672 # scripting languages (e.g., bash, python, or lisp).
674 # Example: printing "Hello World"
675 # <HTML><HEAD><TITLE>Hello World</TITLE>
676 # <BODY>
677 # <H1><SCRIPT TYPE="text/ssperl">"Hello World"</SCRIPT></H1>
678 # </BODY></HTML>
680 # Save this in a file, hello.html, in the directory you indicated with
681 # $YOUR_HTML_FILES and access http://your_server/SHTML/hello.html
682 # (or to whatever name you use as an alias for CGIscriptor.pl).
683 # This is realy ALL you need to do to get going.
685 # You can use any values that are delivered in CGI-compliant form (i.e.,
686 # the "?name=value" type URL additions) transparently as "$name" variables
687 # in your scripts IFF you have declared them in the CGI attribute of
688 # a META or SCRIPT tag before e.g.:
689 # <META CONTENT="text/ssperl; CGI='$name = `default value`'
690 # [SRC='ScriptSource']">
691 # or
692 # <SCRIPT TYPE="text/ssperl" CGI="$name = 'default value'"
693 # [SRC='ScriptSource']>
694 # After such a 'CGI' attribute, you can use $name as an ordinary PERL variable
695 # (the ScriptSource file is immediately evaluated with "do 'ScriptSource'").
696 # The CGIscriptor script allows you to write ordinary HTML files which will
697 # include dynamic CGI aware (run time) features, such as on-line answers
698 # to specific CGI requests, queries, or the results of calculations.
700 # For example, if you wanted to answer questions of clients, you could write
701 # a Perl program called "Answer.pl" with a function "AnswerQuestion()"
702 # that prints out the answer to requests given as arguments. You then write
703 # an HTML page "Respond.html" containing the following fragment:
705 # <center>
706 # The Answer to your question
707 # <META CONTENT="text/ssperl; CGI='$Question'">
708 # <h3><SCRIPT TYPE="text/ssperl">$Question</SCRIPT></h3>
709 # is
710 # <h3><SCRIPT TYPE="text/ssperl" SRC="./PATH/Answer.pl">
711 # AnswerQuestion($Question);
712 # </SCRIPT></h3>
713 # </center>
714 # <FORM ACTION=Respond.html METHOD=GET>
715 # Next question: <INPUT NAME="Question" TYPE=TEXT SIZE=40><br>
716 # <INPUT TYPE=SUBMIT VALUE="Ask">
717 # </FORM>
719 # The output could look like the following (in HTML-speak):
721 # <CENTER>
722 # The Answer to your question
723 # <h3>What is the capital of the Netherlands?</h3>
724 # is
725 # <h3>Amsterdam</h3>
726 # </CENTER>
727 # <FORM ACTION=Respond.html METHOD=GET>
728 # Next question: <INPUT NAME="Question" TYPE=TEXT SIZE=40><br>
729 # <INPUT TYPE=SUBMIT VALUE="Ask">
731 # Note that the function "Answer.pl" does know nothing about CGI or HTML,
732 # it just prints out answers to arguments. Likewise, the text has no
733 # provisions for scripts or CGI like constructs. Also, it is completely
734 # trivial to extend this "program" to use the "Answer" later in the page
735 # to call up other information or pictures/sounds. The final text never
736 # shows any cue as to what the original "source" looked like, i.e.,
737 # where you store your scripts and how they are called.
739 # There are some extra's. The argument of the files called in a SRC= tag
740 # can access the CGI variables declared in the preceding META tag from
741 # the @ARGV array. Executable files are called as:
742 # `file '$ARGV[0]' ... ` (e.g., `Answer.pl \'$Question\'`;)
743 # The files called from SRC can even be (CGIscriptor) html files which are
744 # processed in-line. Furthermore, the SRC= tag can contain a perl block
745 # that is evaluated. That is,
746 # <META CONTENT="text/ssperl; CGI='$Question' SRC='{$Question}'">
747 # will result in the evaluation of "print do {$Question};" and the VALUE
748 # of $Question will be printed. Note that these "SRC-blocks" can be
749 # preceded and followed by other file names, but only a single block is
750 # allowed in a SRC= tag.
752 # One of the major hassles of dynamic WWW pages is the fact that several
753 # mutually incompatible browsers and platforms must be supported. For example,
754 # the way sound is played automatically is different for Netscape and
755 # Internet Explorer, and for each browser it is different again on
756 # Unix, MacOS, and Windows. Realy dangerous is processing user-supplied
757 # (form-) values to construct email addresses, file names, or database
758 # queries. All Apache WWW-server exploits reported in the media are
759 # based on faulty CGI-scripts that didn't check their user-data properly.
761 # There is no panacee for these problems, but a lot of work and problems
762 # can be saved by allowing easy and transparent control over which
763 # <SCRIPT></SCRIPT> blocks are executed on what CGI-data. CGIscriptor
764 # supplies such a method in the form of a pair of attributes:
765 # IF='...condition..' and UNLESS='...condition...'. When added to a
766 # script tag, the whole block (including the SRC attribute) will be
767 # ignored if the condition is false (IF) or true (UNLESS).
768 # For example, the following block will NOT be evaluated if the value
769 # of the CGI variable FILENAME is NOT a valid filename:
771 # <SCRIPT TYPE='text/ssperl' CGI='$FILENAME'
772 # IF='CGIscriptor::CGIsafeFileName($FILENAME)'>
773 # .....
774 # </SCRIPT>
776 # (the function CGIsafeFileName(String) returns an empty string ("")
777 # if the String argument is not a valid filename).
778 # The UNLESS attribute is the mirror image of IF.
780 # A user manual follows the HTML 4 and security paragraphs below.
782 ##########################################################################
784 # HTML 4 compliance
786 # In general, CGIscriptor.pl complies with the HTML 4 recommendations of
787 # the W3C. This means that any software to manage Web sites will be able
788 # to handle CGIscriptor files, as will web agents.
790 # All script code should be placed between <SCRIPT></SCRIPT> tags, the
791 # script type is indicated with TYPE="mime-type", the LANGUAGE
792 # feature is ignored, and a SRC feature is implemented. All CGI specific
793 # features are delegated to the CGI attribute.
795 # However, the behavior deviates from the W3C recommendations at some
796 # points. Most notably:
797 # 0- The scripts are executed at the server side, invissible to the
798 # client (i.e., the browser)
799 # 1- The mime-types are personal and idiosyncratic, but can be adapted.
800 # 2- Code in the body of a <SCRIPT></SCRIPT> tag-pair is still evaluated
801 # when a SRC feature is present.
802 # 3- The SRC attribute reads a list of files.
803 # 4- The files in a SRC attribute are processed according to file type.
804 # 5- The SRC attribute evaluates inline Perl code.
805 # 6- Processed META, DIV, INS tags are removed from the output
806 # document.
807 # 7- All attributes of the processed META tags, except CONTENT, are ignored
808 # (i.e., deleted from the output).
809 # 8- META tags can be placed ANYWHERE in the document.
810 # 9- Through the SRC feature, META tags can have visible output in the
811 # document.
812 # 10- The CGI attribute that declares CGI parameters, can be used
813 # inside the <SCRIPT> tag.
814 # 11- Use of an extended quote set, i.e., '', "", ``, (), {}, []
815 # and their \-slashed combinations: \'\', \"\", \`\`, \(\),
816 # \{\}, \[\].
817 # 12- IF and UNLESS attributes to <SCRIPT>, <META>, <DIV>, <INS> tags.
818 # 13- <DIV> tags cannot be nested, DIV tags are not
819 # rendered with new-lines.
820 # 14- The XML style <TAG .... /> is recognized and handled correctly.
821 # (i.e., no content is processed)
823 # The reasons for these choices are:
824 # You can still write completely HTML4 compliant documents. CGIscriptor
825 # will not force you to write "deviant" code. However, it allows you to
826 # do so (which is, in fact, just as bad). The prime design principle
827 # was to allow users to include plain Perl code. The code itself should
828 # be "enhancement free". Therefore, extra features were needed to
829 # supply easy access to CGI and Web site components. For security
830 # reasons these have to be declared explicitly. The SRC feature
831 # transparently manages access to external files, especially the safe
832 # use of executable files.
833 # The CGI attribute handles the declarations of external (CGI) variables
834 # in the SCRIPT and META tag's.
835 # EVERYTHING THE CGI ATTRIBUTE AND THE META TAG DO CAN BE DONE INSIDE
836 # A <SCRIPT></SCRIPT> TAG CONSTRUCT.
838 # The reason for the IF, UNLESS, and SRC attributes (and their Perl code
839 # evaluation) were build into the META and SCRIPT tags is part laziness,
840 # part security. The SRC blocks allows more compact documents and easier
841 # debugging. The values of the CGI variables can be immediately screened
842 # for security by IF or UNLESS conditions, and even SRC attributes (e.g.,
843 # email addresses and file names), and a few commands can be called
844 # without having to add another Perl TAG pair. This is especially important
845 # for documents that require the use of other (more restricted) "scripting"
846 # languages and facilities that lag transparent control structures.
848 ##########################################################################
850 # SECURITY
852 # Your WWW site is a few keystrokes away from a few hundred million internet
853 # users. A fair percentage of these users knows more about your computer
854 # than you do. And some of these just might have bad intentions.
856 # To ensure uncompromized operation of your server and platform, several
857 # features are incorporated in CGIscriptor.pl to enhance security.
858 # First of all, you should check the source of this program. No security
859 # measures will help you when you download programs from anonymous sources.
860 # If you want to use THIS file, please make sure that it is uncompromized.
861 # The best way to do this is to contact the source and try to determine
862 # whether s/he is reliable (and accountable).
864 # BE AWARE THAT ANY PROGRAMMER CAN CHANGE THIS PROGRAM IN SUCH A WAY THAT
865 # IT WILL SET THE DOORS TO YOUR SYSTEM WIDE OPEN
867 # I would like to ask any user who finds bugs that could compromise
868 # security to report them to me (and any other bug too,
869 # Email: R.J.J.H.vanSon@uva.nl or ifa@hum.uva.nl).
871 # Security features
873 # 1 Invisibility
874 # The inner workings of the HTML source files are completely hidden
875 # from the client. Only the HTTP header and the ever changing content
876 # of the output distinguish it from the output of a plain, fixed HTML
877 # file. Names, structures, and arguments of the "embedded" scripts
878 # are invisible to the client. Error output is suppressed except
879 # during debugging (user configurable).
881 # 2 Separate directory trees
882 # Directories containing Inline text and script files can reside on
883 # separate trees, distinct from those of the HTTP server. This means
884 # that NEITHER the text files, NOR the script files can be read by
885 # clients other than through CGIscriptor.pl, UNLESS they are
886 # EXPLICITELY made available.
888 # 3 Requests are NEVER "evaluated"
889 # All client supplied values are used as literal values (''-quoted).
890 # Client supplied ''-quotes are ALWAYS removed. Therefore, as long as the
891 # embedded scripts do NOT themselves evaluate these values, clients CANNOT
892 # supply executable commands. Be sure to AVOID scripts like:
894 # <META CONTENT="text/ssperl; CGI='$UserValue'">
895 # <SCRIPT TYPE="text/ssperl">$dir = `ls -1 $UserValue`;</SCRIPT>
897 # These are a recipe for disaster. However, the following quoted
898 # form should be save (but is still not adviced):
900 # <SCRIPT TYPE="text/ssperl">$dir = `ls -1 \'$UserValue\'`;</SCRIPT>
902 # A special function, SAFEqx(), will automatically do exactly this,
903 # e.g., SAFEqx('ls -1 $UserValue') will execute `ls -1 \'$UserValue\'`
904 # with $UserValue interpolated. I recommend to use SAFEqx() instead
905 # of backticks whenever you can. The OS shell scripts inside
907 # <SCRIPT TYPE="text/osshell">ls -1 $UserValue</SCRIPT>
909 # are handeld by SAFEqx and automatically ''-quoted.
911 # 4 Logging of requests
912 # All requests can be logged separate from the Host server. The level of
913 # detail is user configurable: Including or excluding the actual queries.
914 # This allows for the inspection of (im-) proper use.
916 # 5 Access control: Clients
917 # The Remote addresses can be checked against a list of authorized
918 # (i.e., accepted) or non-authorized (i.e., rejected) clients. Both
919 # REMOTE_HOST and REMOTE_ADDR are tested so clients without a proper
920 # HOST name can be (in-) excluded by their IP-address. Client patterns
921 # containing all numbers and dots are considered IP-addresses, all others
922 # domain names. No wild-cards or regexp's are allowed, only partial
923 # addresses.
924 # Matching of names is done from the back to the front (domain first,
925 # i.e., $REMOTE_HOST =~ /\Q$pattern\E$/is), so including ".edu" will
926 # accept or reject all clients from the domain EDU. Matching of
927 # IP-addresses is done from the front to the back (domain first, i.e.,
928 # $REMOTE_ADDR =~ /^\Q$pattern\E/is), so including "128." will (in-)
929 # exclude all clients whose IP-address starts with 128.
930 # There are two special symbols: "-" matches HOSTs with no name and "*"
931 # matches ALL HOSTS/clients.
932 # For those needing more expressional power, lines starting with
933 # "-e" are evaluated by the perl eval() function. E.g.,
934 # '-e $REMOTE_HOST =~ /\.edu$/is;' will accept/reject clients from the
935 # domain '.edu'.
937 # 6 Access control: Files
938 # In principle, CGIscriptor could read ANY file in the directory
939 # tree as discussed in 1. However, for security reasons this is
940 # restricted to text files. It can be made more restricted by entering
941 # a global file pattern (e.g., ".html"). This is done by default.
942 # For each client requesting access, the file pattern(s) can be made
943 # more restrictive than the global pattern by entering client specific
944 # file patterns in the Access Control files (see 5).
945 # For example: if the ACCEPT file contained the lines
946 # * DEMO
947 # .hum.uva.nl LET
948 # 145.18.230.
949 # Then all clients could request paths containing "DEMO" or "demo", e.g.
950 # "/my/demo/file.html" ($PATH_INFO =~ /\Q$pattern\E/), Clients from
951 # *.hum.uva.nl could also request paths containing "LET or "let", e.g.
952 # "/my/let/file.html", and clients from the local cluster
953 # 145.18.230.[0-9]+ could access ALL files.
954 # Again, for those needing more expressional power, lines starting with
955 # "-e" are evaluated. For instance:
956 # '-e $REMOTE_HOST =~ /\.edu$/is && $PATH_INFO =~ m@/DEMO/@is;'
957 # will accept/reject requests for files from the directory "/demo/" from
958 # clients from the domain '.edu'.
960 # 7 Access control: Server side session tickets
961 # Specific paths can be controlled by Session Tickets which must be
962 # present as a SESSIONTICKET=<value> CGI variable in the request. These paths
963 # are defined in %TicketRequiredPatterns as pairs of:
964 # ('regexp' => 'SessionPath\tPasswordPath\tLogin.html\tExpiration').
965 # Session Tickets are stored in a separate directory (SessionPath, e.g.,
966 # "Private/.Session") as files with the exact same name of the SESSIONTICKET
967 # CGI. The following is an example:
968 # Type: SESSION
969 # IPaddress: 127.0.0.1
970 # AllowedPaths: ^/Private/Name/
971 # Expires: 3600
972 # Username: test
973 # ...
974 # Other content can follow.
976 # It is adviced that Session Tickets should be deleted
977 # after some (idle) time. The IP address should be the IP number at login, and
978 # the SESSIONTICKET will be rejected if it is presented from another IP address.
979 # AllowedPaths is a perl regexp. Be careful how they match. Make sure to delimit
980 # the names to prevent access to overlapping names, eg, "^/Private/Rob" will also
981 # match "^/Private/Robert", however, "^/Private/Rob/" will not. Expires is the
982 # time the ticket will remain valid after creation (file ctime). Time can be given
983 # in s[econds] (default), m[inutes], h[hours], or d[ays], eg, "24h" means 24 hours.
984 # None of these need be present, but the Ticket must have a non-zero size.
986 # Next to Session Tickets, there are two other type of ticket files:
987 # - LOGIN tickets store information about a current login request
988 # - PASSWORD ticket store account information to authorize login requests
990 # 8 Query length limiting
991 # The length of the Query string can be limited. If CONTENT_LENGTH is larger
992 # than this limit, the request is rejected. The combined length of the
993 # Query string and the POST input is checked before any processing is done.
994 # This will prevent clients from overloading the scripts.
995 # The actual, combined, Query Size is accessible as a variable through
996 # $CGI_Content_Length.
998 # 9 Illegal filenames, paths, and protected directories
999 # One of the primary security concerns in handling CGI-scripts is the
1000 # use of "funny" characters in the requests that con scripts in executing
1001 # malicious commands. Examples are inserting ';', null bytes, or <newline>
1002 # characters in URL's and filenames, followed by executable commands. A
1003 # special variable $FileAllowedChars stores a string of all allowed
1004 # characters. Any request that translates to a filename with a character
1005 # OUTSIDE this set will be rejected.
1006 # In general, all (readable files) in the DocumentRoot tree are accessible.
1007 # This might not be what you want. For instance, your DocumentRoot directory
1008 # might be the working directory of a CVS project and contain sensitive
1009 # information (e.g., the password to get to the repository). You can block
1010 # access to these subdirectories by adding the corresponding patterns to
1011 # the $BlockPathAccess variable. For instance, $BlockPathAccess = '/CVS/'
1012 # will block any request that contains '/CVS/' or:
1013 # die if $BlockPathAccess && $ENV{'PATH_INFO'} =~ m@$BlockPathAccess@;
1015 #10 The execution of code blocks can be controlled in a transparent way
1016 # by adding IF or UNLESS conditions in the tags themselves. That is,
1017 # a simple check of the validity of filenames or email addresses can
1018 # be done before any code is executed.
1020 ###############################################################################
1022 # USER MANUAL (sort of)
1024 # CGIscriptor removes embedded scripts, indicated by an HTML 4 type
1025 # <SCRIPT TYPE='text/ssperl'> </SCRIPT> or <SCRIPT TYPE='text/osshell'>
1026 # </SCRIPT> constructs. CGIscriptor also recognizes XML-type
1027 # <SCRIPT TYPE='text/ssperl'/> constructs. These are usefull when
1028 # the necessary code is already available in the TAG itself (e.g.,
1029 # using external files). The contents of the directive are executed by
1030 # the PERL eval() and `` functions (in a separate name space). The
1031 # result of the eval() function replaces the <SCRIPT> </SCRIPT> construct
1032 # in the output file. You can use the values that are delivered in
1033 # CGI-compliant form (i.e., the "?name=value&.." type URL additions)
1034 # transparently as "$name" variables in your directives after they are
1035 # defined in a <META> or <SCRIPT> tag.
1036 # If you define the variable "$CGIscriptorResults" in a CGI attribute, all
1037 # subsequent <SCRIPT> and <META> results (including the defining
1038 # tag) will also be pushed onto a stack: @CGIscriptorResults. This list
1039 # behaves like any other, ordinary list and can be manipulated.
1041 # Both GET and POST requests are accepted. These two methods are treated
1042 # equal. Variables, i.e., those values that are determined when a file is
1043 # processed, are indicated in the CGI attribute by $<name> or $<name>=<default>
1044 # in which <name> is the name of the variable and <default> is the value
1045 # used when there is NO current CGI value for <name> (you can use
1046 # white-spaces in $<name>=<default> but really DO make sure that the
1047 # default value is followed by white space or is quoted). Names can contain
1048 # any alphanumeric characters and _ (i.e., names match /[\w]+/).
1049 # If the Content-type: is 'multipart/*', the input is treated as a
1050 # MIME multipart message and automatically delimited. CGI variables get
1051 # the "raw" (i.e., undecoded) body of the corresponding message part.
1053 # Variables can be CGI variables, i.e., those from the QUERY_STRING,
1054 # environment variables, e.g., REMOTE_USER, REMOTE_HOST, or REMOTE_ADDR,
1055 # or predefined values, e.g., CGI_Decoded_QS (The complete, decoded,
1056 # query string), CGI_Content_Length (the length of the decoded query
1057 # string), CGI_Year, CGI_Month, CGI_Time, and CGI_Hour (the current
1058 # date and time).
1060 # All these are available when defined in a CGI attribute. All environment
1061 # variables are accessible as $ENV{'name'}. So, to access the REMOTE_HOST
1062 # and the REMOTE_USER, use, e.g.:
1064 # <SCRIPT TYPE='text/ssperl'>
1065 # ($ENV{'REMOTE_HOST'}||"-")." $ENV{'REMOTE_USER'}"
1066 # </SCRIPT>
1068 # (This will print a "-" if REMOTE_HOST is not known)
1069 # Another way to do this is:
1071 # <META CONTENT="text/ssperl; CGI='$REMOTE_HOST = - $REMOTE_USER'">
1072 # <SCRIPT TYPE='text/ssperl'>"$REMOTE_HOST $REMOTE_USER"</SCRIPT>
1073 # or
1074 # <META CONTENT='text/ssperl; CGI="$REMOTE_HOST = - $REMOTE_USER"
1075 # SRC={"$REMOTE_HOST $REMOTE_USER\n"}'>
1077 # This is possible because ALL environment variables are available as
1078 # CGI variables. The environment variables take precedence over CGI
1079 # names in case of a "name clash". For instance:
1080 # <META CONTENT="text/ssperl; CGI='$HOME' SRC={$HOME}">
1081 # Will print the current HOME directory (environment) irrespective whether
1082 # there is a CGI variable from the query
1083 # (e.g., Where do you live? <INPUT TYPE="TEXT" NAME="HOME">)
1084 # THIS IS A SECURITY FEATURE. It prevents clients from changing
1085 # the values of defined environment variables (e.g., by supplying
1086 # a bogus $REMOTE_ADDR). Although $ENV{} is not changed by the META tags,
1087 # it would make the use of declared variables insecure. You can still
1088 # access CGI variables after a name clash with
1089 # CGIscriptor::CGIparseValue(<name>).
1091 # Some CGI variables are present several times in the query string
1092 # (e.g., from multiple selections). These should be defined as
1093 # @VARIABLENAME=default in the CGI attribute. The list @VARIABLENAME
1094 # will contain ALL VARIABLENAME values from the query, or a single
1095 # default value. If there is an ENVIRONMENT variable of the
1096 # same name, it will be used instead of the default AND the query
1097 # values. The corresponding function is
1098 # CGIscriptor::CGIparseValueList(<name>)
1100 # CGI variables collected in a @VARIABLENAME list are unordered.
1101 # When more structured variables are needed, a hash table can be used.
1102 # A variable defined as %VARIABLE=default will collect all
1103 # CGI-parameters whose name start with 'VARIABLE' in a hash table with
1104 # the remainder of the name as a key. For instance, %PERSON will
1105 # collect PERSONname='John Doe', PERSONbirthdate='01 Jan 00', and
1106 # PERSONspouse='Alice' into a hash table %PERSON such that $PERSON{'spouse'}
1107 # equals 'Alice'. Any default value or environment value will be stored
1108 # under the "" key. If there is an ENVIRONMENT variable of the same name,
1109 # it will be used instead of the default AND the query values. The
1110 # corresponding function is CGIscriptor::CGIparseValueHash(<name>)
1112 # This method of first declaring your environment and CGI variables
1113 # before being able to use them in the scripts might seem somewhat
1114 # clumsy, but it protects you from inadvertedly printing out the values of
1115 # system environment variables when their names coincide with those used
1116 # in the CGI forms. It also prevents "clients" from supplying CGI
1117 # parameter values for your private variables.
1118 # THIS IS A SECURITY FEATURE!
1121 # NON-HTML CONTENT TYPES
1123 # Normally, CGIscriptor prints the standard "Content-type: text/html\n\n"
1124 # message before anything is printed. This has been extended to include
1125 # plain text (.txt) files, for which the Content-type (MIME type)
1126 # 'text/plain' is printed. In all other respects, text files are treated
1127 # as HTML files (this can be switched off by removing '.txt' from the
1128 # $FilePattern variable) . When the content type should be something else,
1129 # e.g., with multipart files, use the $RawFilePattern (.xmr, see also next
1130 # item). CGIscriptor will not print a Content-type message for this file
1131 # type (which must supply its OWN Content-type message). Raw files must
1132 # still conform to the <SCRIPT></SCRIPT> and <META> tag specifications.
1135 # NON-HTML FILES
1137 # CGIscriptor is intended to process HTML and text files only. You can
1138 # create documents of any mime-type on-the-fly using "raw" text files,
1139 # e.g., with the .xmr extension. However, CGIscriptor will not process
1140 # binary files of any type, e.g., pictures or sounds. Given the sheer
1141 # number of formats, I do not have any intention to do so. However,
1142 # an escape route has been provided. You can construct a genuine raw
1143 # (.xmr) text file that contains the perl code to service any file type
1144 # you want. If the global $BinaryMapFile variable contains the path to
1145 # this file (e.g., /BinaryMapFile.xmr), this file will be called
1146 # whenever an unsupported (non-HTML) file type is requested. The path
1147 # to the requested binary file is stored in $ENV('CGI_BINARY_FILE')
1148 # and can be used like any other CGI-variable. Servicing binary files
1149 # then becomes supplying the correct Content-type (e.g., print
1150 # "Content-type: image/jpeg\n\n";) and reading the file and writing it
1151 # to STDOUT (e.g., using sysread() and syswrite()).
1154 # THE META TAG
1156 # All attributes of a META tag are ignored, except the
1157 # CONTENT='text/ssperl; CGI=" ... " [SRC=" ... "]' attribute. The string
1158 # inside the quotes following the CONTENT= indication (white-space is
1159 # ignored, "" '' `` (){}[]-quote pairs are allowed, plus their \ versions)
1160 # MUST start with any of the CGIscriptor mime-types (e.g.: text/ssperl or
1161 # text/osshell) and a comma or semicolon.
1162 # The quoted string following CGI= contains a white-space separated list
1163 # of declarations of the CGI (and Environment) values and default values
1164 # used when no CGI values are supplied by the query string.
1166 # If the default value is a longer string containing special characters,
1167 # possibly spanning several lines, the string must be enclosed in quotes.
1168 # You may use any pair of quotes or brackets from the list '', "", ``, (),
1169 # [], or {} to distinguish default values (or preceded by \, e.g., \(...\)
1170 # is different from (...)). The outermost pair will always be used and any
1171 # other quotes inside the string are considered to be part of the string
1172 # value, e.g.,
1174 # $Value = {['this'
1175 # "and" (this)]}
1176 # will result in $Value getting the default value: ['this'
1177 # "and" (this)]
1178 # (NOTE that the newline is part of the default value!).
1180 # Internally, for defining and initializing CGI (ENV) values, the META
1181 # and SCRIPT tags use the functions "defineCGIvariable($name, $default)"
1182 # (scalars) and "defineCGIvariableList($name, $default)" (lists).
1183 # These functions can be used inside scripts as
1184 # "CGIscriptor::defineCGIvariable($name, $default)" and
1185 # "CGIscriptor::defineCGIvariableList($name, $default)".
1186 # "CGIscriptor::defineCGIvariableHash($name, $default)".
1188 # The CGI attribute will be processed exactly identical when used inside
1189 # the <SCRIPT> tag. However, this use is not according to the
1190 # HTML 4.0 specifications of the W3C.
1193 # THE DIV/INS TAGS
1195 # There is a problem when constructing html files containing
1196 # server-side perl scripts with standard HTML tools. These
1197 # tools will refuse to process any text between <SCRIPT></SCRIPT>
1198 # tags. This is quite annoying when you want to use large
1199 # HTML templates where you will fill in values.
1201 # For this purpose, CGIscriptor will read the neutral
1202 # <DIV CLASS="ssperl" ID="varname"></DIV> or
1203 # <INS CLASS="ssperl" ID="varname"></INS>
1204 # tag (in Cascading Style Sheet manner) Note that
1205 # "varname" has NO '$' before it, it is a bare name.
1206 # Any text between these <DIV ...></DIV> or
1207 # <INS ...></INS>tags will be assigned to '$varname'
1208 # as is (e.g., as a literal).
1209 # No processing or interpolation will be performed.
1210 # There is also NO nesting possible. Do NOT nest a
1211 # </DIV> inside a <DIV></DIV>! Moreover, neither INS nor
1212 # DIV tags do ensure a block structure in the final
1213 # rendering (i.e., no empty lines).
1215 # Note that <DIV CLASS="ssperl" ID="varname"/>
1216 # is handled the XML way. No content is processed,
1217 # but varname is defined, and any SRC directives are
1218 # processed.
1220 # You can use $varname like any other variable name.
1221 # However, $varname is NOT a CGI variable and will be
1222 # completely internal to your script. There is NO
1223 # interaction between $varname and the outside world.
1225 # To interpolate a DIV derived text, you can use:
1226 # $varname =~ s/([\]])/\\\1/g; # Mark ']'-quotes
1227 # $varname = eval("qq[$varname]"); # Interpolate all values
1229 # The DIV tags will process IF, UNLESS, CGI and
1230 # SRC attributes. The SRC files will be pre-pended to the
1231 # body text of the tag. SRC blocks are NOT executed.
1233 # CONDITIONAL PROCESSING: THE 'IF' AND 'UNLESS' ATTRIBUTES
1235 # It is often necessary to include code-blocks that should be executed
1236 # conditionally, e.g., only for certain browsers or operating system.
1237 # Furthermore, quite often sanity and security checks are necessary
1238 # before user (form) data can be processed, e.g., with respect to
1239 # email addresses and filenames.
1241 # Checks added to the code are often difficult to find, interpret or
1242 # maintain and in general mess up the code flow. This kind of confussion
1243 # is dangerous.
1244 # Also, for many of the supported "foreign" scripting languages, adding
1245 # these checks is cumbersome or even impossible.
1247 # As a uniform method for asserting the correctness of "context", two
1248 # attributes are added to all supported tags: IF and UNLESS.
1249 # They both evaluate their value and block execution when the
1250 # result is <FALSE> (IF) or <TRUE> (UNLESS) in Perl, e.g.,
1251 # UNLESS='$NUMBER \> 100;' blocks execution if $NUMBER <= 100. Note that
1252 # the backslash in the '\>' is removed and only used to differentiate
1253 # this conditional '>' from the tag-closing '>'. For symmetry, the
1254 # backslash in '\<' is also removed. Inside these conditionals,
1255 # ~/ and ./ are expanded to their respective directory root paths.
1257 # For example, the following tag will be ignored when the filename is
1258 # invalid:
1260 # <SCRIPT TYPE='text/ssperl' CGI='$FILENAME'
1261 # IF='CGIscriptor::CGIsafeFileName($FILENAME);'>
1262 # ...
1263 # </SCRIPT>
1265 # The IF and UNLESS values must be quoted. The same quotes are supported
1266 # as with the other attributes. The SRC attribute is ignored when IF and
1267 # UNLESS block execution.
1269 # NOTE: 'IF' and 'UNLESS' always evaluate perl code.
1272 # THE MAGIC SOURCE ATTRIBUTE (SRC=)
1274 # The SRC attribute inside tags accepts a list of filenames and URL's
1275 # separated by "," comma's (or ";" semicolons).
1276 # ALL the variable values defined in the CGI attribute are available
1277 # in @ARGV as if the file or block was executed from the command line,
1278 # in the exact order in which they were declared in the preceding CGI
1279 # attribute.
1281 # First, a SRC={}-block will be evaluated as if the code inside the
1282 # block was part of a <SCRIPT></SCRIPT> construct, i.e.,
1283 # "print do { code };'';" or `code` (i.e., SAFEqx('code)).
1284 # Only a single block is evaluated. Note that this is processed less
1285 # efficiently than <SCRIPT> </SCRIPT> blocks. Type of evaluation
1286 # depends on the content-type: Perl for text/ssperl and OS shell for
1287 # text/osshell. For other mime types (scripting languages), anything in
1288 # the source block is put in front of the code block "inside" the tag.
1290 # Second, executable files (i.e., -x filename != 0) are evaluated as:
1291 # print `filename \'$ARGV[0]\' \'$ARGV[1]\' ...`
1292 # That is, you can actually call executables savely from the SRC tag.
1294 # Third, text files that match the file pattern, used by CGIscriptor to
1295 # check whether files should be processed ($FilePattern), are
1296 # processed in-line (i.e., recursively) by CGIscriptor as if the code
1297 # was inserted in the original source file. Recursions, i.e., calling
1298 # a file inside itself, are blocked. If you need them, you have to code
1299 # them explicitely using "main::ProcessFile($file_path)".
1301 # Fourth, Perl text files (i.e., -T filename != 0) are evaluated as:
1302 # "do FileName;'';".
1304 # Last, URL's (i.e., starting with 'HTTP://', 'FTP://', 'GOPHER://',
1305 # 'TELNET://', 'WHOIS://' etc.) are loaded
1306 # and printed. The loading and handling of <BASE> and document header
1307 # is done by a command generated by main::GET_URL($URL [, 0]). You can enter your
1308 # own code (default is curl, wget, or snarf and some post-processing to add a <BASE> tag).
1310 # There are two pseudo-file names: PREFIX and POSTFIX. These implement
1311 # a switch from prefixing the SRC code/files (PREFIX, default) before the
1312 # content of the tag to appending the code after the content of the tag
1313 # (POSTFIX). The switches are done in the order in which the PREFIX and
1314 # POSTFIX labels are encountered. You can mix PREFIX and POSTFIX labels
1315 # in any order with the SRC files. Note that the ORDER of file execution
1316 # is determined for prefixed and postfixed files seperately.
1318 # File paths can be preceded by the URL protocol prefix "file://". This
1319 # is simply STRIPPED from the name.
1321 # Example:
1322 # The request
1323 # "http://cgi-bin/Action_Forms.pl/Statistics/Sign_Test.html?positive=8&negative=22
1324 # will result in printing "${SS_PUB}/Statistics/Sign_Test.html"
1325 # With QUERY_STRING = "positive=8&negative=22"
1327 # on encountering the lines:
1328 # <META CONTENT="text/osshell; CGI='$positive=11 $negative=3'">
1329 # <b><SCRIPT LANGUAGE=PERL TYPE="text/ssperl" SRC="./Statistics/SignTest.pl">
1330 # </SCRIPT></b><p>"
1332 # This line will be processed as:
1333 # "<b>`${SS_SCRIPT}/Statistics/SignTest.pl '8' '22'`</b><p>"
1335 # In which "${SS_SCRIPT}/Statistics/SignTest.pl" is an executable script,
1336 # This line will end up printed as:
1337 # "<b>p <= 0.0161</b><p>"
1339 # Note that the META tag itself will never be printed, and is invisible to
1340 # the outside world.
1342 # The SRC files in a DIV or INS tag will be added (pre-pended) to the body
1343 # of the <DIV></DIV> tag. Blocks are NOT executed! If you do not
1344 # need any content, you can use the <DIV...../> format.
1347 # THE CGISCRIPTOR ROOT DIRECTORIES ~/ AND ./
1349 # Inside <SCRIPT></SCRIPT> tags, filepaths starting
1350 # with "~/" are replaced by "$YOUR_HTML_FILES/", this way files in the
1351 # public directories can be accessed without direct reference to the
1352 # actual paths. Filepaths starting with "./" are replaced by
1353 # "$YOUR_SCRIPTS/" and this should only be used for scripts.
1355 # Note: this replacement can seriously affect Perl scripts. Watch
1356 # out for constructs like $a =~ s/aap\./noot./g, use
1357 # $a =~ s@aap\.@noot.@g instead.
1359 # CGIscriptor.pl will assign the values of $SS_PUB and $SS_SCRIPT
1360 # (i.e., $YOUR_HTML_FILES and $YOUR_SCRIPTS) to the environment variables
1361 # $SS_PUB and $SS_SCRIPT. These can be accessed by the scripts that are
1362 # executed.
1363 # Values not preceded by $, ~/, or ./ are used as literals
1366 # OS SHELL SCRIPT EVALUATION (CONTENT-TYPE=TEXT/OSSHELL)
1368 # OS scripts are executed by a "safe" version of the `` operator (i.e.,
1369 # SAFEqx(), see also below) and any output is printed. CGIscriptor will
1370 # interpolate the script and replace all user-supplied CGI-variables by
1371 # their ''-quoted values (actually, all variables defined in CGI attributes
1372 # are quoted). Other Perl variables are interpolated in a simple fasion,
1373 # i.e., $scalar by their value, @list by join(' ', @list), and %hash by
1374 # their name=value pairs. Complex references, e.g., @$variable, are all
1375 # evaluated in a scalar context. Quotes should be used with care.
1376 # NOTE: the results of the shell script evaluation will appear in the
1377 # @CGIscriptorResults stack just as any other result.
1378 # All occurrences of $@% that should NOT be interpolated must be
1379 # preceeded by a "\". Interpolation can be switched off completely by
1380 # setting $CGIscriptor::NoShellScriptInterpolation = 1
1381 # (set to 0 or undef to switch interpolation on again)
1382 # i.e.,
1383 # <SCRIPT TYPE="text/ssperl">
1384 # $CGIscriptor::NoShellScriptInterpolation = 1;
1385 # </SCRIPT>
1388 # RUN TIME TRANSLATION OF INPUT FILES
1390 # Allows general and global conversions of files using Regular Expressions.
1391 # Very handy (but costly) to rewrite legacy pages to a new format.
1392 # Select files to use it on with
1393 # my $TranslationPaths = 'filepattern';
1394 # This is costly. For efficiency, define:
1395 # $TranslationPaths = ''; when not using translations.
1396 # Accepts general regular expressions: [$pattern, $replacement]
1398 # Define:
1399 # my $TranslationPaths = 'filepattern'; # Pattern matching PATH_INFO
1401 # push(@TranslationTable, ['pattern', 'replacement']);
1402 # e.g. (for Ruby Rails):
1403 # push(@TranslationTable, ['<%=', '<SCRIPT TYPE="text/ssruby">']);
1404 # push(@TranslationTable, ['%>', '</SCRIPT>']);
1406 # Runs:
1407 # my $currentRegExp;
1408 # foreach $currentRegExp (@TranslationTable)
1410 # my ($pattern, $replacement) = @$currentRegExp;
1411 # $$text =~ s!$pattern!$replacement!msg;
1412 # };
1415 # EVALUATION OF OTHER SCRIPTING LANGUAGES
1417 # Adding a MIME-type and an interpreter command to
1418 # %ScriptingLanguages automatically will catch any other
1419 # scripting language in the standard
1420 # <SCRIPT TYPE="[mime]"></SCRIPT> manner.
1421 # E.g., adding: $ScriptingLanguages{'text/sspython'} = 'python';
1422 # will actually execute the folowing code in an HTML page
1423 # (ignore 'REMOTE_HOST' for the moment):
1424 # <SCRIPT TYPE="text/sspython">
1425 # # A Python script
1426 # x = ["A","real","python","script","Hello","World","and", REMOTE_HOST]
1427 # print x[4:8] # Prints the list ["Hello","World","and", REMOTE_HOST]
1428 # </SCRIPT>
1430 # The script code is NOT interpolated by perl, EXCEPT for those
1431 # interpreters that cannot handle variables themselves.
1432 # Currently, several interpreters are pre-installed:
1434 # Perl test - "text/testperl" => 'perl',
1435 # Python - "text/sspython" => 'python',
1436 # Ruby - "text/ssruby" => 'ruby',
1437 # Tcl - "text/sstcl" => 'tcl',
1438 # Awk - "text/ssawk" => 'awk -f-',
1439 # Gnu Lisp - "text/sslisp" => 'rep | tail +5 '.
1440 # "| egrep -v '> |^rep. |^nil\\\$'",
1441 # XLispstat - "text/xlispstat" => 'xlispstat | tail +7 '.
1442 # "| egrep -v '> \\\$|^NIL'",
1443 # Gnu Prolog- "text/ssprolog" => 'gprolog',
1444 # M4 macro's- "text/ssm4" => 'm4',
1445 # Born shell- "text/sh" => 'sh',
1446 # Bash - "text/bash" => 'bash',
1447 # C-shell - "text/csh" => 'csh',
1448 # Korn shell- "text/ksh" => 'ksh',
1449 # Praat - "text/sspraat" => "praat - | sed 's/Praat > //g'",
1450 # R - "text/ssr" => "R --vanilla --slave | sed 's/^[\[0-9\]*] //g'",
1451 # REBOL - "text/ssrebol" =>
1452 # "rebol --quiet|egrep -v '^[> ]* == '|sed 's/^\s*\[> \]* //g'",
1453 # PostgreSQL- "text/postgresql" => 'psql 2>/dev/null',
1454 # (psql)
1456 # Note that the "value" of $ScriptingLanguages{mime} must be a command
1457 # that reads Standard Input and writes to standard output. Any extra
1458 # output of interactive interpreters (banners, echo's, prompts)
1459 # should be removed by piping the output through 'tail', 'grep',
1460 # 'sed', or even 'awk' or 'perl'.
1462 # For access to CGI variables there is a special hashtable:
1463 # %ScriptingCGIvariables.
1464 # CGI variables can be accessed in three ways.
1465 # 1. If the mime type is not present in %ScriptingCGIvariables,
1466 # nothing is done and the script itself should parse the relevant
1467 # environment variables.
1468 # 2. If the mime type IS present in %ScriptingCGIvariables, but it's
1469 # value is empty, e.g., $ScriptingCGIvariables{"text/sspraat"} = '';,
1470 # the script text is interpolated by perl. That is, all $var, @array,
1471 # %hash, and \-slashes are replaced by their respective values.
1472 # 3. In all other cases, the CGI and environment variables are added
1473 # in front of the script according to the format stored in
1474 # %ScriptingCGIvariables. That is, the following (pseudo-)code is
1475 # executed for each CGI- or Environment variable defined in the CGI-tag:
1476 # printf(INTERPRETER, $ScriptingCGIvariables{$mime}, $CGI_NAME, $CGI_VALUE);
1478 # For instance, "text/testperl" => '$%s = "%s";' defines variable
1479 # definitions for Perl, and "text/sspython" => '%s = "%s"' for Python
1480 # (note that these definitions are not save, the real ones contain '-quotes).
1482 # THIS WILL NOT WORK FOR @VARIABLES, the (empty) $VARIABLES will be used
1483 # instead.
1485 # The $CGI_VALUE parameters are "shrubed" of all control characters
1486 # and quotes (by &shrubCGIparameter($CGI_VALUE)) for the options 2 and 3.
1487 # Control characters are replaced by \0<octal ascii value> (the exception
1488 # is \015, the newline, which is replaced by \n) and quotes
1489 # and backslashes by their HTML character
1490 # value (' -> &#39; ` -> &#96; " -> &quot; \ -> &#92; & -> &amper;).
1491 # For example:
1492 # if a client would supply the string value (in standard perl, e.g.,
1493 # \n means <newline>)
1494 # "/dev/null';\nrm -rf *;\necho '"
1495 # it would be processed as
1496 # '/dev/null&#39;;\nrm -rf *;\necho &#39;'
1497 # (e.g., sh or bash would process the latter more according to your
1498 # intentions).
1499 # If your intepreter requires different protection measures, you will
1500 # have to supply these in %main::SHRUBcharacterTR (string => translation),
1501 # e.g., $SHRUBcharacterTR{"\'"} = "&#39;";
1503 # Currently, the following definitions are used:
1504 # %ScriptingCGIvariables = (
1505 # "text/testperl" => "\$\%s = '\%s';", # Perl $VAR = 'value' (for testing)
1506 # "text/sspython" => "\%s = '\%s'", # Python VAR = 'value'
1507 # "text/ssruby" => '@%s = "%s"', # Ruby @VAR = "value"
1508 # "text/sstcl" => 'set %s "%s"', # TCL set VAR "value"
1509 # "text/ssawk" => '%s = "%s";', # Awk VAR = "value";
1510 # "text/sslisp" => '(setq %s "%s")', # Gnu lisp (rep) (setq VAR "value")
1511 # "text/xlispstat" => '(setq %s "%s")', # Xlispstat (setq VAR "value")
1512 # "text/ssprolog" => '', # Gnu prolog (interpolated)
1513 # "text/ssm4" => "define(`\%s', `\%s')", # M4 macro's define(`VAR', `value')
1514 # "text/sh" => "\%s='\%s';", # Born shell VAR='value';
1515 # "text/bash" => "\%s='\%s';", # Born again shell VAR='value';
1516 # "text/csh" => "\$\%s = '\%s';", # C shell $VAR = 'value';
1517 # "text/ksh" => "\$\%s = '\%s';", # Korn shell $VAR = 'value';
1518 # "text/sspraat" => '', # Praat (interpolation)
1519 # "text/ssr" => '%s <- "%s";', # R VAR <- "value";
1520 # "text/ssrebol" => '%s: copy "%s"', # REBOL VAR: copy "value"
1521 # "text/postgresql" => '', # PostgreSQL (interpolation)
1522 # "" => ""
1523 # );
1525 # Four tables allow fine-tuning of interpreter with code that should be
1526 # added before and after each code block:
1528 # Code added before each script block
1529 # %ScriptingPrefix = (
1530 # "text/testperl" => "\# Prefix Code;", # Perl script testing
1531 # "text/ssm4" => 'divert(0)' # M4 macro's (open STDOUT)
1532 # );
1533 # Code added at the end of each script block
1534 # %ScriptingPostfix = (
1535 # "text/testperl" => "\# Postfix Code;", # Perl script testing
1536 # "text/ssm4" => 'divert(-1)' # M4 macro's (block STDOUT)
1537 # );
1538 # Initialization code, inserted directly after opening (NEVER interpolated)
1539 # %ScriptingInitialization = (
1540 # "text/testperl" => "\# Initialization Code;", # Perl script testing
1541 # "text/ssawk" => 'BEGIN {', # Server Side awk scripts
1542 # "text/sslisp" => '(prog1 nil ', # Lisp (rep)
1543 # "text/xlispstat" => '(prog1 nil ', # xlispstat
1544 # "text/ssm4" => 'divert(-1)' # M4 macro's (block STDOUT)
1545 # );
1546 # Cleanup code, inserted before closing (NEVER interpolated)
1547 # %ScriptingCleanup = (
1548 # "text/testperl" => "\# Cleanup Code;", # Perl script testing
1549 # "text/sspraat" => 'Quit',
1550 # "text/ssawk" => '};', # Server Side awk scripts
1551 # "text/sslisp" => '(princ "\n" standard-output)).' # Closing print to rep
1552 # "text/xlispstat" => '(print "" *standard-output*)).' # Closing print to xlispstat
1553 # "text/postgresql" => '\q',
1554 # );
1557 # The SRC attribute is NOT magical for these interpreters. In short,
1558 # all code inside a source file or {} block is written verbattim
1559 # to the interpreter. No (pre-)processing or executional magic is done.
1561 # A serious shortcomming of the described mechanism for handling other
1562 # (scripting) languages, with respect to standard perl scripts
1563 # (i.e., 'text/ssperl'), is that the code is only executed when
1564 # the pipe to the interpreter is closed. So the pipe has to be
1565 # closed at the end of each block. This means that the state of the
1566 # interpreter (e.g., all variable values) is lost after the closing of
1567 # the next </SCRIPT> tag. The standard 'text/ssperl' scripts retain
1568 # all values and definitions.
1570 # APPLICATION MIME TYPES
1572 # To ease some important auxilliary functions from within the
1573 # html pages I have added them as MIME types. This uses
1574 # the mechanism that is also used for the evaluation of
1575 # other scripting languages, with interpolation of CGI
1576 # parameters (and perl-variables). Actually, these are
1577 # defined exactly like any other "scripting language".
1579 # text/ssdisplay: display some (HTML) text with interpolated
1580 # variables (uses `cat`).
1581 # text/sslogfile: write (append) the interpolated block to the file
1582 # mentioned on the first, non-empty line
1583 # (the filename can be preceded by 'File: ',
1584 # note the space after the ':',
1585 # uses `awk .... >> <filename>`).
1586 # text/ssmailto: send email directly from within the script block.
1587 # The first line of the body must contain
1588 # To:Name@Valid.Email.Address
1589 # (note: NO space between 'To:' and the email adres)
1590 # For other options see the mailto man pages.
1591 # It works by directly sending the (interpolated)
1592 # content of the text block to a pipe into the
1593 # Linux program 'mailto'.
1595 # In these script blocks, all Perl variables will be
1596 # replaced by their values. All CGI variables are cleaned before
1597 # they are used. These CGI variables must be redefined with a
1598 # CGI attribute to restore their original values.
1599 # In general, this will be more secure than constructing
1600 # e.g., your own email command lines. For instance, Mailto will
1601 # not execute any odd (forged) email addres, but just stops
1602 # when the email address is invalid and awk will construct
1603 # any filename you give it (e.g. '<File;rm\\\040-f' would end up
1604 # as a "valid" UNIX filename). Note that it will also gladly
1605 # store this file anywhere (/../../../etc/passwd will work!).
1606 # Use the CGIscriptor::CGIsafeFileName() function to clean the
1607 # filename.
1609 # SHELL SCRIPT PIPING
1611 # If a shell script starts with the UNIX style "#! <shell command> \n"
1612 # line, the rest of the shell script is piped into the indicated command,
1613 # i.e.,
1614 # open(COMMAND, "| command");print COMMAND $RestOfScript;
1616 # In many ways this is equivalent to the MIME-type profiling for
1617 # evaluating other scripting languages as discussed above. The
1618 # difference breaks down to convenience. Shell script piping is a
1619 # "raw" implementation. It allows you to control all aspects of
1620 # execution. Using the MIME-type profiling is easier, but has a
1621 # lot of defaults built in that might get in the way. Another
1622 # difference is that shell script piping uses the SAFEqx() function,
1623 # and MIME-type profiling does not.
1625 # Execution of shell scripts is under the control of the Perl Script blocks
1626 # in the document. The MIME-type triggered execution of <SCRIPT></SCRIPT>
1627 # blocks can be simulated easily. You can switch to a different shell,
1628 # e.g. tcl, completely by executing the following Perl commands inside
1629 # your document:
1631 # <SCRIPT TYPE="text/ssperl">
1632 # $main::ShellScriptContentType = "text/ssTcl"; # Yes, you can do this
1633 # CGIscriptor::RedirectShellScript('/usr/bin/tcl'); # Pipe to Tcl
1634 # $CGIscriptor::NoShellScriptInterpolation = 1;
1635 # </SCRIPT>
1637 # After this script is executed, CGIscriptor will parse scripts of
1638 # TYPE="text/ssTcl" and pipe their contents into '|/usr/bin/tcl'
1639 # WITHOUT interpolation (i.e., NO substitution of Perl variables).
1640 # The crucial function is :
1641 # CGIscriptor::RedirectShellScript('/usr/bin/tcl')
1642 # After executing this function, all shell scripts AND all
1643 # calls to SAFEqx()) are piped into '|/usr/bin/tcl'. If the argument
1644 # of RedirectShellScript is empty, e.g., '', the original (default)
1645 # value is reset.
1647 # The standard output, STDOUT, of any pipe is send to the client.
1648 # Currently, you should be carefull with quotes in such a piped script.
1649 # The results of a pipe is NOT put on the @CGIscriptorResults stack.
1650 # As a result, you do not have access to the output of any piped (#!)
1651 # process! If you want such access, execute
1652 # <SCRIPT TYPE="text/osshell">echo "script"|command</SCRIPT>
1653 # or
1654 # <SCRIPT TYPE="text/ssperl">
1655 # $resultvar = SAFEqx('echo "script"|command');
1656 # </SCRIPT>.
1658 # Safety is never complete. Although SAFEqx() prevents some of the
1659 # most obvious forms of attacks and security slips, it cannot prevent
1660 # them all. Especially, complex combinations of quotes and intricate
1661 # variable references cannot be handled safely by SAFEqx. So be on
1662 # guard.
1665 # PERL CODE EVALUATION (CONTENT-TYPE=TEXT/SSPERL)
1667 # All PERL scripts are evaluated inside a PERL package. This package
1668 # has a separate name space. This isolated name space protects the
1669 # CGIscriptor.pl program against interference from user code. However,
1670 # some variables, e.g., $_, are global and cannot be protected. You are
1671 # advised NOT to use such global variable names. You CAN write
1672 # directives that directly access the variables in the main program.
1673 # You do so at your own risk (there is definitely enough rope available
1674 # to hang yourself). The behavior of CGIscriptor becomes undefined if
1675 # you change its private variables during run time. The PERL code
1676 # directives are used as in:
1677 # $Result = eval($directive); print $Result;'';
1678 # ($directive contains all text between <SCRIPT></SCRIPT>).
1679 # That is, the <directive> is treated as ''-quoted string and
1680 # the result is treated as a scalar. To prevent the VALUE of the code
1681 # block from appearing on the client's screen, end the directive with
1682 # ';""</SCRIPT>'. Evaluated directives return the last value, just as
1683 # eval(), blocks, and subroutines, but only as a scalar.
1685 # IMPORTANT: All PERL variables defined are persistent. Each <SCRIPT>
1686 # </SCRIPT> construct is evaluated as a {}-block with associated scope
1687 # (e.g., for "my $var;" declarations). This means that values assigned
1688 # to a PERL variable can be used throughout the document unless they
1689 # were declared with "my". The following will actually work as intended
1690 # (note that the ``-quotes in this example are NOT evaluated, but used
1691 # as simple quotes):
1693 # <META CONTENT="text/ssperl; CGI=`$String='abcdefg'`">
1694 # anything ...
1695 # <SCRIPT TYPE=text/ssperl>@List = split('', $String);</SCRIPT>
1696 # anything ...
1697 # <SCRIPT TYPE=text/ssperl>join(", ", @List[1..$#List]);</SCRIPT>
1699 # The first <SCRIPT TYPE=text/ssperl></SCRIPT> construct will return the
1700 # value scalar(@List), the second <SCRIPT TYPE=text/ssperl></SCRIPT>
1701 # construct will print the elements of $String separated by commas, leaving
1702 # out the first element, i.e., $List[0].
1704 # Another warning: './' and '~/' are ALWAYS replaced by the values of
1705 # $YOUR_SCRIPTS and $YOUR_HTML_FILES, respectively . This can interfere
1706 # with pattern matching, e.g., $a =~ s/aap\./noot\./g will result in the
1707 # evaluations of $a =~ s/aap\\${YOUR_SCRIPTS}noot\\${YOUR_SCRIPTS}g. Use
1708 # s@<regexp>.@<replacement>.@g instead.
1711 # SERVER SIDE SESSIONS AND ACCESS CONTROL (LOGIN)
1713 # An infrastructure for user acount authorization and file access control
1714 # is available. Each request is matched against a list of URL path patterns.
1715 # If the request matches, a Session Ticket is required to access the URL.
1716 # This Session Ticket should be present as a CGI parameter:
1717 # SESSIONTICKET=<value>
1718 # The example implementation stores Session Tickets as files in a local
1719 # directory. To create Session Tickets, a Login request must be given
1720 # with a LOGIN=<value> CGI parameter, a user name and a (doubly hashed)
1721 # password. The user name and (singly hashed) password are stored in a
1722 # PASSWORD ticket with the same name as the user account (name cleaned up
1723 # for security).
1725 # A Login page should create a LOGIN ticket file localy and send a
1726 # server specific SALT, a Random salt, and both the LOGIN and SESSION ticket
1727 # identifiers. The server side compares the username and hashed password,
1728 # actually hashed(Random salt+hashed(SALT+password)) from the client with
1729 # the values it calculates from the stored Random salt from the LOGIN
1730 # ticket and the hashed(SALT+password) from the PASSWORD ticket. If
1731 # successful, a new SESSION ticket is generated. The SESSION ticket
1732 # identifier is available as $SESSIONTICKET, the Username, IP address
1733 # and Path as $LOGINUSERNAME, $LOGINIPADDRESS, and $LOGINPATH, respectively.
1735 # In the current example implementation, all random values are created as
1736 # a full SHA1 hash (Hex) of a 512 byte block read from /dev/urandom.
1738 # The example session model implements 3 functions:
1739 # 1 Login
1740 # The password is hashed with the server side salt, and then hashed with
1741 # a Random salt. The server side only stores the password hashed with the
1742 # server side salt. Neither the plain password, nor the hashed password is
1743 # ever exchanged. Only values hashed with the one-time salt are exchanged.
1744 # 2 Session
1745 # For every access to a restricted URL, the Session Ticket is checked
1746 # before access is granted.
1747 # 3 Password Change
1748 # A new password is hashed with the server side salt, and then XORed
1749 # with the old password hashed with the salt. That value is exchanged
1750 # and XORed with the stored old hashed(salt+password). Again, the
1751 # stored password value is never exchanged unencrypted.
1753 # USER EXTENSIONS
1755 # A CGIscriptor package is attached to the bottom of this file. With
1756 # this package you can personalize your version of CGIscriptor by
1757 # including often used perl routines. These subroutines can be
1758 # accessed by prefixing their names with CGIscriptor::, e.g.,
1759 # <SCRIPT LANGUAGE=PERL TYPE=text/ssperl>
1760 # CGIscriptor::ListDocs("/Books/*") # List all documents in /Books
1761 # </SCRIPT>
1762 # It already contains some useful subroutines for Document Management.
1763 # As it is a separate package, it has its own namespace, isolated from
1764 # both the evaluator and the main program. To access variables from
1765 # the document <SCRIPT></SCRIPT> blocks, use $CGIexecute::<var>.
1767 # Currently, the following functions are implemented
1768 # (precede them with CGIscriptor::, see below for more information)
1769 # - SAFEqx ('String') -> result of qx/"String"/ # Safe application of ``-quotes
1770 # Is used by text/osshell Shell scripts. Protects all CGI
1771 # (client-supplied) values with single quotes before executing the
1772 # commands (one of the few functions that also works WITHOUT CGIscriptor::
1773 # in front)
1774 # - defineCGIvariable ($name[, $default) -> 0/1 (i.e., failure/success)
1775 # Is used by the META tag to define and initialize CGI and ENV
1776 # name/value pairs. Tries to obtain an initializing value from (in order):
1777 # $ENV{$name}
1778 # The Query string
1779 # The default value given (if any)
1780 # (one of the few functions that also works WITHOUT CGIscriptor::
1781 # in front)
1782 # - CGIsafeFileName (FileName) -> FileName or ""
1783 # Check a string against the Allowed File Characters (and ../ /..).
1784 # Returns an empty string for unsafe filenames.
1785 # - CGIsafeEmailAddress (Email) -> Email or ""
1786 # Check a string against correct email address pattern.
1787 # Returns an empty string for unsafe addresses.
1788 # - RedirectShellScript ('CommandString') -> FILEHANDLER or undef
1789 # Open a named PIPE for SAFEqx to receive ALL shell scripts
1790 # - URLdecode (URL encoded string) -> plain string # Decode URL encoded argument
1791 # - URLencode (plain string) -> URL encoded string # Encode argument as URL code
1792 # - CGIparseValue (ValueName [, URL_encoded_QueryString]) -> Decoded value
1793 # Extract the value of a CGI variable from the global or a private
1794 # URL-encoded query (multipart POST raw, NOT decoded)
1795 # - CGIparseValueList (ValueName [, URL_encoded_QueryString])
1796 # -> List of decoded values
1797 # As CGIparseValue, but now assembles ALL values of ValueName into a list.
1798 # - CGIparseHeader (ValueName [, URL_encoded_QueryString]) -> Header
1799 # Extract the header of a multipart CGI variable from the global or a private
1800 # URL-encoded query ("" when not a multipart variable or absent)
1801 # - CGIparseForm ([URL_encoded_QueryString]) -> Decoded Form
1802 # Decode the complete global URL-encoded query or a private
1803 # URL-encoded query
1804 # - read_url(URL) # Returns the page from URL (with added base tag, both FTP and HTTP)
1805 # Uses main::GET_URL(URL, 1) to get at the command to read the URL.
1806 # - BrowseDirs(RootDirectory [, Pattern, Startdir, CGIname]) # print browsable directories
1807 # - ListDocs(Pattern [,ListType]) # Prints a nested HTML directory listing of
1808 # all documents, e.g., ListDocs("/*", "dl");.
1809 # - HTMLdocTree(Pattern [,ListType]) # Prints a nested HTML listing of all
1810 # local links starting from a given document, e.g.,
1811 # HTMLdocTree("/Welcome.html", "dl");
1814 # THE RESULTS STACK: @CGISCRIPTORRESULTS
1816 # If the pseudo-variable "$CGIscriptorResults" has been defined in a
1817 # META tag, all subsequent SCRIPT and META results are pushed
1818 # on the @CGIscriptorResults stack. This list is just another
1819 # Perl variable and can be used and manipulated like any other list.
1820 # $CGIscriptorResults[-1] is always the last result.
1821 # This is only of limited use, e.g., to use the results of an OS shell
1822 # script inside a Perl script. Will NOT contain the results of Pipes
1823 # or code from MIME-profiling.
1826 # USEFULL CGI PREDEFINED VARIABLES (DO NOT ASSIGN TO THESE)
1828 # $CGI_HOME - The DocumentRoot directory
1829 # $CGI_Decoded_QS - The complete decoded Query String
1830 # $CGI_Content_Length - The ACTUAL length of the Query String
1831 # $CGI_Date - Current date and time
1832 # $CGI_Year $CGI_Month $CGI_Day $CGI_WeekDay - Current Date
1833 # $CGI_Time - Current Time
1834 # $CGI_Hour $CGI_Minutes $CGI_Seconds - Current Time, split
1835 # GMT Date/Time:
1836 # $CGI_GMTYear $CGI_GMTMonth $CGI_GMTDay $CGI_GMTWeekDay $CGI_GMTYearDay
1837 # $CGI_GMTHour $CGI_GMTMinutes $CGI_GMTSeconds $CGI_GMTisdst
1840 # USEFULL CGI ENVIRONMENT VARIABLES
1842 # Variables accessible (in APACHE) as $ENV{<name>}
1843 # (see: "http://hoohoo.ncsa.uiuc.edu/cgi/env.html"):
1845 # QUERY_STRING - The query part of URL, that is, everything that follows the
1846 # question mark.
1847 # PATH_INFO - Extra path information given after the script name
1848 # PATH_TRANSLATED - Extra pathinfo translated through the rule system.
1849 # (This doesn't always make sense.)
1850 # REMOTE_USER - If the server supports user authentication, and the script is
1851 # protected, this is the username they have authenticated as.
1852 # REMOTE_HOST - The hostname making the request. If the server does not have
1853 # this information, it should set REMOTE_ADDR and leave this unset
1854 # REMOTE_ADDR - The IP address of the remote host making the request.
1855 # REMOTE_IDENT - If the HTTP server supports RFC 931 identification, then this
1856 # variable will be set to the remote user name retrieved from
1857 # the server. Usage of this variable should be limited to logging
1858 # only.
1859 # AUTH_TYPE - If the server supports user authentication, and the script
1860 # is protected, this is the protocol-specific authentication
1861 # method used to validate the user.
1862 # CONTENT_TYPE - For queries which have attached information, such as HTTP
1863 # POST and PUT, this is the content type of the data.
1864 # CONTENT_LENGTH - The length of the said content as given by the client.
1865 # SERVER_SOFTWARE - The name and version of the information server software
1866 # answering the request (and running the gateway).
1867 # Format: name/version
1868 # SERVER_NAME - The server's hostname, DNS alias, or IP address as it
1869 # would appear in self-referencing URLs
1870 # GATEWAY_INTERFACE - The revision of the CGI specification to which this
1871 # server complies. Format: CGI/revision
1872 # SERVER_PROTOCOL - The name and revision of the information protocol this
1873 # request came in with. Format: protocol/revision
1874 # SERVER_PORT - The port number to which the request was sent.
1875 # REQUEST_METHOD - The method with which the request was made. For HTTP,
1876 # this is "GET", "HEAD", "POST", etc.
1877 # SCRIPT_NAME - A virtual path to the script being executed, used for
1878 # self-referencing URLs.
1879 # HTTP_ACCEPT - The MIME types which the client will accept, as given by
1880 # HTTP headers. Other protocols may need to get this
1881 # information from elsewhere. Each item in this list should
1882 # be separated by commas as per the HTTP spec.
1883 # Format: type/subtype, type/subtype
1884 # HTTP_USER_AGENT - The browser the client is using to send the request.
1885 # General format: software/version library/version.
1888 # INSTRUCTIONS FOR RUNNING CGIscriptor ON UNIX
1890 # CGIscriptor.pl will run on any WWW server that runs Perl scripts, just add
1891 # a line like the following to your srm.conf file (Apache example):
1893 # ScriptAlias /SHTML/ /real-path/CGIscriptor.pl/
1895 # URL's that refer to http://www.your.address/SHTML/... will now be handled
1896 # by CGIscriptor.pl, which can use a private directory tree (default is the
1897 # DOCUMENT_ROOT directory tree, but it can be anywhere, see manual).
1899 # If your hosting ISP won't let you add ScriptAlias lines you can use
1900 # the following "rewrite"-based "scriptalias" in .htaccess
1901 # (from Gerd Franke)
1903 # RewriteEngine On
1904 # RewriteBase /
1905 # RewriteCond %{REQUEST_FILENAME} .html$
1906 # RewriteCond %{SCRIPT_FILENAME} !cgiscriptor.pl$
1907 # RewriteCond %{REQUEST_FILENAME} -f
1908 # RewriteRule ^(.*)$ /cgi-bin/cgiscriptor.pl/$1?&%{QUERY_STRING}
1910 # Everthing with the extension ".html" and not including "cgiscriptor.pl"
1911 # in the url and where the file "path/filename.html" exists is redirected
1912 # to "/cgi.bin/cgiscriptor.pl/path/filename.html?query".
1913 # The user configuration should get the same path-level as the
1914 # .htaccess-file:
1916 # # Just enter your own directory path here
1917 # $YOUR_HTML_FILES = "$ENV{'DOCUMENT_ROOT'}";
1918 # # use DOCUMENT_ROOT only, if .htaccess lies in the root-directory.
1920 # If this .htaccess goes in a specific directory, the path to this
1921 # directory must be added to $ENV{'DOCUMENT_ROOT'}.
1923 # The CGIscriptor file contains all documentation as comments. These
1924 # comments can be removed to speed up loading (e.g., `egrep -v '^#'
1925 # CGIscriptor.pl` > leanScriptor.pl). A bare bones version of
1926 # CGIscriptor.pl, lacking documentation, most comments, access control,
1927 # example functions etc. (but still with the copyright notice and some
1928 # minimal documentation) can be obtained by calling CGIscriptor.pl on the
1929 # command line with the '-slim' command line argument, e.g.,
1931 # >CGIscriptor.pl -slim > slimCGIscriptor.pl
1933 # CGIscriptor.pl can be run from the command line with <path> and <query> as
1934 # arguments, as `CGIscriptor.pl <path> <query>`, inside a perl script
1935 # with 'do CGIscriptor.pl' after setting $ENV{PATH_INFO}
1936 # and $ENV{QUERY_STRING}, or CGIscriptor.pl can be loaded with 'require
1937 # "/real-path/CGIscriptor.pl"'. In the latter case, requests are processed
1938 # by 'Handle_Request();' (again after setting $ENV{PATH_INFO} and
1939 # $ENV{QUERY_STRING}).
1941 # Using the command line execution option, CGIscriptor.pl can be used as a
1942 # document (meta-)preprocessor. If the first argument is '-', STDIN will be read.
1943 # For example:
1945 # > cat MyDynamicDocument.html | CGIscriptor.pl - '[QueryString]' > MyStaticFile.html
1947 # This command line will produce a STATIC file with the DYNAMIC content of
1948 # MyDocument.html "interpolated".
1950 # This option would be very dangerous when available over the internet.
1951 # If someone could sneak a 'http://www.your.domain/-' URL past your
1952 # server, CGIscriptor could EXECUTE any POSTED contend.
1953 # Therefore, for security reasons, STDIN will NOT be read
1954 # if ANY of the HTTP server environment variables is set (e.g.,
1955 # SERVER_PORT, SERVER_PROTOCOL, SERVER_NAME, SERVER_SOFTWARE,
1956 # HTTP_USER_AGENT, REMOTE_ADDR).
1957 # This block on processing STDIN on HTTP requests can be lifted by setting
1958 # $BLOCK_STDIN_HTTP_REQUEST = 0;
1959 # In the security configuration. Butbe carefull when doing this.
1960 # It can be very dangerous.
1962 # Running demo's and more information can be found at
1963 # http://www.fon.hum.uva.nl/~rob/OSS/OSS.html
1965 # A pocket-size HTTP daemon, CGIservlet.pl, is available from my web site or
1966 # CPAN that can use CGIscriptor.pl as the base of a µWWW server and
1967 # demonstrates its use.
1970 # PROCESSING NON-FILESYSTEM DATA
1972 # Normally, HTTP (WWW) requests map onto file that can be accessed
1973 # using the perl open() function. That is, the web server runs on top of
1974 # some directory structure. However, we can envission (and put to good
1975 # use) other systems that do not use a normal file system. The whole CGI
1976 # was developed to make dynamic document generation possible.
1978 # A special case is where we want to have it both: A normal web server
1979 # with normal "file data", but not a normal files system. For instance,
1980 # we want or normal Web Site to run directly from a RAM hash table or
1981 # other database, instead of from disk. But we do NOT want to code the
1982 # whole site structure in CGI.
1984 # CGIscriptor can do this. If the web server fills an environment variable
1985 # $ENV{'CGI_FILE_CONTENT'} with the content of the "file", then the content
1986 # of this variable is processed instead of opening a file. If this environment
1987 # variable has the value '-', the content of another environment variable,
1988 # $ENV{'CGI_DATA_ACCESS_CODE'} is executed as:
1989 # eval("\@_ = ($file_path); do {$ENV{'CGI_DATA_ACCESS_CODE'}};")
1990 # and the result is processed as if it was the content of the requested
1991 # file.
1992 # (actually, the names of the environment variables are user configurable,
1993 # they are stored in the local variables $CGI_FILE_CONTENT and
1994 # $CGI_DATA_ACCESS_CODE)
1996 # When using this mechanism, the SRC attribute mechanism will only partially work.
1997 # Only the "recursive" calls to CGIscriptor (the ProcessFile() function)
1998 # will work, the automagical execution of SRC files won't. (In this case,
1999 # the SRC attribute won't work either for other scripting languages)
2002 # NON-UNIX PLATFORMS
2004 # CGIscriptor.pl was mainly developed and tested on UNIX. However, as I
2005 # coded part of the time on an Apple Macintosh under MacPerl, I made sure
2006 # CGIscriptor did run under MacPerl (with command line options). But only
2007 # as an independend script, not as part of a HTTP server. I have used it
2008 # under Apache in Windows XP.
2010 ENDOFHELPTEXT
2011 exit;
2013 ###############################################################################
2015 # SECURITY CONFIGURATION
2017 # Special configurations related to SECURITY
2018 # (i.e., optional, see also environment variables below)
2020 # LOGGING
2021 # Log Clients and the requested paths (Redundant when loging Queries)
2023 $ClientLog = "./Client.log"; # (uncomment for use)
2025 # Format: Localtime | REMOTE_USER REMOTE_IDENT REMOTE_HOST REMOTE_ADDRESS \
2026 # PATH_INFO CONTENT_LENGTH (actually, the real query+post length)
2028 # Log Clients and the queries, the CGIQUERYDECODE is required if you want
2029 # to log queries. If you log Queries, the loging of Clients is redundant
2030 # (note that queries can be quite long, so this might not be a good idea)
2032 #$QueryLog = "./Query.log"; # (uncomment for use)
2034 # ACCESS CONTROL
2035 # the Access files should contain Hostnames or IP addresses,
2036 # i.e. REMOTE_HOST or REMOTE_ADDR, each on a separate line
2037 # optionally followed by one ore more file patterns, e.g., "edu /DEMO".
2038 # Matching is done "domain first". For example ".edu" matches all
2039 # clients whose "name" ends in ".edu" or ".EDU". The file pattern
2040 # "/DEMO" matches all paths that contain the strings "/DEMO" or "/demo"
2041 # (both matchings are done case-insensitive).
2042 # The name special symbol "-" matches ALL clients who do not supply a
2043 # REMOTE_HOST name, "*" matches all clients.
2044 # Lines starting with '-e' are evaluated. A non-zero return value indicates
2045 # a match. You can use $REMOTE_HOST, $REMOTE_ADDR, and $PATH_INFO. These
2046 # lines are evaluated in the program's own name-space. So DO NOT assign to
2047 # variables.
2049 # Accept the following users (remove comment # and adapt filename)
2050 $CGI_Accept = -s "$YOUR_SCRIPTS/ACCEPT.lis" ? "$YOUR_SCRIPTS/ACCEPT.lis" : ''; # (uncomment for use)
2052 # Reject requests from the following users (remove comment # and
2053 # adapt filename, this is only of limited use)
2054 $CGI_Reject = -s "$YOUR_SCRIPTS/REJECT.lis" ? "$YOUR_SCRIPTS/REJECT.lis" : ''; # (uncomment for use)
2056 # Empty lines or comment lines starting with '#' are ignored in both
2057 # $CGI_Accept and $CGI_Reject.
2059 # Block STDIN (i.e., '-') requests when servicing an HTTP request
2060 # Comment this out if you realy want to use STDIN in an on-line web server
2061 $BLOCK_STDIN_HTTP_REQUEST = 1;
2064 # End of security configuration
2066 ##################################################<<<<<<<<<<End Remove
2068 # PARSING CGI VALUES FROM THE QUERY STRING (USER CONFIGURABLE)
2070 # The CGI parse commands. These commands extract the values of the
2071 # CGI variables from the URL encoded Query String.
2072 # If you want to use your own CGI decoders, you can call them here
2073 # instead, using your own PATH and commenting/uncommenting the
2074 # appropriate lines
2076 # CGI parse command for individual values
2077 # (if $List > 0, returns a list value, if $List < 0, a hash table, this is optional)
2078 sub YOUR_CGIPARSE # ($Name [, $List]) -> Decoded value
2080 my $Name = shift;
2081 my $List = shift || 0;
2082 # Use one of the following by uncommenting
2083 if(!$List) # Simple value
2085 return CGIscriptor::CGIparseValue($Name) ;
2087 elsif($List < 0) # Hash tables
2089 return CGIscriptor::CGIparseValueHash($Name); # Defined in CGIscriptor below
2091 else # Lists
2093 return CGIscriptor::CGIparseValueList($Name); # Defined in CGIscriptor below
2096 # return `/PATH/cgiparse -value $Name`; # Shell commands
2097 # require "/PATH/cgiparse.pl"; return cgivalue($Name); # Library
2099 # Complete queries
2100 sub YOUR_CGIQUERYDECODE
2102 # Use one of the following by uncommenting
2103 return CGIscriptor::CGIparseForm(); # Defined in CGIscriptor below
2104 # return `/PATH/cgiparse -form`; # Shell commands
2105 # require "/PATH/cgiparse.pl"; return cgiform(); # Library
2108 # End of configuration
2110 #######################################################################
2112 # Translating input files.
2113 # Allows general and global conversions of files using Regular Expressions
2114 # Translations are applied in the order of definition.
2116 # Define:
2117 # my $TranslationPaths = 'pattern'; # Pattern matching PATH_INFO
2119 # push(@TranslationTable, ['pattern', 'replacement']);
2120 # e.g. (for Ruby Rails):
2121 # push(@TranslationTable, ['<%=', '<SCRIPT TYPE="text/ssruby">']);
2122 # push(@TranslationTable, ['%>', '</SCRIPT>']);
2124 # Runs:
2125 # my $currentRegExp;
2126 # foreach $currentRegExp (keys(%TranslationTable))
2128 # my $currentRegExp;
2129 # foreach $currentRegExp (@TranslationTable)
2131 # my ($pattern, $replacement) = @$currentRegExp;
2132 # $$text =~ s!$pattern!$replacement!msg;
2133 # };
2134 # };
2136 # Configuration section
2138 #######################################################################
2140 # The file paths on which to apply the translation
2141 my $TranslationPaths = ''; # NO files
2142 #$TranslationPaths = '.'; # ANY file
2143 # $TranslationPaths = '\.html'; # HTML files
2145 my @TranslationTable = ();
2146 # Some legacy code
2147 push(@TranslationTable, ['\<\s*CGI\s+([^\>])*\>', '\<SCRIPT TYPE=\"text/ssperl\"\>$1\<\/SCRIPT>']);
2148 # Ruby Rails?
2149 push(@TranslationTable, ['<%=', '<SCRIPT TYPE="text/ssruby">']);
2150 push(@TranslationTable, ['%>', '</SCRIPT>']);
2152 sub performTranslation # (\$text)
2154 my $text = shift || return;
2155 if(@TranslationTable && $TranslationPaths && $ENV{'PATH_INFO'} =~ m!$TranslationPaths!)
2157 my $currentRegExp;
2158 foreach $currentRegExp (@TranslationTable)
2160 my ($pattern, $replacement) = @$currentRegExp;
2161 $$text =~ s!$pattern!$replacement!msg;
2166 #######################################################################
2168 # Seamless access to other (Scripting) Languages
2169 # TYPE='text/ss<interpreter>'
2171 # Configuration section
2173 #######################################################################
2175 # OTHER SCRIPTING LANGUAGES AT THE SERVER SIDE (MIME => OScommand)
2176 # Yes, it realy is this simple! (unbelievable, isn't it)
2177 # NOTE: Some interpreters require some filtering to obtain "clean" output
2179 %ScriptingLanguages = (
2180 "text/testperl" => 'perl', # Perl for testing
2181 "text/sspython" => 'python', # Python
2182 "text/ssruby" => 'ruby', # Ruby
2183 "text/sstcl" => 'tcl', # TCL
2184 "text/ssawk" => 'awk -f-', # Awk
2185 "text/sslisp" => # lisp (rep, GNU)
2186 'rep | tail +4 '."| egrep -v '> |^rep. |^nil\\\$'",
2187 "text/xlispstat" => # xlispstat
2188 'xlispstat | tail +7 ' ."| egrep -v '> \\\$|^NIL'",
2189 "text/ssprolog" => # Prolog (GNU)
2190 "gprolog | tail +4 | sed 's/^| ?- //'",
2191 "text/ssm4" => 'm4', # M4 macro's
2192 "text/sh" => 'sh', # Born shell
2193 "text/bash" => 'bash', # Born again shell
2194 "text/csh" => 'csh', # C shell
2195 "text/ksh" => 'ksh', # Korn shell
2196 "text/sspraat" => # Praat (sound/speech analysis)
2197 "praat - | sed 's/Praat > //g'",
2198 "text/ssr" => # R
2199 "R --vanilla --slave | sed 's/^[\[0-9\]*] //'",
2200 "text/ssrebol" => # REBOL
2201 "rebol --quiet|egrep -v '^[> ]* == '|sed 's/^\\s*\[> \]* //'",
2202 "text/postgresql" => 'psql 2>/dev/null',
2204 # Not real scripting, but the use of other applications
2205 "text/ssmailto" => "awk 'NF||F{F=1;print \\\$0;}'|mailto >/dev/null", # Send mail from server
2206 "text/ssdisplay" => 'cat', # Display, (interpolation)
2207 "text/sslogfile" => # Log to file, (interpolation)
2208 "awk 'NF||L {if(!L){L=tolower(\\\$1)~/^file:\\\$/ ? \\\$2 : \\\$1;}else{print \\\$0 >> L;};}'",
2210 "" => ""
2213 # To be able to access the CGI variables in your script, they
2214 # should be passed to the scripting language in a readable form
2215 # Here you can enter how they should be printed (the first %s
2216 # is replaced by the NAME of the CGI variable as it apears in the
2217 # META tag, the second by its VALUE).
2218 # For Perl this would be:
2219 # "text/testperl" => '$%s = "%s";',
2220 # which would be executed as
2221 # printf('$%s = "%s";', $CGI_NAME, $CGI_VALUE);
2223 # If the hash table value doesn't exist, nothing is done
2224 # (you have to parse the Environment variables yourself).
2225 # If it DOES exist but is empty (e.g., "text/sspraat" => '',)
2226 # Perl string interpolation of variables (i.e., $var, @array,
2227 # %hash) is performed. This means that $@%\ must be protected
2228 # with a \.
2230 %ScriptingCGIvariables = (
2231 "text/testperl" => "\$\%s = '\%s';", # Perl $VAR = 'value'; (for testing)
2232 "text/sspython" => "\%s = '\%s'", # Python VAR = 'value'
2233 "text/ssruby" => '@%s = "%s"', # Ruby @VAR = 'value'
2234 "text/sstcl" => 'set %s "%s"', # TCL set VAR "value"
2235 "text/ssawk" => '%s = "%s";', # Awk VAR = 'value';
2236 "text/sslisp" => '(setq %s "%s")', # Gnu lisp (rep) (setq VAR "value")
2237 "text/xlispstat" => '(setq %s "%s")', # xlispstat (setq VAR "value")
2238 "text/ssprolog" => '', # Gnu prolog (interpolated)
2239 "text/ssm4" => "define(`\%s', `\%s')", # M4 macro's define(`VAR', `value')
2240 "text/sh" => "\%s='\%s'", # Born shell VAR='value'
2241 "text/bash" => "\%s='\%s'", # Born again shell VAR='value'
2242 "text/csh" => "\$\%s='\%s';", # C shell $VAR = 'value';
2243 "text/ksh" => "\$\%s='\%s';", # Korn shell $VAR = 'value';
2245 "text/ssrebol" => '%s: copy "%s"', # REBOL VAR: copy "value"
2246 "text/sspraat" => '', # Praat (interpolation)
2247 "text/ssr" => '%s <- "%s";', # R VAR <- "value";
2248 "text/postgresql" => '', # PostgreSQL (interpolation)
2250 # Not real scripting, but the use of other applications
2251 "text/ssmailto" => '', # MAILTO, (interpolation)
2252 "text/ssdisplay" => '', # Display, (interpolation)
2253 "text/sslogfile" => '', # Log to file, (interpolation)
2255 "" => ""
2258 # If you want something added in front or at the back of each script
2259 # block as send to the interpreter add it here.
2260 # mime => "string", e.g., "text/sspython" => "python commands"
2261 %ScriptingPrefix = (
2262 "text/testperl" => "\# Prefix Code;", # Perl script testing
2263 "text/ssm4" => 'divert(0)', # M4 macro's (open STDOUT)
2265 "" => ""
2267 # If you want something added at the end of each script block
2268 %ScriptingPostfix = (
2269 "text/testperl" => "\# Postfix Code;", # Perl script testing
2270 "text/ssm4" => 'divert(-1)', # M4 macro's (block STDOUT)
2272 "" => ""
2274 # If you need initialization code, directly after opening
2275 %ScriptingInitialization = (
2276 "text/testperl" => "\# Initialization Code;", # Perl script testing
2277 "text/ssawk" => 'BEGIN {', # Server Side awk scripts (VAR = "value")
2278 "text/sslisp" => '(prog1 nil ', # Lisp (rep)
2279 "text/xlispstat" => '(prog1 nil ', # xlispstat
2280 "text/ssm4" => 'divert(-1)', # M4 macro's (block STDOUT)
2282 "" => ""
2284 # If you need cleanup code before closing
2285 %ScriptingCleanup = (
2286 "text/testperl" => "\# Cleanup Code;", # Perl script testing
2287 "text/sspraat" => 'Quit',
2288 "text/ssawk" => '};', # Server Side awk scripts (VAR = "value")
2289 "text/sslisp" => '(princ "\n" standard-output)).', # Closing print to rep
2290 "text/xlispstat" => '(print ""))', # Closing print to xlispstat
2291 "text/postgresql" => '\q', # quit psql
2292 "text/ssdisplay" => "", # close cat
2294 "" => ""
2297 # End of configuration for foreign scripting languages
2299 ###############################################################################
2301 # Initialization Code
2304 sub Initialize_Request
2306 ###############################################################################
2308 # ENVIRONMENT VARIABLES
2310 # Use environment variables to configure CGIscriptor on a temporary basis.
2311 # If you define any of the configurable variables as environment variables,
2312 # these are used instead of the "hard coded" values above.
2314 $SS_PUB = $ENV{'SS_PUB'} || $YOUR_HTML_FILES;
2315 $SS_SCRIPT = $ENV{'SS_SCRIPT'} || $YOUR_SCRIPTS;
2318 # Substitution strings, these are used internally to handle the
2319 # directory separator strings, e.g., '~/' -> 'SS_PUB:' (Mac)
2320 $HOME_SUB = $SS_PUB;
2321 $SCRIPT_SUB = $SS_SCRIPT;
2324 # Make sure all script are reliably loaded
2325 push(@INC, $SS_SCRIPT);
2328 # Add the directory separator to the "home" directories.
2329 # (This is required for ~/ and ./ substitution)
2330 $HOME_SUB .= '/' if $HOME_SUB;
2331 $SCRIPT_SUB .= '/' if $SCRIPT_SUB;
2333 $CGI_HOME = $ENV{'DOCUMENT_ROOT'};
2334 $ENV{'PATH_TRANSLATED'} =~ /$ENV{'PATH_INFO'}/is;
2335 $CGI_HOME = $` unless $ENV{'DOCUMENT_ROOT'}; # Get the DOCUMENT_ROOT directory
2336 $default_values{'CGI_HOME'} = $CGI_HOME;
2337 $ENV{'HOME'} = $CGI_HOME;
2338 # Set SS_PUB and SS_SCRIPT as Environment variables (make them available
2339 # to the scripts)
2340 $ENV{'SS_PUB'} = $SS_PUB unless $ENV{'SS_PUB'};
2341 $ENV{'SS_SCRIPT'} = $SS_SCRIPT unless $ENV{'SS_SCRIPT'};
2343 $FilePattern = $ENV{'FilePattern'} || $FilePattern;
2344 $MaximumQuerySize = $ENV{'MaximumQuerySize'} || $MaximumQuerySize;
2345 $ClientLog = $ENV{'ClientLog'} || $ClientLog;
2346 $QueryLog = $ENV{'QueryLog'} || $QueryLog;
2347 $CGI_Accept = $ENV{'CGI_Accept'} || $CGI_Accept;
2348 $CGI_Reject = $ENV{'CGI_Reject'} || $CGI_Reject;
2350 # Parse file names
2351 $CGI_Accept =~ s@^\~/@$HOME_SUB@g if $CGI_Accept;
2352 $CGI_Reject =~ s@^\~/@$HOME_SUB@g if $CGI_Reject;
2353 $ClientLog =~ s@^\~/@$HOME_SUB@g if $ClientLog;
2354 $QueryLog =~ s@^\~/@$HOME_SUB@g if $QueryLog;
2356 $CGI_Accept =~ s@^\./@$SCRIPT_SUB@g if $CGI_Accept;
2357 $CGI_Reject =~ s@^\./@$SCRIPT_SUB@g if $CGI_Reject;
2358 $ClientLog =~ s@^\./@$SCRIPT_SUB@g if $ClientLog;
2359 $QueryLog =~ s@^\./@$SCRIPT_SUB@g if $QueryLog;
2361 @CGIscriptorResults = (); # A stack of results
2363 # end of Environment variables
2365 #############################################################################
2367 # Define and Store "standard" values
2369 # BEFORE doing ANYTHING check the size of Query String
2370 length($ENV{'QUERY_STRING'}) <= $MaximumQuerySize || dieHandler(2, "QUERY TOO LONG\n");
2372 # The Translated Query String and the Actual length of the (decoded)
2373 # Query String
2374 if($ENV{'QUERY_STRING'})
2376 # If this can contain '`"-quotes, be carefull to use it QUOTED
2377 $default_values{CGI_Decoded_QS} = YOUR_CGIQUERYDECODE();
2378 $default_values{CGI_Content_Length} = length($default_values{CGI_Decoded_QS});
2381 # Get the current Date and time and store them as default variables
2383 # Get Local Time
2384 $LocalTime = localtime;
2386 # CGI_Year CGI_Month CGI_Day CGI_WeekDay CGI_Time
2387 # CGI_Hour CGI_Minutes CGI_Seconds
2389 $default_values{CGI_Date} = $LocalTime;
2390 ($default_values{CGI_WeekDay},
2391 $default_values{CGI_Month},
2392 $default_values{CGI_Day},
2393 $default_values{CGI_Time},
2394 $default_values{CGI_Year}) = split(' ', $LocalTime);
2395 ($default_values{CGI_Hour},
2396 $default_values{CGI_Minutes},
2397 $default_values{CGI_Seconds}) = split(':', $default_values{CGI_Time});
2399 # GMT:
2400 # CGI_GMTYear CGI_GMTMonth CGI_GMTDay CGI_GMTWeekDay CGI_GMTYearDay
2401 # CGI_GMTHour CGI_GMTMinutes CGI_GMTSeconds CGI_GMTisdst
2403 ($default_values{CGI_GMTSeconds},
2404 $default_values{CGI_GMTMinutes},
2405 $default_values{CGI_GMTHour},
2406 $default_values{CGI_GMTDay},
2407 $default_values{CGI_GMTMonth},
2408 $default_values{CGI_GMTYear},
2409 $default_values{CGI_GMTWeekDay},
2410 $default_values{CGI_GMTYearDay},
2411 $default_values{CGI_GMTisdst}) = gmtime;
2415 # End of Initialize Request
2417 ###################################################################
2419 # SECURITY: ACCESS CONTROL
2421 # Check the credentials of each client (use pattern matching, domain first).
2422 # This subroutine will kill-off (die) the current process whenever access
2423 # is denied.
2425 sub Access_Control
2427 # >>>>>>>>>>Start Remove
2429 # ACCEPTED CLIENTS
2431 # Only accept clients which are authorized, reject all unnamed clients
2432 # if REMOTE_HOST is given.
2433 # If file patterns are given, check whether the user is authorized for
2434 # THIS file.
2435 if($CGI_Accept)
2437 # Use local variables, REMOTE_HOST becomes '-' if undefined
2438 my $REMOTE_HOST = $ENV{REMOTE_HOST} || '-';
2439 my $REMOTE_ADDR = $ENV{REMOTE_ADDR};
2440 my $PATH_INFO = $ENV{'PATH_INFO'};
2442 open(CGI_Accept, "<$CGI_Accept") || dieHandler(3, "$CGI_Accept: $!\n");
2443 $NoAccess = 1;
2444 while(<CGI_Accept>)
2446 next unless /\S/; # Skip empty lines
2447 next if /^\s*\#/; # Skip comments
2449 # Full expressions
2450 if(/^\s*-e\s/is)
2452 my $Accept = $'; # Get the expression
2453 $NoAccess &&= eval($Accept); # evaluate the expresion
2455 else
2457 my ($Accept, @FilePatternList) = split;
2458 if($Accept eq '*' # Always match
2459 ||$REMOTE_HOST =~ /\Q$Accept\E$/is # REMOTE_HOST matches
2460 || (
2461 $Accept =~ /^[0-9\.]+$/
2462 && $REMOTE_ADDR =~ /^\Q$Accept\E/ # IP address matches
2466 if($FilePatternList[0])
2468 foreach $Pattern (@FilePatternList)
2470 # Check whether this patterns is accepted
2471 $NoAccess &&= ($PATH_INFO !~ m@\Q$Pattern\E@is);
2474 else
2476 $NoAccess = 0; # No file patterns -> Accepted
2480 # Blocked
2481 last unless $NoAccess;
2483 close(CGI_Accept);
2484 if($NoAccess){ dieHandler(4, "No Access: $PATH_INFO\n");};
2488 # REJECTED CLIENTS
2490 # Reject named clients, accept all unnamed clients
2491 if($CGI_Reject)
2493 # Use local variables, REMOTE_HOST becomes '-' if undefined
2494 my $REMOTE_HOST = $ENV{'REMOTE_HOST'} || '-';
2495 my $REMOTE_ADDR = $ENV{'REMOTE_ADDR'};
2496 my $PATH_INFO = $ENV{'PATH_INFO'};
2498 open(CGI_Reject, "<$CGI_Reject") || dieHandler(5, "$CGI_Reject: $!\n");
2499 $NoAccess = 0;
2500 while(<CGI_Reject>)
2502 next unless /\S/; # Skip empty lines
2503 next if /^\s*\#/; # Skip comments
2505 # Full expressions
2506 if(/^-e\s/is)
2508 my $Reject = $'; # Get the expression
2509 $NoAccess ||= eval($Reject); # evaluate the expresion
2511 else
2513 my ($Reject, @FilePatternList) = split;
2514 if($Reject eq '*' # Always match
2515 ||$REMOTE_HOST =~ /\Q$Reject\E$/is # REMOTE_HOST matches
2516 ||($Reject =~ /^[0-9\.]+$/
2517 && $REMOTE_ADDR =~ /^\Q$Reject\E/is # IP address matches
2521 if($FilePatternList[0])
2523 foreach $Pattern (@FilePatternList)
2525 $NoAccess ||= ($PATH_INFO =~ m@\Q$Pattern\E@is);
2528 else
2530 $NoAccess = 1; # No file patterns -> Rejected
2534 last if $NoAccess;
2536 close(CGI_Reject);
2537 if($NoAccess){ dieHandler(6, "Request rejected: $PATH_INFO\n");};
2540 ##########################################################<<<<<<<<<<End Remove
2543 # Get the filename
2545 # Does the filename contain any illegal characters (e.g., |, >, or <)
2546 dieHandler(7, "Illegal request: $ENV{'PATH_INFO'}\n") if $ENV{'PATH_INFO'} =~ /[^$FileAllowedChars]/;
2547 # Does the pathname contain an illegal (blocked) "directory"
2548 dieHandler(8, "Illegal request: $ENV{'PATH_INFO'}\n") if $BlockPathAccess && $ENV{'PATH_INFO'} =~ m@$BlockPathAccess@; # Access is blocked
2549 # Does the pathname contain a direct referencer to BinaryMapFile
2550 dieHandler(9, "Illegal request: $ENV{'PATH_INFO'}\n") if $BinaryMapFile && $ENV{'PATH_INFO'} =~ m@\Q$BinaryMapFile\E@; # Access is blocked
2552 # SECURITY: Is PATH_INFO allowed?
2553 if($FilePattern && $ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} ne '-' &&
2554 ($ENV{'PATH_INFO'} !~ m@($FilePattern)$@is))
2556 # Unsupported file types can be processed by a special raw-file
2557 if($BinaryMapFile)
2559 $ENV{'CGI_BINARY_FILE'} = $ENV{'PATH_INFO'};
2560 $ENV{'PATH_INFO'} = $BinaryMapFile;
2562 else
2564 dieHandler(10, "Illegal file\n");
2570 # End of Security Access Control
2573 ############################################################################
2575 # Get the POST part of the query and add it to the QUERY_STRING.
2578 sub Get_POST_part_of_query
2581 # If POST, Read data from stdin to QUERY_STRING
2582 if($ENV{'REQUEST_METHOD'} =~ /POST/is)
2584 # SECURITY: Check size of Query String
2585 $ENV{'CONTENT_LENGTH'} <= $MaximumQuerySize || dieHandler(11, "Query too long: $ENV{'CONTENT_LENGTH'}\n"); # Query too long
2586 my $QueryRead = 0;
2587 my $SystemRead = $ENV{'CONTENT_LENGTH'};
2588 $ENV{'QUERY_STRING'} .= '&' if length($ENV{'QUERY_STRING'}) > 0;
2589 while($SystemRead > 0)
2591 $QueryRead = sysread(STDIN, $Post, $SystemRead); # Limit length
2592 $ENV{'QUERY_STRING'} .= $Post;
2593 $SystemRead -= $QueryRead;
2595 # Update decoded Query String
2596 $default_values{CGI_Decoded_QS} = YOUR_CGIQUERYDECODE();
2597 $default_values{CGI_Content_Length} =
2598 length($default_values{CGI_Decoded_QS});
2602 # End of getting POST part of query
2605 ############################################################################
2607 # Start (HTML) output and logging
2608 # (if there are irregularities, it can kill the current process)
2611 sub Initialize_output
2613 # Construct the REAL file path (except for STDIN on the command line)
2614 my $file_path = $ENV{'PATH_INFO'} ne '-' ? $SS_PUB . $ENV{'PATH_INFO'} : '-';
2615 $file_path =~ s/\?.*$//; # Remove query
2616 # This is only necessary if your server does not catch ../ directives
2617 $file_path !~ m@\.\./@ || dieHandler(12, "Illegal ../ Construct\n"); # SECURITY: Do not allow ../ constructs
2619 # Block STDIN use (-) if CGIscriptor is servicing a HTTP request
2620 if($file_path eq '-')
2622 dieHandler(13, "STDIN request in On Line system\n") if $BLOCK_STDIN_HTTP_REQUEST
2623 && ($ENV{'SERVER_SOFTWARE'}
2624 || $ENV{'SERVER_NAME'}
2625 || $ENV{'GATEWAY_INTERFACE'}
2626 || $ENV{'SERVER_PROTOCOL'}
2627 || $ENV{'SERVER_PORT'}
2628 || $ENV{'REMOTE_ADDR'}
2629 || $ENV{'HTTP_USER_AGENT'});
2634 if($ClientLog)
2636 open(ClientLog, ">>$ClientLog");
2637 print ClientLog "$LocalTime | ",
2638 ($ENV{REMOTE_USER} || "-"), " ",
2639 ($ENV{REMOTE_IDENT} || "-"), " ",
2640 ($ENV{REMOTE_HOST} || "-"), " ",
2641 $ENV{REMOTE_ADDR}, " ",
2642 $ENV{PATH_INFO}, " ",
2643 $ENV{'CGI_BINARY_FILE'}, " ",
2644 ($default_values{CGI_Content_Length} || "-"),
2645 "\n";
2646 close(ClientLog);
2648 if($QueryLog)
2650 open(QueryLog, ">>$QueryLog");
2651 print QueryLog "$LocalTime\n",
2652 ($ENV{REMOTE_USER} || "-"), " ",
2653 ($ENV{REMOTE_IDENT} || "-"), " ",
2654 ($ENV{REMOTE_HOST} || "-"), " ",
2655 $ENV{REMOTE_ADDR}, ": ",
2656 $ENV{PATH_INFO}, " ",
2657 $ENV{'CGI_BINARY_FILE'}, "\n";
2659 # Write Query to Log file
2660 print QueryLog $default_values{CGI_Decoded_QS}, "\n\n";
2661 close(QueryLog);
2664 # Return the file path
2665 return $file_path;
2668 # End of Initialize output
2671 ############################################################################
2673 # Handle login access
2675 # Access is based on a valid session ticket.
2676 # Session tickets should be dependend on user name
2677 # and IP address. The patterns of URLs for which a
2678 # session ticket is needed and the login URL are stored in
2679 # %TicketRequiredPatterns as:
2680 # 'RegEx pattern' -> 'SessionPath\tPasswordPath\tLogin URL\tExpiration'
2683 sub Log_In_Access # () -> 0 = Access Allowed, Login page if access is not allowed
2685 # No patterns, no login
2686 return 0 unless %TicketRequiredPatterns;
2688 # Get and initialize values (watch out for stuff processed by BinaryMap files)
2689 my ($SessionPath, $PasswordsPath, $Login, $valid_duration) = ("", "", "", 0);
2690 my $PATH_INFO = $ENV{'CGI_BINARY_FILE'} ? $ENV{'CGI_BINARY_FILE'} : $ENV{'PATH_INFO'};
2691 my $REMOTE_ADDR = $ENV{'REMOTE_ADDR'};
2692 return 0 if $REMOTE_ADDR =~ /[^0-9\.]/;
2694 # Extract TICKETs, starting with returned cookies
2695 CGIexecute::defineCGIvariable('LOGINTICKET', "");
2696 CGIexecute::defineCGIvariable('SESSIONTICKET', "");
2697 CGIexecute::defineCGIvariable('CHALLENGETICKET', "");
2698 if($ENV{'COOKIE_JAR'})
2700 if($ENV{'COOKIE_JAR'} =~ /\s+CGIscriptorLOGIN\=([^\;\-][^\;]*|\-[^\;]+)/ && $1 ne '-')
2702 ${"CGIexecute::LOGINTICKET"} = $1;
2704 if($ENV{'COOKIE_JAR'} =~ /\s+CGIscriptorCHALLENGE\=([^\;\-][^\;]*|\-[^\;]+)/ && $1 ne '-')
2706 ${"CGIexecute::CHALLENGETICKET"} = $1;
2708 if($ENV{'COOKIE_JAR'} =~ /\s+CGIscriptorSESSION\=([^\;\-][^\;]*|\-[^\;]+)/ && $1 ne '-')
2710 ${"CGIexecute::SESSIONTICKET"} = $1;
2713 # Get and check the tickets. Tickets are restricted to word-characters (alphanumeric+_+.)
2714 my $LOGINTICKET = ${"CGIexecute::LOGINTICKET"};
2715 return 0 if ($LOGINTICKET && $LOGINTICKET =~ /[^\w\.]/isg);
2716 my $SESSIONTICKET = ${"CGIexecute::SESSIONTICKET"};
2717 return 0 if ($SESSIONTICKET && $SESSIONTICKET =~ /[^\w\.]/isg);
2718 my $CHALLENGETICKET = ${"CGIexecute::CHALLENGETICKET"};
2719 return 0 if ($SESSIONTICKET && $SESSIONTICKET =~ /[^\w\.]/isg);
2720 # Look for a LOGOUT message
2721 my $LOGOUT = $ENV{QUERY_STRING} =~ /(^|\&)LOGOUT([\=\&]|$)/;
2723 # Username and password
2724 CGIexecute::defineCGIvariable('USERNAME', "");
2725 my $username = ${"CGIexecute::USERNAME"};
2726 return 0 if $username =~ m!^[^\w]!isg || $username =~ m![^\w \-]!isg;
2727 my $userfile = lc($username);
2728 $userfile =~ s/[^\w]/_/isg;
2729 CGIexecute::defineCGIvariable('PASSWORD', "");
2730 my $password = ${"CGIexecute::PASSWORD"};
2731 CGIexecute::defineCGIvariable('NEWPASSWORD', "");
2732 my $newpassword = ${"CGIexecute::NEWPASSWORD"};
2734 foreach my $pattern (keys(%TicketRequiredPatterns))
2736 # Check BOTH the real PATH_INFO and the CGI_BINARY_FILE variable
2737 if($ENV{'PATH_INFO'} =~ m#$pattern# || $ENV{'CGI_BINARY_FILE'} =~ m#$pattern#)
2739 # Fall through a sieve of requirements
2740 ($SessionPath, $PasswordsPath, $Login, $validtime) = split(/\t/, $TicketRequiredPatterns{$pattern});
2741 # If a LOGOUT is present, remove everything
2742 if($LOGOUT && !$LOGINTICKET)
2744 unlink "$SessionPath/$LOGINTICKET" if $LOGINTICKET && (-s "$SessionPath/$LOGINTICKET");
2745 $LOGINTICKET = "";
2746 unlink "$SessionPath/$SESSIONTICKET" if $SESSIONTICKET && (-s "$SessionPath/$SESSIONTICKET");
2747 $SESSIONTICKET = "";
2748 unlink "$SessionPath/$CHALLENGETICKET" if $CHALLENGETICKET && (-s "$SessionPath/$CHALLENGETICKET");
2749 $CHALLENGETICKET = "";
2750 unlink "$SessionPath/$REMOTE_ADDR" if (-s "$SessionPath/$$REMOTE_ADDR");
2751 $CHALLENGETICKET = "";
2752 goto Login;
2755 # Is there a change password request?
2756 if($newpassword && $LOGINTICKET && $SESSIONTICKET)
2758 my $tickets_removed = remove_expired_tickets($SessionPath);
2759 goto Login unless (-s "$SessionPath/$LOGINTICKET");
2760 goto Login unless (-s "$PasswordsPath/$userfile");
2761 goto Login unless (-s "$SessionPath/$SESSIONTICKET");
2762 my $ticket_valid = check_ticket_validity("SESSION", "$SessionPath/$SESSIONTICKET", $REMOTE_ADDR, $PATH_INFO);
2763 goto Login unless $ticket_valid;
2764 # Sessionticket is available to scripts
2765 $ENV{'SESSIONTICKET'} = $SESSIONTICKET;
2766 # Authorize
2767 change_password("$SessionPath/$LOGINTICKET", "$SessionPath/$SESSIONTICKET", "$PasswordsPath/$userfile", $password, $newpassword);
2768 # Ready
2769 return 0;
2771 # Is there a login ticket of this name?
2772 elsif($LOGINTICKET)
2774 my $tickets_removed = remove_expired_tickets($SessionPath);
2775 goto Login unless (-s "$SessionPath/$LOGINTICKET");
2776 goto Login unless (-s "$PasswordsPath/$userfile");
2777 my $ticket_valid = check_ticket_validity("LOGIN", "$SessionPath/$LOGINTICKET", $REMOTE_ADDR, ".");
2778 goto Login unless $ticket_valid;
2780 # Remove any lingering tickets
2781 unlink "$SessionPath/$SESSIONTICKET" if $SESSIONTICKET && (-s "$SessionPath/$SESSIONTICKET");
2782 $SESSIONTICKET = "";
2783 unlink "$SessionPath/$CHALLENGETICKET" if $CHALLENGETICKET && (-s "$SessionPath/$CHALLENGETICKET");
2784 $CHALLENGETICKET = "";
2787 # Authorize
2788 my $TMPTICKET = authorize_login("$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $password, $SessionPath);
2789 if($TMPTICKET)
2791 my $authorization = read_ticket("$PasswordsPath/$userfile");
2792 # Session type is read from the userfile
2793 if($authorization->{"Session"} && $authorization->{"Session"}->[0] eq "CHALLENGE")
2795 $CHALLENGETICKET = $TMPTICKET;
2796 $SETCOOKIELIST{"CGIscriptorCHALLENGE"} = "-";
2798 elsif($authorization->{"Session"} && $authorization->{"Session"}->[0] eq "IPADDRESS")
2800 create_session_file("$SessionPath/$REMOTE_ADDR", "$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $PATH_INFO);
2802 else
2804 $SESSIONTICKET = $TMPTICKET;
2805 create_session_file("$SessionPath/$SESSIONTICKET", "$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $PATH_INFO);
2806 $SETCOOKIELIST{"CGIscriptorSESSION"} = "-";
2809 # Login ticket file has been used, remove it
2810 unlink($loginfile);
2812 # Is there a session ticket of this name?
2813 # CHALLENGE
2814 if($CHALLENGETICKET)
2816 goto Login unless (-s "$SessionPath/$CHALLENGETICKET");
2817 my $ticket_valid = check_ticket_validity("CHALLENGE", "$SessionPath/$CHALLENGETICKET", $REMOTE_ADDR, $PATH_INFO);
2818 goto Login unless $ticket_valid;
2820 my $NEWCHALLENGETICKET = "";
2821 $NEWCHALLENGETICKET = copy_challenge_file("$SessionPath/$CHALLENGETICKET", "$PasswordsPath/$userfile", $SessionPath);
2823 # Sessionticket is available to scripts
2824 $ENV{'CHALLENGETICKET'} = $NEWCHALLENGETICKET;
2825 $SETCOOKIELIST{"CGIscriptorCHALLENGE"} = $NEWCHALLENGETICKET;
2826 return 0;
2828 # IPADDRESS
2829 elsif(-s "$SessionPath/$REMOTE_ADDR")
2831 my $ticket_valid = check_ticket_validity("IPADDRESS", "$SessionPath/$REMOTE_ADDR", $REMOTE_ADDR, $PATH_INFO);
2832 goto Login unless $ticket_valid;
2833 return 0;
2835 # SESSION
2836 elsif($SESSIONTICKET)
2838 goto Login unless (-s "$SessionPath/$SESSIONTICKET");
2839 my $ticket_valid = check_ticket_validity("SESSION", "$SessionPath/$SESSIONTICKET", $REMOTE_ADDR, $PATH_INFO);
2840 goto Login unless $ticket_valid;
2841 # Sessionticket is available to scripts
2842 $ENV{'SESSIONTICKET'} = $SESSIONTICKET;
2843 return 0;
2846 goto Login;
2847 return 0;
2850 return 0;
2852 Login:
2853 create_login_file($PasswordsPath, $SessionPath, $REMOTE_ADDR);
2854 # Note, cookies are set only ONCE
2855 $SETCOOKIELIST{"CGIscriptorLOGIN"} = "-";
2856 return "$YOUR_HTML_FILES/$Login";
2859 sub authorize_login # ($loginfile, $authorizationfile, $password, $SessionPath) => SESSIONTICKET First two arguments are file paths
2861 my $loginfile = shift || "";
2862 my $authorizationfile = shift || "";
2863 my $password = shift || "";
2864 my $SessionPath = shift || "";
2866 # Get Login session ticket
2867 my $loginticket = read_ticket($loginfile);
2868 # Get User credentials for authorization
2869 my $authorization = read_ticket($authorizationfile);
2871 # Get Randomsalt
2872 my $Randomsalt = $loginticket->{'Randomsalt'}->[0];
2874 return "" unless $Randomsalt;
2876 my $storedpassword = $authorization->{'Password'}->[0];
2877 return "" unless $storedpassword;
2878 # Without the "bash -c", the 'echo -n' could use sh, which does not recognize the -n option
2879 my $Hashedpassword = `bash -c 'echo -n $Randomsalt$storedpassword| $ENV{"SHASUMCMD"}'`;
2880 chomp($Hashedpassword);
2881 return "" unless $password eq $Hashedpassword;
2883 # Extract Session Ticket
2884 my $loginsession = $loginticket->{'Session'}->[0];
2885 my $sessionticket = `bash -c 'echo -n $loginsession$storedpassword| $ENV{"SHASUMCMD"}'`;
2886 chomp($sessionticket);
2887 $sessionticket = "" if -x "$SessionPath/$sessionticket";
2889 return $sessionticket;
2892 sub change_password # ($loginfile, $sessionfile, $authorizationfile, $password, $newpassword) First two arguments are file paths
2894 my $loginfile = shift || "";
2895 my $sessionfile = shift || "";
2896 my $authorizationfile = shift || "";
2897 my $password = shift || "";
2898 my $newpassword = shift || "";
2899 # Get Login session ticket
2900 my $loginticket = read_ticket($loginfile);
2901 # Login ticket file has been used, remove it
2902 unlink($loginfile);
2903 # Get Randomsalt
2904 my $Randomsalt = $loginticket->{'Randomsalt'}->[0];
2906 return "" unless $Randomsalt;
2908 # Get session ticket
2909 my $sessionticket = read_ticket($sessionfile);
2910 # Get User credentials for authorization
2911 my $authorization = read_ticket($authorizationfile);
2912 return "" unless $authorization->{'Username'}->[0] eq $sessionticket->{'Username'}->[0];
2914 my $storedpassword = $authorization->{'Password'}->[0];
2915 # Without the "bash -c", the 'echo -n' could use sh, which does not recognize the -n option
2916 my $Hashedpassword = `bash -c 'echo -n $Randomsalt$storedpassword| $ENV{"SHASUMCMD"}'`;
2917 chomp($Hashedpassword);
2918 return "" unless $password eq $Hashedpassword;
2920 # Decrypt the $newpassword
2921 my $loginticketid = $loginticket->{'Session'}->[0];
2922 my $passwordkey = `bash -c 'echo -n $loginticketid$storedpassword| $ENV{"SHASUMCMD"}'`;
2923 chomp($passwordkey);
2924 my $decryptedPassword = XOR_hex_strings($passwordkey, $newpassword);
2925 return "" unless $decryptedPassword;
2926 # Authorization succeeded, change password
2927 $authorization->{'Password'}->[0] = $decryptedPassword;
2929 open(USERFILE, "<$authorizationfile") || die "<$authorizationfile: $!\n";
2930 my @USERlines = <USERFILE>;
2931 close(USERFILE);
2932 # Change
2933 open(USERFILE, ">$authorizationfile") || die ">$authorizationfile: $!\n";
2934 foreach my $line (@USERlines)
2936 $line =~ s/^Password: ($storedpassword)$/Password: $decryptedPassword/ig;
2937 print USERFILE $line;
2939 close(USERFILE);
2941 return $newpassword;
2944 sub XOR_hex_strings # (hex1, hex2) -> hex
2946 my $hex1 = shift || "";
2947 my $hex2 = shift || "";
2948 my @hex1list = split('', $hex1);
2949 my @hex2list = split('', $hex2);
2950 my @hexresultlist = ();
2951 for(my $i; $i < scalar(@hex1list); ++$i)
2953 my $d1 = hex($hex1list[$i]);
2954 my $d2 = hex($hex2list[$i]);
2955 my $dresult = ($d1 ^ $d2);
2956 $hexresultlist[$i] = sprintf("%x", $dresult);
2958 $hexresult = join('', @hexresultlist);
2959 return $hexresult;
2962 # Copy a Challenge ticket file to a new name which is the hash of the new $CHALLENGETICKET and the password
2963 sub copy_challenge_file #($oldchallengefile, $authorizationfile, $sessionpath) -> $CHALLENGETICKET
2965 my $oldchallengefile = shift || "";
2966 my $authorizationfile = shift || "";
2967 my $sessionpath = shift || "";
2968 $sessionpath =~ s!/+$!!g;
2970 # Get Login session ticket
2971 my $oldchallenge = read_ticket($oldchallengefile);
2972 # Old file should now be removed
2973 unlink($oldchallengefile);
2975 # Get Authorization (user) session file
2976 my $authorization = read_ticket($authorizationfile);
2977 my $storedpassword = $authorization->{'Password'}->[0];
2978 return "" unless $storedpassword;
2979 my $Randomsalt = $oldchallenge->{'Randomsalt'}->[0];
2980 return "" unless $Randomsalt;
2981 $challengeroot = `bash -c 'echo -n $Randomsalt$storedpassword| $ENV{"SHASUMCMD"}'`;
2982 chomp($challengeroot);
2983 return "" unless $challengeroot;
2985 # Create Random Hash Salt
2986 open(URANDOM, "$RANDOMHASHCMD |") || die "URANDOM; $RANDOMHASHCMD | $!\n";
2987 my $NEWCHALLENGETICKET = <URANDOM>;
2988 close(URANDOM);
2989 chomp($NEWCHALLENGETICKET);
2990 my $newchallengefile = `bash -c 'echo -n $NEWCHALLENGETICKET$challengeroot| $ENV{"SHASUMCMD"}'`;
2991 chomp($newchallengefile);
2992 return "" unless $newchallengefile;
2994 $ENV{'CHALLENGETICKET'} = $NEWCHALLENGETICKET;
2995 CGIexecute::defineCGIvariable('CHALLENGETICKET', "");
2996 ${"CGIexecute::CHALLENGETICKET"} = $NEWCHALLENGETICKET;
2998 # Write Session Ticket
2999 open(OLDCHALLENGE, "<$oldchallengefile") || die "$oldchallengefile: $!\n";
3000 my @OldChallengeLines = <OLDCHALLENGE>;
3002 open(SESSION, ">$sessionpath/$newchallengefile") || die "$sessionpath/$newchallengefile: $!\n";
3003 foreach $line (@OldChallengeLines)
3005 print SESSION $line;
3007 close(SESSION);
3009 return $NEWCHALLENGETICKET;
3012 sub create_login_file #($PasswordDir, $SessionDir, $IPaddress)
3014 my $PasswordDir = shift || "";
3015 my $SessionDir = shift || "";
3016 my $IPaddress = shift || "";
3018 # Create Login Ticket
3019 open(URANDOM, "$RANDOMHASHCMD |") || die "URANDOM; $!\n";
3020 my $LOGINTICKET= <URANDOM>;
3021 close(URANDOM);
3022 chomp($LOGINTICKET);
3024 # Create Random Hash Salt
3025 open(URANDOM, "$RANDOMHASHCMD |") || die "URANDOM; $RANDOMHASHCMD | $!\n";
3026 my $RANDOMSALT= <URANDOM>;
3027 close(URANDOM);
3028 chomp($RANDOMSALT);
3030 # Create SALT file if it does not exist
3031 # Remove this, including test account for life system
3032 unless(-d "$SessionDir")
3034 `mkdir -p "$SessionDir"`;
3036 unless(-d "$PasswordDir")
3038 `mkdir -p "$PasswordDir"`;
3040 # Create SERVERSALT and default test account
3041 my $SERVERSALT = "";
3042 unless(-s "$PasswordDir/SALT")
3044 open(URANDOM, "$RANDOMHASHCMD |") || die "URANDOM; $!\n";
3045 $SERVERSALT= <URANDOM>;
3046 chomp($SERVERSALT);
3047 close(URANDOM);
3048 open(SALTFILE, ">$PasswordDir/SALT") || die ">$PasswordDir/SALT: $!\n";
3049 print SALTFILE "$SERVERSALT\n";
3050 close(SALTFILE);
3052 # Update test account (should be removed in live system)
3053 if(-s "$PasswordDir/test")
3055 my $storedpassword = `bash -c 'echo -n ${SERVERSALT}test | $ENV{"SHASUMCMD"}'`;
3056 chomp($storedpassword);
3057 open(USERFILE, "<$PasswordDir/test") || die "</Private/.Passwords/test: $!\n";
3058 @USERlines = <USERFILE>;
3059 close(USERFILE);
3061 open(USERFILE, ">$PasswordDir/test") || die ">/Private/.Passwords/test: $!\n";
3062 # Add Password and Salt
3063 foreach my $line (@USERlines)
3065 $line =~ s/^Password: (.*)$/Password: $storedpassword/ig;
3066 $line =~ s/^Salt: (.*)$/Salt: $SERVERSALT/ig;
3068 print USERFILE $line;
3070 close(USERFILE);
3075 # Read in site Salt
3076 open(SALTFILE, "<$PasswordDir/SALT") || die "$PasswordDir/SALT: $!\n";
3077 $SERVERSALT=<SALTFILE>;
3078 close(SALTFILE);
3079 chomp($SERVERSALT);
3081 # Create login session ticket
3082 open(LOGINTICKET, ">$SessionDir/$LOGINTICKET") || die "$SessionDir/$LOGINTICKET: $!\n";
3083 print LOGINTICKET << "ENDOFLOGINTICKET";
3084 Type: LOGIN
3085 IPaddress: $IPaddress
3086 Salt: $SERVERSALT
3087 Session: $LOGINTICKET
3088 Randomsalt: $RANDOMSALT
3089 Expires: +600s
3090 ENDOFLOGINTICKET
3091 close(LOGINTICKET);
3093 # Set global variables
3094 # $SERVERSALT
3095 $ENV{'SERVERSALT'} = $SERVERSALT;
3096 CGIexecute::defineCGIvariable('SERVERSALT', "");
3097 ${"CGIexecute::SERVERSALT"} = $SERVERSALT;
3099 # $SESSIONTICKET
3100 $ENV{'SESSIONTICKET'} = $SESSIONTICKET;
3101 CGIexecute::defineCGIvariable('SESSIONTICKET', "");
3102 ${"CGIexecute::SESSIONTICKET"} = $SESSIONTICKET;
3104 # $RANDOMSALT
3105 $ENV{'RANDOMSALT'} = $RANDOMSALT;
3106 CGIexecute::defineCGIvariable('RANDOMSALT', "");
3107 ${"CGIexecute::RANDOMSALT"} = $RANDOMSALT;
3109 # $LOGINTICKET
3110 $ENV{'LOGINTICKET'} = $LOGINTICKET;
3111 CGIexecute::defineCGIvariable('LOGINTICKET', "");
3112 ${"CGIexecute::LOGINTICKET"} = $LOGINTICKET;
3114 return $ENV{'LOGINTICKET'};
3117 sub create_session_file #($sessionfile, $loginfile, $authorizationfile, $path) -> Is $loginfile deleted? 0/1
3119 my $sessionfile = shift || "";
3120 my $loginfile = shift || "";
3121 my $authorizationfile = shift || "";
3122 my $path = shift || "";
3124 # Get Login session ticket
3125 my $loginticket = read_ticket($loginfile);
3126 # Get Authorization (user) session file
3127 my $authorization = read_ticket($authorizationfile);
3129 my @IPaddress = @{$loginticket->{'IPaddress'}};
3130 my @AllowedPaths = @{$authorization->{'AllowedPaths'}};;
3131 my @Expires = ();
3132 foreach my $pattern (keys(%TicketRequiredPatterns))
3134 if($path =~ m#$pattern#)
3136 my ($SessionPath, $PasswordsPath, $Login, $validtime) = split(/\t/, $TicketRequiredPatterns{$pattern});
3137 push(@Expires, $validtime);
3140 # Write Session Ticket
3141 open(SESSION, ">$sessionfile") || die "$sessionfile: $!\n";
3142 if($authorization->{'Session'} && $authorization->{'Session'}->[0])
3144 print SESSION "Type: ", $authorization->{'Session'}->[0], "\n";
3146 else
3148 print SESSION "Type: SESSION\n";
3150 foreach my $address (@IPaddress)
3152 print SESSION "IPaddress: $address\n";
3154 foreach my $path (@AllowedPaths)
3156 print SESSION "AllowedPaths: $path\n";
3158 foreach my $validtime (@Expires)
3160 print SESSION "Expires: $validtime\n";
3162 print SESSION "Username: ", $authorization->{'Username'}->[0], "\n";
3163 close(SESSION);
3165 # Login file should now be removed
3166 return unlink($loginfile);
3169 sub check_ticket_validity # ($type, $ticketfile, $address, $path)
3171 my $type = shift || "SESSION";
3172 my $ticketfile = shift || "";
3173 my $address = shift || "";
3174 my $path = shift || "";
3176 # Is there a session ticket of this name?
3177 return 0 unless -s "$ticketfile";
3179 # There is a session ticket, is it linked to this IP address?
3180 my $ticket = read_ticket($ticketfile);
3182 # Is this the right type of ticket
3183 return unless $ticket->{"Type"}->[0] eq $type;
3185 # Does the IP address match?
3186 $IPmatches = 0;
3187 for my $IPpattern (@{$ticket->{"IPaddress"}})
3189 ++$IPmatches if $address =~ m#^$IPpattern#ig;
3191 return 0 unless !$ticket->{"IPaddress"} || $IPmatches;
3193 # Is the path allowed
3194 my $Pathmatches = 0;
3195 foreach my $Pathpattern (@{$ticket->{"AllowedPaths"}})
3197 ++$Pathmatches if $path =~ m#$Pathpattern#ig;
3199 return 0 unless !@{$ticket->{"AllowedPaths"}} || $Pathmatches;
3201 # Is the ticket expired?
3202 my $Expired = 0;
3203 if($ticket->{"Expires"} && @{$ticket->{"Expires"}})
3205 my $CurrentTime = time();
3206 ++$Expired if($CurrentTime > $ticket->{"Expires"}->[0]);
3208 return 0 if $Expired;
3210 # Make login values available
3211 $ENV{"LOGINUSERNAME"} = $ticket->{'Username'}->[0];
3212 $ENV{"LOGINIPADDRESS"} = $address;
3213 $ENV{"LOGINPATH"} = $path;
3214 $ENV{"SESSIONTYPE"} = $type;
3216 return 1;
3220 sub remove_expired_tickets # ($path) -> number of tickets removed
3222 my $path = shift || "";
3223 return 0 unless $path;
3224 $path =~ s!/+$!!g;
3225 my $removed_tickets = 0;
3226 my @ticketlist = glob("$path/*");
3227 foreach my $ticketfile (@ticketlist)
3229 my $ticket = read_ticket($ticketfile);
3230 if(@{$ticket->{'Expires'}} && $ticket->{'Expires'}->[0] < time)
3232 unlink $ticketfile;
3233 ++$removed_tickets;
3236 return $removed_tickets;
3239 sub read_ticket # ($ticketfile) -> &%ticket
3241 my $ticketfile = shift || "";
3242 my $ticket = {};
3243 if($ticketfile && -s $ticketfile)
3245 open(TICKETFILE, "<$ticketfile") || die "$ticketfile: $!\n";
3246 my @alllines = <TICKETFILE>;
3247 close(TICKETFILE);
3248 foreach my $currentline (@alllines)
3250 if($currentline =~ /^\s*(\S[^\:]+)\:\s+(.*)\s*$/)
3252 my $Label = $1;
3253 my $Value = $2;
3254 # Recalculate expire date from relative time
3255 if($Label =~ /^Expires$/ig && $Value =~ /^\+/)
3257 # Get SessionTicket file stats
3258 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks)
3259 = stat("$ticketfile");
3260 if($Value =~ /^\+(\d+)\s*d(ays)?\s*$/)
3262 $ExpireTime = 24*3600*$1;
3264 elsif($Value =~ /^\+(\d+)\s*m(inutes)?\s*$/)
3266 $ExpireTime = 60*$1;
3268 elsif($Value =~ /^\+(\d+)\s*h(ours)?\s*$/)
3270 $ExpireTime = 3600*$1;
3272 elsif($Value =~ /^\+(\d+)\s*s(econds)?\s*$/)
3274 $ExpireTime = $1;
3276 elsif($Value =~ /^\+(\d+)\s*$/)
3278 $ExpireTime = $1;
3281 my $ActualExpireTime = $ExpireTime + $ctime;
3282 $Value = $ActualExpireTime;
3284 $ticket->{$Label} = () unless exists($ticket->{$Label});
3285 push(@{$ticket->{$Label}}, $Value);
3289 if(exists($ticket->{Expires}))
3291 @{$ticket->{Expires}} = sort(@{$ticket->{Expires}});
3293 return $ticket;
3296 # End of Handle login access
3299 ############################################################################
3301 # Handle foreign interpreters (i.e., scripting languages)
3303 # Insert perl code to execute scripts in foreign scripting languages.
3304 # Actually, the scripts inside the <SCRIPT></SCRIPT> blocks are piped
3305 # into an interpreter.
3306 # The code presented here is fairly confusing because it
3307 # actually writes perl code code to the output.
3309 # A table with the file handles
3310 %SCRIPTINGINPUT = ();
3312 # A function to clean up Client delivered CGI parameter values
3313 # (i.e., quote all odd characters)
3314 %SHRUBcharacterTR =
3316 "\'" => '&#39;',
3317 "\`" => '&#96;',
3318 "\"" => '&quot;',
3319 '&' => '&amper;',
3320 "\\" => '&#92;'
3323 sub shrubCGIparameter # ($String) -> Cleaned string
3325 my $String = shift || "";
3327 # Change all quotes [`'"] into HTML character entities
3328 my ($Char, $Transcript) = ('&', $SHRUBcharacterTR{'&'});
3330 # Protect &
3331 $String =~ s/\Q$Char\E/$Transcript/isg if $Transcript;
3333 while( ($Char, $Transcript) = each %SHRUBcharacterTR)
3335 next if $Char eq '&';
3336 $String =~ s/\Q$Char\E/$Transcript/isg;
3339 # Replace newlines
3340 $String =~ s/[\n]/\\n/g;
3341 # Replace control characters with their backslashed octal ordinal numbers
3342 $String =~ s/([^\S \t])/(sprintf("\\0%o", ord($1)))/eisg; #
3343 $String =~ s/([\x00-\x08\x0A-\x1F])/(sprintf("\\0%o", ord($1)))/eisg; #
3345 return $String;
3349 # The initial open statements: Open a pipe to the foreign script interpreter
3350 sub OpenForeignScript # ($ContentType) -> $DirectivePrefix
3352 my $ContentType = lc(shift) || return "";
3353 my $NewDirective = "";
3355 return $NewDirective if($SCRIPTINGINPUT{$ContentType});
3357 # Construct a unique file handle name
3358 $SCRIPTINGFILEHANDLE = uc($ContentType);
3359 $SCRIPTINGFILEHANDLE =~ s/\W/\_/isg;
3360 $SCRIPTINGINPUT{$ContentType} = $SCRIPTINGFILEHANDLE
3361 unless $SCRIPTINGINPUT{$ContentType};
3363 # Create the relevant script: Open the pipe to the interpreter
3364 $NewDirective .= <<"BLOCKCGISCRIPTOROPEN";
3365 # Open interpreter for '$ContentType'
3366 # Open pipe to interpreter (if it isn't open already)
3367 open($SCRIPTINGINPUT{$ContentType}, "|$ScriptingLanguages{$ContentType}") || main::dieHandler(14, "$ContentType: \$!\\n");
3368 BLOCKCGISCRIPTOROPEN
3370 # Insert Initialization code and CGI variables
3371 $NewDirective .= InitializeForeignScript($ContentType);
3373 # Ready
3374 return $NewDirective;
3378 # The final closing code to stop the interpreter
3379 sub CloseForeignScript # ($ContentType) -> $DirectivePrefix
3381 my $ContentType = lc(shift) || return "";
3382 my $NewDirective = "";
3384 # Do nothing unless the pipe realy IS open
3385 return "" unless $SCRIPTINGINPUT{$ContentType};
3387 # Initial comment
3388 $NewDirective .= "\# Close interpreter for '$ContentType'\n";
3391 # Write the Postfix code
3392 $NewDirective .= CleanupForeignScript($ContentType);
3394 # Create the relevant script: Close the pipe to the interpreter
3395 $NewDirective .= <<"BLOCKCGISCRIPTORCLOSE";
3396 close($SCRIPTINGINPUT{$ContentType}) || main::dieHandler(15, \"$ContentType: \$!\\n\");
3397 select(STDOUT); \$|=1;
3399 BLOCKCGISCRIPTORCLOSE
3401 # Remove the file handler of the foreign script
3402 delete($SCRIPTINGINPUT{$ContentType});
3404 return $NewDirective;
3408 # The initialization code for the foreign script interpreter
3409 sub InitializeForeignScript # ($ContentType) -> $DirectivePrefix
3411 my $ContentType = lc(shift) || return "";
3412 my $NewDirective = "";
3414 # Add initialization code
3415 if($ScriptingInitialization{$ContentType})
3417 $NewDirective .= <<"BLOCKCGISCRIPTORINIT";
3418 # Initialization Code for '$ContentType'
3419 # Select relevant output filehandle
3420 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3422 # The Initialization code (if any)
3423 print $SCRIPTINGINPUT{$ContentType} <<'${ContentType}INITIALIZATIONCODE';
3424 $ScriptingInitialization{$ContentType}
3425 ${ContentType}INITIALIZATIONCODE
3427 BLOCKCGISCRIPTORINIT
3430 # Add all CGI variables defined
3431 if(exists($ScriptingCGIvariables{$ContentType}))
3433 # Start writing variable definitions to the Interpreter
3434 if($ScriptingCGIvariables{$ContentType})
3436 $NewDirective .= <<"BLOCKCGISCRIPTORVARDEF";
3437 # CGI variables (from the %default_values table)
3438 print $SCRIPTINGINPUT{$ContentType} << '${ContentType}CGIVARIABLES';
3439 BLOCKCGISCRIPTORVARDEF
3442 my ($N, $V);
3443 foreach $N (keys(%default_values))
3445 # Determine whether the parameter has been defined
3446 # (the eval is a workaround to get at the variable value)
3447 next unless eval("defined(\$CGIexecute::$N)");
3449 # Get the value from the EXECUTION environment
3450 $V = eval("\$CGIexecute::$N");
3451 # protect control characters (i.e., convert them to \0.. form)
3452 $V = shrubCGIparameter($V);
3454 # Protect interpolated variables
3455 eval("\$CGIexecute::$N = '$V';") unless $ScriptingCGIvariables{$ContentType};
3457 # Print the actual declaration for this scripting language
3458 if($ScriptingCGIvariables{$ContentType})
3460 $NewDirective .= sprintf($ScriptingCGIvariables{$ContentType}, $N, $V);
3461 $NewDirective .= "\n";
3465 # Stop writing variable definitions to the Interpreter
3466 if($ScriptingCGIvariables{$ContentType})
3468 $NewDirective .= <<"BLOCKCGISCRIPTORVARDEFEND";
3469 ${ContentType}CGIVARIABLES
3470 BLOCKCGISCRIPTORVARDEFEND
3475 $NewDirective .= << "BLOCKCGISCRIPTOREND";
3477 # Select STDOUT filehandle
3478 select(STDOUT); \$|=1;
3480 BLOCKCGISCRIPTOREND
3482 return $NewDirective;
3486 # The cleanup code for the foreign script interpreter
3487 sub CleanupForeignScript # ($ContentType) -> $DirectivePrefix
3489 my $ContentType = lc(shift) || return "";
3490 my $NewDirective = "";
3492 # Return if not needed
3493 return $NewDirective unless $ScriptingCleanup{$ContentType};
3495 # Create the relevant script: Open the pipe to the interpreter
3496 $NewDirective .= <<"BLOCKCGISCRIPTORSTOP";
3497 # Cleanup Code for '$ContentType'
3498 # Select relevant output filehandle
3499 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3500 # Print Cleanup code to foreign script
3501 print $SCRIPTINGINPUT{$ContentType} <<'${ContentType}SCRIPTSTOP';
3502 $ScriptingCleanup{$ContentType}
3503 ${ContentType}SCRIPTSTOP
3505 # Select STDOUT filehandle
3506 select(STDOUT); \$|=1;
3507 BLOCKCGISCRIPTORSTOP
3509 return $NewDirective;
3513 # The prefix code for each <script></script> block
3514 sub PrefixForeignScript # ($ContentType) -> $DirectivePrefix
3516 my $ContentType = lc(shift) || return "";
3517 my $NewDirective = "";
3519 # Return if not needed
3520 return $NewDirective unless $ScriptingPrefix{$ContentType};
3522 my $Quote = "\'";
3523 # If the CGIvariables parameter is defined, but empty, interpolate
3524 # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END')
3525 $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) &&
3526 !$ScriptingCGIvariables{$ContentType};
3528 # Add initialization code
3529 $NewDirective .= <<"BLOCKCGISCRIPTORPREFIX";
3530 # Prefix Code for '$ContentType'
3531 # Select relevant output filehandle
3532 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3534 # The block Prefix code (if any)
3535 print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}PREFIXCODE$Quote;
3536 $ScriptingPrefix{$ContentType}
3537 ${ContentType}PREFIXCODE
3538 # Select STDOUT filehandle
3539 select(STDOUT); \$|=1;
3540 BLOCKCGISCRIPTORPREFIX
3542 return $NewDirective;
3546 # The postfix code for each <script></script> block
3547 sub PostfixForeignScript # ($ContentType) -> $DirectivePrefix
3549 my $ContentType = lc(shift) || return "";
3550 my $NewDirective = "";
3552 # Return if not needed
3553 return $NewDirective unless $ScriptingPostfix{$ContentType};
3555 my $Quote = "\'";
3556 # If the CGIvariables parameter is defined, but empty, interpolate
3557 # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END')
3558 $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) &&
3559 !$ScriptingCGIvariables{$ContentType};
3561 # Create the relevant script: Open the pipe to the interpreter
3562 $NewDirective .= <<"BLOCKCGISCRIPTORPOSTFIX";
3563 # Postfix Code for '$ContentType'
3564 # Select filehandle to interpreter
3565 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3566 # Print postfix code to foreign script
3567 print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}SCRIPTPOSTFIX$Quote;
3568 $ScriptingPostfix{$ContentType}
3569 ${ContentType}SCRIPTPOSTFIX
3570 # Select STDOUT filehandle
3571 select(STDOUT); \$|=1;
3572 BLOCKCGISCRIPTORPOSTFIX
3574 return $NewDirective;
3577 sub InsertForeignScript # ($ContentType, $directive, @SRCfile) -> $NewDirective
3579 my $ContentType = lc(shift) || return "";
3580 my $directive = shift || return "";
3581 my @SRCfile = @_;
3582 my $NewDirective = "";
3584 my $Quote = "\'";
3585 # If the CGIvariables parameter is defined, but empty, interpolate
3586 # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END')
3587 $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) &&
3588 !$ScriptingCGIvariables{$ContentType};
3590 # Create the relevant script
3591 $NewDirective .= <<"BLOCKCGISCRIPTORINSERT";
3592 # Insert Code for '$ContentType'
3593 # Select filehandle to interpreter
3594 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3595 BLOCKCGISCRIPTORINSERT
3597 # Use SRC feature files
3598 my $ThisSRCfile;
3599 while($ThisSRCfile = shift(@_))
3601 # Handle blocks
3602 if($ThisSRCfile =~ /^\s*\{\s*/)
3604 my $Block = $';
3605 $Block = $` if $Block =~ /\s*\}\s*$/;
3606 $NewDirective .= <<"BLOCKCGISCRIPTORSRCBLOCK";
3607 print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}SRCBLOCKCODE$Quote;
3608 $Block
3609 ${ContentType}SRCBLOCKCODE
3610 BLOCKCGISCRIPTORSRCBLOCK
3612 next;
3615 # Handle files
3616 $NewDirective .= <<"BLOCKCGISCRIPTORSRCFILES";
3617 # Read $ThisSRCfile
3618 open(SCRIPTINGSOURCE, "<$ThisSRCfile") || main::dieHandler(16, "$ThisSRCfILE: \$!");
3619 while(<SCRIPTINGSOURCE>)
3621 print $SCRIPTINGINPUT{$ContentType} \$_;
3623 close(SCRIPTINGSOURCE);
3625 BLOCKCGISCRIPTORSRCFILES
3629 # Add the directive
3630 if($directive)
3632 $NewDirective .= <<"BLOCKCGISCRIPTORINSERT";
3633 print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}DIRECTIVECODE$Quote;
3634 $directive
3635 ${ContentType}DIRECTIVECODE
3636 BLOCKCGISCRIPTORINSERT
3640 $NewDirective .= <<"BLOCKCGISCRIPTORSELECT";
3641 # Select STDOUT filehandle
3642 select(STDOUT); \$|=1;
3643 BLOCKCGISCRIPTORSELECT
3645 # Ready
3646 return $NewDirective;
3649 sub CloseAllForeignScripts # Call CloseForeignScript on all open scripts
3651 my $ContentType;
3652 foreach $ContentType (keys(%SCRIPTINGINPUT))
3654 my $directive = CloseForeignScript($ContentType);
3655 print STDERR "\nDirective $CGI_Date: ", $directive;
3656 CGIexecute->evaluate($directive);
3661 # End of handling foreign (external) scripting languages.
3663 ############################################################################
3665 # A subroutine to handle "nested" quotes, it cuts off the leading
3666 # item or quoted substring
3667 # E.g.,
3668 # ' A_word and more words' -> @('A_word', ' and more words')
3669 # '"quoted string" The rest' -> @('quoted string', ' The rest')
3670 # (this is needed for parsing the <TAGS> and their attributes)
3671 my $SupportedQuotes = "\'\"\`\(\{\[";
3672 my %QuotePairs = ('('=>')','['=>']','{'=>'}'); # Brackets
3673 sub ExtractQuotedItem # ($String) -> @($QuotedString, $RestOfString)
3675 my @Result = ();
3676 my $String = shift || return @Result;
3678 if($String =~ /^\s*([\w\/\-\.]+)/is)
3680 push(@Result, $1, $');
3682 elsif($String =~ /^\s*(\\?)([\Q$SupportedQuotes\E])/is)
3684 my $BackSlash = $1 || "";
3685 my $OpenQuote = $2;
3686 my $CloseQuote = $OpenQuote;
3687 $CloseQuote = $QuotePairs{$OpenQuote} if $QuotePairs{$OpenQuote};
3689 if($BackSlash)
3691 $String =~ /^\s*\\\Q$OpenQuote\E/i;
3692 my $Onset = $';
3693 $Onset =~ /\\\Q$CloseQuote\E/i;
3694 my $Rest = $';
3695 my $Item = $`;
3696 push(@Result, $Item, $Rest);
3699 else
3701 $String =~ /^\s*\Q$OpenQuote\E([^\Q$CloseQuote\E]*)\Q$CloseQuote\E/i;
3702 push(@Result, $1, $');
3705 else
3707 push(@Result, "", $String);
3709 return @Result;
3712 # Now, start with the real work
3714 # Control the output of the Content-type: text/html\n\n message
3715 my $SupressContentType = 0;
3717 # Process a file
3718 sub ProcessFile # ($file_path)
3720 my $file_path = shift || return 0;
3723 # Generate a unique file handle (for recursions)
3724 my @SRClist = ();
3725 my $FileHandle = "file";
3726 my $n = 0;
3727 while(!eof($FileHandle.$n)) {++$n;};
3728 $FileHandle .= $n;
3730 # Start HTML output
3731 # Use the default Content-type if this is NOT a raw file
3732 unless(($RawFilePattern && $ENV{'PATH_INFO'} =~ m@($RawFilePattern)$@i)
3733 || $SupressContentType)
3735 $ENV{'PATH_INFO'} =~ m@($FilePattern)$@i;
3736 my $ContentType = $ContentTypeTable{$1};
3737 print "Content-type: $ContentType\n";
3738 if(%SETCOOKIELIST && keys(%SETCOOKIELIST))
3740 foreach my $name (keys(%SETCOOKIELIST))
3742 my $value = $SETCOOKIELIST{$name};
3743 print "Set-Cookie: $name=$value\n";
3745 # Cookies are set only ONCE
3746 %SETCOOKIELIST = ();
3748 print "\n";
3749 $SupressContentType = 1; # Content type has been printed
3753 # Get access to the actual data. This can be from RAM (by way of an
3754 # environment variable) or by opening a file.
3756 # Handle the use of RAM images (file-data is stored in the
3757 # $CGI_FILE_CONTENTS environment variable)
3758 # Note that this environment variable will be cleared, i.e., it is strictly for
3759 # single-use only!
3760 if($ENV{$CGI_FILE_CONTENTS})
3762 # File has been read already
3763 $_ = $ENV{$CGI_FILE_CONTENTS};
3764 # Sorry, you have to do the reading yourself (dynamic document creation?)
3765 # NOTE: you must read the whole document at once
3766 if($_ eq '-')
3768 $_ = eval("\@_=('$file_path'); do{$ENV{$CGI_DATA_ACCESS_CODE}}");
3770 else # Clear environment variable
3772 $ENV{$CGI_FILE_CONTENTS} = '-';
3775 # Open Only PLAIN TEXT files (or STDIN) and NO executable files (i.e., scripts).
3776 # THIS IS A SECURITY FEATURE!
3777 elsif($file_path eq '-' || (-e "$file_path" && -r _ && -T _ && -f _ && ! (-x _ || -X _) ))
3779 open($FileHandle, $file_path) || dieHandler(17, "<h2>File not found</h2>\n");
3780 push(@OpenFiles, $file_path);
3781 $_ = <$FileHandle>; # Read first line
3783 else
3785 print "<h2>File not found</h2>\n";
3786 dieHandler(18, "$file_path\n");
3789 $| = 1; # Flush output buffers
3791 # Initialize variables
3792 my $METAarguments = ""; # The CGI arguments from the latest META tag
3793 my @METAvalues = (); # The ''-quoted CGI values from the latest META tag
3794 my $ClosedTag = 0; # <TAG> </TAG> versus <TAG/>
3797 # Send document to output
3798 # Process the requested document.
3799 # Do a loop BEFORE reading input again (this catches the RAM/Database
3800 # type of documents).
3801 do {
3804 # Handle translations if needed
3806 performTranslation(\$_) if $TranslationPaths;
3808 # Catch <SCRIPT LANGUAGE="PERL" TYPE="text/ssperl" > directives in $_
3809 # There can be more than 1 <SCRIPT> or META tags on a line
3810 while(/\<\s*(SCRIPT|META|DIV|INS)\s/is)
3812 my $directive = "";
3813 # Store rest of line
3814 my $Before = $`;
3815 my $ScriptTag = $&;
3816 my $After = $';
3817 my $TagType = uc($1);
3818 # The before part can be send to the output
3819 print $Before;
3821 # Read complete Tag from after and/or file
3822 until($After =~ /([^\\])\>/)
3824 $After .= <$FileHandle>;
3825 performTranslation(\$After) if $TranslationPaths;
3828 if($After =~ /([^\\])\>/)
3830 $ScriptTag .= $`.$&; # Keep the Script Tag intact
3831 $After = $';
3833 else
3835 dieHandler(19, "Closing > not found\n");
3838 # The tag could be closed by />, we handle this in the XML way
3839 # and don't process any content (we ignore whitespace)
3840 $ClosedTag = ($ScriptTag =~ m@[^\\]/\s*\>\s*$@) ? 1 : 0;
3843 # TYPE or CLASS?
3844 my $TypeName = ($TagType =~ /META/is) ? "CONTENT" : "TYPE";
3845 $TypeName = "CLASS" if $TagType eq 'DIV' || $TagType eq 'INS';
3847 # Parse <SCRIPT> or <META> directive
3848 # If NOT (TYPE|CONTENT)="text/ssperl" (i.e., $ServerScriptContentType),
3849 # send the line to the output and go to the next loop
3850 my $CurrentContentType = "";
3851 if($ScriptTag =~ /(^|\s)$TypeName\s*=\s*/is)
3853 my ($Type) = ExtractQuotedItem($');
3854 $Type =~ /^\s*([\w\/\-]+)\s*[\,\;]?/;
3855 $CurrentContentType = lc($1); # Note: mime-types are "case-less"
3856 # CSS classes are aliases of $ServerScriptContentType
3857 if($TypeName eq "CLASS" && $CurrentContentType eq $ServerScriptContentClass)
3859 $CurrentContentType = $ServerScriptContentType;
3864 # Not a known server-side content type, print and continue
3865 unless(($CurrentContentType =~
3866 /$ServerScriptContentType|$ShellScriptContentType/is) ||
3867 $ScriptingLanguages{$CurrentContentType})
3869 print $ScriptTag;
3870 $_ = $After;
3871 next;
3875 # A known server-side content type, evaluate
3877 # First, handle \> and \<
3878 $ScriptTag =~ s/\\\>/\>/isg;
3879 $ScriptTag =~ s/\\\</\</isg;
3881 # Extract the CGI, SRC, ID, IF and UNLESS attributes
3882 my %ScriptTagAttributes = ();
3883 while($ScriptTag =~ /(^|\s)(CGI|IF|UNLESS|SRC|ID)\s*=\s*/is)
3885 my $Attribute = $2;
3886 my $Rest = $';
3887 my $Value = "";
3888 ($Value, $ScriptTag) = ExtractQuotedItem($Rest);
3889 $ScriptTagAttributes{uc($Attribute)} = $Value;
3893 # The attribute used to define the CGI variables
3894 # Extract CGI-variables from
3895 # <META CONTENT="text/ssperl; CGI='' SRC=''">
3896 # <SCRIPT TYPE='text/ssperl' CGI='' SRC=''>
3897 # <DIV CLASS='ssperl' CGI='' SRC='' ID=""> tags
3898 # <INS CLASS='ssperl' CGI='' SRC='' ID=""> tags
3899 if($ScriptTagAttributes{'CGI'})
3901 @ARGV = (); # Reset ARGV
3902 $ARGC = 0;
3903 $METAarguments = ""; # Reset the META CGI arguments
3904 @METAvalues = ();
3905 my $Meta_CGI = $ScriptTagAttributes{'CGI'};
3907 # Process default values of variables ($<name> = 'default value')
3908 # Allowed quotes are '', "", ``, (), [], and {}
3909 while($Meta_CGI =~ /(^\s*|[^\\])([\$\@\%]?)([\w\-]+)\s*/is)
3911 my $varType = $2 || '$'; # Variable or list
3912 my $name = $3; # The Name
3913 my $default = "";
3914 $Meta_CGI = $';
3916 if($Meta_CGI =~ /^\s*\=\s*/is)
3918 # Locate (any) default value
3919 ($default, $Meta_CGI) = ExtractQuotedItem($'); # Cut the parameter from the CGI
3921 $RemainingTag = $Meta_CGI;
3924 # Define CGI (or ENV) variable, initalize it from the
3925 # Query string or the default value
3927 # Also construct the @ARGV and @_ arrays. This allows other (SRC=) Perl
3928 # scripts to access the CGI arguments defined in the META tag
3929 # (Not for CGI inside <SCRIPT> tags)
3930 if($varType eq '$')
3932 CGIexecute::defineCGIvariable($name, $default)
3933 || dieHandler(20, "INVALID CGI name/value pair ($name, $default)\n");
3934 push(@METAvalues, "'".${"CGIexecute::$name"}."'");
3935 # Add value to the @ARGV list
3936 push(@ARGV, ${"CGIexecute::$name"});
3937 ++$ARGC;
3939 elsif($varType eq '@')
3941 CGIexecute::defineCGIvariableList($name, $default)
3942 || dieHandler(21, "INVALID CGI name/value list pair ($name, $default)\n");
3943 push(@METAvalues, "'".join("'", @{"CGIexecute::$name"})."'");
3944 # Add value to the @ARGV list
3945 push(@ARGV, @{"CGIexecute::$name"});
3946 $ARGC = scalar(@CGIexecute::ARGV);
3948 elsif($varType eq '%')
3950 CGIexecute::defineCGIvariableHash($name, $default)
3951 || dieHandler(22, "INVALID CGI name/value hash pair ($name, $default)\n");
3952 my @PairList = map {"$_ => ".${"CGIexecute::$name"}{$_}} keys(%{"CGIexecute::$name"});
3953 push(@METAvalues, "'".join("'", @PairList)."'");
3954 # Add value to the @ARGV list
3955 push(@ARGV, %{"CGIexecute::$name"});
3956 $ARGC = scalar(@CGIexecute::ARGV);
3959 # Store the values for internal and later use
3960 $METAarguments .= "$varType".$name.","; # A string of CGI variable names
3962 push(@METAvalues, "\'".eval("\"$varType\{CGIexecute::$name\}\"")."\'"); # ALWAYS add '-quotes around values
3967 # The IF (conditional execution) Attribute
3968 # Evaluate the condition and stop unless it evaluates to true
3969 if($ScriptTagAttributes{'IF'})
3971 my $IFcondition = $ScriptTagAttributes{'IF'};
3973 # Convert SCRIPT calls, ./<script>
3974 $IFcondition =~ s@([\W]|^)\./([\S])@$1$SCRIPT_SUB$2@g;
3976 # Convert FILE calls, ~/<file>
3977 $IFcondition =~ s@([\W])\~/([\S])@$1$HOME_SUB$2@g;
3979 # Block execution if necessary
3980 unless(CGIexecute->evaluate($IFcondition))
3982 %ScriptTagAttributes = ();
3983 $CurrentContentType = "";
3987 # The UNLESS (conditional execution) Attribute
3988 # Evaluate the condition and stop if it evaluates to true
3989 if($ScriptTagAttributes{'UNLESS'})
3991 my $UNLESScondition = $ScriptTagAttributes{'UNLESS'};
3993 # Convert SCRIPT calls, ./<script>
3994 $UNLESScondition =~ s@([\W]|^)\./([\S])@$1$SCRIPT_SUB$2@g;
3996 # Convert FILE calls, ~/<file>
3997 $UNLESScondition =~ s@([\W])\~/([\S])@$1$HOME_SUB$2@g;
3999 # Block execution if necessary
4000 if(CGIexecute->evaluate($UNLESScondition))
4002 %ScriptTagAttributes = ();
4003 $CurrentContentType = "";
4007 # The SRC (Source File) Attribute
4008 # Extract any source script files and add them in
4009 # front of the directive
4010 # The SRC list should be emptied
4011 @SRClist = ();
4012 my $SRCtag = "";
4013 my $Prefix = 1;
4014 my $PrefixDirective = "";
4015 my $PostfixDirective = "";
4016 # There is a SRC attribute
4017 if($ScriptTagAttributes{'SRC'})
4019 $SRCtag = $ScriptTagAttributes{'SRC'};
4020 # Remove "file://" prefixes
4021 $SRCtag =~ s@([^\w\/\\]|^)file\://([^\s\/\@\=])@$1$2@gis;
4022 # Expand script filenames "./Script"
4023 $SRCtag =~ s@([^\w\/\\]|^)\./([^\s\/\@\=])@$1$SCRIPT_SUB/$2@gis;
4024 # Expand script filenames "~/Script"
4025 $SRCtag =~ s@([^\w\/\\]|^)\~/([^\s\/\@\=])@$1$HOME_SUB/$2@gis;
4028 # File source tags
4029 while($SRCtag =~ /\S/is)
4031 my $SRCdirective = "";
4033 # Pseudo file, just a switch to go from PREFIXING to POSTFIXING
4034 # SRC files
4035 if($SRCtag =~ /^[\s\;\,]*(POSTFIX|PREFIX)([^$FileAllowedChars]|$)/is)
4037 my $InsertionPlace = $1;
4038 $SRCtag = $2.$';
4040 $Prefix = $InsertionPlace =~ /POSTFIX/i ? 0 : 1;
4041 # Go to next round
4042 next;
4044 # {}-blocks are just evaluated by "do"
4045 elsif($SRCtag =~ /^[\s\;\,]*\{/is)
4047 my $SRCblock = $';
4048 if($SRCblock =~ /\}[\s\;\,]*([^\}]*)$/is)
4050 $SRCblock = $`;
4051 $SRCtag = $1.$';
4052 # SAFEqx shell script blocks
4053 if($CurrentContentType =~ /$ShellScriptContentType/is)
4055 # Handle ''-quotes inside the script
4056 $SRCblock =~ s/[\']/\\$&/gis;
4058 $SRCblock = "print do { SAFEqx(\'".$SRCblock."\'); };'';";
4059 $SRCdirective .= $SRCblock."\n";
4061 # do { SRCblocks }
4062 elsif($CurrentContentType =~ /$ServerScriptContentType/is)
4064 $SRCblock = "print do { $SRCblock };'';";
4065 $SRCdirective .= $SRCblock."\n";
4067 else # The interpreter should handle this
4069 push(@SRClist, "{ $SRCblock }");
4073 else
4074 { dieHandler(23, "Closing \} missing\n");};
4076 # Files are processed as Text or Executable files
4077 elsif($SRCtag =~ /[\s\;\,]*([$FileAllowedChars]+)[\;\,\s]*/is)
4079 my $SrcFile = $1;
4080 $SRCtag = $';
4082 # We are handling one of the external interpreters
4083 if($ScriptingLanguages{$CurrentContentType})
4085 push(@SRClist, $SrcFile);
4087 # We are at the start of a DIV tag, just load all SRC files and/or URL's
4088 elsif($TagType eq 'DIV' || $TagType eq 'INS') # All files are prepended in DIV's
4090 # $SrcFile is a URL pointing to an HTTP or FTP server
4091 if($SrcFile =~ m!^([a-z]+)\://!)
4093 my $URLoutput = CGIscriptor::read_url($SrcFile);
4094 $SRCdirective .= $URLoutput;
4096 # SRC file is an existing file
4097 elsif(-e "$SrcFile")
4099 open(DIVSOURCE, "<$SrcFile") || dieHandler(24, "<$SrcFile: $!\n");
4100 my $Content;
4101 while(sysread(DIVSOURCE, $Content, 1024) > 0)
4103 $SRCdirective .= $Content;
4105 close(DIVSOURCE);
4108 # Executable files are executed as
4109 # `$SrcFile 'ARGV[0]' 'ARGV[1]'`
4110 elsif(-x "$SrcFile")
4112 $SRCdirective .= "print \`$SrcFile @METAvalues\`;'';\n";
4114 # Handle 'standard' files, using ProcessFile
4115 elsif((-T "$SrcFile" || $ENV{$CGI_FILE_CONTENTS})
4116 && $SrcFile =~ m@($FilePattern)$@) # A recursion
4119 # Do not process still open files because it can lead
4120 # to endless recursions
4121 if(grep(/^$SrcFile$/, @OpenFiles))
4122 { dieHandler(25, "$SrcFile allready opened (endless recursion)\n")};
4123 # Prepare meta arguments
4124 $SRCdirective .= '@ARGV = (' .$METAarguments.");\n" if $METAarguments;
4125 # Process the file
4126 $SRCdirective .= "main::ProcessFile(\'$SrcFile\');'';\n";
4128 elsif($SrcFile =~ m!^([a-z]+)\://!) # URL's are loaded and printed
4130 $SRCdirective .= GET_URL($SrcFile);
4132 elsif(-T "$SrcFile") # Textfiles are "do"-ed (Perl execution)
4134 $SRCdirective .= '@ARGV = (' .$METAarguments.");\n" if $METAarguments;
4135 $SRCdirective .= "do \'$SrcFile\';'';\n";
4137 else # This one could not be resolved (should be handled by BinaryMapFile)
4139 $SRCdirective .= 'print "'.$SrcFile.' cannot be used"'."\n";
4144 # Postfix or Prefix
4145 if($Prefix)
4147 $PrefixDirective .= $SRCdirective;
4149 else
4151 $PostfixDirective .= $SRCdirective;
4154 # The prefix should be handled immediately
4155 $directive .= $PrefixDirective;
4156 $PrefixDirective = "";
4160 # Handle the content of the <SCRIPT></SCRIPT> tags
4161 # Do not process the content of <SCRIPT/>
4162 if($TagType =~ /SCRIPT/is && !$ClosedTag) # The <SCRIPT> TAG
4164 my $EndScriptTag = "";
4166 # Execute SHELL scripts with SAFEqx()
4167 if($CurrentContentType =~ /$ShellScriptContentType/is)
4169 $directive .= "SAFEqx(\'";
4172 # Extract Program
4173 while($After !~ /\<\s*\/SCRIPT[^\>]*\>/is && !eof($FileHandle))
4175 $After .= <$FileHandle>;
4176 performTranslation(\$After) if $TranslationPaths;
4179 if($After =~ /\<\s*\/SCRIPT[^\>]*\>/is)
4181 $directive .= $`;
4182 $EndScriptTag = $&;
4183 $After = $';
4185 else
4187 dieHandler(26, "Missing </SCRIPT> end tag in $ENV{'PATH_INFO'}\n");
4190 # Process only when content should be executed
4191 if($CurrentContentType)
4194 # Remove all comments from Perl scripts
4195 # (NOT from OS shell scripts)
4196 $directive =~ s/[^\\\$]\#[^\n\f\r]*([\n\f\r])/$1/g
4197 if $CurrentContentType =~ /$ServerScriptContentType/i;
4199 # Convert SCRIPT calls, ./<script>
4200 $directive =~ s@([\W]|^)\./([\S])@$1$SCRIPT_SUB$2@g;
4202 # Convert FILE calls, ~/<file>
4203 $directive =~ s@([\W])\~/([\S])@$1$HOME_SUB$2@g;
4205 # Execute SHELL scripts with SAFEqx(), closing bracket
4206 if($CurrentContentType =~ /$ShellScriptContentType/i)
4208 # Handle ''-quotes inside the script
4209 $directive =~ /SAFEqx\(\'/;
4210 $directive = $`.$&;
4211 my $Executable = $';
4212 $Executable =~ s/[\']/\\$&/gs;
4214 $directive .= $Executable."\');"; # Closing bracket
4217 else
4219 $directive = "";
4222 # Handle the content of the <DIV></DIV> tags
4223 # Do not process the content of <DIV/>
4224 elsif(($TagType eq 'DIV' || $TagType eq 'INS') && !$ClosedTag) # The <DIV> TAGs
4226 my $EndScriptTag = "";
4228 # Extract Text
4229 while($After !~ /\<\s*\/$TagType[^\>]*\>/is && !eof($FileHandle))
4231 $After .= <$FileHandle>;
4232 performTranslation(\$After) if $TranslationPaths;
4235 if($After =~ /\<\s*\/$TagType[^\>]*\>/is)
4237 $directive .= $`;
4238 $EndScriptTag = $&;
4239 $After = $';
4241 else
4243 dieHandler(27, "Missing </$TagType> end tag in $ENV{'PATH_INFO'}\n");
4246 # Add the Postfixed directives (but only when it contains something printable)
4247 $directive .= "\n".$PostfixDirective if $PostfixDirective =~ /\S/;
4248 $PostfixDirective = "";
4251 # Process only when content should be handled
4252 if($CurrentContentType)
4255 # Get the name (ID), and clean it (i.e., remove anything that is NOT part of
4256 # a valid Perl name). Names should not contain $, but we can handle it.
4257 my $name = $ScriptTagAttributes{'ID'};
4258 $name =~ /^\s*[\$\@\%]?([\w\-]+)/;
4259 $name = $1;
4261 # Assign DIV contents to $NAME value OUTSIDE the CGI values!
4262 CGIexecute::defineCGIexecuteVariable($name, $directive);
4263 $directive = "";
4266 # Nothing to execute
4267 $directive = "";
4271 # Handle Foreign scripting languages
4272 if($ScriptingLanguages{$CurrentContentType})
4274 my $newDirective = "";
4275 $newDirective .= OpenForeignScript($CurrentContentType); # Only if not already done
4276 $newDirective .= PrefixForeignScript($CurrentContentType);
4277 $newDirective .= InsertForeignScript($CurrentContentType, $directive, @SRClist);
4278 $newDirective .= PostfixForeignScript($CurrentContentType);
4279 $newDirective .= CloseForeignScript($CurrentContentType); # This shouldn't be necessary
4281 $newDirective .= '"";';
4283 $directive = $newDirective;
4287 # Add the Postfixed directives (but only when it contains something printable)
4288 $directive .= "\n".$PostfixDirective if $PostfixDirective =~ /\S/;
4289 $PostfixDirective = "";
4292 # EXECUTE the script and print the results
4294 # Use this to debug the program
4295 # print STDERR "Directive $CGI_Date: \n", $directive, "\n\n";
4297 my $Result = CGIexecute->evaluate($directive) if $directive; # Evaluate as PERL code
4298 $Result =~ s/\n$//g; # Remove final newline
4300 # Print the Result of evaluating the directive
4301 # (this will handle LARGE, >64 kB output)
4302 my $BytesWritten = 1;
4303 while($Result && $BytesWritten)
4305 $BytesWritten = syswrite(STDOUT, $Result, 64);
4306 $Result = substr($Result, $BytesWritten);
4308 # print $Result; # Could be used instead of above code
4310 # Store result if wanted, i.e., if $CGIscriptorResults has been
4311 # defined in a <META> tag.
4312 push(@CGIexecute::CGIscriptorResults, $Result)
4313 if exists($default_values{'CGIscriptorResults'});
4315 # Process the rest of the input line (this could contain
4316 # another directive)
4317 $_ = $After;
4319 print $_;
4320 } while(<$FileHandle>); # Read and Test AFTER first loop!
4322 close ($FileHandle);
4323 dieHandler(28, "Error in recursion\n") unless pop(@OpenFiles) == $file_path;
4327 ###############################################################################
4329 # Call the whole package
4331 sub Handle_Request
4333 my $file_path = "";
4335 # Initialization Code
4336 Initialize_Request();
4338 # SECURITY: ACCESS CONTROL
4339 Access_Control();
4341 # Read the POST part of the query, if there is one
4342 Get_POST_part_of_query();
4344 # Start (HTML) output and logging
4345 $file_path = Initialize_output();
4347 # Check login access or divert to login procedure
4348 $Use_Login = Log_In_Access();
4349 $file_path = $Use_Login if $Use_Login;
4351 # Record which files are still open (to avoid endless recursions)
4352 my @OpenFiles = ();
4354 # Record whether the default HTML ContentType has already been printed
4355 # but only if the SERVER uses HTTP or some other protocol that might interpret
4356 # a content MIME type.
4358 $SupressContentType = !("$ENV{'SERVER_PROTOCOL'}" =~ /($ContentTypeServerProtocols)/i);
4360 # Process the specified file
4361 ProcessFile($file_path) if $file_path ne $SS_PUB;
4363 # Cleanup all open external (foreign) interpreters
4364 CloseAllForeignScripts();
4367 "" # SUCCESS
4370 # Make a single call to handle an (empty) request
4371 Handle_Request();
4374 # END OF PACKAGE MAIN
4377 ####################################################################################
4379 # The CGIEXECUTE PACKAGE
4381 ####################################################################################
4383 # Isolate the evaluation of directives as PERL code from the rest of the program.
4384 # Remember that each package has its own name space.
4385 # Note that only the FIRST argument of execute->evaluate is actually evaluated,
4386 # all other arguments are accessible inside the first argument as $_[0] to $_[$#_].
4388 package CGIexecute;
4390 sub evaluate
4392 my $self = shift;
4393 my $directive = shift;
4394 $directive = eval($directive);
4395 warn $@ if $@; # Write an error message to STDERR
4396 $directive; # Return value of directive
4400 # defineCGIexecuteVariable($name [, $value]) -> 0/1
4402 # Define and intialize variables inside CGIexecute
4403 # Does no sanity checking, for internal use only
4405 sub defineCGIexecuteVariable # ($name [, $value]) -> 0/1
4407 my $name = shift || return 0; # The Name
4408 my $value = shift || ""; # The value
4410 ${$name} = $value;
4412 return 1;
4415 # defineCGIvariable($name [, $default]) -> 0/1
4417 # Define and intialize CGI variables
4418 # Tries (in order) $ENV{$name}, the Query string and the
4419 # default value.
4420 # Removes all '-quotes etc.
4422 sub defineCGIvariable # ($name [, $default]) -> 0/1
4424 my $name = shift || return 0; # The Name
4425 my $default = shift || ""; # The default value
4427 # Remove \-quoted characters
4428 $default =~ s/\\(.)/$1/g;
4429 # Store default values
4430 $::default_values{$name} = $default if $default;
4432 # Process variables
4433 my $temp = undef;
4434 # If there is a user supplied value, it replaces the
4435 # default value.
4437 # Environment values have precedence
4438 if(exists($ENV{$name}))
4440 $temp = $ENV{$name};
4442 # Get name and its value from the query string
4443 elsif($ENV{QUERY_STRING} =~ /$name/) # $name is in the query string
4445 $temp = ::YOUR_CGIPARSE($name);
4447 # Defined values must exist for security
4448 elsif(!exists($::default_values{$name}))
4450 $::default_values{$name} = undef;
4453 # SECURITY, do not allow '- and `-quotes in
4454 # client values.
4455 # Remove all existing '-quotes
4456 $temp =~ s/([\r\f]+\n)/\n/g; # Only \n is allowed
4457 $temp =~ s/[\']/&#8217;/igs; # Remove all single quotes
4458 $temp =~ s/[\`]/&#8216;/igs; # Remove all backtick quotes
4459 # If $temp is empty, use the default value (if it exists)
4460 unless($temp =~ /\S/ || length($temp) > 0) # I.e., $temp is empty
4462 $temp = $::default_values{$name};
4463 # Remove all existing '-quotes
4464 $temp =~ s/([\r\f]+\n)/\n/g; # Only \n is allowed
4465 $temp =~ s/[\']/&#8217;/igs; # Remove all single quotes
4466 $temp =~ s/[\`]/&#8216;/igs; # Remove all backtick quotes
4468 else # Store current CGI values and remove defaults
4470 $::default_values{$name} = $temp;
4472 # Define the CGI variable and its value (in the execute package)
4473 ${$name} = $temp;
4475 # return SUCCES
4476 return 1;
4479 sub defineCGIvariableList # ($name [, $default]) -> 0/1)
4481 my $name = shift || return 0; # The Name
4482 my $default = shift || ""; # The default value
4484 # Defined values must exist for security
4485 if(!exists($::default_values{$name}))
4487 $::default_values{$name} = $default;
4490 my @temp = ();
4493 # For security:
4494 # Environment values have precedence
4495 if(exists($ENV{$name}))
4497 push(@temp, $ENV{$name});
4499 # Get name and its values from the query string
4500 if($ENV{QUERY_STRING} =~ /$name/) # $name is in the query string
4502 push(@temp, ::YOUR_CGIPARSE($name, 1)); # Extract LIST
4504 else
4506 push(@temp, $::default_values{$name});
4510 # SECURITY, do not allow '- and `-quotes in
4511 # client values.
4512 # Remove all existing '-quotes
4513 @temp = map {s/([\r\f]+\n)/\n/g; $_} @temp; # Only \n is allowed
4514 @temp = map {s/[\']/&#8217;/igs; $_} @temp; # Remove all single quotes
4515 @temp = map {s/[\`]/&#8216;/igs; $_} @temp; # Remove all backtick quotes
4517 # Store current CGI values and remove defaults
4518 $::default_values{$name} = $temp[0];
4520 # Define the CGI variable and its value (in the execute package)
4521 @{$name} = @temp;
4523 # return SUCCES
4524 return 1;
4527 sub defineCGIvariableHash # ($name [, $default]) -> 0/1) Note: '$name{""} = $default';
4529 my $name = shift || return 0; # The Name
4530 my $default = shift || ""; # The default value
4532 # Defined values must exist for security
4533 if(!exists($::default_values{$name}))
4535 $::default_values{$name} = $default;
4538 my %temp = ();
4541 # For security:
4542 # Environment values have precedence
4543 if(exists($ENV{$name}))
4545 $temp{""} = $ENV{$name};
4547 # Get name and its values from the query string
4548 if($ENV{QUERY_STRING} =~ /$name/) # $name is in the query string
4550 %temp = ::YOUR_CGIPARSE($name, -1); # Extract HASH table
4552 elsif($::default_values{$name} ne "")
4554 $temp{""} = $::default_values{$name};
4558 # SECURITY, do not allow '- and `-quotes in
4559 # client values.
4560 # Remove all existing '-quotes
4561 my $Key;
4562 foreach $Key (keys(%temp))
4564 $temp{$Key} =~ s/([\r\f]+\n)/\n/g; # Only \n is allowed
4565 $temp{$Key} =~ s/[\']/&#8217;/igs; # Remove all single quotes
4566 $temp{$Key} =~ s/[\`]/&#8216;/igs; # Remove all backtick quotes
4569 # Store current CGI values and remove defaults
4570 $::default_values{$name} = $temp{""};
4572 # Define the CGI variable and its value (in the execute package)
4573 %{$name} = ();
4574 my $tempKey;
4575 foreach $tempKey (keys(%temp))
4577 ${$name}{$tempKey} = $temp{$tempKey};
4580 # return SUCCES
4581 return 1;
4585 # SAFEqx('CommandString')
4587 # A special function that is a safe alternative to backtick quotes (and qx//)
4588 # with client-supplied CGI values. All CGI variables are surrounded by
4589 # single ''-quotes (except between existing \'\'-quotes, don't try to be
4590 # too smart). All variables are then interpolated. Simple (@) lists are
4591 # expanded with join(' ', @List), and simple (%) hash tables expanded
4592 # as a list of "key=value" pairs. Complex variables, e.g., @$var, are
4593 # evaluated in a scalar context (e.g., as scalar(@$var)). All occurrences of
4594 # $@% that should NOT be interpolated must be preceeded by a "\".
4595 # If the first line of the String starts with "#! interpreter", the
4596 # remainder of the string is piped into interpreter (after interpolation), i.e.,
4597 # open(INTERPRETER, "|interpreter");print INTERPRETER remainder;
4598 # just like in UNIX. There are some problems with quotes. Be carefull in
4599 # using them. You do not have access to the output of any piped (#!)
4600 # process! If you want such access, execute
4601 # <SCRIPT TYPE="text/osshell">echo "script"|interpreter</SCRIPT> or
4602 # <SCRIPT TYPE="text/ssperl">$resultvar = SAFEqx('echo "script"|interpreter');
4603 # </SCRIPT>.
4605 # SAFEqx ONLY WORKS WHEN THE STRING ITSELF IS SURROUNDED BY SINGLE QUOTES
4606 # (SO THAT IT IS NOT INTERPOLATED BEFORE IT CAN BE PROTECTED)
4607 sub SAFEqx # ('String') -> result of executing qx/"String"/
4609 my $CommandString = shift;
4610 my $NewCommandString = "";
4612 # Only interpolate when required (check the On/Off switch)
4613 unless($CGIscriptor::NoShellScriptInterpolation)
4616 # Handle existing single quotes around CGI values
4617 while($CommandString =~ /\'[^\']+\'/s)
4619 my $CurrentQuotedString = $&;
4620 $NewCommandString .= $`;
4621 $CommandString = $'; # The remaining string
4622 # Interpolate CGI variables between quotes
4623 # (e.g., '$CGIscriptorResults[-1]')
4624 $CurrentQuotedString =~
4625 s/(^|[^\\])([\$\@])((\w*)([\{\[][\$\@\%]?[\:\w\-]+[\}\]])*)/if(exists($main::default_values{$4})){
4626 "$1".eval("$2$3")}else{"$&"}/egs;
4628 # Combine result with previous result
4629 $NewCommandString .= $CurrentQuotedString;
4631 $CommandString = $NewCommandString.$CommandString;
4633 # Select known CGI variables and surround them with single quotes,
4634 # then interpolate all variables
4635 $CommandString =~
4636 s/(^|[^\\])([\$\@\%]+)((\w*)([\{\[][\w\:\$\"\-]+[\}\]])*)/
4637 if($2 eq '$' && exists($main::default_values{$4}))
4638 {"$1\'".eval("\$$3")."\'";}
4639 elsif($2 eq '@'){$1.join(' ', @{"$3"});}
4640 elsif($2 eq '%'){my $t=$1;map {$t.=" $_=".${"$3"}{$_}}
4641 keys(%{"$3"});$t}
4642 else{$1.eval("${2}$3");
4643 }/egs;
4645 # Remove backslashed [$@%]
4646 $CommandString =~ s/\\([\$\@\%])/$1/gs;
4649 # Debugging
4650 # return $CommandString;
4652 # Handle UNIX style "#! shell command\n" constructs as
4653 # a pipe into the shell command. The output cannot be tapped.
4654 my $ReturnValue = "";
4655 if($CommandString =~ /^\s*\#\!([^\f\n\r]+)[\f\n\r]/is)
4657 my $ShellScripts = $';
4658 my $ShellCommand = $1;
4659 open(INTERPRETER, "|$ShellCommand") || dieHandler(29, "\'$ShellCommand\' PIPE not opened: &!\n");
4660 select(INTERPRETER);$| = 1;
4661 print INTERPRETER $ShellScripts;
4662 close(INTERPRETER);
4663 select(STDOUT);$| = 1;
4665 # Shell scripts which are redirected to an existing named pipe.
4666 # The output cannot be tapped.
4667 elsif($CGIscriptor::ShellScriptPIPE)
4669 CGIscriptor::printSAFEqxPIPE($CommandString);
4671 else # Plain ``-backtick execution
4673 # Execute the commands
4674 $ReturnValue = qx/$CommandString/;
4676 return $ReturnValue;
4679 ####################################################################################
4681 # The CGIscriptor PACKAGE
4683 ####################################################################################
4685 # Isolate the evaluation of CGIscriptor functions, i.e., those prefixed with
4686 # "CGIscriptor::"
4688 package CGIscriptor;
4691 # The Interpolation On/Off switch
4692 my $NoShellScriptInterpolation = undef;
4693 # The ShellScript redirection pipe
4694 my $ShellScriptPIPE = undef;
4696 # Open a named PIPE for SAFEqx to receive ALL shell scripts
4697 sub RedirectShellScript # ('CommandString')
4699 my $CommandString = shift || undef;
4701 if($CommandString)
4703 $ShellScriptPIPE = "ShellScriptNamedPipe";
4704 open($ShellScriptPIPE, "|$CommandString")
4705 || main::dieHandler(30, "\'|$CommandString\' PIPE open failed: $!\n");
4707 else
4709 close($ShellScriptPIPE);
4710 $ShellScriptPIPE = undef;
4712 return $ShellScriptPIPE;
4715 # Print to redirected shell script pipe
4716 sub printSAFEqxPIPE # ("String") -> print return value
4718 my $String = shift || undef;
4720 select($ShellScriptPIPE); $| = 1;
4721 my $returnvalue = print $ShellScriptPIPE ($String);
4722 select(STDOUT); $| = 1;
4724 return $returnvalue;
4727 # a pointer to CGIexecute::SAFEqx
4728 sub SAFEqx # ('String') -> result of qx/"String"/
4730 my $CommandString = shift;
4731 return CGIexecute::SAFEqx($CommandString);
4735 # a pointer to CGIexecute::defineCGIvariable
4736 sub defineCGIvariable # ($name[, $default]) ->0/1
4738 my $name = shift;
4739 my $default = shift;
4740 return CGIexecute::defineCGIvariable($name, $default);
4744 # Decode URL encoded arguments
4745 sub URLdecode # (URL encoded input) -> string
4747 my $output = "";
4748 my $char;
4749 my $Value;
4750 foreach $Value (@_)
4752 my $EncodedValue = $Value; # Do not change the loop variable
4753 # Convert all "+" to " "
4754 $EncodedValue =~ s/\+/ /g;
4755 # Convert all hexadecimal codes (%FF) to their byte values
4756 while($EncodedValue =~ /\%([0-9A-F]{2})/i)
4758 $output .= $`.chr(hex($1));
4759 $EncodedValue = $';
4761 $output .= $EncodedValue; # The remaining part of $Value
4763 $output;
4766 # Encode arguments as URL codes.
4767 sub URLencode # (input) -> URL encoded string
4769 my $output = "";
4770 my $char;
4771 my $Value;
4772 foreach $Value (@_)
4774 my @CharList = split('', $Value);
4775 foreach $char (@CharList)
4777 if($char =~ /\s/)
4778 { $output .= "+";}
4779 elsif($char =~ /\w\-/)
4780 { $output .= $char;}
4781 else
4783 $output .= uc(sprintf("%%%2.2x", ord($char)));
4787 $output;
4790 # Extract the value of a CGI variable from the URL-encoded $string
4791 # Also extracts the data blocks from a multipart request. Does NOT
4792 # decode the multipart blocks
4793 sub CGIparseValue # (ValueName [, URL_encoded_QueryString [, \$QueryReturnReference]]) -> Decoded value
4795 my $ValueName = shift;
4796 my $QueryString = shift || $main::ENV{'QUERY_STRING'};
4797 my $ReturnReference = shift || undef;
4798 my $output = "";
4800 if($QueryString =~ /(^|\&)$ValueName\=([^\&]*)(\&|$)/)
4802 $output = URLdecode($2);
4803 $$ReturnReference = $' if ref($ReturnReference);
4805 # Get multipart POST or PUT methods
4806 elsif($main::ENV{'CONTENT_TYPE'} =~ m@(multipart/([\w\-]+)\;\s+boundary\=([\S]+))@i)
4808 my $MultipartType = $2;
4809 my $BoundaryString = $3;
4810 # Remove the boundary-string
4811 my $temp = $QueryString;
4812 $temp =~ /^\Q--$BoundaryString\E/m;
4813 $temp = $';
4815 # Identify the newline character(s), this is the first character in $temp
4816 my $NewLine = "\r\n"; # Actually, this IS the correct one
4817 unless($temp =~ /^(\-\-|\r\n)/) # However, you never realy can be sure
4819 # Is this correct??? I have to check.
4820 $NewLine = "\r\n" if $temp =~ /^(\r\n)/; # Double (CRLF, the correct one)
4821 $NewLine = "\n\r" if $temp =~ /^(\n\r)/; # Double
4822 $NewLine = "\n" if $temp =~ /^([\n])/; # Single Line Feed
4823 $NewLine = "\r" if $temp =~ /^([\r])/; # Single Return
4826 # search through all data blocks
4827 while($temp =~ /^\Q--$BoundaryString\E/m)
4829 my $DataBlock = $`;
4830 $temp = $';
4831 # Get the empty line after the header
4832 $DataBlock =~ /$NewLine$NewLine/;
4833 $Header = $`;
4834 $output = $';
4835 my $Header = $`;
4836 $output = $';
4838 # Remove newlines from the header
4839 $Header =~ s/$NewLine/ /g;
4841 # Look whether this block is the one you are looking for
4842 # Require the quotes!
4843 if($Header =~ /name\s*=\s*[\"\']$ValueName[\"\']/m)
4845 my $i;
4846 for($i=length($NewLine); $i; --$i)
4848 chop($output);
4850 # OK, get out
4851 last;
4853 # reinitialize the output
4854 $output = "";
4856 $$ReturnReference = $temp if ref($ReturnReference);
4858 elsif($QueryString !~ /(^|\&)$ValueName\=/) # The value simply isn't there
4860 return undef;
4861 $$ReturnReference = undef if ref($ReturnReference);
4863 else
4865 print "ERROR: $ValueName $main::ENV{'CONTENT_TYPE'}\n";
4867 return $output;
4871 # Get a list of values for the same ValueName. Uses CGIparseValue
4873 sub CGIparseValueList # (ValueName [, URL_encoded_QueryString]) -> List of decoded values
4875 my $ValueName = shift;
4876 my $QueryString = shift || $main::ENV{'QUERY_STRING'};
4877 my @output = ();
4878 my $RestQueryString;
4879 my $Value;
4880 while($QueryString &&
4881 (($Value = CGIparseValue($ValueName, $QueryString, \$RestQueryString))
4882 || defined($Value)))
4884 push(@output, $Value);
4885 $QueryString = $RestQueryString; # QueryString is consumed!
4887 # ready, return list with values
4888 return @output;
4891 sub CGIparseValueHash # (ValueName [, URL_encoded_QueryString]) -> Hash table of decoded values
4893 my $ValueName = shift;
4894 my $QueryString = shift || $main::ENV{'QUERY_STRING'};
4895 my $RestQueryString;
4896 my %output = ();
4897 while($QueryString && $QueryString =~ /(^|\&)$ValueName([\w]*)\=/)
4899 my $Key = $2;
4900 my $Value = CGIparseValue("$ValueName$Key", $QueryString, \$RestQueryString);
4901 $output{$Key} = $Value;
4902 $QueryString = $RestQueryString; # QueryString is consumed!
4904 # ready, return list with values
4905 return %output;
4908 sub CGIparseForm # ([URL_encoded_QueryString]) -> Decoded Form (NO multipart)
4910 my $QueryString = shift || $main::ENV{'QUERY_STRING'};
4911 my $output = "";
4913 $QueryString =~ s/\&/\n/g;
4914 $output = URLdecode($QueryString);
4916 $output;
4919 # Extract the header of a multipart CGI variable from the POST input
4920 sub CGIparseHeader # (ValueName [, URL_encoded_QueryString]) -> Decoded value
4922 my $ValueName = shift;
4923 my $QueryString = shift || $main::ENV{'QUERY_STRING'};
4924 my $output = "";
4926 if($main::ENV{'CONTENT_TYPE'} =~ m@(multipart/([\w\-]+)\;\s+boundary\=([\S]+))@i)
4928 my $MultipartType = $2;
4929 my $BoundaryString = $3;
4930 # Remove the boundary-string
4931 my $temp = $QueryString;
4932 $temp =~ /^\Q--$BoundaryString\E/m;
4933 $temp = $';
4935 # Identify the newline character(s), this is the first character in $temp
4936 my $NewLine = "\r\n"; # Actually, this IS the correct one
4937 unless($temp =~ /^(\-\-|\r\n)/) # However, you never realy can be sure
4939 $NewLine = "\n" if $temp =~ /^([\n])/; # Single Line Feed
4940 $NewLine = "\r" if $temp =~ /^([\r])/; # Single Return
4941 $NewLine = "\r\n" if $temp =~ /^(\r\n)/; # Double (CRLF, the correct one)
4942 $NewLine = "\n\r" if $temp =~ /^(\n\r)/; # Double
4945 # search through all data blocks
4946 while($temp =~ /^\Q--$BoundaryString\E/m)
4948 my $DataBlock = $`;
4949 $temp = $';
4950 # Get the empty line after the header
4951 $DataBlock =~ /$NewLine$NewLine/;
4952 $Header = $`;
4953 my $Header = $`;
4955 # Remove newlines from the header
4956 $Header =~ s/$NewLine/ /g;
4958 # Look whether this block is the one you are looking for
4959 # Require the quotes!
4960 if($Header =~ /name\s*=\s*[\"\']$ValueName[\"\']/m)
4962 $output = $Header;
4963 last;
4965 # reinitialize the output
4966 $output = "";
4969 return $output;
4973 # Checking variables for security (e.g., file names and email addresses)
4974 # File names are tested against the $::FileAllowedChars and $::BlockPathAccess variables
4975 sub CGIsafeFileName # FileName -> FileName or ""
4977 my $FileName = shift || "";
4978 return "" if $FileName =~ m?[^$::FileAllowedChars]?;
4979 return "" if $FileName =~ m!(^|/|\:)[\-\.]!;
4980 return "" if $FileName =~ m@\.\.\Q$::DirectorySeparator\E@; # Higher directory not allowed
4981 return "" if $FileName =~ m@\Q$::DirectorySeparator\E\.\.@; # Higher directory not allowed
4982 return "" if $::BlockPathAccess && $FileName =~ m@$::BlockPathAccess@; # Invisible (blocked) file
4984 return $FileName;
4987 sub CGIsafeEmailAddress # email -> email or ""
4989 my $Email = shift || "";
4990 return "" unless $Email =~ m/^[\w\.\-]+[\@][\w\.\-\:]+$/;
4991 return $Email;
4994 # Get a URL from the web. Needs main::GET_URL($URL) function
4995 # (i.e., curl, snarf, or wget)
4996 sub read_url # ($URL) -> page/file
4998 my $URL = shift || return "";
5000 # Get the commands to read the URL, do NOT add a print command
5001 my $URL_command = main::GET_URL($URL, 1);
5002 # execute the commands, i.e., actually read it
5003 my $URLcontent = CGIexecute->evaluate($URL_command);
5005 # Ready, return the content.
5006 return $URLcontent;
5009 ################################################>>>>>>>>>>Start Remove
5011 # BrowseAllDirs(Directory, indexfile)
5013 # usage:
5014 # <SCRIPT TYPE='text/ssperl'>
5015 # CGIscriptor::BrowseAllDirs('Sounds', 'index.html', '\.wav$')
5016 # </SCRIPT>
5018 # Allows to browse all directories. Stops at '/'. If the directory contains
5019 # an indexfile, eg, index.html, that file will be used instead. Files must match
5020 # the $Pattern, if it is given. Default is
5021 # CGIscriptor::BrowseAllDirs('/', 'index.html', '')
5023 sub BrowseAllDirs # (Directory, indexfile, $Pattern) -> Print HTML code
5025 my $Directory = shift || '/';
5026 my $indexfile = shift || 'index.html';
5027 my $Pattern = shift || '';
5028 $Directory =~ s!/$!!g;
5030 # If the index directory exists, use that one
5031 if(-s "$::CGI_HOME$Directory/$indexfile")
5033 return main::ProcessFile("$::CGI_HOME$Directory/$indexfile");
5036 # No indexfile, continue
5037 my @DirectoryList = glob("$::CGI_HOME$Directory");
5038 $CurrentDirectory = shift(@DirectoryList);
5039 $CurrentDirectory = $' if $CurrentDirectory =~ m@(/\.\./)+@;
5040 $CurrentDirectory =~ s@^$::CGI_HOME@@g;
5041 print "<h1>";
5042 print "$CurrentDirectory" if $CurrentDirectory;
5043 print "</h1>\n";
5045 opendir(BROWSE, "$::CGI_HOME$Directory") || main::dieHandler(31, "$::CGI_HOME$Directory $!");
5046 my @AllFiles = sort grep(!/^([\.]+[^\.]|\~)/, readdir(BROWSE));
5048 # Print directories
5049 my $file;
5050 print "<pre><ul TYPE='NONE'>\n";
5051 foreach $file (@AllFiles)
5053 next unless -d "$::CGI_HOME$Directory/$file";
5054 # Check whether this file should be visible
5055 next if $::BlockPathAccess &&
5056 "$Directory/$file/" =~ m@$::BlockPathAccess@;
5057 print "<dt><a href='$Directory/$file'>$file</a></dt>\n";
5059 print "</ul></pre>\n";
5061 # Print files
5062 print "<pre><ul TYPE='CIRCLE'>\n";
5063 my $TotalSize = 0;
5064 foreach $file (@AllFiles)
5066 next if $file =~ /^\./;
5067 next if -d "$::CGI_HOME$Directory/$file";
5068 next if -l "$::CGI_HOME$Directory/$file";
5069 # Check whether this file should be visible
5070 next if $::BlockPathAccess &&
5071 "$Directory/$file" =~ m@$::BlockPathAccess@;
5073 if(!$Pattern || $file =~ m@$Pattern@)
5075 my $Date = localtime($^T - (-M "$::CGI_HOME$Directory/$file")*3600*24);
5076 my $Size = -s "$::CGI_HOME$Directory/$file";
5077 $Size = sprintf("%6.0F kB", $Size/1024);
5078 my $Type = `file $::CGI_HOME$Directory/$file`;
5079 $Type =~ s@\s*$::CGI_HOME$Directory/$file\s*\:\s*@@ig;
5080 chomp($Type);
5082 print "<li>";
5083 print "<a href='$Directory/$file'>";
5084 printf("%-40s", "$file</a>");
5085 print "\t$Size\t$Date\t$Type";
5086 print "</li>\n";
5089 print "</ul></pre>";
5091 return 1;
5095 ################################################
5097 # BrowseDirs(RootDirectory [, Pattern, Start])
5099 # usage:
5100 # <SCRIPT TYPE='text/ssperl'>
5101 # CGIscriptor::BrowseDirs('Sounds', '\.aifc$', 'Speech', 'DIRECTORY')
5102 # </SCRIPT>
5104 # Allows to browse subdirectories. Start should be relative to the RootDirectory,
5105 # e.g., the full path of the directory 'Speech' is '~/Sounds/Speech'.
5106 # Only files which fit /$Pattern/ and directories are displayed.
5107 # Directories down or up the directory tree are supplied with a
5108 # GET request with the name of the CGI variable in the fourth argument (default
5109 # is 'BROWSEDIRS'). So the correct call for a subdirectory could be:
5110 # CGIscriptor::BrowseDirs('Sounds', '\.aifc$', $DIRECTORY, 'DIRECTORY')
5112 sub BrowseDirs # (RootDirectory [, Pattern, Start, CGIvariable, HTTPserver]) -> Print HTML code
5114 my $RootDirectory = shift; # || return 0;
5115 my $Pattern = shift || '\S';
5116 my $Start = shift || "";
5117 my $CGIvariable = shift || "BROWSEDIRS";
5118 my $HTTPserver = shift || '';
5120 $Start = CGIscriptor::URLdecode($Start); # Sometimes, too much has been encoded
5121 $Start =~ s@//+@/@g;
5122 $Start =~ s@[^/]+/\.\.@@ig;
5123 $Start =~ s@^\.\.@@ig;
5124 $Start =~ s@/\.$@@ig;
5125 $Start =~ s!/+$!!g;
5126 $Start .= "/" if $Start;
5128 my @Directory = glob("$::CGI_HOME/$RootDirectory/$Start");
5129 $CurrentDirectory = shift(@Directory);
5130 $CurrentDirectory = $' if $CurrentDirectory =~ m@(/\.\./)+@;
5131 $CurrentDirectory =~ s@^$::CGI_HOME@@g;
5132 print "<h1>";
5133 print "$CurrentDirectory" if $CurrentDirectory;
5134 print "</h1>\n";
5135 opendir(BROWSE, "$::CGI_HOME/$RootDirectory/$Start") || main::dieHandler(31, "$::CGI_HOME/$RootDirectory/$Start $!");
5136 my @AllFiles = sort grep(!/^([\.]+[^\.]|\~)/, readdir(BROWSE));
5138 # Print directories
5139 my $file;
5140 print "<pre><ul TYPE='NONE'>\n";
5141 foreach $file (@AllFiles)
5143 next unless -d "$::CGI_HOME/$RootDirectory/$Start$file";
5144 # Check whether this file should be visible
5145 next if $::BlockPathAccess &&
5146 "/$RootDirectory/$Start$file/" =~ m@$::BlockPathAccess@;
5148 my $NewURL = $Start ? "$Start$file" : $file;
5149 $NewURL = CGIscriptor::URLencode($NewURL);
5150 print "<dt><a href='";
5151 print "$ENV{SCRIPT_NAME}" if $ENV{SCRIPT_NAME} !~ m@[^\w+\-/]@;
5152 print "$ENV{PATH_INFO}?$CGIvariable=$NewURL'>$file</a></dt>\n";
5154 print "</ul></pre>\n";
5156 # Print files
5157 print "<pre><ul TYPE='CIRCLE'>\n";
5158 my $TotalSize = 0;
5159 foreach $file (@AllFiles)
5161 next if $file =~ /^\./;
5162 next if -d "$::CGI_HOME/$RootDirectory/$Start$file";
5163 next if -l "$::CGI_HOME/$RootDirectory/$Start$file";
5164 # Check whether this file should be visible
5165 next if $::BlockPathAccess &&
5166 "$::CGI_HOME/$RootDirectory/$Start$file" =~ m@$::BlockPathAccess@;
5168 if($file =~ m@$Pattern@)
5170 my $Date = localtime($^T - (-M "$::CGI_HOME/$RootDirectory/$Start$file")*3600*24);
5171 my $Size = -s "$::CGI_HOME/$RootDirectory/$Start$file";
5172 $Size = sprintf("%6.0F kB", $Size/1024);
5173 my $Type = `file $::CGI_HOME/$RootDirectory/$Start$file`;
5174 $Type =~ s@\s*$::CGI_HOME/$RootDirectory/$Start$file\s*\:\s*@@ig;
5175 chomp($Type);
5177 print "<li>";
5178 if($HTTPserver =~ /^\s*[\.\~]\s*$/)
5180 print "<a href='$RootDirectory/$Start$file'>";
5182 elsif($HTTPserver)
5184 print "<a href='$HTTPserver/$RootDirectory/$Start$file'>";
5186 printf("%-40s", "$file</a>") if $HTTPserver;
5187 printf("%-40s", "$file") unless $HTTPserver;
5188 print "\t$Size\t$Date\t$Type";
5189 print "</li>\n";
5192 print "</ul></pre>";
5194 return 1;
5198 # ListDocs(Pattern [,ListType])
5200 # usage:
5201 # <SCRIPT TYPE=text/ssperl>
5202 # CGIscriptor::ListDocs("/*", "dl");
5203 # </SCRIPT>
5205 # This subroutine is very usefull to manage collections of independent
5206 # documents. The resulting list will display the tree-like directory
5207 # structure. If this routine is too slow for online use, you can
5208 # store the result and use a link to that stored file.
5210 # List HTML and Text files with title and first header (HTML)
5211 # or filename and first meaningfull line (general text files).
5212 # The listing starts at the ServerRoot directory. Directories are
5213 # listed recursively.
5215 # You can change the list type (default is dl).
5216 # e.g.,
5217 # <dt><a href=<file.html>>title</a>
5218 # <dd>First Header
5219 # <dt><a href=<file.txt>>file.txt</a>
5220 # <dd>First meaningfull line of text
5222 sub ListDocs # ($Pattern [, prefix]) e.g., ("/Books/*", [, "dl"])
5224 my $Pattern = shift;
5225 $Pattern =~ /\*/;
5226 my $ListType = shift || "dl";
5227 my $Prefix = lc($ListType) eq "dl" ? "dt" : "li";
5228 my $URL_root = "http://$::ENV{'SERVER_NAME'}\:$::ENV{'SERVER_PORT'}";
5229 my @FileList = glob("$::CGI_HOME$Pattern");
5230 my ($FileName, $Path, $Link);
5232 # Print List markers
5233 print "<$ListType>\n";
5235 # Glob all files
5236 File: foreach $FileName (@FileList)
5238 # Check whether this file should be visible
5239 next if $::BlockPathAccess && $FileName =~ m@$::BlockPathAccess@;
5241 # Recursively list files in all directories
5242 if(-d $FileName)
5244 $FileName =~ m@([^/]*)$@;
5245 my $DirName = $1;
5246 print "<$Prefix>$DirName\n";
5247 $Pattern =~ m@([^/]*)$@;
5248 &ListDocs("$`$DirName/$1", $ListType);
5249 next;
5251 # Use textfiles
5252 elsif(-T "$FileName")
5254 open(TextFile, $FileName) || next;
5256 # Ignore all other file types
5257 else
5258 { next;};
5260 # Get file path for link
5261 $FileName =~ /$::CGI_HOME/;
5262 print "<$Prefix><a href=$URL_root$'>";
5263 # Initialize all variables
5264 my $Line = "";
5265 my $TitleFound = 0;
5266 my $Caption = "";
5267 my $Title = "";
5268 # Read file and step through
5269 while(<TextFile>)
5271 chop $_;
5272 $Line = $_;
5273 # HTML files
5274 if($FileName =~ /\.ht[a-zA-Z]*$/i)
5276 # Catch Title
5277 while(!$Title)
5279 if($Line =~ m@<title>([^<]*)</title>@i)
5281 $Title = $1;
5282 $Line = $';
5284 else
5286 $Line .= <TextFile> || goto Print;
5287 chop $Line;
5290 # Catch First Header
5291 while(!$Caption)
5293 if($Line =~ m@</h1>@i)
5295 $Caption = $`;
5296 $Line = $';
5297 $Caption =~ m@<h1>@i;
5298 $Caption = $';
5299 $Line = $`.$Caption.$Line;
5301 else
5303 $Line .= <TextFile> || goto Print;
5304 chop $Line;
5308 # Other text files
5309 else
5311 # Title equals file name
5312 $FileName =~ /([^\/]+)$/;
5313 $Title = $1;
5314 # Catch equals First Meaningfull line
5315 while(!$Caption)
5317 if($Line =~ /[A-Z]/ &&
5318 ($Line =~ /subject|title/i || $Line =~ /^[\w,\.\s\?\:]+$/)
5319 && $Line !~ /Newsgroup/ && $Line !~ /\:\s*$/)
5321 $Line =~ s/\<[^\>]+\>//g;
5322 $Caption = $Line;
5324 else
5326 $Line = <TextFile> || goto Print;
5330 Print: # Print title and subject
5331 print "$Title</a>\n";
5332 print "<dd>$Caption\n" if $ListType eq "dl";
5333 $TitleFound = 0;
5334 $Caption = "";
5335 close TextFile;
5336 next File;
5339 # Print Closing List Marker
5340 print "</$ListType>\n";
5341 ""; # Empty return value
5345 # HTMLdocTree(Pattern [,ListType])
5347 # usage:
5348 # <SCRIPT TYPE=text/ssperl>
5349 # CGIscriptor::HTMLdocTree("/Welcome.html", "dl");
5350 # </SCRIPT>
5352 # The following subroutine is very usefull for checking large document
5353 # trees. Starting from the root (s), it reads all files and prints out
5354 # a nested list of links to all attached files. Non-existing or misplaced
5355 # files are flagged. This is quite a file-i/o intensive routine
5356 # so you would not like it to be accessible to everyone. If you want to
5357 # use the result, save the whole resulting page to disk and use a link
5358 # to this file.
5360 # HTMLdocTree takes an HTML file or file pattern and constructs nested lists
5361 # with links to *local* files (i.e., only links to the local server are
5362 # followed). The list entries are the document titles.
5363 # If the list type is <dl>, the first <H1> header is used too.
5364 # For each file matching the pattern, a list is made recursively of all
5365 # HTML documents that are linked from it and are stored in the same directory
5366 # or a sub-directory. Warnings are given for missing files.
5367 # The listing starts for the ServerRoot directory.
5368 # You can change the default list type <dl> (<dl>, <ul>, <ol>).
5370 %LinkUsed = ();
5372 sub HTMLdocTree # ($Pattern [, listtype])
5373 # e.g., ("/Welcome.html", [, "ul"])
5375 my $Pattern = shift;
5376 my $ListType = shift || "dl";
5377 my $Prefix = lc($ListType) eq "dl" ? "dt" : "li";
5378 my $URL_root = "http://$::ENV{'SERVER_NAME'}\:$::ENV{'SERVER_PORT'}";
5379 my ($Filename, $Path, $Link);
5380 my %LocalLinks = {};
5382 # Read files (glob them for expansion of wildcards)
5383 my @FileList = glob("$::CGI_HOME$Pattern");
5384 foreach $Path (@FileList)
5386 # Get URL_path
5387 $Path =~ /$::CGI_HOME/;
5388 my $URL_path = $';
5389 # Check whether this file should be visible
5390 next if $::BlockPathAccess && $URL_path =~ m@$::BlockPathAccess@;
5392 my $Title = $URL_path;
5393 my $Caption = "";
5394 # Current file should not be used again
5395 ++$LinkUsed{$URL_path};
5396 # Open HTML doc
5397 unless(open(TextFile, $Path))
5399 print "<$Prefix>$Title <blink>(not found)</blink><br>\n";
5400 next;
5402 while(<TextFile>)
5404 chop $_;
5405 $Line = $_;
5406 # Catch Title
5407 while($Line =~ m@<title>@i)
5409 if($Line =~ m@<title>([^<]*)</title>@i)
5411 $Title = $1;
5412 $Line = $';
5414 else
5416 $Line .= <TextFile>;
5417 chop $Line;
5420 # Catch First Header
5421 while(!$Caption && $Line =~ m@<h1>@i)
5423 if($Line =~ m@</h[1-9]>@i)
5425 $Caption = $`;
5426 $Line = $';
5427 $Caption =~ m@<h1>@i;
5428 $Caption = $';
5429 $Line = $`.$Caption.$Line;
5431 else
5433 $Line .= <TextFile>;
5434 chop $Line;
5437 # Catch and print Links
5438 while($Line =~ m@<a href\=([^>]*)>@i)
5440 $Link = $1;
5441 $Line = $';
5442 # Remove quotes
5443 $Link =~ s/\"//g;
5444 # Remove extras
5445 $Link =~ s/[\#\?].*$//g;
5446 # Remove Servername
5447 if($Link =~ m@(http://|^)@i)
5449 $Link = $';
5450 # Only build tree for current server
5451 next unless $Link =~ m@$::ENV{'SERVER_NAME'}|^/@;
5452 # Remove server name and port
5453 $Link =~ s@^[^\/]*@@g;
5455 # Store the current link
5456 next if $LinkUsed{$Link} || $Link eq $URL_path;
5457 ++$LinkUsed{$Link};
5458 ++$LocalLinks{$Link};
5462 close TextFile;
5463 print "<$Prefix>";
5464 print "<a href=http://";
5465 print "$::ENV{'SERVER_NAME'}\:$::ENV{'SERVER_PORT'}$URL_path>";
5466 print "$Title</a>\n";
5467 print "<br>$Caption\n"
5468 if $Caption && $Caption ne $Title && $ListType =~ /dl/i;
5469 print "<$ListType>\n";
5470 foreach $Link (keys(%LocalLinks))
5472 &HTMLdocTree($Link, $ListType);
5474 print "</$ListType>\n";
5478 ###########################<<<<<<<<<<End Remove
5480 # Make require happy
5483 =head1 NAME
5485 CGIscriptor -
5487 =head1 DESCRIPTION
5489 A flexible HTML 4 compliant script/module for CGI-aware
5490 embeded Perl, shell-scripts, and other scripting languages,
5491 executed at the server side.
5493 =head1 README
5495 Executes embeded Perl code in HTML pages with easy
5496 access to CGI variables. Also processes embeded shell
5497 scripts and scripts in any other language with an
5498 interactive interpreter (e.g., in-line Python, Tcl,
5499 Ruby, Awk, Lisp, Xlispstat, Prolog, M4, R, REBOL, Praat,
5500 sh, bash, csh, ksh).
5502 CGIscriptor is very flexible and hides all the specifics
5503 and idiosyncrasies of correct output and CGI coding and naming.
5504 CGIscriptor complies with the W3C HTML 4.0 recommendations.
5506 This Perl program will run on any WWW server that runs
5507 Perl scripts, just add a line like the following to your
5508 srm.conf file (Apache example):
5510 ScriptAlias /SHTML/ /real-path/CGIscriptor.pl/
5512 URL's that refer to http://www.your.address/SHTML/... will
5513 now be handled by CGIscriptor.pl, which can use a private
5514 directory tree (default is the DOCUMENT_ROOT directory tree,
5515 but it can be anywhere).
5517 =head1 PREREQUISITES
5520 =head1 COREQUISITES
5523 =pod OSNAMES
5525 Linux, *BSD, *nix, MS WinXP
5527 =pod SCRIPT CATEGORIES
5529 Servers
5533 =cut