3 # (configure the first line to contain YOUR path to perl 5.000+)
11 # perl 5.0 or higher (see: "http://www.perl.org/")
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
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.
57 # Configuration, copyright notice, and user manual follow the next
60 ############################################################################
62 # Changes (document ALL changes with date, name and email here):
63 # 11 Jun 2012 - Securing CGIvariable setting. Made
64 # 'if($ENV{QUERY_STRING} =~ /$name/)' into elsif in
65 # defineCGIvariable/List/Hash to give precedence to ENV{$name}
66 # This was a very old security bug. Added ProtectCGIvariable($name).
67 # 06 Jun 2012 - Added IP only session types after login.
68 # 31 May 2012 - Session ticket system added for handling login sessions.
69 # 29 May 2012 - CGIsafeFileName does not accept filenames starting with '.'
70 # 29 May 2012 - Added CGIscriptor::BrowseAllDirs to handle browsing directories
72 # 22 May 2012 - Added Access control with Session Tickets linked to
73 # IP Address and PATH_INFO.
74 # 21 May 2012 - Corrected the links generated by CGIscriptor::BrowseDirs
75 # Will link to current base URL when the HTTP server is '.' or '~'
76 # 29 Oct 2009 - Adapted David A. Wheeler's suggestion about filenames:
77 # CGIsafeFileName does not accept filenames starting with '-'
78 # (http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)
79 # 08 Oct 2009 - Some corrections in the README.txt file, eg, new email address
80 # 28 Jan 2005 - Added a file selector to performTranslation.
81 # Changed %TranslationTable to @TranslationTable
82 # and patterns to lists.
83 # 27 Jan 2005 - Added a %TranslationTable with associated
84 # performTranslation(\$text) function to allow
85 # run changes in the web pages. Say, to translate
86 # legacy pages with <%=...%> delimiters to the new
87 # <SCRIPT TYPE=..></SCRIPT> format.
88 # 27 Jan 2005 - Small bug of extra '\n' in output removed from the
89 # Other Languages Code.
90 # 10 May 2004 - Belated upload of latest version (2.3) to CPAN
91 # 07 Oct 2003 - Corrected error '\s' -> '\\s' in rebol scripting
93 # 07 Oct 2003 - Corrected omitted INS tags in <DIV><INS> handling
94 # 20 May 2003 - Added a --help switch to print the manual.
95 # 06 Mar 2003 - Adapted the blurb at the end of the file.
96 # 03 Mar 2003 - Added a user definable dieHandler function to catch all
97 # "die" calls. Also "enhanced" the STDERR printout.
98 # 10 Feb 2003 - Split off the reading of the POST part of a query
99 # from Initialize_output. This was suggested by Gerd Franke
100 # to allow for the catching of the file_path using a
101 # POST based lookup. That is, he needed the POST part
102 # to change the file_path.
103 # 03 Feb 2003 - %{$name}; => %{$name} = (); in defineCGIvariableHash.
104 # 03 Feb 2003 - \1 better written as $1 in
105 # $directive =~ s/[^\\\$]\#[^\n\f\r]*([\n\f\r])/$1/g
106 # 29 Jan 2003 - This makes "CLASS="ssperl" CSS-compatible Gerd Franke
108 # $ServerScriptContentClass = "ssperl";
109 # changed in ProcessFile():
110 # unless(($CurrentContentType =~
111 # 28 Jan 2003 - Added 'INS' Tag! Gerd Franke
112 # 20 Dec 2002 - Removed useless $Directoryseparator variable.
113 # Update comments and documentation.
114 # 18 Dec 2002 - Corrected bug in Accept/Reject processing.
116 # 24 Jul 2002 - Added .htaccess documentation (from Gerd Franke)
117 # Also added a note that RawFilePattern can be a
118 # complete file name.
119 # 19 Mar 2002 - Added SRC pseudo-files PREFIX and POSTFIX. These
120 # switch to prepending or to appending the content
121 # of the SRC attribute. Default is prefixing. You
122 # can add as many of these switches as you like.
123 # 13 Mar 2002 - Do not search for tag content if a tag closes with
124 # />, i.e., <DIV ... /> will be handled the XML/XHTML way.
125 # 25 Jan 2002 - Added 'curl' and 'snarf' to SRC attribute URL handling
127 # 25 Jan 2002 - Found a bug in SAFEqx, now executes qx() in a scalar context
128 # (i.o. a list context). This is necessary for binary results.
129 # 24 Jan 2002 - Disambiguated -T $SRCfile to -T "$SRCfile" (and -e) and
130 # changed the order of if/elsif to allow removing these
131 # conditions in systems with broken -T functions.
132 # (I also removed a spurious ')' bracket)
133 # 17 Jan 2002 - Changed DIV tag SRC from <SOURCE> to sysread(SOURCE,...)
134 # to support binary files.
135 # 17 Jan 2002 - Removed WhiteSpace from $FileAllowedCharacters.
136 # 17 Jan 2002 - Allow "file://" prefix in SRC attribute. It is simply
137 # stipped from the path.
138 # 15 Jan 2002 - Version 2.2
139 # 15 Jan 2002 - Debugged and completed URL support (including
140 # CGIscriptor::read_url() function)
141 # 07 Jan 2002 - Added automatic (magic) URL support to the SRC attribute
142 # with the main::GET_URL function. Uses wget -O underlying.
143 # 04 Jan 2002 - Added initialization of $NewDirective in InsertForeignScript
144 # (i.e., my $NewDirective = "";) to clear old output
145 # (this was a realy anoying bug).
146 # 03 Jan 2002 - Added a <DIV CLASS='text/ssperl' ID='varname'></DIV>
147 # tags that assign the body text as-is (literally)
148 # to $varname. Allows standard HTML-tools to handle
149 # Cascading Style Sheet templates. This implements a
150 # design by Gerd Franke (franke@roo.de).
151 # 03 Jan 2002 - I finaly gave in and allowed SRC files to expand ~/.
152 # 12 Oct 2001 - Normalized spelling of "CGIsafFileName" in documentation.
153 # 09 Oct 2001 - Added $ENV{'CGI_BINARY_FILE'} to log files to
154 # detect unwanted indexing of TAR files by webcrawlers.
155 # 10 Sep 2001 - Added $YOUR_SCRIPTS directory to @INC for 'require'.
156 # 22 Aug 2001 - Added .txt (Content-type: text/plain) as a default
157 # processed file type. Was processed via BinaryMapFile.
158 # 31 May 2001 - Changed =~ inside CGIsafeEmailAddress that was buggy.
159 # 29 May 2001 - Updated $CGI_HOME to point to $ENV{DOCUMENT_ROOT} io
160 # the root of PATH_TRANSLATED. DOCUMENT_ROOT can now
161 # be manipulated to achieve a "Sub Root".
162 # NOTE: you can have $YOUR_HTML_FILES != DOCUMENT_ROOT
163 # 28 May 2001 - Changed CGIscriptor::BrowsDirs function for security
164 # and debugging (it now works).
165 # 21 May 2001 - defineCGIvariableHash will ADD values to existing
166 # hashes,instead of replacing existing hashes.
167 # 17 May 2001 - Interjected a '&' when pasting POST to GET data
168 # 24 Apr 2001 - Blocked direct requests for BinaryMapFile.
169 # 16 Aug 2000 - Added hash table extraction for CGI parameters with
170 # CGIparseValueHash (used with structured parameters).
171 # Use: CGI='%<CGI-partial-name>' (fill in your name in <>)
172 # Will collect all <CGI-partial-name><key>=value pairs in
173 # $<CGI-partial-name>{<key>} = value;
174 # 16 Aug 2000 - Adapted SAFEqx to protect @PARAMETER values.
175 # 09 Aug 2000 - Added support for non-filesystem input by way of
176 # the CGI_FILE_CONTENTS and CGI_DATA_ACCESS_CODE
177 # environment variables.
178 # 26 Jul 2000 - On the command-line, file-path '-' indicates STDIN.
179 # This allows CGIscriptor to be used in pipes.
180 # Default, $BLOCK_STDIN_HTTP_REQUEST=1 will block this
181 # in an HTTP request (i.e., in a web server).
182 # 26 Jul 2000 - Blocked 'Content-type: text/html' if the SERVER_PROTOCOL
183 # is not HTTP or another protocol. Changed the default
184 # source directory to DOCUMENT_ROOT (i.o. the incorrect
186 # 24 Jul 2000 - -slim Command-line argument added to remove all
187 # comments, security, etc.. Updated documentation.
188 # 05 Jul 2000 - Added IF and UNLESS attributes to make the
189 # execution of all <META> and <SCRIPT> code
191 # 05 Jul 2000 - Rewrote and isolated the code for extracting
192 # quoted items from CGI and SRC attributes.
193 # Now all attributes expect the same set of
194 # quotes: '', "", ``, (), {}, [] and the same
195 # preceded by a \, e.g., "\((aap)\)" will be
196 # extracted as "(aap)".
197 # 17 Jun 2000 - Construct @ARGV list directly in CGIexecute
198 # name-space (i.o. by evaluation) from
199 # CGI attributes to prevent interference with
200 # the processing for non perl scripts.
201 # Changed CGIparseValueList to prevent runaway
203 # 16 Jun 2000 - Added a direct (interpolated) display mode
204 # (text/ssdisplay) and a user log mode
206 # 06 Jun 2000 - Replace "print $Result" with a syswrite loop to
207 # allow large string output.
208 # 02 Jun 2000 - Corrected shrubCGIparameter($CGI_VALUE) to realy
209 # remove all control characters. Changed Interpreter
210 # initialization to shrub interpolated CGI parameters.
211 # Added 'text/ssmailto' interpreter script.
212 # 22 May 2000 - Changed some of the comments
213 # 09 May 2000 - Added list extraction for CGI parameters with
214 # CGIparseValueList (used with multiple selections).
215 # Use: CGI='@<CGI-parameter>' (fill in your name in <>)
216 # 09 May 2000 - Added a 'Not Present' condition to CGIparseValue.
217 # 27 Apr 2000 - Updated documentation to reflect changes.
218 # 27 Apr 2000 - SRC attribute "cleaned". Supported for external
220 # 27 Apr 2000 - CGI attribute can be used in <SCRIPT> tag.
221 # 27 Apr 2000 - Gprolog, M4 support added.
222 # 26 Apr 2000 - Lisp (rep) support added.
223 # 20 Apr 2000 - Use of external interpreters now functional.
224 # 20 Apr 2000 - Removed bug from extracting Content types (RegExp)
225 # 10 Mar 2000 - Qualified unconditional removal of '#' that preclude
226 # the use of $#foo, i.e., I changed
227 # s/[^\\]\#[^\n\f\r]*([\n\f\r])/\1/g
229 # s/[^\\\$]\#[^\n\f\r]*([\n\f\r])/\1/g
230 # 03 Mar 2000 - Added a '$BlockPathAccess' variable to "hide"
231 # things like, e.g., CVS information in CVS subtrees
232 # 10 Feb 2000 - URLencode/URLdecode have been made case-insensitive
233 # 10 Feb 2000 - Added a BrowseDirs function (CGIscriptor package)
234 # 01 Feb 2000 - A BinaryMapFile in the ~/ directory has precedence
235 # over a "burried" BinaryMapFile.
236 # 04 Oct 1999 - Added two functions to check file names and email addresses
237 # (CGIscriptor::CGIsafeFileName and
238 # CGIscriptor::CGIsafeEmailAddress)
239 # 28 Sept 1999 - Corrected bug in sysread call for reading POST method
240 # to allow LONG posts.
241 # 28 Sept 1999 - Changed CGIparseValue to handle multipart/form-data.
242 # 29 July 1999 - Refer to BinaryMapFile from CGIscriptor directory, if
243 # this directory exists.
244 # 07 June 1999 - Limit file-pattern matching to LAST extension
245 # 04 June 1999 - Default text/html content type is printed only once.
246 # 18 May 1999 - Bug in replacement of ~/ and ./ removed.
247 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
248 # 15 May 1999 - Changed the name of the execute package to CGIexecute.
249 # Changed the processing of the Accept and Reject file.
250 # Added a full expression evaluation to Access Control.
251 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
252 # 27 Apr 1999 - Brought CGIscriptor under the GNU GPL. Made CGIscriptor
253 # Version 1.1 a module that can be called with 'require "CGIscriptor.pl"'.
254 # Requests are serviced by "Handle_Request()". CGIscriptor
255 # can still be called as a isolated perl script and a shell
257 # Changed the "factory default setting" so that it will run
258 # from the DOCUMENT_ROOT directory.
259 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
260 # 29 Mar 1999 - Remove second debugging STDERR switch. Moved most code
261 # to subroutines to change CGIscriptor into a module.
262 # Added mapping to process unsupported file types (e.g., binary
263 # pictures). See $BinaryMapFile.
264 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
265 # 24 Sept 1998 - Changed text of license (Rob van Son, R.J.J.H.vanSon@uva.nl)
266 # Removed a double setting of filepatterns and maximum query
267 # size. Changed email address. Removed some typos from the
269 # 02 June 1998 - Bug fixed in URLdecode. Changing the foreach loop variable
270 # caused quiting CGIscriptor.(Rob van Son, R.J.J.H.vanSon@uva.nl)
271 # 02 June 1998 - $SS_PUB and $SS_SCRIPT inserted an extra /, removed.
272 # (Rob van Son, R.J.J.H.vanSon@uva.nl)
278 # It is not possible to use operators or variables to construct variable names,
279 # e.g., $bar = \@{$foo}; won't work. However, eval('$bar = \@{'.$foo.'};');
280 # will indeed work. If someone could tell me why, I would be obliged.
283 ############################################################################
285 # OBLIGATORY USER CONFIGURATION
287 # Configure the directories where all user files can be found (this
288 # is the equivalent of the server root directory of a WWW-server).
289 # These directories can be located ANYWHERE. For security reasons, it is
290 # better to locate them outside the WWW-tree of your HTTP server, unless
291 # CGIscripter handles ALL requests.
293 # For convenience, the defaults are set to the root of the WWW server.
294 # However, this might not be safe!
297 # $YOUR_HTML_FILES = "/usr/pub/WWW/SHTML"; # or SS_PUB as environment var
298 # (patch to use the parent directory of CGIscriptor as document root, should be removed)
299 if($ENV{'SCRIPT_FILENAME'}) # && $ENV{'SCRIPT_FILENAME'} !~ /\Q$ENV{'DOCUMENT_ROOT'}\E/)
301 $ENV{'DOCUMENT_ROOT'} = $ENV{'SCRIPT_FILENAME'};
302 $ENV{'DOCUMENT_ROOT'} =~ s@
/CGIscriptor
.*$@
@ig;
305 # Just enter your own directory path here
306 $YOUR_HTML_FILES = $ENV{'DOCUMENT_ROOT'}; # default is the DOCUMENT_ROOT
308 # ./ script files (recommended to be different from the previous)
309 # $YOUR_SCRIPTS = "/usr/pub/WWW/scripts"; # or SS_SCRIPT as environment var
310 $YOUR_SCRIPTS = $YOUR_HTML_FILES; # This might be a SECURITY RISK
312 # End of obligatory user configuration
313 # (note: there is more non-essential user configuration below)
315 ############################################################################
317 # OPTIONAL USER CONFIGURATION (all values are used CASE INSENSITIVE)
319 # Script content-types: TYPE="Content-type" (user defined mime-type)
320 $ServerScriptContentType = "text/ssperl"; # Server Side Perl scripts
321 # CSS require a simple class
322 $ServerScriptContentClass = $ServerScriptContentType =~ m!/! ?
323 $' : "ssperl"; # Server Side Perl CSS classes
325 $ShellScriptContentType = "text/osshell"; # OS shell scripts
326 # # (Server Side perl ``-execution)
328 # Accessible file patterns, block any request that doesn't match
.
329 # Matches any file with the extension .(s)htm(l), .txt, or .xmr
330 # (\. is used in regexp)
331 # Note: die unless $PATH_INFO =~ m@($FilePattern)$@is;
332 $FilePattern = ".shtml|.htm|.html|.xml|.xmr|.txt|.js";
334 # The table with the content type MIME types
335 # (allows to differentiate MIME types, if needed)
338 '.html' => 'text/html',
339 '.shtml' => 'text/html',
340 '.htm' => 'text/html',
341 '.xml' => 'text/xml',
342 '.txt' => 'text/plain',
343 '.js' => 'text/plain'
347 # File pattern post-processing
348 $FilePattern =~ s/([@.])/\\$1/g; # Convert . and @ to \. and \@
350 # SHAsum command needed for Authorization and Login
351 # (note, these have to be accessible in the HTML pages, ie, the CGIexecute environment)
352 my $shasum = "shasum -a 256";
353 if(qx{uname
} =~ /Darwin/)
355 $shasum = "shasum-5.12 -a 256" unless `which shasum`;
357 my $SHASUMCMD = $shasum.' |cut -f 1 -d" "';
358 $ENV{"SHASUMCMD"} = $SHASUMCMD;
359 my $RANDOMHASHCMD = 'dd bs=1 count=64 if=/dev/urandom 2>/dev/null | '.$shasum.' -b |cut -f 1 -d" "';
360 $ENV{"RANDOMHASHCMD"} = $RANDOMHASHCMD;
362 # File patterns of files which are handled by session tickets.
363 %TicketRequiredPatterns = (
364 '^/Private(/|$)' => "Private/.Sessions\tPrivate/.Passwords\t/Private/Login.html\t+36000"
366 # Used to set cookies, only session cookies supported
367 my %SETCOOKIELIST = ();
369 # Session Ticket Directory: Private/.Sessions
370 # Password Directory: Private/.Passwords
371 # Login page (url path): /Private/Login.html
372 # Expiration time (s): +3600
373 # +<seconds> = relative time <seconds> is absolute date-time
375 # Raw files must contain their own Content-type (xmr <- x-multipart-replace).
376 # THIS IS A SUBSET OF THE FILES DEFINED IN $FilePattern
377 $RawFilePattern = ".xmr";
378 # (In principle, this could contain a full file specification, e.g.,
379 # ".xmr|relocated.html")
381 # Raw File pattern post-processing
382 $RawFilePattern =~ s/([@.])/\\$1/g; # Convert . and @ to \. and \@
384 # Server protocols for which "Content-type: text/html\n\n" should be printed
385 # (you should not bother with these, except for HTTP, they are mostly imaginary)
386 $ContentTypeServerProtocols = 'HTTP|MAIL|MIME';
388 # Block access to all (sub-) paths and directories that match the
389 # following (URL) path (is used as:
390 # 'die if $BlockPathAccess && $ENV{'PATH_INFO'} =~ m@$BlockPathAccess@;' )
391 $BlockPathAccess = '/(CVS|\.git)/'; # Protect CVS and .git information
393 # All (blocked) other file-types can be mapped to a single "binary-file"
394 # processor (a kind of pseudo-file path). This can either be an error
395 # message (e.g., "illegal file") or contain a script that serves binary
397 # Note: the real file path wil be stored in $ENV{CGI_BINARY_FILE}.
398 $BinaryMapFile = "/BinaryMapFile.xmr";
399 # Allow for the addition of a CGIscriptor directory
400 # Note that a BinaryMapFile in the root "~/" directory has precedence
401 $BinaryMapFile = "/CGIscriptor".$BinaryMapFile
402 if ! -e
"$YOUR_HTML_FILES".$BinaryMapFile
403 && -e
"$YOUR_HTML_FILES/CGIscriptor".$BinaryMapFile;
406 # List of all characters that are allowed in file names and paths.
407 # All requests containing illegal characters are blocked. This
408 # blocks most tricks (e.g., adding "\000", "\n", or other control
409 # characters, also blocks URI's using %FF)
410 # THIS IS A SECURITY FEATURE
411 # (this is also used to parse filenames in SRC= features, note the
412 # '-quotes, they are essential)
413 $FileAllowedChars = '\w\.\~\/\:\*\?\-'; # Covers Unix and Mac, but NO spaces
415 # Maximum size of the Query (number of characters clients can send
416 # covers both GET & POST combined)
417 $MaximumQuerySize = 2**20 - 1; # = 2**14 - 1
420 # Embeded URL get function used in SRC attributes and CGIscriptor::read_url
421 # (returns a string with the PERL code to transfer the URL contents, e.g.,
422 # "SAFEqx(\'curl \"http://www.fon.hum.uva.nl\"\')")
423 # "SAFEqx(\'wget --quiet --output-document=- \"http://www.fon.hum.uva.nl\"\')")
424 # Be sure to handle <BASE HREF='URL'> and allow BOTH
425 # direct printing GET_URL($URL [, 0]) and extracting the content of
426 # the $URL for post-processing GET_URL($URL, 1).
427 # You get the WHOLE file, including HTML header.
428 # The shell command Use $URL where the URL should go
429 # ('wget', 'snarf' or 'curl', uncomment the one you would like to use)
430 my $GET_URL_shell_command = 'wget --quiet --output-document=- $URL';
431 #my $GET_URL_shell_command = 'snarf $URL -';
432 #my $GET_URL_shell_command = 'curl $URL';
434 sub GET_URL
# ($URL, $ValueNotPrint) -> content_of_url
436 my $URL = shift || return;
437 my $ValueNotPrint = shift || 0;
439 # Check URL for illegal characters
440 return "print '<h1>Illegal URL<h1>'\"\n\";" if $URL =~ /[^$FileAllowedChars\%]/;
442 # Include URL in final command
443 my $CurrentCommand = $GET_URL_shell_command;
444 $CurrentCommand =~ s/\$URL/$URL/g;
446 # Print to STDOUT or return a value
447 my $BlockPrint = "print STDOUT ";
448 $BlockPrint = "" if $ValueNotPrint;
450 my $Commands = <<"GETURLCODE";
455 # Simple, using shell command
456 \$Page = SAFEqx('$CurrentCommand');
458 # Add a BASE tage to the header
459 \$Page =~ s!\\</head!\\<base href='$URL'\\>\\</head!ig unless \$Page =~ m!\\<base!;
461 # Print the URL value, or return it as a value
468 # As files can get rather large (and binary), you might want to use
469 # some more intelligent reading procedure, e.g.,
471 # # open(URLHANDLE, '/usr/bin/wget --quiet --output-document=- "$URL"|') || die "wget: \$!";
472 # #open(URLHANDLE, '/usr/bin/snarf "$URL" -|') || die "snarf: \$!";
473 # open(URLHANDLE, '/usr/bin/curl "$URL"|') || die "curl: \$!";
475 # while(sysread(URLHANDLE,\$text, 1024) > 0)
479 # close(URLHANDLE) || die "\$!";
480 # However, this doesn't work with the CGIexecute->evaluate() function.
481 # You get an error: 'No child processes at (eval 16) line 15, <file0> line 8.'
483 # You can forget the next two variables, they are only needed when
484 # you don't want to use a regular file system (i.e., with open)
485 # but use some kind of database/RAM image for accessing (generating)
488 # Name of the environment variable that contains the file contents
489 # when reading directly from Database/RAM. When this environment variable,
490 # $ENV{$CGI_FILE_CONTENTS}, is not false, no real file will be read.
491 $CGI_FILE_CONTENTS = 'CGI_FILE_CONTENTS';
492 # Uncomment the following if you want to force the use of the data access code
493 # $ENV{$CGI_FILE_CONTENTS} = '-'; # Force use of $ENV{$CGI_DATA_ACCESS_CODE}
495 # Name of the environment variable that contains the RAM access perl
496 # code needed to read additional "files", i.e.,
497 # $ENV{$CGI_FILE_CONTENTS} = eval("\@_=('$file_path'); do{$ENV{$CGI_DATA_ACCESS_CODE}}");
498 # When $ENV{$CGI_FILE_CONTENTS} eq '-', this code is executed to generate the data.
499 $CGI_DATA_ACCESS_CODE = 'CGI_DATA_ACCESS_CODE';
501 # You can, of course, fill this yourself, e.g.,
502 # $ENV{$CGI_DATA_ACCESS_CODE} =
503 # 'open(INPUT, "<$_[0]"); while(<INPUT>){print;};close(INPUT);'
508 # Suppress error messages, this can be changed for debugging or error-logging
509 #open(STDERR, "/dev/null"); # (comment out for use in debugging)
511 # SPECIAL: Remove Comments, security, etc. if the command line is
512 # '>CGIscriptor.pl -slim >slimCGIscriptor.pl'
513 $TrimDownCGIscriptor = 1 if $ARGV[0] =~ /^\-slim/i;
515 # If CGIscriptor is used from the command line, the command line
516 # arguments are interpreted as the file (1st) and the Query String (rest).
518 $ENV{'PATH_INFO'} = shift(@ARGV) unless exists($ENV{'PATH_INFO'}) || grep(/\-\-help/i, @ARGV);
519 $ENV{'QUERY_STRING'} = join("&", @ARGV) unless exists($ENV{'QUERY_STRING'});
522 # Handle bail-outs in a user definable way.
523 # Catch Die and replace it with your own function.
524 # Ends with a call to "die $_[0];"
526 sub dieHandler
# ($ErrorCode, "Message", @_) -> DEAD
528 my $ErrorCode = shift;
529 my $ErrorMessage = shift;
531 # Place your own reporting functions here
533 # Now, kill everything (default)
534 print STDERR
"$ErrorCode: $ErrorMessage\n";
539 # End of optional user configuration
540 # (note: there is more non-essential user configuration below)
542 if(grep(/\-\-help/i, @ARGV))
544 print << 'ENDOFPREHELPTEXT2';
546 ###############################################################################
548 # Author and Copyright (c):
549 # Rob van Son, © 1995,1996,1997,1998,1999,2000,2001,2002-2012
552 # Institute of Phonetic Sciences & IFOTT/ACLS
553 # University of Amsterdam
554 # Email: R.J.J.H.vanSon@gmail.com
555 # Email: R.J.J.H.vanSon@uva.nl
556 # WWW : http://www.fon.hum.uva.nl/rob/
558 # License for use and disclaimers
560 # CGIscriptor merges plain ASCII HTML files transparantly
561 # with CGI variables, in-line PERL code, shell commands,
562 # and executable scripts in other scripting languages.
564 # This program is free software; you can redistribute it and/or
565 # modify it under the terms of the GNU General Public License
566 # as published by the Free Software Foundation; either version 2
567 # of the License, or (at your option) any later version.
569 # This program is distributed in the hope that it will be useful,
570 # but WITHOUT ANY WARRANTY; without even the implied warranty of
571 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
572 # GNU General Public License for more details.
574 # You should have received a copy of the GNU General Public License
575 # along with this program; if not, write to the Free Software
576 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
580 # Rob van Son (R.J.J.H.vanSon@uva.nl)
581 # Gerd Franke franke@roo.de (designed the <DIV> behaviour)
583 #######################################################
586 #######################################################>>>>>>>>>>Start Remove
588 # You can skip the following code, it is an auto-splice
591 # Construct a slimmed down version of CGIscriptor
592 # (i.e., CGIscriptor.pl -slim > slimCGIscriptor.pl)
594 if($TrimDownCGIscriptor)
596 open(CGISCRIPTOR
, "<CGIscriptor.pl")
597 || dieHandler
(1, "<CGIscriptor.pl not slimmed down: $!\n");
599 my $SKIPComments = 0;
608 $SKIPtext = 1 if /[\>]{10}Start Remove/;
609 $SKIPComments = 1 if $SKIPtext == 1;
612 $SKIPline = 1 if $SKIPtext || ($SKIPComments && /^\s*\#/);
614 ++$PrintCount unless $SKIPline;
616 print STDOUT
$_ unless $SKIPline;
619 $SKIPtext = 0 if /[\<]{10}End Remove/;
622 print STDERR
"\# Printed $PrintCount out of $LineCount lines\n";
626 #######################################################
628 if(grep(/\-\-help/i, @ARGV))
630 print << 'ENDOFHELPTEXT';
634 # CGIscriptor merges plain ASCII HTML files transparantly and safely
635 # with CGI variables, in-line PERL code, shell commands, and executable
636 # scripts in many languages (on-line and real-time). It combines the
637 # "ease of use" of HTML files with the versatillity of specialized
638 # scripts and PERL programs. It hides all the specifics and
639 # idiosyncrasies of correct output and CGI coding and naming. Scripts
640 # do not have to be aware of HTML, HTTP, or CGI conventions just as HTML
641 # files can be ignorant of scripts and the associated values. CGIscriptor
642 # complies with the W3C HTML 4.0 recommendations.
643 # In addition to its use as a WWW embeded CGI processor, it can
644 # be used as a command-line document preprocessor (text-filter).
646 # THIS IS HOW IT WORKS
648 # The aim of CGIscriptor is to execute "plain" scripts inside a text file
649 # using any required CGIparameters and environment variables. It
650 # is optimized to transparantly process HTML files inside a WWW server.
651 # The native language is Perl, but many other scripting languages
654 # CGIscriptor reads text files from the requested input file (i.e., from
655 # $YOUR_HTML_FILES$PATH_INFO) and writes them to <STDOUT> (i.e., the
656 # client requesting the service) preceded by the obligatory
657 # "Content-type: text/html\n\n" or "Content-type: text/plain\n\n" string
658 # (except for "raw" files which supply their own Content-type message
659 # and only if the SERVER_PROTOCOL supports HTTP, MAIL, or MIME).
661 # When CGIscriptor encounters an embedded script, indicated by an HTML4 tag
663 # <SCRIPT TYPE="text/ssperl" [CGI="$VAR='default value'"] [SRC="ScriptSource"]>
669 # <SCRIPT TYPE="text/osshell" [CGI="$name='default value'"] [SRC="ScriptSource"]>
673 # construct (anything between []-brackets is optional, other MIME-types
674 # and scripting languages are supported), the embedded script is removed
675 # and both the contents of the source file (i.e., "do 'ScriptSource'")
676 # AND the script are evaluated as a PERL program (i.e., by eval()),
677 # shell script (i.e., by a "safe" version of `Command`, qx) or an external
678 # interpreter. The output of the eval() function takes the place of the
679 # original <SCRIPT></SCRIPT> construct in the output string. Any CGI
680 # parameters declared by the CGI attribute are available as simple perl
681 # variables, and can subsequently be made available as variables to other
682 # scripting languages (e.g., bash, python, or lisp).
684 # Example: printing "Hello World"
685 # <HTML><HEAD><TITLE>Hello World</TITLE>
687 # <H1><SCRIPT TYPE="text/ssperl">"Hello World"</SCRIPT></H1>
690 # Save this in a file, hello.html, in the directory you indicated with
691 # $YOUR_HTML_FILES and access http://your_server/SHTML/hello.html
692 # (or to whatever name you use as an alias for CGIscriptor.pl).
693 # This is realy ALL you need to do to get going.
695 # You can use any values that are delivered in CGI-compliant form (i.e.,
696 # the "?name=value" type URL additions) transparently as "$name" variables
697 # in your scripts IFF you have declared them in the CGI attribute of
698 # a META or SCRIPT tag before e.g.:
699 # <META CONTENT="text/ssperl; CGI='$name = `default value`'
700 # [SRC='ScriptSource']">
702 # <SCRIPT TYPE="text/ssperl" CGI="$name = 'default value'"
703 # [SRC='ScriptSource']>
704 # After such a 'CGI' attribute, you can use $name as an ordinary PERL variable
705 # (the ScriptSource file is immediately evaluated with "do 'ScriptSource'").
706 # The CGIscriptor script allows you to write ordinary HTML files which will
707 # include dynamic CGI aware (run time) features, such as on-line answers
708 # to specific CGI requests, queries, or the results of calculations.
710 # For example, if you wanted to answer questions of clients, you could write
711 # a Perl program called "Answer.pl" with a function "AnswerQuestion()"
712 # that prints out the answer to requests given as arguments. You then write
713 # an HTML page "Respond.html" containing the following fragment:
716 # The Answer to your question
717 # <META CONTENT="text/ssperl; CGI='$Question'">
718 # <h3><SCRIPT TYPE="text/ssperl">$Question</SCRIPT></h3>
720 # <h3><SCRIPT TYPE="text/ssperl" SRC="./PATH/Answer.pl">
721 # AnswerQuestion($Question);
724 # <FORM ACTION=Respond.html METHOD=GET>
725 # Next question: <INPUT NAME="Question" TYPE=TEXT SIZE=40><br>
726 # <INPUT TYPE=SUBMIT VALUE="Ask">
729 # The output could look like the following (in HTML-speak):
732 # The Answer to your question
733 # <h3>What is the capital of the Netherlands?</h3>
737 # <FORM ACTION=Respond.html METHOD=GET>
738 # Next question: <INPUT NAME="Question" TYPE=TEXT SIZE=40><br>
739 # <INPUT TYPE=SUBMIT VALUE="Ask">
741 # Note that the function "Answer.pl" does know nothing about CGI or HTML,
742 # it just prints out answers to arguments. Likewise, the text has no
743 # provisions for scripts or CGI like constructs. Also, it is completely
744 # trivial to extend this "program" to use the "Answer" later in the page
745 # to call up other information or pictures/sounds. The final text never
746 # shows any cue as to what the original "source" looked like, i.e.,
747 # where you store your scripts and how they are called.
749 # There are some extra's. The argument of the files called in a SRC= tag
750 # can access the CGI variables declared in the preceding META tag from
751 # the @ARGV array. Executable files are called as:
752 # `file '$ARGV[0]' ... ` (e.g., `Answer.pl \'$Question\'`;)
753 # The files called from SRC can even be (CGIscriptor) html files which are
754 # processed in-line. Furthermore, the SRC= tag can contain a perl block
755 # that is evaluated. That is,
756 # <META CONTENT="text/ssperl; CGI='$Question' SRC='{$Question}'">
757 # will result in the evaluation of "print do {$Question};" and the VALUE
758 # of $Question will be printed. Note that these "SRC-blocks" can be
759 # preceded and followed by other file names, but only a single block is
760 # allowed in a SRC= tag.
762 # One of the major hassles of dynamic WWW pages is the fact that several
763 # mutually incompatible browsers and platforms must be supported. For example,
764 # the way sound is played automatically is different for Netscape and
765 # Internet Explorer, and for each browser it is different again on
766 # Unix, MacOS, and Windows. Realy dangerous is processing user-supplied
767 # (form-) values to construct email addresses, file names, or database
768 # queries. All Apache WWW-server exploits reported in the media are
769 # based on faulty CGI-scripts that didn't check their user-data properly.
771 # There is no panacee for these problems, but a lot of work and problems
772 # can be saved by allowing easy and transparent control over which
773 # <SCRIPT></SCRIPT> blocks are executed on what CGI-data. CGIscriptor
774 # supplies such a method in the form of a pair of attributes:
775 # IF='...condition..' and UNLESS='...condition...'. When added to a
776 # script tag, the whole block (including the SRC attribute) will be
777 # ignored if the condition is false (IF) or true (UNLESS).
778 # For example, the following block will NOT be evaluated if the value
779 # of the CGI variable FILENAME is NOT a valid filename:
781 # <SCRIPT TYPE='text/ssperl' CGI='$FILENAME'
782 # IF='CGIscriptor::CGIsafeFileName($FILENAME)'>
786 # (the function CGIsafeFileName(String) returns an empty string ("")
787 # if the String argument is not a valid filename).
788 # The UNLESS attribute is the mirror image of IF.
790 # A user manual follows the HTML 4 and security paragraphs below.
792 ##########################################################################
796 # In general, CGIscriptor.pl complies with the HTML 4 recommendations of
797 # the W3C. This means that any software to manage Web sites will be able
798 # to handle CGIscriptor files, as will web agents.
800 # All script code should be placed between <SCRIPT></SCRIPT> tags, the
801 # script type is indicated with TYPE="mime-type", the LANGUAGE
802 # feature is ignored, and a SRC feature is implemented. All CGI specific
803 # features are delegated to the CGI attribute.
805 # However, the behavior deviates from the W3C recommendations at some
806 # points. Most notably:
807 # 0- The scripts are executed at the server side, invissible to the
808 # client (i.e., the browser)
809 # 1- The mime-types are personal and idiosyncratic, but can be adapted.
810 # 2- Code in the body of a <SCRIPT></SCRIPT> tag-pair is still evaluated
811 # when a SRC feature is present.
812 # 3- The SRC attribute reads a list of files.
813 # 4- The files in a SRC attribute are processed according to file type.
814 # 5- The SRC attribute evaluates inline Perl code.
815 # 6- Processed META, DIV, INS tags are removed from the output
817 # 7- All attributes of the processed META tags, except CONTENT, are ignored
818 # (i.e., deleted from the output).
819 # 8- META tags can be placed ANYWHERE in the document.
820 # 9- Through the SRC feature, META tags can have visible output in the
822 # 10- The CGI attribute that declares CGI parameters, can be used
823 # inside the <SCRIPT> tag.
824 # 11- Use of an extended quote set, i.e., '', "", ``, (), {}, []
825 # and their \-slashed combinations: \'\', \"\", \`\`, \(\),
827 # 12- IF and UNLESS attributes to <SCRIPT>, <META>, <DIV>, <INS> tags.
828 # 13- <DIV> tags cannot be nested, DIV tags are not
829 # rendered with new-lines.
830 # 14- The XML style <TAG .... /> is recognized and handled correctly.
831 # (i.e., no content is processed)
833 # The reasons for these choices are:
834 # You can still write completely HTML4 compliant documents. CGIscriptor
835 # will not force you to write "deviant" code. However, it allows you to
836 # do so (which is, in fact, just as bad). The prime design principle
837 # was to allow users to include plain Perl code. The code itself should
838 # be "enhancement free". Therefore, extra features were needed to
839 # supply easy access to CGI and Web site components. For security
840 # reasons these have to be declared explicitly. The SRC feature
841 # transparently manages access to external files, especially the safe
842 # use of executable files.
843 # The CGI attribute handles the declarations of external (CGI) variables
844 # in the SCRIPT and META tag's.
845 # EVERYTHING THE CGI ATTRIBUTE AND THE META TAG DO CAN BE DONE INSIDE
846 # A <SCRIPT></SCRIPT> TAG CONSTRUCT.
848 # The reason for the IF, UNLESS, and SRC attributes (and their Perl code
849 # evaluation) were build into the META and SCRIPT tags is part laziness,
850 # part security. The SRC blocks allows more compact documents and easier
851 # debugging. The values of the CGI variables can be immediately screened
852 # for security by IF or UNLESS conditions, and even SRC attributes (e.g.,
853 # email addresses and file names), and a few commands can be called
854 # without having to add another Perl TAG pair. This is especially important
855 # for documents that require the use of other (more restricted) "scripting"
856 # languages and facilities that lag transparent control structures.
858 ##########################################################################
862 # Your WWW site is a few keystrokes away from a few hundred million internet
863 # users. A fair percentage of these users knows more about your computer
864 # than you do. And some of these just might have bad intentions.
866 # To ensure uncompromized operation of your server and platform, several
867 # features are incorporated in CGIscriptor.pl to enhance security.
868 # First of all, you should check the source of this program. No security
869 # measures will help you when you download programs from anonymous sources.
870 # If you want to use THIS file, please make sure that it is uncompromized.
871 # The best way to do this is to contact the source and try to determine
872 # whether s/he is reliable (and accountable).
874 # BE AWARE THAT ANY PROGRAMMER CAN CHANGE THIS PROGRAM IN SUCH A WAY THAT
875 # IT WILL SET THE DOORS TO YOUR SYSTEM WIDE OPEN
877 # I would like to ask any user who finds bugs that could compromise
878 # security to report them to me (and any other bug too,
879 # Email: R.J.J.H.vanSon@uva.nl or ifa@hum.uva.nl).
884 # The inner workings of the HTML source files are completely hidden
885 # from the client. Only the HTTP header and the ever changing content
886 # of the output distinguish it from the output of a plain, fixed HTML
887 # file. Names, structures, and arguments of the "embedded" scripts
888 # are invisible to the client. Error output is suppressed except
889 # during debugging (user configurable).
891 # 2 Separate directory trees
892 # Directories containing Inline text and script files can reside on
893 # separate trees, distinct from those of the HTTP server. This means
894 # that NEITHER the text files, NOR the script files can be read by
895 # clients other than through CGIscriptor.pl, UNLESS they are
896 # EXPLICITELY made available.
898 # 3 Requests are NEVER "evaluated"
899 # All client supplied values are used as literal values (''-quoted).
900 # Client supplied ''-quotes are ALWAYS removed. Therefore, as long as the
901 # embedded scripts do NOT themselves evaluate these values, clients CANNOT
902 # supply executable commands. Be sure to AVOID scripts like:
904 # <META CONTENT="text/ssperl; CGI='$UserValue'">
905 # <SCRIPT TYPE="text/ssperl">$dir = `ls -1 $UserValue`;</SCRIPT>
907 # These are a recipe for disaster. However, the following quoted
908 # form should be save (but is still not adviced):
910 # <SCRIPT TYPE="text/ssperl">$dir = `ls -1 \'$UserValue\'`;</SCRIPT>
912 # A special function, SAFEqx(), will automatically do exactly this,
913 # e.g., SAFEqx('ls -1 $UserValue') will execute `ls -1 \'$UserValue\'`
914 # with $UserValue interpolated. I recommend to use SAFEqx() instead
915 # of backticks whenever you can. The OS shell scripts inside
917 # <SCRIPT TYPE="text/osshell">ls -1 $UserValue</SCRIPT>
919 # are handeld by SAFEqx and automatically ''-quoted.
921 # 4 Logging of requests
922 # All requests can be logged separate from the Host server. The level of
923 # detail is user configurable: Including or excluding the actual queries.
924 # This allows for the inspection of (im-) proper use.
926 # 5 Access control: Clients
927 # The Remote addresses can be checked against a list of authorized
928 # (i.e., accepted) or non-authorized (i.e., rejected) clients. Both
929 # REMOTE_HOST and REMOTE_ADDR are tested so clients without a proper
930 # HOST name can be (in-) excluded by their IP-address. Client patterns
931 # containing all numbers and dots are considered IP-addresses, all others
932 # domain names. No wild-cards or regexp's are allowed, only partial
934 # Matching of names is done from the back to the front (domain first,
935 # i.e., $REMOTE_HOST =~ /\Q$pattern\E$/is), so including ".edu" will
936 # accept or reject all clients from the domain EDU. Matching of
937 # IP-addresses is done from the front to the back (domain first, i.e.,
938 # $REMOTE_ADDR =~ /^\Q$pattern\E/is), so including "128." will (in-)
939 # exclude all clients whose IP-address starts with 128.
940 # There are two special symbols: "-" matches HOSTs with no name and "*"
941 # matches ALL HOSTS/clients.
942 # For those needing more expressional power, lines starting with
943 # "-e" are evaluated by the perl eval() function. E.g.,
944 # '-e $REMOTE_HOST =~ /\.edu$/is;' will accept/reject clients from the
947 # 6 Access control: Files
948 # In principle, CGIscriptor could read ANY file in the directory
949 # tree as discussed in 1. However, for security reasons this is
950 # restricted to text files. It can be made more restricted by entering
951 # a global file pattern (e.g., ".html"). This is done by default.
952 # For each client requesting access, the file pattern(s) can be made
953 # more restrictive than the global pattern by entering client specific
954 # file patterns in the Access Control files (see 5).
955 # For example: if the ACCEPT file contained the lines
959 # Then all clients could request paths containing "DEMO" or "demo", e.g.
960 # "/my/demo/file.html" ($PATH_INFO =~ /\Q$pattern\E/), Clients from
961 # *.hum.uva.nl could also request paths containing "LET or "let", e.g.
962 # "/my/let/file.html", and clients from the local cluster
963 # 145.18.230.[0-9]+ could access ALL files.
964 # Again, for those needing more expressional power, lines starting with
965 # "-e" are evaluated. For instance:
966 # '-e $REMOTE_HOST =~ /\.edu$/is && $PATH_INFO =~ m@/DEMO/@is;'
967 # will accept/reject requests for files from the directory "/demo/" from
968 # clients from the domain '.edu'.
970 # 7 Access control: Server side session tickets
971 # Specific paths can be controlled by Session Tickets which must be
972 # present as a SESSIONTICKET=<value> CGI variable in the request. These paths
973 # are defined in %TicketRequiredPatterns as pairs of:
974 # ('regexp' => 'SessionPath\tPasswordPath\tLogin.html\tExpiration').
975 # Session Tickets are stored in a separate directory (SessionPath, e.g.,
976 # "Private/.Session") as files with the exact same name of the SESSIONTICKET
977 # CGI. The following is an example:
979 # IPaddress: 127.0.0.1
980 # AllowedPaths: ^/Private/Name/
984 # Other content can follow.
986 # It is adviced that Session Tickets should be deleted
987 # after some (idle) time. The IP address should be the IP number at login, and
988 # the SESSIONTICKET will be rejected if it is presented from another IP address.
989 # AllowedPaths and DeniedPaths are perl regexps. Be careful how they match. Make sure to delimit
990 # the names to prevent access to overlapping names, eg, "^/Private/Rob" will also
991 # match "^/Private/Robert", however, "^/Private/Rob/" will not. Expires is the
992 # time the ticket will remain valid after creation (file ctime). Time can be given
993 # in s[econds] (default), m[inutes], h[hours], or d[ays], eg, "24h" means 24 hours.
994 # None of these need be present, but the Ticket must have a non-zero size.
996 # Next to Session Tickets, there are two other type of ticket files:
997 # - LOGIN tickets store information about a current login request
998 # - PASSWORD ticket store account information to authorize login requests
1000 # 8 Query length limiting
1001 # The length of the Query string can be limited. If CONTENT_LENGTH is larger
1002 # than this limit, the request is rejected. The combined length of the
1003 # Query string and the POST input is checked before any processing is done.
1004 # This will prevent clients from overloading the scripts.
1005 # The actual, combined, Query Size is accessible as a variable through
1006 # $CGI_Content_Length.
1008 # 9 Illegal filenames, paths, and protected directories
1009 # One of the primary security concerns in handling CGI-scripts is the
1010 # use of "funny" characters in the requests that con scripts in executing
1011 # malicious commands. Examples are inserting ';', null bytes, or <newline>
1012 # characters in URL's and filenames, followed by executable commands. A
1013 # special variable $FileAllowedChars stores a string of all allowed
1014 # characters. Any request that translates to a filename with a character
1015 # OUTSIDE this set will be rejected.
1016 # In general, all (readable files) in the DocumentRoot tree are accessible.
1017 # This might not be what you want. For instance, your DocumentRoot directory
1018 # might be the working directory of a CVS project and contain sensitive
1019 # information (e.g., the password to get to the repository). You can block
1020 # access to these subdirectories by adding the corresponding patterns to
1021 # the $BlockPathAccess variable. For instance, $BlockPathAccess = '/CVS/'
1022 # will block any request that contains '/CVS/' or:
1023 # die if $BlockPathAccess && $ENV{'PATH_INFO'} =~ m@$BlockPathAccess@;
1025 #10 The execution of code blocks can be controlled in a transparent way
1026 # by adding IF or UNLESS conditions in the tags themselves. That is,
1027 # a simple check of the validity of filenames or email addresses can
1028 # be done before any code is executed.
1030 ###############################################################################
1032 # USER MANUAL (sort of)
1034 # CGIscriptor removes embedded scripts, indicated by an HTML 4 type
1035 # <SCRIPT TYPE='text/ssperl'> </SCRIPT> or <SCRIPT TYPE='text/osshell'>
1036 # </SCRIPT> constructs. CGIscriptor also recognizes XML-type
1037 # <SCRIPT TYPE='text/ssperl'/> constructs. These are usefull when
1038 # the necessary code is already available in the TAG itself (e.g.,
1039 # using external files). The contents of the directive are executed by
1040 # the PERL eval() and `` functions (in a separate name space). The
1041 # result of the eval() function replaces the <SCRIPT> </SCRIPT> construct
1042 # in the output file. You can use the values that are delivered in
1043 # CGI-compliant form (i.e., the "?name=value&.." type URL additions)
1044 # transparently as "$name" variables in your directives after they are
1045 # defined in a <META> or <SCRIPT> tag.
1046 # If you define the variable "$CGIscriptorResults" in a CGI attribute, all
1047 # subsequent <SCRIPT> and <META> results (including the defining
1048 # tag) will also be pushed onto a stack: @CGIscriptorResults. This list
1049 # behaves like any other, ordinary list and can be manipulated.
1051 # Both GET and POST requests are accepted. These two methods are treated
1052 # equal. Variables, i.e., those values that are determined when a file is
1053 # processed, are indicated in the CGI attribute by $<name> or $<name>=<default>
1054 # in which <name> is the name of the variable and <default> is the value
1055 # used when there is NO current CGI value for <name> (you can use
1056 # white-spaces in $<name>=<default> but really DO make sure that the
1057 # default value is followed by white space or is quoted). Names can contain
1058 # any alphanumeric characters and _ (i.e., names match /[\w]+/).
1059 # If the Content-type: is 'multipart/*', the input is treated as a
1060 # MIME multipart message and automatically delimited. CGI variables get
1061 # the "raw" (i.e., undecoded) body of the corresponding message part.
1063 # Variables can be CGI variables, i.e., those from the QUERY_STRING,
1064 # environment variables, e.g., REMOTE_USER, REMOTE_HOST, or REMOTE_ADDR,
1065 # or predefined values, e.g., CGI_Decoded_QS (The complete, decoded,
1066 # query string), CGI_Content_Length (the length of the decoded query
1067 # string), CGI_Year, CGI_Month, CGI_Time, and CGI_Hour (the current
1070 # All these are available when defined in a CGI attribute. All environment
1071 # variables are accessible as $ENV{'name'}. So, to access the REMOTE_HOST
1072 # and the REMOTE_USER, use, e.g.:
1074 # <SCRIPT TYPE='text/ssperl'>
1075 # ($ENV{'REMOTE_HOST'}||"-")." $ENV{'REMOTE_USER'}"
1078 # (This will print a "-" if REMOTE_HOST is not known)
1079 # Another way to do this is:
1081 # <META CONTENT="text/ssperl; CGI='$REMOTE_HOST = - $REMOTE_USER'">
1082 # <SCRIPT TYPE='text/ssperl'>"$REMOTE_HOST $REMOTE_USER"</SCRIPT>
1084 # <META CONTENT='text/ssperl; CGI="$REMOTE_HOST = - $REMOTE_USER"
1085 # SRC={"$REMOTE_HOST $REMOTE_USER\n"}'>
1087 # This is possible because ALL environment variables are available as
1088 # CGI variables. The environment variables take precedence over CGI
1089 # names in case of a "name clash". For instance:
1090 # <META CONTENT="text/ssperl; CGI='$HOME' SRC={$HOME}">
1091 # Will print the current HOME directory (environment) irrespective whether
1092 # there is a CGI variable from the query
1093 # (e.g., Where do you live? <INPUT TYPE="TEXT" NAME="HOME">)
1094 # THIS IS A SECURITY FEATURE. It prevents clients from changing
1095 # the values of defined environment variables (e.g., by supplying
1096 # a bogus $REMOTE_ADDR). Although $ENV{} is not changed by the META tags,
1097 # it would make the use of declared variables insecure. You can still
1098 # access CGI variables after a name clash with
1099 # CGIscriptor::CGIparseValue(<name>).
1101 # Some CGI variables are present several times in the query string
1102 # (e.g., from multiple selections). These should be defined as
1103 # @VARIABLENAME=default in the CGI attribute. The list @VARIABLENAME
1104 # will contain ALL VARIABLENAME values from the query, or a single
1105 # default value. If there is an ENVIRONMENT variable of the
1106 # same name, it will be used instead of the default AND the query
1107 # values. The corresponding function is
1108 # CGIscriptor::CGIparseValueList(<name>)
1110 # CGI variables collected in a @VARIABLENAME list are unordered.
1111 # When more structured variables are needed, a hash table can be used.
1112 # A variable defined as %VARIABLE=default will collect all
1113 # CGI-parameters whose name start with 'VARIABLE' in a hash table with
1114 # the remainder of the name as a key. For instance, %PERSON will
1115 # collect PERSONname='John Doe', PERSONbirthdate='01 Jan 00', and
1116 # PERSONspouse='Alice' into a hash table %PERSON such that $PERSON{'spouse'}
1117 # equals 'Alice'. Any default value or environment value will be stored
1118 # under the "" key. If there is an ENVIRONMENT variable of the same name,
1119 # it will be used instead of the default AND the query values. The
1120 # corresponding function is CGIscriptor::CGIparseValueHash(<name>)
1122 # This method of first declaring your environment and CGI variables
1123 # before being able to use them in the scripts might seem somewhat
1124 # clumsy, but it protects you from inadvertedly printing out the values of
1125 # system environment variables when their names coincide with those used
1126 # in the CGI forms. It also prevents "clients" from supplying CGI
1127 # parameter values for your private variables.
1128 # THIS IS A SECURITY FEATURE!
1131 # NON-HTML CONTENT TYPES
1133 # Normally, CGIscriptor prints the standard "Content-type: text/html\n\n"
1134 # message before anything is printed. This has been extended to include
1135 # plain text (.txt) files, for which the Content-type (MIME type)
1136 # 'text/plain' is printed. In all other respects, text files are treated
1137 # as HTML files (this can be switched off by removing '.txt' from the
1138 # $FilePattern variable) . When the content type should be something else,
1139 # e.g., with multipart files, use the $RawFilePattern (.xmr, see also next
1140 # item). CGIscriptor will not print a Content-type message for this file
1141 # type (which must supply its OWN Content-type message). Raw files must
1142 # still conform to the <SCRIPT></SCRIPT> and <META> tag specifications.
1147 # CGIscriptor is intended to process HTML and text files only. You can
1148 # create documents of any mime-type on-the-fly using "raw" text files,
1149 # e.g., with the .xmr extension. However, CGIscriptor will not process
1150 # binary files of any type, e.g., pictures or sounds. Given the sheer
1151 # number of formats, I do not have any intention to do so. However,
1152 # an escape route has been provided. You can construct a genuine raw
1153 # (.xmr) text file that contains the perl code to service any file type
1154 # you want. If the global $BinaryMapFile variable contains the path to
1155 # this file (e.g., /BinaryMapFile.xmr), this file will be called
1156 # whenever an unsupported (non-HTML) file type is requested. The path
1157 # to the requested binary file is stored in $ENV('CGI_BINARY_FILE')
1158 # and can be used like any other CGI-variable. Servicing binary files
1159 # then becomes supplying the correct Content-type (e.g., print
1160 # "Content-type: image/jpeg\n\n";) and reading the file and writing it
1161 # to STDOUT (e.g., using sysread() and syswrite()).
1166 # All attributes of a META tag are ignored, except the
1167 # CONTENT='text/ssperl; CGI=" ... " [SRC=" ... "]' attribute. The string
1168 # inside the quotes following the CONTENT= indication (white-space is
1169 # ignored, "" '' `` (){}[]-quote pairs are allowed, plus their \ versions)
1170 # MUST start with any of the CGIscriptor mime-types (e.g.: text/ssperl or
1171 # text/osshell) and a comma or semicolon.
1172 # The quoted string following CGI= contains a white-space separated list
1173 # of declarations of the CGI (and Environment) values and default values
1174 # used when no CGI values are supplied by the query string.
1176 # If the default value is a longer string containing special characters,
1177 # possibly spanning several lines, the string must be enclosed in quotes.
1178 # You may use any pair of quotes or brackets from the list '', "", ``, (),
1179 # [], or {} to distinguish default values (or preceded by \, e.g., \(...\)
1180 # is different from (...)). The outermost pair will always be used and any
1181 # other quotes inside the string are considered to be part of the string
1186 # will result in $Value getting the default value: ['this'
1188 # (NOTE that the newline is part of the default value!).
1190 # Internally, for defining and initializing CGI (ENV) values, the META
1191 # and SCRIPT tags use the functions "defineCGIvariable($name, $default)"
1192 # (scalars) and "defineCGIvariableList($name, $default)" (lists).
1193 # These functions can be used inside scripts as
1194 # "CGIscriptor::defineCGIvariable($name, $default)" and
1195 # "CGIscriptor::defineCGIvariableList($name, $default)".
1196 # "CGIscriptor::defineCGIvariableHash($name, $default)".
1198 # The CGI attribute will be processed exactly identical when used inside
1199 # the <SCRIPT> tag. However, this use is not according to the
1200 # HTML 4.0 specifications of the W3C.
1205 # There is a problem when constructing html files containing
1206 # server-side perl scripts with standard HTML tools. These
1207 # tools will refuse to process any text between <SCRIPT></SCRIPT>
1208 # tags. This is quite annoying when you want to use large
1209 # HTML templates where you will fill in values.
1211 # For this purpose, CGIscriptor will read the neutral
1212 # <DIV CLASS="ssperl" ID="varname"></DIV> or
1213 # <INS CLASS="ssperl" ID="varname"></INS>
1214 # tag (in Cascading Style Sheet manner) Note that
1215 # "varname" has NO '$' before it, it is a bare name.
1216 # Any text between these <DIV ...></DIV> or
1217 # <INS ...></INS>tags will be assigned to '$varname'
1218 # as is (e.g., as a literal).
1219 # No processing or interpolation will be performed.
1220 # There is also NO nesting possible. Do NOT nest a
1221 # </DIV> inside a <DIV></DIV>! Moreover, neither INS nor
1222 # DIV tags do ensure a block structure in the final
1223 # rendering (i.e., no empty lines).
1225 # Note that <DIV CLASS="ssperl" ID="varname"/>
1226 # is handled the XML way. No content is processed,
1227 # but varname is defined, and any SRC directives are
1230 # You can use $varname like any other variable name.
1231 # However, $varname is NOT a CGI variable and will be
1232 # completely internal to your script. There is NO
1233 # interaction between $varname and the outside world.
1235 # To interpolate a DIV derived text, you can use:
1236 # $varname =~ s/([\]])/\\\1/g; # Mark ']'-quotes
1237 # $varname = eval("qq[$varname]"); # Interpolate all values
1239 # The DIV tags will process IF, UNLESS, CGI and
1240 # SRC attributes. The SRC files will be pre-pended to the
1241 # body text of the tag. SRC blocks are NOT executed.
1243 # CONDITIONAL PROCESSING: THE 'IF' AND 'UNLESS' ATTRIBUTES
1245 # It is often necessary to include code-blocks that should be executed
1246 # conditionally, e.g., only for certain browsers or operating system.
1247 # Furthermore, quite often sanity and security checks are necessary
1248 # before user (form) data can be processed, e.g., with respect to
1249 # email addresses and filenames.
1251 # Checks added to the code are often difficult to find, interpret or
1252 # maintain and in general mess up the code flow. This kind of confussion
1254 # Also, for many of the supported "foreign" scripting languages, adding
1255 # these checks is cumbersome or even impossible.
1257 # As a uniform method for asserting the correctness of "context", two
1258 # attributes are added to all supported tags: IF and UNLESS.
1259 # They both evaluate their value and block execution when the
1260 # result is <FALSE> (IF) or <TRUE> (UNLESS) in Perl, e.g.,
1261 # UNLESS='$NUMBER \> 100;' blocks execution if $NUMBER <= 100. Note that
1262 # the backslash in the '\>' is removed and only used to differentiate
1263 # this conditional '>' from the tag-closing '>'. For symmetry, the
1264 # backslash in '\<' is also removed. Inside these conditionals,
1265 # ~/ and ./ are expanded to their respective directory root paths.
1267 # For example, the following tag will be ignored when the filename is
1270 # <SCRIPT TYPE='text/ssperl' CGI='$FILENAME'
1271 # IF='CGIscriptor::CGIsafeFileName($FILENAME);'>
1275 # The IF and UNLESS values must be quoted. The same quotes are supported
1276 # as with the other attributes. The SRC attribute is ignored when IF and
1277 # UNLESS block execution.
1279 # NOTE: 'IF' and 'UNLESS' always evaluate perl code.
1282 # THE MAGIC SOURCE ATTRIBUTE (SRC=)
1284 # The SRC attribute inside tags accepts a list of filenames and URL's
1285 # separated by "," comma's (or ";" semicolons).
1286 # ALL the variable values defined in the CGI attribute are available
1287 # in @ARGV as if the file or block was executed from the command line,
1288 # in the exact order in which they were declared in the preceding CGI
1291 # First, a SRC={}-block will be evaluated as if the code inside the
1292 # block was part of a <SCRIPT></SCRIPT> construct, i.e.,
1293 # "print do { code };'';" or `code` (i.e., SAFEqx('code)).
1294 # Only a single block is evaluated. Note that this is processed less
1295 # efficiently than <SCRIPT> </SCRIPT> blocks. Type of evaluation
1296 # depends on the content-type: Perl for text/ssperl and OS shell for
1297 # text/osshell. For other mime types (scripting languages), anything in
1298 # the source block is put in front of the code block "inside" the tag.
1300 # Second, executable files (i.e., -x filename != 0) are evaluated as:
1301 # print `filename \'$ARGV[0]\' \'$ARGV[1]\' ...`
1302 # That is, you can actually call executables savely from the SRC tag.
1304 # Third, text files that match the file pattern, used by CGIscriptor to
1305 # check whether files should be processed ($FilePattern), are
1306 # processed in-line (i.e., recursively) by CGIscriptor as if the code
1307 # was inserted in the original source file. Recursions, i.e., calling
1308 # a file inside itself, are blocked. If you need them, you have to code
1309 # them explicitely using "main::ProcessFile($file_path)".
1311 # Fourth, Perl text files (i.e., -T filename != 0) are evaluated as:
1312 # "do FileName;'';".
1314 # Last, URL's (i.e., starting with 'HTTP://', 'FTP://', 'GOPHER://',
1315 # 'TELNET://', 'WHOIS://' etc.) are loaded
1316 # and printed. The loading and handling of <BASE> and document header
1317 # is done by a command generated by main::GET_URL($URL [, 0]). You can enter your
1318 # own code (default is curl, wget, or snarf and some post-processing to add a <BASE> tag).
1320 # There are two pseudo-file names: PREFIX and POSTFIX. These implement
1321 # a switch from prefixing the SRC code/files (PREFIX, default) before the
1322 # content of the tag to appending the code after the content of the tag
1323 # (POSTFIX). The switches are done in the order in which the PREFIX and
1324 # POSTFIX labels are encountered. You can mix PREFIX and POSTFIX labels
1325 # in any order with the SRC files. Note that the ORDER of file execution
1326 # is determined for prefixed and postfixed files seperately.
1328 # File paths can be preceded by the URL protocol prefix "file://". This
1329 # is simply STRIPPED from the name.
1333 # "http://cgi-bin/Action_Forms.pl/Statistics/Sign_Test.html?positive=8&negative=22
1334 # will result in printing "${SS_PUB}/Statistics/Sign_Test.html"
1335 # With QUERY_STRING = "positive=8&negative=22"
1337 # on encountering the lines:
1338 # <META CONTENT="text/osshell; CGI='$positive=11 $negative=3'">
1339 # <b><SCRIPT LANGUAGE=PERL TYPE="text/ssperl" SRC="./Statistics/SignTest.pl">
1342 # This line will be processed as:
1343 # "<b>`${SS_SCRIPT}/Statistics/SignTest.pl '8' '22'`</b><p>"
1345 # In which "${SS_SCRIPT}/Statistics/SignTest.pl" is an executable script,
1346 # This line will end up printed as:
1347 # "<b>p <= 0.0161</b><p>"
1349 # Note that the META tag itself will never be printed, and is invisible to
1350 # the outside world.
1352 # The SRC files in a DIV or INS tag will be added (pre-pended) to the body
1353 # of the <DIV></DIV> tag. Blocks are NOT executed! If you do not
1354 # need any content, you can use the <DIV...../> format.
1357 # THE CGISCRIPTOR ROOT DIRECTORIES ~/ AND ./
1359 # Inside <SCRIPT></SCRIPT> tags, filepaths starting
1360 # with "~/" are replaced by "$YOUR_HTML_FILES/", this way files in the
1361 # public directories can be accessed without direct reference to the
1362 # actual paths. Filepaths starting with "./" are replaced by
1363 # "$YOUR_SCRIPTS/" and this should only be used for scripts.
1365 # Note: this replacement can seriously affect Perl scripts. Watch
1366 # out for constructs like $a =~ s/aap\./noot./g, use
1367 # $a =~ s@aap\.@noot.@g instead.
1369 # CGIscriptor.pl will assign the values of $SS_PUB and $SS_SCRIPT
1370 # (i.e., $YOUR_HTML_FILES and $YOUR_SCRIPTS) to the environment variables
1371 # $SS_PUB and $SS_SCRIPT. These can be accessed by the scripts that are
1373 # Values not preceded by $, ~/, or ./ are used as literals
1376 # OS SHELL SCRIPT EVALUATION (CONTENT-TYPE=TEXT/OSSHELL)
1378 # OS scripts are executed by a "safe" version of the `` operator (i.e.,
1379 # SAFEqx(), see also below) and any output is printed. CGIscriptor will
1380 # interpolate the script and replace all user-supplied CGI-variables by
1381 # their ''-quoted values (actually, all variables defined in CGI attributes
1382 # are quoted). Other Perl variables are interpolated in a simple fasion,
1383 # i.e., $scalar by their value, @list by join(' ', @list), and %hash by
1384 # their name=value pairs. Complex references, e.g., @$variable, are all
1385 # evaluated in a scalar context. Quotes should be used with care.
1386 # NOTE: the results of the shell script evaluation will appear in the
1387 # @CGIscriptorResults stack just as any other result.
1388 # All occurrences of $@% that should NOT be interpolated must be
1389 # preceeded by a "\". Interpolation can be switched off completely by
1390 # setting $CGIscriptor::NoShellScriptInterpolation = 1
1391 # (set to 0 or undef to switch interpolation on again)
1393 # <SCRIPT TYPE="text/ssperl">
1394 # $CGIscriptor::NoShellScriptInterpolation = 1;
1398 # RUN TIME TRANSLATION OF INPUT FILES
1400 # Allows general and global conversions of files using Regular Expressions.
1401 # Very handy (but costly) to rewrite legacy pages to a new format.
1402 # Select files to use it on with
1403 # my $TranslationPaths = 'filepattern';
1404 # This is costly. For efficiency, define:
1405 # $TranslationPaths = ''; when not using translations.
1406 # Accepts general regular expressions: [$pattern, $replacement]
1409 # my $TranslationPaths = 'filepattern'; # Pattern matching PATH_INFO
1411 # push(@TranslationTable, ['pattern', 'replacement']);
1412 # e.g. (for Ruby Rails):
1413 # push(@TranslationTable, ['<%=', '<SCRIPT TYPE="text/ssruby">']);
1414 # push(@TranslationTable, ['%>', '</SCRIPT>']);
1417 # my $currentRegExp;
1418 # foreach $currentRegExp (@TranslationTable)
1420 # my ($pattern, $replacement) = @$currentRegExp;
1421 # $$text =~ s!$pattern!$replacement!msg;
1425 # EVALUATION OF OTHER SCRIPTING LANGUAGES
1427 # Adding a MIME-type and an interpreter command to
1428 # %ScriptingLanguages automatically will catch any other
1429 # scripting language in the standard
1430 # <SCRIPT TYPE="[mime]"></SCRIPT> manner.
1431 # E.g., adding: $ScriptingLanguages{'text/sspython'} = 'python';
1432 # will actually execute the folowing code in an HTML page
1433 # (ignore 'REMOTE_HOST' for the moment):
1434 # <SCRIPT TYPE="text/sspython">
1436 # x = ["A","real","python","script","Hello","World","and", REMOTE_HOST]
1437 # print x[4:8] # Prints the list ["Hello","World","and", REMOTE_HOST]
1440 # The script code is NOT interpolated by perl, EXCEPT for those
1441 # interpreters that cannot handle variables themselves.
1442 # Currently, several interpreters are pre-installed:
1444 # Perl test - "text/testperl" => 'perl',
1445 # Python - "text/sspython" => 'python',
1446 # Ruby - "text/ssruby" => 'ruby',
1447 # Tcl - "text/sstcl" => 'tcl',
1448 # Awk - "text/ssawk" => 'awk -f-',
1449 # Gnu Lisp - "text/sslisp" => 'rep | tail +5 '.
1450 # "| egrep -v '> |^rep. |^nil\\\$'",
1451 # XLispstat - "text/xlispstat" => 'xlispstat | tail +7 '.
1452 # "| egrep -v '> \\\$|^NIL'",
1453 # Gnu Prolog- "text/ssprolog" => 'gprolog',
1454 # M4 macro's- "text/ssm4" => 'm4',
1455 # Born shell- "text/sh" => 'sh',
1456 # Bash - "text/bash" => 'bash',
1457 # C-shell - "text/csh" => 'csh',
1458 # Korn shell- "text/ksh" => 'ksh',
1459 # Praat - "text/sspraat" => "praat - | sed 's/Praat > //g'",
1460 # R - "text/ssr" => "R --vanilla --slave | sed 's/^[\[0-9\]*] //g'",
1461 # REBOL - "text/ssrebol" =>
1462 # "rebol --quiet|egrep -v '^[> ]* == '|sed 's/^\s*\[> \]* //g'",
1463 # PostgreSQL- "text/postgresql" => 'psql 2>/dev/null',
1466 # Note that the "value" of $ScriptingLanguages{mime} must be a command
1467 # that reads Standard Input and writes to standard output. Any extra
1468 # output of interactive interpreters (banners, echo's, prompts)
1469 # should be removed by piping the output through 'tail', 'grep',
1470 # 'sed', or even 'awk' or 'perl'.
1472 # For access to CGI variables there is a special hashtable:
1473 # %ScriptingCGIvariables.
1474 # CGI variables can be accessed in three ways.
1475 # 1. If the mime type is not present in %ScriptingCGIvariables,
1476 # nothing is done and the script itself should parse the relevant
1477 # environment variables.
1478 # 2. If the mime type IS present in %ScriptingCGIvariables, but it's
1479 # value is empty, e.g., $ScriptingCGIvariables{"text/sspraat"} = '';,
1480 # the script text is interpolated by perl. That is, all $var, @array,
1481 # %hash, and \-slashes are replaced by their respective values.
1482 # 3. In all other cases, the CGI and environment variables are added
1483 # in front of the script according to the format stored in
1484 # %ScriptingCGIvariables. That is, the following (pseudo-)code is
1485 # executed for each CGI- or Environment variable defined in the CGI-tag:
1486 # printf(INTERPRETER, $ScriptingCGIvariables{$mime}, $CGI_NAME, $CGI_VALUE);
1488 # For instance, "text/testperl" => '$%s = "%s";' defines variable
1489 # definitions for Perl, and "text/sspython" => '%s = "%s"' for Python
1490 # (note that these definitions are not save, the real ones contain '-quotes).
1492 # THIS WILL NOT WORK FOR @VARIABLES, the (empty) $VARIABLES will be used
1495 # The $CGI_VALUE parameters are "shrubed" of all control characters
1496 # and quotes (by &shrubCGIparameter($CGI_VALUE)) for the options 2 and 3.
1497 # Control characters are replaced by \0<octal ascii value> (the exception
1498 # is \015, the newline, which is replaced by \n) and quotes
1499 # and backslashes by their HTML character
1500 # value (' -> ' ` -> ` " -> " \ -> \ & -> &er;).
1502 # if a client would supply the string value (in standard perl, e.g.,
1503 # \n means <newline>)
1504 # "/dev/null';\nrm -rf *;\necho '"
1505 # it would be processed as
1506 # '/dev/null';\nrm -rf *;\necho ''
1507 # (e.g., sh or bash would process the latter more according to your
1509 # If your intepreter requires different protection measures, you will
1510 # have to supply these in %main::SHRUBcharacterTR (string => translation),
1511 # e.g., $SHRUBcharacterTR{"\'"} = "'";
1513 # Currently, the following definitions are used:
1514 # %ScriptingCGIvariables = (
1515 # "text/testperl" => "\$\%s = '\%s';", # Perl $VAR = 'value' (for testing)
1516 # "text/sspython" => "\%s = '\%s'", # Python VAR = 'value'
1517 # "text/ssruby" => '@%s = "%s"', # Ruby @VAR = "value"
1518 # "text/sstcl" => 'set %s "%s"', # TCL set VAR "value"
1519 # "text/ssawk" => '%s = "%s";', # Awk VAR = "value";
1520 # "text/sslisp" => '(setq %s "%s")', # Gnu lisp (rep) (setq VAR "value")
1521 # "text/xlispstat" => '(setq %s "%s")', # Xlispstat (setq VAR "value")
1522 # "text/ssprolog" => '', # Gnu prolog (interpolated)
1523 # "text/ssm4" => "define(`\%s', `\%s')", # M4 macro's define(`VAR', `value')
1524 # "text/sh" => "\%s='\%s';", # Born shell VAR='value';
1525 # "text/bash" => "\%s='\%s';", # Born again shell VAR='value';
1526 # "text/csh" => "\$\%s = '\%s';", # C shell $VAR = 'value';
1527 # "text/ksh" => "\$\%s = '\%s';", # Korn shell $VAR = 'value';
1528 # "text/sspraat" => '', # Praat (interpolation)
1529 # "text/ssr" => '%s <- "%s";', # R VAR <- "value";
1530 # "text/ssrebol" => '%s: copy "%s"', # REBOL VAR: copy "value"
1531 # "text/postgresql" => '', # PostgreSQL (interpolation)
1535 # Four tables allow fine-tuning of interpreter with code that should be
1536 # added before and after each code block:
1538 # Code added before each script block
1539 # %ScriptingPrefix = (
1540 # "text/testperl" => "\# Prefix Code;", # Perl script testing
1541 # "text/ssm4" => 'divert(0)' # M4 macro's (open STDOUT)
1543 # Code added at the end of each script block
1544 # %ScriptingPostfix = (
1545 # "text/testperl" => "\# Postfix Code;", # Perl script testing
1546 # "text/ssm4" => 'divert(-1)' # M4 macro's (block STDOUT)
1548 # Initialization code, inserted directly after opening (NEVER interpolated)
1549 # %ScriptingInitialization = (
1550 # "text/testperl" => "\# Initialization Code;", # Perl script testing
1551 # "text/ssawk" => 'BEGIN {', # Server Side awk scripts
1552 # "text/sslisp" => '(prog1 nil ', # Lisp (rep)
1553 # "text/xlispstat" => '(prog1 nil ', # xlispstat
1554 # "text/ssm4" => 'divert(-1)' # M4 macro's (block STDOUT)
1556 # Cleanup code, inserted before closing (NEVER interpolated)
1557 # %ScriptingCleanup = (
1558 # "text/testperl" => "\# Cleanup Code;", # Perl script testing
1559 # "text/sspraat" => 'Quit',
1560 # "text/ssawk" => '};', # Server Side awk scripts
1561 # "text/sslisp" => '(princ "\n" standard-output)).' # Closing print to rep
1562 # "text/xlispstat" => '(print "" *standard-output*)).' # Closing print to xlispstat
1563 # "text/postgresql" => '\q',
1567 # The SRC attribute is NOT magical for these interpreters. In short,
1568 # all code inside a source file or {} block is written verbattim
1569 # to the interpreter. No (pre-)processing or executional magic is done.
1571 # A serious shortcomming of the described mechanism for handling other
1572 # (scripting) languages, with respect to standard perl scripts
1573 # (i.e., 'text/ssperl'), is that the code is only executed when
1574 # the pipe to the interpreter is closed. So the pipe has to be
1575 # closed at the end of each block. This means that the state of the
1576 # interpreter (e.g., all variable values) is lost after the closing of
1577 # the next </SCRIPT> tag. The standard 'text/ssperl' scripts retain
1578 # all values and definitions.
1580 # APPLICATION MIME TYPES
1582 # To ease some important auxilliary functions from within the
1583 # html pages I have added them as MIME types. This uses
1584 # the mechanism that is also used for the evaluation of
1585 # other scripting languages, with interpolation of CGI
1586 # parameters (and perl-variables). Actually, these are
1587 # defined exactly like any other "scripting language".
1589 # text/ssdisplay: display some (HTML) text with interpolated
1590 # variables (uses `cat`).
1591 # text/sslogfile: write (append) the interpolated block to the file
1592 # mentioned on the first, non-empty line
1593 # (the filename can be preceded by 'File: ',
1594 # note the space after the ':',
1595 # uses `awk .... >> <filename>`).
1596 # text/ssmailto: send email directly from within the script block.
1597 # The first line of the body must contain
1598 # To:Name@Valid.Email.Address
1599 # (note: NO space between 'To:' and the email adres)
1600 # For other options see the mailto man pages.
1601 # It works by directly sending the (interpolated)
1602 # content of the text block to a pipe into the
1603 # Linux program 'mailto'.
1605 # In these script blocks, all Perl variables will be
1606 # replaced by their values. All CGI variables are cleaned before
1607 # they are used. These CGI variables must be redefined with a
1608 # CGI attribute to restore their original values.
1609 # In general, this will be more secure than constructing
1610 # e.g., your own email command lines. For instance, Mailto will
1611 # not execute any odd (forged) email addres, but just stops
1612 # when the email address is invalid and awk will construct
1613 # any filename you give it (e.g. '<File;rm\\\040-f' would end up
1614 # as a "valid" UNIX filename). Note that it will also gladly
1615 # store this file anywhere (/../../../etc/passwd will work!).
1616 # Use the CGIscriptor::CGIsafeFileName() function to clean the
1619 # SHELL SCRIPT PIPING
1621 # If a shell script starts with the UNIX style "#! <shell command> \n"
1622 # line, the rest of the shell script is piped into the indicated command,
1624 # open(COMMAND, "| command");print COMMAND $RestOfScript;
1626 # In many ways this is equivalent to the MIME-type profiling for
1627 # evaluating other scripting languages as discussed above. The
1628 # difference breaks down to convenience. Shell script piping is a
1629 # "raw" implementation. It allows you to control all aspects of
1630 # execution. Using the MIME-type profiling is easier, but has a
1631 # lot of defaults built in that might get in the way. Another
1632 # difference is that shell script piping uses the SAFEqx() function,
1633 # and MIME-type profiling does not.
1635 # Execution of shell scripts is under the control of the Perl Script blocks
1636 # in the document. The MIME-type triggered execution of <SCRIPT></SCRIPT>
1637 # blocks can be simulated easily. You can switch to a different shell,
1638 # e.g. tcl, completely by executing the following Perl commands inside
1641 # <SCRIPT TYPE="text/ssperl">
1642 # $main::ShellScriptContentType = "text/ssTcl"; # Yes, you can do this
1643 # CGIscriptor::RedirectShellScript('/usr/bin/tcl'); # Pipe to Tcl
1644 # $CGIscriptor::NoShellScriptInterpolation = 1;
1647 # After this script is executed, CGIscriptor will parse scripts of
1648 # TYPE="text/ssTcl" and pipe their contents into '|/usr/bin/tcl'
1649 # WITHOUT interpolation (i.e., NO substitution of Perl variables).
1650 # The crucial function is :
1651 # CGIscriptor::RedirectShellScript('/usr/bin/tcl')
1652 # After executing this function, all shell scripts AND all
1653 # calls to SAFEqx()) are piped into '|/usr/bin/tcl'. If the argument
1654 # of RedirectShellScript is empty, e.g., '', the original (default)
1657 # The standard output, STDOUT, of any pipe is send to the client.
1658 # Currently, you should be carefull with quotes in such a piped script.
1659 # The results of a pipe is NOT put on the @CGIscriptorResults stack.
1660 # As a result, you do not have access to the output of any piped (#!)
1661 # process! If you want such access, execute
1662 # <SCRIPT TYPE="text/osshell">echo "script"|command</SCRIPT>
1664 # <SCRIPT TYPE="text/ssperl">
1665 # $resultvar = SAFEqx('echo "script"|command');
1668 # Safety is never complete. Although SAFEqx() prevents some of the
1669 # most obvious forms of attacks and security slips, it cannot prevent
1670 # them all. Especially, complex combinations of quotes and intricate
1671 # variable references cannot be handled safely by SAFEqx. So be on
1675 # PERL CODE EVALUATION (CONTENT-TYPE=TEXT/SSPERL)
1677 # All PERL scripts are evaluated inside a PERL package. This package
1678 # has a separate name space. This isolated name space protects the
1679 # CGIscriptor.pl program against interference from user code. However,
1680 # some variables, e.g., $_, are global and cannot be protected. You are
1681 # advised NOT to use such global variable names. You CAN write
1682 # directives that directly access the variables in the main program.
1683 # You do so at your own risk (there is definitely enough rope available
1684 # to hang yourself). The behavior of CGIscriptor becomes undefined if
1685 # you change its private variables during run time. The PERL code
1686 # directives are used as in:
1687 # $Result = eval($directive); print $Result;'';
1688 # ($directive contains all text between <SCRIPT></SCRIPT>).
1689 # That is, the <directive> is treated as ''-quoted string and
1690 # the result is treated as a scalar. To prevent the VALUE of the code
1691 # block from appearing on the client's screen, end the directive with
1692 # ';""</SCRIPT>'. Evaluated directives return the last value, just as
1693 # eval(), blocks, and subroutines, but only as a scalar.
1695 # IMPORTANT: All PERL variables defined are persistent. Each <SCRIPT>
1696 # </SCRIPT> construct is evaluated as a {}-block with associated scope
1697 # (e.g., for "my $var;" declarations). This means that values assigned
1698 # to a PERL variable can be used throughout the document unless they
1699 # were declared with "my". The following will actually work as intended
1700 # (note that the ``-quotes in this example are NOT evaluated, but used
1701 # as simple quotes):
1703 # <META CONTENT="text/ssperl; CGI=`$String='abcdefg'`">
1705 # <SCRIPT TYPE=text/ssperl>@List = split('', $String);</SCRIPT>
1707 # <SCRIPT TYPE=text/ssperl>join(", ", @List[1..$#List]);</SCRIPT>
1709 # The first <SCRIPT TYPE=text/ssperl></SCRIPT> construct will return the
1710 # value scalar(@List), the second <SCRIPT TYPE=text/ssperl></SCRIPT>
1711 # construct will print the elements of $String separated by commas, leaving
1712 # out the first element, i.e., $List[0].
1714 # Another warning: './' and '~/' are ALWAYS replaced by the values of
1715 # $YOUR_SCRIPTS and $YOUR_HTML_FILES, respectively . This can interfere
1716 # with pattern matching, e.g., $a =~ s/aap\./noot\./g will result in the
1717 # evaluations of $a =~ s/aap\\${YOUR_SCRIPTS}noot\\${YOUR_SCRIPTS}g. Use
1718 # s@<regexp>.@<replacement>.@g instead.
1721 # SERVER SIDE SESSIONS AND ACCESS CONTROL (LOGIN)
1723 # An infrastructure for user acount authorization and file access control
1724 # is available. Each request is matched against a list of URL path patterns.
1725 # If the request matches, a Session Ticket is required to access the URL.
1726 # This Session Ticket should be present as a CGI parameter or Cookie, eg:
1728 # CGI: SESSIONTICKET=<value>
1729 # Cookie: CGIscriptorSESSION=<value>
1731 # The example implementation stores Session Tickets as files in a local
1732 # directory. To create Session Tickets, a Login request must be given
1733 # with a LOGIN=<value> CGI parameter, a user name and a (doubly hashed)
1734 # password. The user name and (singly hashed) password are stored in a
1735 # PASSWORD ticket with the same name as the user account (name cleaned up
1738 # The example session model implements 3 functions:
1740 # The password is hashed with the user name and server side salt, and then
1741 # hashed with a random salt. Client and Server both perform these actions
1742 # and the Server only grants access if restults are the same. The server
1743 # side only stores the password hashed with the user name and
1744 # server side salt. Neither the plain password, nor the hashed password is
1745 # ever exchanged. Only values hashed with the one-time salt are exchanged.
1747 # For every access to a restricted URL, the Session Ticket is checked before
1748 # access is granted. There are three session modes. The first uses a fixed
1749 # Session Ticket that is stored as a cookie value in the browser (actually,
1750 # as a sessionStorage value). The second uses only the IP address at login
1751 # to authenticate requests. The third
1752 # is a Challenge mode, where the client has to calculate the value of the
1753 # next one-time Session Ticket from a value derived from the password and
1756 # A new password is hashed with the user name and server side salt, and
1757 # then encrypted (XORed)
1758 # with the old password hashed with the user name and salt. That value is
1759 # exchanged and XORed with the stored old hashed(salt+password+username).
1760 # Again, the stored password value is never exchanged unencrypted.
1764 # The session authentication mechanism is based on the exchange of ticket
1765 # identifiers. A ticket identifier is just a string of characters, a name
1766 # or a random 64 character hexadecimal string. Ticket identifiers should be
1767 # "safe" filenames (except user names). There are four types of tickets:
1768 # PASSWORD: User account descriptors, including a user name and password
1769 # LOGIN: Temporary anonymous tickets used during login
1770 # IPADDRESS: Authetication tokens that allow access based on the IP address of the request
1771 # SESSION: Reusable authetication tokens
1772 # CHALLENGE: One-time authetication tokens
1773 # All tickets can have an expiration date in the form of a time duration
1774 # from creation, in seconds, minutes, hours, or days (+duration[smhd]).
1775 # An absolute time can be given in seconds since the epoch of the server host.
1776 # Note that expiration times of CHALLENGE authetication tokens are calculated
1777 # from the last access time. Accounts can include a maximal lifetime
1778 # for session tickets (MaxLifetime).
1780 # A Login page should create a LOGIN ticket file locally and send a
1781 # server specific salt, a Random salt, and a LOGIN ticket
1782 # identifier. The server side compares the username and hashed password,
1783 # actually hashed(Random salt+hashed(serversalt+password)) from the client with
1784 # the values it calculates from the stored Random salt from the LOGIN
1785 # ticket and the hashed(serversalt+password) from the PASSWORD ticket. If
1786 # successful, a new SESSION ticket is generated as a hash sum of the LOGIN
1787 # ticket and the stored password. This SESSION ticket should also be
1788 # generated by the client and stored as sessionStorage and cookie values
1789 # as needed. The Username, IP address and Path are available as
1790 # $LoginUsername, $LoginIPaddress, and $LoginPath, respectively.
1792 # The CHALLENGE protocol stores the same value as the SESSION tickets.
1793 # However, this value is not exchanged, but kept secret in the JavaScript
1794 # sessionStorage object. Instead, every page returned from the
1795 # server will contain a one-time Challenge value ($CHALLENGETICKET) which
1796 # has to be hashed with the stored value to return the current ticket
1799 # In the current example implementation, all random values are created as
1800 # full, 256 bit SHA256 hash values (Hex strings) of 64 bytes read from
1803 # Security considerations with Session tickets
1805 # For strong security, please use end-to-end encryption. This can be
1806 # achieved using a VPN (Virtual Private Network), SSH tunnel, or a HTTPS
1807 # capable server with OpenSSL. The session ticket system of CGIscriptor.pl
1808 # is intended to be used as a simple authentication mechanism WITHOUT
1809 # END-TO-END ENCRYPTION. The authenticating mechanism tries to use some
1810 # simple means to protect the authentication process from eavesdropping.
1811 # For this it uses a secure hash function, SHA256. For all practial purposes,
1812 # it is impossible to "decrypt" a SHA256 sum. But this login scheme is
1813 # only as secure as your browser. Which, in general, is not very secure.
1815 # Humans tend to reuse passwords. A compromise of a site running
1816 # CGIscriptor.pl could therefore lead to a compromise of user accounts at
1817 # other sites. Therefore, plain text passwords are never stored, used, or
1818 # exchanged. Instead, a server site salt value is "encrypted" with
1819 # the plain password and user name. Actually, all are concatenated and hashed
1820 # with a one-way secure hash function (SHA256) into a single string.
1821 # Whenever the word "password" is used, this hash sum is meant. Note that
1822 # the salts are generated from /dev/urandom. You should check whether the
1823 # implementation of /dev/urandom on your platform is secure before
1824 # relying on it. This might be a problem when running CGIscriptor under
1825 # Cygwin on MS Windows.
1826 # Note: not attempt is made to slow down the password hash, so bad
1827 # passwords can be cracked by brute force
1829 # For the authentication and a change of password, the (old) password
1830 # is used to "encrypt" a random one-time token or the new password,
1831 # respectively. For authentication, decryption is not needed, so a secure
1832 # hash function (SHA256) is used to create a one-way hash sum "encryption".
1833 # A new password must be decrypted. New passwords are encryped by XORing
1834 # them with the old password.
1838 # A CGIscriptor package is attached to the bottom of this file. With
1839 # this package you can personalize your version of CGIscriptor by
1840 # including often used perl routines. These subroutines can be
1841 # accessed by prefixing their names with CGIscriptor::, e.g.,
1842 # <SCRIPT LANGUAGE=PERL TYPE=text/ssperl>
1843 # CGIscriptor::ListDocs("/Books/*") # List all documents in /Books
1845 # It already contains some useful subroutines for Document Management.
1846 # As it is a separate package, it has its own namespace, isolated from
1847 # both the evaluator and the main program. To access variables from
1848 # the document <SCRIPT></SCRIPT> blocks, use $CGIexecute::<var>.
1850 # Currently, the following functions are implemented
1851 # (precede them with CGIscriptor::, see below for more information)
1852 # - SAFEqx ('String') -> result of qx/"String"/ # Safe application of ``-quotes
1853 # Is used by text/osshell Shell scripts. Protects all CGI
1854 # (client-supplied) values with single quotes before executing the
1855 # commands (one of the few functions that also works WITHOUT CGIscriptor::
1857 # - defineCGIvariable ($name[, $default) -> 0/1 (i.e., failure/success)
1858 # Is used by the META tag to define and initialize CGI and ENV
1859 # name/value pairs. Tries to obtain an initializing value from (in order):
1862 # The default value given (if any)
1863 # (one of the few functions that also works WITHOUT CGIscriptor::
1865 # - CGIsafeFileName (FileName) -> FileName or ""
1866 # Check a string against the Allowed File Characters (and ../ /..).
1867 # Returns an empty string for unsafe filenames.
1868 # - CGIsafeEmailAddress (Email) -> Email or ""
1869 # Check a string against correct email address pattern.
1870 # Returns an empty string for unsafe addresses.
1871 # - RedirectShellScript ('CommandString') -> FILEHANDLER or undef
1872 # Open a named PIPE for SAFEqx to receive ALL shell scripts
1873 # - URLdecode (URL encoded string) -> plain string # Decode URL encoded argument
1874 # - URLencode (plain string) -> URL encoded string # Encode argument as URL code
1875 # - CGIparseValue (ValueName [, URL_encoded_QueryString]) -> Decoded value
1876 # Extract the value of a CGI variable from the global or a private
1877 # URL-encoded query (multipart POST raw, NOT decoded)
1878 # - CGIparseValueList (ValueName [, URL_encoded_QueryString])
1879 # -> List of decoded values
1880 # As CGIparseValue, but now assembles ALL values of ValueName into a list.
1881 # - CGIparseHeader (ValueName [, URL_encoded_QueryString]) -> Header
1882 # Extract the header of a multipart CGI variable from the global or a private
1883 # URL-encoded query ("" when not a multipart variable or absent)
1884 # - CGIparseForm ([URL_encoded_QueryString]) -> Decoded Form
1885 # Decode the complete global URL-encoded query or a private
1887 # - read_url(URL) # Returns the page from URL (with added base tag, both FTP and HTTP)
1888 # Uses main::GET_URL(URL, 1) to get at the command to read the URL.
1889 # - BrowseDirs(RootDirectory [, Pattern, Startdir, CGIname]) # print browsable directories
1890 # - ListDocs(Pattern [,ListType]) # Prints a nested HTML directory listing of
1891 # all documents, e.g., ListDocs("/*", "dl");.
1892 # - HTMLdocTree(Pattern [,ListType]) # Prints a nested HTML listing of all
1893 # local links starting from a given document, e.g.,
1894 # HTMLdocTree("/Welcome.html", "dl");
1897 # THE RESULTS STACK: @CGISCRIPTORRESULTS
1899 # If the pseudo-variable "$CGIscriptorResults" has been defined in a
1900 # META tag, all subsequent SCRIPT and META results are pushed
1901 # on the @CGIscriptorResults stack. This list is just another
1902 # Perl variable and can be used and manipulated like any other list.
1903 # $CGIscriptorResults[-1] is always the last result.
1904 # This is only of limited use, e.g., to use the results of an OS shell
1905 # script inside a Perl script. Will NOT contain the results of Pipes
1906 # or code from MIME-profiling.
1909 # USEFULL CGI PREDEFINED VARIABLES (DO NOT ASSIGN TO THESE)
1911 # $CGI_HOME - The DocumentRoot directory
1912 # $CGI_Decoded_QS - The complete decoded Query String
1913 # $CGI_Content_Length - The ACTUAL length of the Query String
1914 # $CGI_Date - Current date and time
1915 # $CGI_Year $CGI_Month $CGI_Day $CGI_WeekDay - Current Date
1916 # $CGI_Time - Current Time
1917 # $CGI_Hour $CGI_Minutes $CGI_Seconds - Current Time, split
1919 # $CGI_GMTYear $CGI_GMTMonth $CGI_GMTDay $CGI_GMTWeekDay $CGI_GMTYearDay
1920 # $CGI_GMTHour $CGI_GMTMinutes $CGI_GMTSeconds $CGI_GMTisdst
1923 # USEFULL CGI ENVIRONMENT VARIABLES
1925 # Variables accessible (in APACHE) as $ENV{<name>}
1926 # (see: "http://hoohoo.ncsa.uiuc.edu/cgi/env.html"):
1928 # QUERY_STRING - The query part of URL, that is, everything that follows the
1930 # PATH_INFO - Extra path information given after the script name
1931 # PATH_TRANSLATED - Extra pathinfo translated through the rule system.
1932 # (This doesn't always make sense.)
1933 # REMOTE_USER - If the server supports user authentication, and the script is
1934 # protected, this is the username they have authenticated as.
1935 # REMOTE_HOST - The hostname making the request. If the server does not have
1936 # this information, it should set REMOTE_ADDR and leave this unset
1937 # REMOTE_ADDR - The IP address of the remote host making the request.
1938 # REMOTE_IDENT - If the HTTP server supports RFC 931 identification, then this
1939 # variable will be set to the remote user name retrieved from
1940 # the server. Usage of this variable should be limited to logging
1942 # AUTH_TYPE - If the server supports user authentication, and the script
1943 # is protected, this is the protocol-specific authentication
1944 # method used to validate the user.
1945 # CONTENT_TYPE - For queries which have attached information, such as HTTP
1946 # POST and PUT, this is the content type of the data.
1947 # CONTENT_LENGTH - The length of the said content as given by the client.
1948 # SERVER_SOFTWARE - The name and version of the information server software
1949 # answering the request (and running the gateway).
1950 # Format: name/version
1951 # SERVER_NAME - The server's hostname, DNS alias, or IP address as it
1952 # would appear in self-referencing URLs
1953 # GATEWAY_INTERFACE - The revision of the CGI specification to which this
1954 # server complies. Format: CGI/revision
1955 # SERVER_PROTOCOL - The name and revision of the information protocol this
1956 # request came in with. Format: protocol/revision
1957 # SERVER_PORT - The port number to which the request was sent.
1958 # REQUEST_METHOD - The method with which the request was made. For HTTP,
1959 # this is "GET", "HEAD", "POST", etc.
1960 # SCRIPT_NAME - A virtual path to the script being executed, used for
1961 # self-referencing URLs.
1962 # HTTP_ACCEPT - The MIME types which the client will accept, as given by
1963 # HTTP headers. Other protocols may need to get this
1964 # information from elsewhere. Each item in this list should
1965 # be separated by commas as per the HTTP spec.
1966 # Format: type/subtype, type/subtype
1967 # HTTP_USER_AGENT - The browser the client is using to send the request.
1968 # General format: software/version library/version.
1971 # INSTRUCTIONS FOR RUNNING CGIscriptor ON UNIX
1973 # CGIscriptor.pl will run on any WWW server that runs Perl scripts, just add
1974 # a line like the following to your srm.conf file (Apache example):
1976 # ScriptAlias /SHTML/ /real-path/CGIscriptor.pl/
1978 # URL's that refer to http://www.your.address/SHTML/... will now be handled
1979 # by CGIscriptor.pl, which can use a private directory tree (default is the
1980 # DOCUMENT_ROOT directory tree, but it can be anywhere, see manual).
1982 # If your hosting ISP won't let you add ScriptAlias lines you can use
1983 # the following "rewrite"-based "scriptalias" in .htaccess
1984 # (from Gerd Franke)
1988 # RewriteCond %{REQUEST_FILENAME} .html$
1989 # RewriteCond %{SCRIPT_FILENAME} !cgiscriptor.pl$
1990 # RewriteCond %{REQUEST_FILENAME} -f
1991 # RewriteRule ^(.*)$ /cgi-bin/cgiscriptor.pl/$1?&%{QUERY_STRING}
1993 # Everthing with the extension ".html" and not including "cgiscriptor.pl"
1994 # in the url and where the file "path/filename.html" exists is redirected
1995 # to "/cgi.bin/cgiscriptor.pl/path/filename.html?query".
1996 # The user configuration should get the same path-level as the
1999 # # Just enter your own directory path here
2000 # $YOUR_HTML_FILES = "$ENV{'DOCUMENT_ROOT'}";
2001 # # use DOCUMENT_ROOT only, if .htaccess lies in the root-directory.
2003 # If this .htaccess goes in a specific directory, the path to this
2004 # directory must be added to $ENV{'DOCUMENT_ROOT'}.
2006 # The CGIscriptor file contains all documentation as comments. These
2007 # comments can be removed to speed up loading (e.g., `egrep -v '^#'
2008 # CGIscriptor.pl` > leanScriptor.pl). A bare bones version of
2009 # CGIscriptor.pl, lacking documentation, most comments, access control,
2010 # example functions etc. (but still with the copyright notice and some
2011 # minimal documentation) can be obtained by calling CGIscriptor.pl on the
2012 # command line with the '-slim' command line argument, e.g.,
2014 # >CGIscriptor.pl -slim > slimCGIscriptor.pl
2016 # CGIscriptor.pl can be run from the command line with <path> and <query> as
2017 # arguments, as `CGIscriptor.pl <path> <query>`, inside a perl script
2018 # with 'do CGIscriptor.pl' after setting $ENV{PATH_INFO}
2019 # and $ENV{QUERY_STRING}, or CGIscriptor.pl can be loaded with 'require
2020 # "/real-path/CGIscriptor.pl"'. In the latter case, requests are processed
2021 # by 'Handle_Request();' (again after setting $ENV{PATH_INFO} and
2022 # $ENV{QUERY_STRING}).
2024 # Using the command line execution option, CGIscriptor.pl can be used as a
2025 # document (meta-)preprocessor. If the first argument is '-', STDIN will be read.
2028 # > cat MyDynamicDocument.html | CGIscriptor.pl - '[QueryString]' > MyStaticFile.html
2030 # This command line will produce a STATIC file with the DYNAMIC content of
2031 # MyDocument.html "interpolated".
2033 # This option would be very dangerous when available over the internet.
2034 # If someone could sneak a 'http://www.your.domain/-' URL past your
2035 # server, CGIscriptor could EXECUTE any POSTED contend.
2036 # Therefore, for security reasons, STDIN will NOT be read
2037 # if ANY of the HTTP server environment variables is set (e.g.,
2038 # SERVER_PORT, SERVER_PROTOCOL, SERVER_NAME, SERVER_SOFTWARE,
2039 # HTTP_USER_AGENT, REMOTE_ADDR).
2040 # This block on processing STDIN on HTTP requests can be lifted by setting
2041 # $BLOCK_STDIN_HTTP_REQUEST = 0;
2042 # In the security configuration. Butbe carefull when doing this.
2043 # It can be very dangerous.
2045 # Running demo's and more information can be found at
2046 # http://www.fon.hum.uva.nl/~rob/OSS/OSS.html
2048 # A pocket-size HTTP daemon, CGIservlet.pl, is available from my web site or
2049 # CPAN that can use CGIscriptor.pl as the base of a µWWW server and
2050 # demonstrates its use.
2053 # PROCESSING NON-FILESYSTEM DATA
2055 # Normally, HTTP (WWW) requests map onto file that can be accessed
2056 # using the perl open() function. That is, the web server runs on top of
2057 # some directory structure. However, we can envission (and put to good
2058 # use) other systems that do not use a normal file system. The whole CGI
2059 # was developed to make dynamic document generation possible.
2061 # A special case is where we want to have it both: A normal web server
2062 # with normal "file data", but not a normal files system. For instance,
2063 # we want or normal Web Site to run directly from a RAM hash table or
2064 # other database, instead of from disk. But we do NOT want to code the
2065 # whole site structure in CGI.
2067 # CGIscriptor can do this. If the web server fills an environment variable
2068 # $ENV{'CGI_FILE_CONTENT'} with the content of the "file", then the content
2069 # of this variable is processed instead of opening a file. If this environment
2070 # variable has the value '-', the content of another environment variable,
2071 # $ENV{'CGI_DATA_ACCESS_CODE'} is executed as:
2072 # eval("\@_ = ($file_path); do {$ENV{'CGI_DATA_ACCESS_CODE'}};")
2073 # and the result is processed as if it was the content of the requested
2075 # (actually, the names of the environment variables are user configurable,
2076 # they are stored in the local variables $CGI_FILE_CONTENT and
2077 # $CGI_DATA_ACCESS_CODE)
2079 # When using this mechanism, the SRC attribute mechanism will only partially work.
2080 # Only the "recursive" calls to CGIscriptor (the ProcessFile() function)
2081 # will work, the automagical execution of SRC files won't. (In this case,
2082 # the SRC attribute won't work either for other scripting languages)
2085 # NON-UNIX PLATFORMS
2087 # CGIscriptor.pl was mainly developed and tested on UNIX. However, as I
2088 # coded part of the time on an Apple Macintosh under MacPerl, I made sure
2089 # CGIscriptor did run under MacPerl (with command line options). But only
2090 # as an independend script, not as part of a HTTP server. I have used it
2091 # under Apache in Windows XP.
2096 ###############################################################################
2098 # SECURITY CONFIGURATION
2100 # Special configurations related to SECURITY
2101 # (i.e., optional, see also environment variables below)
2104 # Log Clients and the requested paths (Redundant when loging Queries)
2106 $ClientLog = "./Client.log"; # (uncomment for use)
2108 # Format: Localtime | REMOTE_USER REMOTE_IDENT REMOTE_HOST REMOTE_ADDRESS \
2109 # PATH_INFO CONTENT_LENGTH (actually, the real query+post length)
2111 # Log Clients and the queries, the CGIQUERYDECODE is required if you want
2112 # to log queries. If you log Queries, the loging of Clients is redundant
2113 # (note that queries can be quite long, so this might not be a good idea)
2115 #$QueryLog = "./Query.log"; # (uncomment for use)
2118 # the Access files should contain Hostnames or IP addresses,
2119 # i.e. REMOTE_HOST or REMOTE_ADDR, each on a separate line
2120 # optionally followed by one ore more file patterns, e.g., "edu /DEMO".
2121 # Matching is done "domain first". For example ".edu" matches all
2122 # clients whose "name" ends in ".edu" or ".EDU". The file pattern
2123 # "/DEMO" matches all paths that contain the strings "/DEMO" or "/demo"
2124 # (both matchings are done case-insensitive).
2125 # The name special symbol "-" matches ALL clients who do not supply a
2126 # REMOTE_HOST name, "*" matches all clients.
2127 # Lines starting with '-e' are evaluated. A non-zero return value indicates
2128 # a match. You can use $REMOTE_HOST, $REMOTE_ADDR, and $PATH_INFO. These
2129 # lines are evaluated in the program's own name-space. So DO NOT assign to
2132 # Accept the following users (remove comment # and adapt filename)
2133 $CGI_Accept = -s
"$YOUR_SCRIPTS/ACCEPT.lis" ?
"$YOUR_SCRIPTS/ACCEPT.lis" : ''; # (uncomment for use)
2135 # Reject requests from the following users (remove comment # and
2136 # adapt filename, this is only of limited use)
2137 $CGI_Reject = -s
"$YOUR_SCRIPTS/REJECT.lis" ?
"$YOUR_SCRIPTS/REJECT.lis" : ''; # (uncomment for use)
2139 # Empty lines or comment lines starting with '#' are ignored in both
2140 # $CGI_Accept and $CGI_Reject.
2142 # Block STDIN (i.e., '-') requests when servicing an HTTP request
2143 # Comment this out if you realy want to use STDIN in an on-line web server
2144 $BLOCK_STDIN_HTTP_REQUEST = 1;
2147 # End of security configuration
2149 ##################################################<<<<<<<<<<End Remove
2151 # PARSING CGI VALUES FROM THE QUERY STRING (USER CONFIGURABLE)
2153 # The CGI parse commands. These commands extract the values of the
2154 # CGI variables from the URL encoded Query String.
2155 # If you want to use your own CGI decoders, you can call them here
2156 # instead, using your own PATH and commenting/uncommenting the
2159 # CGI parse command for individual values
2160 # (if $List > 0, returns a list value, if $List < 0, a hash table, this is optional)
2161 sub YOUR_CGIPARSE
# ($Name [, $List]) -> Decoded value
2164 my $List = shift || 0;
2165 # Use one of the following by uncommenting
2166 if(!$List) # Simple value
2168 return CGIscriptor
::CGIparseValue
($Name) ;
2170 elsif($List < 0) # Hash tables
2172 return CGIscriptor
::CGIparseValueHash
($Name); # Defined in CGIscriptor below
2176 return CGIscriptor
::CGIparseValueList
($Name); # Defined in CGIscriptor below
2179 # return `/PATH/cgiparse -value $Name`; # Shell commands
2180 # require "/PATH/cgiparse.pl"; return cgivalue($Name); # Library
2183 sub YOUR_CGIQUERYDECODE
2185 # Use one of the following by uncommenting
2186 return CGIscriptor
::CGIparseForm
(); # Defined in CGIscriptor below
2187 # return `/PATH/cgiparse -form`; # Shell commands
2188 # require "/PATH/cgiparse.pl"; return cgiform(); # Library
2191 # End of configuration
2193 #######################################################################
2195 # Translating input files.
2196 # Allows general and global conversions of files using Regular Expressions
2197 # Translations are applied in the order of definition.
2200 # my $TranslationPaths = 'pattern'; # Pattern matching PATH_INFO
2202 # push(@TranslationTable, ['pattern', 'replacement']);
2203 # e.g. (for Ruby Rails):
2204 # push(@TranslationTable, ['<%=', '<SCRIPT TYPE="text/ssruby">']);
2205 # push(@TranslationTable, ['%>', '</SCRIPT>']);
2208 # my $currentRegExp;
2209 # foreach $currentRegExp (keys(%TranslationTable))
2211 # my $currentRegExp;
2212 # foreach $currentRegExp (@TranslationTable)
2214 # my ($pattern, $replacement) = @$currentRegExp;
2215 # $$text =~ s!$pattern!$replacement!msg;
2219 # Configuration section
2221 #######################################################################
2223 # The file paths on which to apply the translation
2224 my $TranslationPaths = ''; # NO files
2225 #$TranslationPaths = '.'; # ANY file
2226 # $TranslationPaths = '\.html'; # HTML files
2228 my @TranslationTable = ();
2230 push(@TranslationTable, ['\<\s*CGI\s+([^\>])*\>', '\<SCRIPT TYPE=\"text/ssperl\"\>$1\<\/SCRIPT>']);
2232 push(@TranslationTable, ['<%=', '<SCRIPT TYPE="text/ssruby">']);
2233 push(@TranslationTable, ['%>', '</SCRIPT>']);
2235 sub performTranslation
# (\$text)
2237 my $text = shift || return;
2238 if(@TranslationTable && $TranslationPaths && $ENV{'PATH_INFO'} =~ m!$TranslationPaths!)
2241 foreach $currentRegExp (@TranslationTable)
2243 my ($pattern, $replacement) = @
$currentRegExp;
2244 $$text =~ s!$pattern!$replacement!msg;
2249 #######################################################################
2251 # Seamless access to other (Scripting) Languages
2252 # TYPE='text/ss<interpreter>'
2254 # Configuration section
2256 #######################################################################
2258 # OTHER SCRIPTING LANGUAGES AT THE SERVER SIDE (MIME => OScommand)
2259 # Yes, it realy is this simple! (unbelievable, isn't it)
2260 # NOTE: Some interpreters require some filtering to obtain "clean" output
2262 %ScriptingLanguages = (
2263 "text/testperl" => 'perl', # Perl for testing
2264 "text/sspython" => 'python', # Python
2265 "text/ssruby" => 'ruby', # Ruby
2266 "text/sstcl" => 'tcl', # TCL
2267 "text/ssawk" => 'awk -f-', # Awk
2268 "text/sslisp" => # lisp (rep, GNU)
2269 'rep | tail +4 '."| egrep -v '> |^rep. |^nil\\\$'",
2270 "text/xlispstat" => # xlispstat
2271 'xlispstat | tail +7 ' ."| egrep -v '> \\\$|^NIL'",
2272 "text/ssprolog" => # Prolog (GNU)
2273 "gprolog | tail +4 | sed 's/^| ?- //'",
2274 "text/ssm4" => 'm4', # M4 macro's
2275 "text/sh" => 'sh', # Born shell
2276 "text/bash" => 'bash', # Born again shell
2277 "text/csh" => 'csh', # C shell
2278 "text/ksh" => 'ksh', # Korn shell
2279 "text/sspraat" => # Praat (sound/speech analysis)
2280 "praat - | sed 's/Praat > //g'",
2282 "R --vanilla --slave | sed 's/^[\[0-9\]*] //'",
2283 "text/ssrebol" => # REBOL
2284 "rebol --quiet|egrep -v '^[> ]* == '|sed 's/^\\s*\[> \]* //'",
2285 "text/postgresql" => 'psql 2>/dev/null',
2287 # Not real scripting, but the use of other applications
2288 "text/ssmailto" => "awk 'NF||F{F=1;print \\\$0;}'|mailto >/dev/null", # Send mail from server
2289 "text/ssdisplay" => 'cat', # Display, (interpolation)
2290 "text/sslogfile" => # Log to file, (interpolation)
2291 "awk 'NF||L {if(!L){L=tolower(\\\$1)~/^file:\\\$/ ? \\\$2 : \\\$1;}else{print \\\$0 >> L;};}'",
2296 # To be able to access the CGI variables in your script, they
2297 # should be passed to the scripting language in a readable form
2298 # Here you can enter how they should be printed (the first %s
2299 # is replaced by the NAME of the CGI variable as it apears in the
2300 # META tag, the second by its VALUE).
2301 # For Perl this would be:
2302 # "text/testperl" => '$%s = "%s";',
2303 # which would be executed as
2304 # printf('$%s = "%s";', $CGI_NAME, $CGI_VALUE);
2306 # If the hash table value doesn't exist, nothing is done
2307 # (you have to parse the Environment variables yourself).
2308 # If it DOES exist but is empty (e.g., "text/sspraat" => '',)
2309 # Perl string interpolation of variables (i.e., $var, @array,
2310 # %hash) is performed. This means that $@%\ must be protected
2313 %ScriptingCGIvariables = (
2314 "text/testperl" => "\$\%s = '\%s';", # Perl $VAR = 'value'; (for testing)
2315 "text/sspython" => "\%s = '\%s'", # Python VAR = 'value'
2316 "text/ssruby" => '@%s = "%s"', # Ruby @VAR = 'value'
2317 "text/sstcl" => 'set %s "%s"', # TCL set VAR "value"
2318 "text/ssawk" => '%s = "%s";', # Awk VAR = 'value';
2319 "text/sslisp" => '(setq %s "%s")', # Gnu lisp (rep) (setq VAR "value")
2320 "text/xlispstat" => '(setq %s "%s")', # xlispstat (setq VAR "value")
2321 "text/ssprolog" => '', # Gnu prolog (interpolated)
2322 "text/ssm4" => "define(`\%s', `\%s')", # M4 macro's define(`VAR', `value')
2323 "text/sh" => "\%s='\%s'", # Born shell VAR='value'
2324 "text/bash" => "\%s='\%s'", # Born again shell VAR='value'
2325 "text/csh" => "\$\%s='\%s';", # C shell $VAR = 'value';
2326 "text/ksh" => "\$\%s='\%s';", # Korn shell $VAR = 'value';
2328 "text/ssrebol" => '%s: copy "%s"', # REBOL VAR: copy "value"
2329 "text/sspraat" => '', # Praat (interpolation)
2330 "text/ssr" => '%s <- "%s";', # R VAR <- "value";
2331 "text/postgresql" => '', # PostgreSQL (interpolation)
2333 # Not real scripting, but the use of other applications
2334 "text/ssmailto" => '', # MAILTO, (interpolation)
2335 "text/ssdisplay" => '', # Display, (interpolation)
2336 "text/sslogfile" => '', # Log to file, (interpolation)
2341 # If you want something added in front or at the back of each script
2342 # block as send to the interpreter add it here.
2343 # mime => "string", e.g., "text/sspython" => "python commands"
2344 %ScriptingPrefix = (
2345 "text/testperl" => "\# Prefix Code;", # Perl script testing
2346 "text/ssm4" => 'divert(0)', # M4 macro's (open STDOUT)
2350 # If you want something added at the end of each script block
2351 %ScriptingPostfix = (
2352 "text/testperl" => "\# Postfix Code;", # Perl script testing
2353 "text/ssm4" => 'divert(-1)', # M4 macro's (block STDOUT)
2357 # If you need initialization code, directly after opening
2358 %ScriptingInitialization = (
2359 "text/testperl" => "\# Initialization Code;", # Perl script testing
2360 "text/ssawk" => 'BEGIN {', # Server Side awk scripts (VAR = "value")
2361 "text/sslisp" => '(prog1 nil ', # Lisp (rep)
2362 "text/xlispstat" => '(prog1 nil ', # xlispstat
2363 "text/ssm4" => 'divert(-1)', # M4 macro's (block STDOUT)
2367 # If you need cleanup code before closing
2368 %ScriptingCleanup = (
2369 "text/testperl" => "\# Cleanup Code;", # Perl script testing
2370 "text/sspraat" => 'Quit',
2371 "text/ssawk" => '};', # Server Side awk scripts (VAR = "value")
2372 "text/sslisp" => '(princ "\n" standard-output)).', # Closing print to rep
2373 "text/xlispstat" => '(print ""))', # Closing print to xlispstat
2374 "text/postgresql" => '\q', # quit psql
2375 "text/ssdisplay" => "", # close cat
2380 # End of configuration for foreign scripting languages
2382 ###############################################################################
2384 # Initialization Code
2387 sub Initialize_Request
2389 ###############################################################################
2391 # ENVIRONMENT VARIABLES
2393 # Use environment variables to configure CGIscriptor on a temporary basis.
2394 # If you define any of the configurable variables as environment variables,
2395 # these are used instead of the "hard coded" values above.
2397 $SS_PUB = $ENV{'SS_PUB'} || $YOUR_HTML_FILES;
2398 $SS_SCRIPT = $ENV{'SS_SCRIPT'} || $YOUR_SCRIPTS;
2401 # Substitution strings, these are used internally to handle the
2402 # directory separator strings, e.g., '~/' -> 'SS_PUB:' (Mac)
2403 $HOME_SUB = $SS_PUB;
2404 $SCRIPT_SUB = $SS_SCRIPT;
2407 # Make sure all script are reliably loaded
2408 push(@INC, $SS_SCRIPT);
2411 # Add the directory separator to the "home" directories.
2412 # (This is required for ~/ and ./ substitution)
2413 $HOME_SUB .= '/' if $HOME_SUB;
2414 $SCRIPT_SUB .= '/' if $SCRIPT_SUB;
2416 $CGI_HOME = $ENV{'DOCUMENT_ROOT'};
2417 $ENV{'PATH_TRANSLATED'} =~ /$ENV{'PATH_INFO'}/is;
2418 $CGI_HOME = $` unless $ENV{'DOCUMENT_ROOT'}; # Get the DOCUMENT_ROOT directory
2419 $default_values{'CGI_HOME'} = $CGI_HOME;
2420 $ENV{'HOME'} = $CGI_HOME;
2421 # Set SS_PUB and SS_SCRIPT as Environment variables (make them available
2423 $ENV{'SS_PUB'} = $SS_PUB unless $ENV{'SS_PUB'};
2424 $ENV{'SS_SCRIPT'} = $SS_SCRIPT unless $ENV{'SS_SCRIPT'};
2426 $FilePattern = $ENV{'FilePattern'} || $FilePattern;
2427 $MaximumQuerySize = $ENV{'MaximumQuerySize'} || $MaximumQuerySize;
2428 $ClientLog = $ENV{'ClientLog'} || $ClientLog;
2429 $QueryLog = $ENV{'QueryLog'} || $QueryLog;
2430 $CGI_Accept = $ENV{'CGI_Accept'} || $CGI_Accept;
2431 $CGI_Reject = $ENV{'CGI_Reject'} || $CGI_Reject;
2434 $CGI_Accept =~ s@^\~/@$HOME_SUB@g if $CGI_Accept;
2435 $CGI_Reject =~ s@^\~/@$HOME_SUB@g if $CGI_Reject;
2436 $ClientLog =~ s@^\~/@$HOME_SUB@g if $ClientLog;
2437 $QueryLog =~ s@^\~/@$HOME_SUB@g if $QueryLog;
2439 $CGI_Accept =~ s@^\./@$SCRIPT_SUB@g if $CGI_Accept;
2440 $CGI_Reject =~ s@^\./@$SCRIPT_SUB@g if $CGI_Reject;
2441 $ClientLog =~ s@^\./@$SCRIPT_SUB@g if $ClientLog;
2442 $QueryLog =~ s@^\./@$SCRIPT_SUB@g if $QueryLog;
2444 @CGIscriptorResults = (); # A stack of results
2446 # end of Environment variables
2448 #############################################################################
2450 # Define and Store "standard" values
2452 # BEFORE doing ANYTHING check the size of Query String
2453 length($ENV{'QUERY_STRING'}) <= $MaximumQuerySize || dieHandler(2, "QUERY TOO LONG\n");
2455 # The Translated Query String and the Actual length of the (decoded)
2457 if($ENV{'QUERY_STRING'})
2459 # If this can contain '`"-quotes, be carefull to use it QUOTED
2460 $default_values{CGI_Decoded_QS} = YOUR_CGIQUERYDECODE();
2461 $default_values{CGI_Content_Length} = length($default_values{CGI_Decoded_QS});
2464 # Get the current Date and time and store them as default variables
2467 $LocalTime = localtime;
2469 # CGI_Year CGI_Month CGI_Day CGI_WeekDay CGI_Time
2470 # CGI_Hour CGI_Minutes CGI_Seconds
2472 $default_values{CGI_Date} = $LocalTime;
2473 ($default_values{CGI_WeekDay},
2474 $default_values{CGI_Month},
2475 $default_values{CGI_Day},
2476 $default_values{CGI_Time},
2477 $default_values{CGI_Year}) = split(' ', $LocalTime);
2478 ($default_values{CGI_Hour},
2479 $default_values{CGI_Minutes},
2480 $default_values{CGI_Seconds}) = split(':', $default_values{CGI_Time});
2483 # CGI_GMTYear CGI_GMTMonth CGI_GMTDay CGI_GMTWeekDay CGI_GMTYearDay
2484 # CGI_GMTHour CGI_GMTMinutes CGI_GMTSeconds CGI_GMTisdst
2486 ($default_values{CGI_GMTSeconds},
2487 $default_values{CGI_GMTMinutes},
2488 $default_values{CGI_GMTHour},
2489 $default_values{CGI_GMTDay},
2490 $default_values{CGI_GMTMonth},
2491 $default_values{CGI_GMTYear},
2492 $default_values{CGI_GMTWeekDay},
2493 $default_values{CGI_GMTYearDay},
2494 $default_values{CGI_GMTisdst}) = gmtime;
2498 # End of Initialize Request
2500 ###################################################################
2502 # SECURITY: ACCESS CONTROL
2504 # Check the credentials of each client (use pattern matching, domain first).
2505 # This subroutine will kill-off (die) the current process whenever access
2510 # >>>>>>>>>>Start Remove
2514 # Only accept clients which are authorized, reject all unnamed clients
2515 # if REMOTE_HOST is given.
2516 # If file patterns are given, check whether the user is authorized for
2520 # Use local variables, REMOTE_HOST becomes '-' if undefined
2521 my $REMOTE_HOST = $ENV{REMOTE_HOST} || '-';
2522 my $REMOTE_ADDR = $ENV{REMOTE_ADDR};
2523 my $PATH_INFO = $ENV{'PATH_INFO'};
2525 open(CGI_Accept, "<$CGI_Accept") || dieHandler(3, "$CGI_Accept: $!\n");
2529 next unless /\S/; # Skip empty lines
2530 next if /^\s*\#/; # Skip comments
2535 my $Accept = $'; # Get the expression
2536 $NoAccess &&= eval($Accept); # evaluate the expresion
2540 my ($Accept, @FilePatternList) = split;
2541 if($Accept eq '*' # Always match
2542 ||$REMOTE_HOST =~ /\Q$Accept\E$/is # REMOTE_HOST matches
2544 $Accept =~ /^[0-9\.]+$/
2545 && $REMOTE_ADDR =~ /^\Q$Accept\E/ # IP address matches
2549 if($FilePatternList[0])
2551 foreach $Pattern (@FilePatternList)
2553 # Check whether this patterns is accepted
2554 $NoAccess &&= ($PATH_INFO !~ m@\Q$Pattern\E@is);
2559 $NoAccess = 0; # No file patterns -> Accepted
2564 last unless $NoAccess;
2567 if($NoAccess){ dieHandler(4, "No Access
: $PATH_INFO\n");};
2573 # Reject named clients, accept all unnamed clients
2576 # Use local variables, REMOTE_HOST becomes '-' if undefined
2577 my $REMOTE_HOST = $ENV{'REMOTE_HOST'} || '-';
2578 my $REMOTE_ADDR = $ENV{'REMOTE_ADDR'};
2579 my $PATH_INFO = $ENV{'PATH_INFO'};
2581 open(CGI_Reject, "<$CGI_Reject") || dieHandler(5, "$CGI_Reject: $!\n");
2585 next unless /\S/; # Skip empty lines
2586 next if /^\s*\#/; # Skip comments
2591 my $Reject = $'; # Get the expression
2592 $NoAccess ||= eval($Reject); # evaluate the expresion
2596 my ($Reject, @FilePatternList) = split;
2597 if($Reject eq '*' # Always match
2598 ||$REMOTE_HOST =~ /\Q$Reject\E$/is # REMOTE_HOST matches
2599 ||($Reject =~ /^[0-9\.]+$/
2600 && $REMOTE_ADDR =~ /^\Q$Reject\E/is # IP address matches
2604 if($FilePatternList[0])
2606 foreach $Pattern (@FilePatternList)
2608 $NoAccess ||= ($PATH_INFO =~ m@\Q$Pattern\E@is);
2613 $NoAccess = 1; # No file patterns -> Rejected
2620 if($NoAccess){ dieHandler(6, "Request rejected
: $PATH_INFO\n");};
2623 ##########################################################<<<<<<<<<<End Remove
2628 # Does the filename contain any illegal characters (e.g., |, >, or <)
2629 dieHandler(7, "Illegal request
: $ENV{'PATH_INFO'}\n") if $ENV{'PATH_INFO'} =~ /[^$FileAllowedChars]/;
2630 # Does the pathname contain an illegal (blocked) "directory
"
2631 dieHandler(8, "Illegal request
: $ENV{'PATH_INFO'}\n") if $BlockPathAccess && $ENV{'PATH_INFO'} =~ m@$BlockPathAccess@; # Access is blocked
2632 # Does the pathname contain a direct referencer to BinaryMapFile
2633 dieHandler(9, "Illegal request
: $ENV{'PATH_INFO'}\n") if $BinaryMapFile && $ENV{'PATH_INFO'} =~ m@\Q$BinaryMapFile\E@; # Access is blocked
2635 # SECURITY: Is PATH_INFO allowed?
2636 if($FilePattern && $ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} ne '-' &&
2637 ($ENV{'PATH_INFO'} !~ m@($FilePattern)$@is))
2639 # Unsupported file types can be processed by a special raw-file
2642 $ENV{'CGI_BINARY_FILE'} = $ENV{'PATH_INFO'};
2643 $ENV{'PATH_INFO'} = $BinaryMapFile;
2647 dieHandler(10, "Illegal file
\n");
2653 # End of Security Access Control
2656 ############################################################################
2658 # Get the POST part of the query and add it to the QUERY_STRING.
2661 sub Get_POST_part_of_query
2664 # If POST, Read data from stdin to QUERY_STRING
2665 if($ENV{'REQUEST_METHOD'} =~ /POST/is)
2667 # SECURITY: Check size of Query String
2668 $ENV{'CONTENT_LENGTH'} <= $MaximumQuerySize || dieHandler
(11, "Query too long: $ENV{'CONTENT_LENGTH'}\n"); # Query too long
2670 my $SystemRead = $ENV{'CONTENT_LENGTH'};
2671 $ENV{'QUERY_STRING'} .= '&' if length($ENV{'QUERY_STRING'}) > 0;
2672 while($SystemRead > 0)
2674 $QueryRead = sysread(STDIN
, $Post, $SystemRead); # Limit length
2675 $ENV{'QUERY_STRING'} .= $Post;
2676 $SystemRead -= $QueryRead;
2678 # Update decoded Query String
2679 $default_values{CGI_Decoded_QS
} = YOUR_CGIQUERYDECODE
();
2680 $default_values{CGI_Content_Length
} =
2681 length($default_values{CGI_Decoded_QS
});
2685 # End of getting POST part of query
2688 ############################################################################
2690 # Start (HTML) output and logging
2691 # (if there are irregularities, it can kill the current process)
2694 sub Initialize_output
2696 # Construct the REAL file path (except for STDIN on the command line)
2697 my $file_path = $ENV{'PATH_INFO'} ne '-' ?
$SS_PUB . $ENV{'PATH_INFO'} : '-';
2698 $file_path =~ s/\?.*$//; # Remove query
2699 # This is only necessary if your server does not catch ../ directives
2700 $file_path !~ m@\
.\
./@ || dieHandler(12, "Illegal ../ Construct
\n"); # SECURITY: Do not allow ../ constructs
2702 # Block STDIN use (-) if CGIscriptor is servicing a HTTP request
2703 if($file_path eq '-')
2705 dieHandler(13, "STDIN request
in On Line
system\n") if $BLOCK_STDIN_HTTP_REQUEST
2706 && ($ENV{'SERVER_SOFTWARE'}
2707 || $ENV{'SERVER_NAME'}
2708 || $ENV{'GATEWAY_INTERFACE'}
2709 || $ENV{'SERVER_PROTOCOL'}
2710 || $ENV{'SERVER_PORT'}
2711 || $ENV{'REMOTE_ADDR'}
2712 || $ENV{'HTTP_USER_AGENT'});
2719 open(ClientLog, ">>$ClientLog");
2720 print ClientLog "$LocalTime | ",
2721 ($ENV{REMOTE_USER} || "-"), " ",
2722 ($ENV{REMOTE_IDENT} || "-"), " ",
2723 ($ENV{REMOTE_HOST} || "-"), " ",
2724 $ENV{REMOTE_ADDR}, " ",
2725 $ENV{PATH_INFO}, " ",
2726 $ENV{'CGI_BINARY_FILE'}, " ",
2727 ($default_values{CGI_Content_Length} || "-"),
2733 open(QueryLog, ">>$QueryLog");
2734 print QueryLog "$LocalTime\n",
2735 ($ENV{REMOTE_USER} || "-"), " ",
2736 ($ENV{REMOTE_IDENT} || "-"), " ",
2737 ($ENV{REMOTE_HOST} || "-"), " ",
2738 $ENV{REMOTE_ADDR}, ": ",
2739 $ENV{PATH_INFO}, " ",
2740 $ENV{'CGI_BINARY_FILE'}, "\n";
2742 # Write Query to Log file
2743 print QueryLog $default_values{CGI_Decoded_QS}, "\n\n";
2747 # Return the file path
2751 # End of Initialize output
2754 ############################################################################
2756 # Handle login access
2758 # Access is based on a valid session ticket.
2759 # Session tickets should be dependend on user name
2760 # and IP address. The patterns of URLs for which a
2761 # session ticket is needed and the login URL are stored in
2762 # %TicketRequiredPatterns as:
2763 # 'RegEx pattern' -> 'SessionPath\tPasswordPath\tLogin URL\tExpiration'
2766 sub Log_In_Access # () -> 0 = Access Allowed, Login page if access is not allowed
2768 # No patterns, no login
2769 return 0 unless %TicketRequiredPatterns;
2771 # Get and initialize values (watch out for stuff processed by BinaryMap files)
2772 my ($SessionPath, $PasswordsPath, $Login, $valid_duration) = ("", "", "", 0);
2773 my $PATH_INFO = $ENV{'CGI_BINARY_FILE'} ? $ENV{'CGI_BINARY_FILE'} : $ENV{'PATH_INFO'};
2774 my $REMOTE_ADDR = $ENV{'REMOTE_ADDR'};
2775 return 0 if $REMOTE_ADDR =~ /[^0-9\.]/;
2776 # Extract TICKETs, starting with returned cookies
2777 CGIexecute::defineCGIvariable('LOGINTICKET', "");
2778 CGIexecute::defineCGIvariable('SESSIONTICKET', "");
2779 CGIexecute::defineCGIvariable('CHALLENGETICKET', "");
2780 if($ENV{'COOKIE_JAR'})
2782 my $CurrentCookieJar = $ENV{'COOKIE_JAR'};
2783 $CurrentCookieJar =~ s/\w+\=\-\s*(\;\s*|$)//isg;
2784 if($CurrentCookieJar =~ /\s*CGIscriptorLOGIN\=\s*([^\;]+)/)
2786 ${"CGIexecute
::LOGINTICKET
"} = $1;
2788 if($CurrentCookieJar =~ /\s*CGIscriptorCHALLENGE\=\s*([^\;]+)/ && $1 ne '-')
2790 ${"CGIexecute
::CHALLENGETICKET
"} = $1;
2792 if($CurrentCookieJar =~ /\s*CGIscriptorSESSION\=\s*([^\;]+)/ && $1 ne '-')
2794 ${"CGIexecute
::SESSIONTICKET
"} = $1;
2797 # Get and check the tickets. Tickets are restricted to word-characters (alphanumeric+_+.)
2798 my $LOGINTICKET = ${"CGIexecute
::LOGINTICKET
"};
2799 return 0 if ($LOGINTICKET && $LOGINTICKET =~ /[^\w\.]/isg);
2800 my $SESSIONTICKET = ${"CGIexecute
::SESSIONTICKET
"};
2801 return 0 if ($SESSIONTICKET && $SESSIONTICKET =~ /[^\w\.]/isg);
2802 my $CHALLENGETICKET = ${"CGIexecute
::CHALLENGETICKET
"};
2803 return 0 if ($SESSIONTICKET && $SESSIONTICKET =~ /[^\w\.]/isg);
2804 # Look for a LOGOUT message
2805 my $LOGOUT = $ENV{QUERY_STRING} =~ /(^|\&)LOGOUT([\=\&]|$)/;
2806 # Username and password
2807 CGIexecute::defineCGIvariable('CGIUSERNAME', "");
2808 my $username = lc(${"CGIexecute
::CGIUSERNAME
"});
2809 return 0 if $username =~ m!^[^\w]!isg || $username =~ m![^\w \-]!isg;
2810 my $userfile = lc($username);
2811 $userfile =~ s/[^\w]/_/isg;
2812 CGIexecute::defineCGIvariable('PASSWORD', "");
2813 my $password = ${"CGIexecute
::PASSWORD
"};
2814 CGIexecute::defineCGIvariable('NEWPASSWORD', "");
2815 my $newpassword = ${"CGIexecute
::NEWPASSWORD
"};
2817 foreach my $pattern (keys(%TicketRequiredPatterns))
2819 # Check BOTH the real PATH_INFO and the CGI_BINARY_FILE variable
2820 if($ENV{'PATH_INFO'} =~ m#$pattern# || $ENV{'CGI_BINARY_FILE'} =~ m#$pattern#)
2822 # Fall through a sieve of requirements
2823 ($SessionPath, $PasswordsPath, $Login, $validtime) = split(/\t/, $TicketRequiredPatterns{$pattern});
2824 # If a LOGOUT is present, remove everything
2825 if($LOGOUT && !$LOGINTICKET)
2827 unlink "$SessionPath/$LOGINTICKET" if $LOGINTICKET && (-s "$SessionPath/$LOGINTICKET");
2829 unlink "$SessionPath/$SESSIONTICKET" if $SESSIONTICKET && (-s "$SessionPath/$SESSIONTICKET");
2830 $SESSIONTICKET = "";
2831 unlink "$SessionPath/$CHALLENGETICKET" if $CHALLENGETICKET && (-s "$SessionPath/$CHALLENGETICKET");
2832 $CHALLENGETICKET = "";
2833 unlink "$SessionPath/$REMOTE_ADDR" if (-s "$SessionPath/$$REMOTE_ADDR");
2834 $CHALLENGETICKET = "";
2837 # Is there a change password request?
2838 if($newpassword && $LOGINTICKET && $username)
2840 my $tickets_removed = remove_expired_tickets($SessionPath);
2841 goto Login unless (-s "$SessionPath/$LOGINTICKET");
2842 goto Login unless (-s "$PasswordsPath/$userfile");
2843 my $ticket_valid = check_ticket_validity("PASSWORD
", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO);
2844 goto Login unless $ticket_valid;
2846 my ($sessiontype, $currentticket) = ("", "");
2847 if($CHALLENGETICKET) {($sessiontype, $currentticket) = ("CHALLENGE
", $CHALLENGETICKET);}
2848 elsif($SESSIONTICKET) {($sessiontype, $currentticket) = ("SESSION
", $SESSIONTICKET);}
2849 elsif(-s "$SessionPath/$REMOTE_ADDR") {($sessiontype, $currentticket) = ("IPADDRESS
", $REMOTE_ADDR);
2853 goto Login unless (-s "$SessionPath/$currentticket");
2854 my $ticket_valid = check_ticket_validity($sessiontype, "$SessionPath/$currentticket", $REMOTE_ADDR, $PATH_INFO);
2855 goto Login unless $ticket_valid;
2858 change_password("$SessionPath/$LOGINTICKET", "$SessionPath/$currentticket", "$PasswordsPath/$userfile", $password, $newpassword);
2859 # After a change of password, you have to login again for a CHALLENGE
2860 if($CHALLENGETICKET){$CHALLENGETICKET = "";};
2864 # Is there a login ticket of this name?
2867 my $tickets_removed = remove_expired_tickets($SessionPath);
2868 goto Login unless (-s "$SessionPath/$LOGINTICKET");
2869 goto Login unless (-s "$PasswordsPath/$userfile");
2870 my $ticket_valid = check_ticket_validity("PASSWORD
", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO);
2871 goto Login unless $ticket_valid;
2872 $ticket_valid = check_ticket_validity("LOGIN
", "$SessionPath/$LOGINTICKET", $REMOTE_ADDR, ".");
2873 goto Login unless $ticket_valid;
2875 # Remove any lingering tickets
2876 unlink "$SessionPath/$SESSIONTICKET" if $SESSIONTICKET && (-s "$SessionPath/$SESSIONTICKET");
2877 $SESSIONTICKET = "";
2878 unlink "$SessionPath/$CHALLENGETICKET" if $CHALLENGETICKET && (-s "$SessionPath/$CHALLENGETICKET");
2879 $CHALLENGETICKET = "";
2883 my $TMPTICKET = authorize_login("$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $password, $SessionPath);
2886 my $authorization = read_ticket("$PasswordsPath/$userfile");
2887 # Session type is read from the userfile
2888 if($authorization->{"Session
"} && $authorization->{"Session
"}->[0] eq "CHALLENGE
")
2890 # Create New Random CHALLENGETICKET
2891 $CHALLENGETICKET = $TMPTICKET;
2892 create_session_file("$SessionPath/$CHALLENGETICKET", "$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $PATH_INFO);
2894 elsif($authorization->{"Session
"} && $authorization->{"Session
"}->[0] eq "IPADDRESS
")
2896 create_session_file("$SessionPath/$REMOTE_ADDR", "$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $PATH_INFO);
2900 $SESSIONTICKET = $TMPTICKET;
2901 create_session_file("$SessionPath/$SESSIONTICKET", "$SessionPath/$LOGINTICKET", "$PasswordsPath/$userfile", $PATH_INFO);
2902 $SETCOOKIELIST{"CGIscriptorSESSION
"} = "-";
2905 # Login ticket file has been used, remove it
2908 # Is there a session ticket of this name?
2910 if($CHALLENGETICKET)
2912 goto Login unless (-s "$SessionPath/$CHALLENGETICKET");
2913 my $ticket_valid = check_ticket_validity("CHALLENGE
", "$SessionPath/$CHALLENGETICKET", $REMOTE_ADDR, $PATH_INFO);
2914 goto Login unless $ticket_valid;
2916 my $oldchallenge = read_ticket("$SessionPath/$CHALLENGETICKET");
2917 my $userfile = lc($oldchallenge->{"Username
"}->[0]);
2918 $userfile =~ s/[^\w]/_/isg;
2919 goto Login unless (-s "$PasswordsPath/$userfile");
2921 $ticket_valid = check_ticket_validity("PASSWORD
", "$PasswordsPath/$userfile", $REMOTE_ADDR, $PATH_INFO);
2922 goto Login unless $ticket_valid;
2924 my $NEWCHALLENGETICKET = "";
2925 $NEWCHALLENGETICKET = copy_challenge_file("$SessionPath/$CHALLENGETICKET", "$PasswordsPath/$userfile", $SessionPath);
2926 # Sessionticket is available to scripts, do NOT set the cookie
2927 $ENV{'CHALLENGETICKET'} = $NEWCHALLENGETICKET;
2931 elsif(-s "$SessionPath/$REMOTE_ADDR")
2933 my $ticket_valid = check_ticket_validity("IPADDRESS
", "$SessionPath/$REMOTE_ADDR", $REMOTE_ADDR, $PATH_INFO);
2934 goto Login unless $ticket_valid;
2938 elsif($SESSIONTICKET)
2940 goto Login unless (-s "$SessionPath/$SESSIONTICKET");
2941 my $ticket_valid = check_ticket_validity("SESSION
", "$SessionPath/$SESSIONTICKET", $REMOTE_ADDR, $PATH_INFO);
2942 goto Login unless $ticket_valid;
2943 # Sessionticket is available to scripts
2944 $ENV{'SESSIONTICKET'} = $SESSIONTICKET;
2955 create_login_file($PasswordsPath, $SessionPath, $REMOTE_ADDR);
2956 # Note, cookies are set only ONCE
2957 $SETCOOKIELIST{"CGIscriptorLOGIN
"} = "-";
2958 return "$YOUR_HTML_FILES/$Login";
2961 sub authorize_login # ($loginfile, $authorizationfile, $password, $SessionPath) => SESSIONTICKET First two arguments are file paths
2963 my $loginfile = shift || "";
2964 my $authorizationfile = shift || "";
2965 my $password = shift || "";
2966 my $SessionPath = shift || "";
2968 # Get Login session ticket
2969 my $loginticket = read_ticket($loginfile);
2970 # Get User credentials for authorization
2971 my $authorization = read_ticket($authorizationfile);
2974 my $Randomsalt = $loginticket->{'Randomsalt'}->[0];
2975 return "" unless $Randomsalt;
2977 my $storedpassword = $authorization->{'Password'}->[0];
2978 return "" unless $storedpassword;
2979 # Without the "bash
-c
", the 'echo -n' could use sh, which does not recognize the -n option
2980 my $Hashedpassword = `bash -c 'echo -n $Randomsalt$storedpassword| $ENV{"SHASUMCMD
"}'`;
2981 chomp($Hashedpassword);
2982 return "" unless $password eq $Hashedpassword;
2984 # Extract Session Ticket
2985 my $loginsession = $loginticket->{'Session'}->[0];
2986 my $sessionticket = `bash -c 'echo -n $loginsession$storedpassword| $ENV{"SHASUMCMD
"}'`;
2987 chomp($sessionticket);
2988 $sessionticket = "" if -x "$SessionPath/$sessionticket";
2990 return $sessionticket;
2993 sub change_password # ($loginfile, $sessionfile, $authorizationfile, $password, $newpassword) First two arguments are file paths
2995 my $loginfile = shift || "";
2996 my $sessionfile = shift || "";
2997 my $authorizationfile = shift || "";
2998 my $password = shift || "";
2999 my $newpassword = shift || "";
3000 # Get Login session ticket
3001 my $loginticket = read_ticket($loginfile);
3002 # Login ticket file has been used, remove it
3005 my $Randomsalt = $loginticket->{'Randomsalt'}->[0];
3007 return "" unless $Randomsalt;
3009 # Get session ticket
3010 my $sessionticket = read_ticket($sessionfile);
3011 # Get User credentials for authorization
3012 my $authorization = read_ticket($authorizationfile);
3013 return "" unless lc($authorization->{'Username'}->[0]) eq lc($sessionticket->{'Username'}->[0]);
3015 my $storedpassword = $authorization->{'Password'}->[0];
3016 # Without the "bash
-c
", the 'echo -n' could use sh, which does not recognize the -n option
3017 my $Hashedpassword = `bash -c 'echo -n $Randomsalt$storedpassword| $ENV{"SHASUMCMD
"}'`;
3018 chomp($Hashedpassword);
3019 return "" unless $password eq $Hashedpassword;
3021 # Decrypt the $newpassword
3022 my $loginticketid = $loginticket->{'Session'}->[0];
3023 my $passwordkey = `bash -c 'echo -n $loginticketid$storedpassword| $ENV{"SHASUMCMD
"}'`;
3024 chomp($passwordkey);
3025 my $decryptedPassword = XOR_hex_strings($passwordkey, $newpassword);
3026 return "" unless $decryptedPassword;
3027 # Authorization succeeded, change password
3028 $authorization->{'Password'}->[0] = $decryptedPassword;
3030 open(USERFILE, "<$authorizationfile") || die "<$authorizationfile: $!\n";
3031 my @USERlines = <USERFILE>;
3034 open(USERFILE, ">$authorizationfile") || die ">$authorizationfile: $!\n";
3035 foreach my $line (@USERlines)
3037 $line =~ s/^Password: ($storedpassword)$/Password: $decryptedPassword/ig;
3038 print USERFILE $line;
3042 return $newpassword;
3045 sub XOR_hex_strings # (hex1, hex2) -> hex
3047 my $hex1 = shift || "";
3048 my $hex2 = shift || "";
3049 my @hex1list = split('', $hex1);
3050 my @hex2list = split('', $hex2);
3051 my @hexresultlist = ();
3052 for(my $i; $i < scalar(@hex1list); ++$i)
3054 my $d1 = hex($hex1list[$i]);
3055 my $d2 = hex($hex2list[$i]);
3056 my $dresult = ($d1 ^ $d2);
3057 $hexresultlist[$i] = sprintf("%x", $dresult);
3059 $hexresult = join('', @hexresultlist);
3063 # Copy a Challenge ticket file to a new name which is the hash of the new $CHALLENGETICKET and the password
3064 sub copy_challenge_file #($oldchallengefile, $authorizationfile, $sessionpath) -> $CHALLENGETICKET
3066 my $oldchallengefile = shift || "";
3067 my $authorizationfile = shift || "";
3068 my $sessionpath = shift || "";
3069 $sessionpath =~ s!/+$!!g;
3071 # Get Login session ticket
3072 my $oldchallenge = read_ticket($oldchallengefile);
3074 # Get Authorization (user) session file
3075 my $authorization = read_ticket($authorizationfile);
3076 my $storedpassword = $authorization->{'Password'}->[0];
3077 return "" unless $storedpassword;
3078 my $challengekey = $oldchallenge->{'Key'}->[0];
3079 return "" unless $challengekey;
3081 # Create Random Hash Salt
3082 open(URANDOM, "$RANDOMHASHCMD |") || die "URANDOM
; $RANDOMHASHCMD | $!\n";
3083 my $NEWCHALLENGETICKET = <URANDOM>;
3085 chomp($NEWCHALLENGETICKET);
3086 my $newchallengefile = `bash -c 'echo -n $NEWCHALLENGETICKET$challengekey| $ENV{"SHASUMCMD
"}'`;
3087 chomp($newchallengefile);
3088 return "" unless $newchallengefile;
3090 $ENV{'CHALLENGETICKET'} = $NEWCHALLENGETICKET;
3091 CGIexecute::defineCGIvariable('CHALLENGETICKET', "");
3092 ${"CGIexecute
::CHALLENGETICKET
"} = $NEWCHALLENGETICKET;
3094 # Write Session Ticket
3095 open(OLDCHALLENGE, "<$oldchallengefile") || die "<$oldchallengefile: $!\n";
3096 my @OldChallengeLines = <OLDCHALLENGE>;
3097 close(OLDCHALLENGE);
3098 # Old file should now be removed
3099 unlink($oldchallengefile);
3101 open(SESSION, ">$sessionpath/$newchallengefile") || die "$sessionpath/$newchallengefile: $!\n";
3102 foreach $line (@OldChallengeLines)
3104 print SESSION $line;
3108 return $NEWCHALLENGETICKET;
3111 # Create a new account ticket. Do not write to file yet, as that might not be
3112 # the secure option!
3113 sub create_account_ticket #($username, $password, $salt)
3115 my $username = shift || return 0;
3116 my $password = shift || return 0;
3117 my $salt = shift || return 0;
3120 "Type
" => ['PASSWORD'],
3121 "Username
" => [$username],
3122 "Password
" => [$password],
3125 "Session
" => ['SESSION']
3130 sub create_login_file #($PasswordDir, $SessionDir, $IPaddress)
3132 my $PasswordDir = shift || "";
3133 my $SessionDir = shift || "";
3134 my $IPaddress = shift || "";
3136 # Create Login Ticket
3137 open(URANDOM, "$RANDOMHASHCMD |") || die "URANDOM
; $!\n";
3138 my $LOGINTICKET= <URANDOM>;
3140 chomp($LOGINTICKET);
3142 # Create Random Hash Salt
3143 open(URANDOM, "$RANDOMHASHCMD |") || die "URANDOM
; $RANDOMHASHCMD | $!\n";
3144 my $RANDOMSALT= <URANDOM>;
3148 # Create SALT file if it does not exist
3149 # Remove this, including test account for life system
3150 unless(-d "$SessionDir")
3152 `mkdir -p "$SessionDir"`;
3154 unless(-d "$PasswordDir")
3156 `mkdir -p "$PasswordDir"`;
3158 # Create SERVERSALT and default test account
3159 my $SERVERSALT = "";
3160 unless(-s "$PasswordDir/SALT
")
3162 open(URANDOM, "$RANDOMHASHCMD |") || die "URANDOM
; $!\n";
3163 $SERVERSALT= <URANDOM>;
3166 open(SALTFILE, ">$PasswordDir/SALT") || die ">$PasswordDir/SALT
: $!\n";
3167 print SALTFILE "$SERVERSALT\n";
3170 # Update test account (should be removed in live system)
3171 my @alltestusers = ("test
", "testip
", "testchallenge
");
3172 foreach my $testuser (@alltestusers)
3174 if(-s "$PasswordDir/$testuser")
3176 my $storedpassword = `bash -c 'echo -n ${SERVERSALT}test${testuser} | $ENV{"SHASUMCMD
"}'`;
3177 chomp($storedpassword);
3178 open(USERFILE, "<$PasswordDir/$testuser") || die "</Private
/.Passwords/$testuser: $!\n";
3179 @USERlines = <USERFILE>;
3182 open(USERFILE, ">$PasswordDir/$testuser") || die ">/Private
/.Passwords/$testuser: $!\n";
3183 # Add Password and Salt
3184 foreach my $line (@USERlines)
3186 $line =~ s/^Password: (.*)$/Password: $storedpassword/ig;
3187 $line =~ s/^Salt: (.*)$/Salt: $SERVERSALT/ig;
3189 print USERFILE $line;
3198 open(SALTFILE, "<$PasswordDir/SALT") || die "$PasswordDir/SALT
: $!\n";
3199 $SERVERSALT=<SALTFILE>;
3203 # Create login session ticket
3204 open(LOGINTICKET, ">$SessionDir/$LOGINTICKET") || die "$SessionDir/$LOGINTICKET: $!\n";
3205 print LOGINTICKET << "ENDOFLOGINTICKET
";
3207 IPaddress: $IPaddress
3209 Session: $LOGINTICKET
3210 Randomsalt: $RANDOMSALT
3215 # Set global variables
3217 $ENV{'SERVERSALT'} = $SERVERSALT;
3218 CGIexecute::defineCGIvariable('SERVERSALT', "");
3219 ${"CGIexecute
::SERVERSALT
"} = $SERVERSALT;
3222 $ENV{'SESSIONTICKET'} = $SESSIONTICKET;
3223 CGIexecute::defineCGIvariable('SESSIONTICKET', "");
3224 ${"CGIexecute
::SESSIONTICKET
"} = $SESSIONTICKET;
3227 $ENV{'RANDOMSALT'} = $RANDOMSALT;
3228 CGIexecute::defineCGIvariable('RANDOMSALT', "");
3229 ${"CGIexecute
::RANDOMSALT
"} = $RANDOMSALT;
3232 $ENV{'LOGINTICKET'} = $LOGINTICKET;
3233 CGIexecute::defineCGIvariable('LOGINTICKET', "");
3234 ${"CGIexecute
::LOGINTICKET
"} = $LOGINTICKET;
3236 return $ENV{'LOGINTICKET'};
3239 sub create_session_file #($sessionfile, $loginfile, $authorizationfile, $path) -> Is $loginfile deleted? 0/1
3241 my $sessionfile = shift || "";
3242 my $loginfile = shift || "";
3243 my $authorizationfile = shift || "";
3244 my $path = shift || "";
3246 # Get Login session ticket
3247 my $loginticket = read_ticket($loginfile);
3249 # Get Authorization (user) session file
3250 my $authorization = read_ticket($authorizationfile);
3251 # For a Session or a Challenge, we need a stored key
3252 my $sessionkey = "";
3253 if($authorization->{'Session'} && $authorization->{'Session'}->[0] ne 'IPADDRESS')
3255 my $storedpassword = $authorization->{'Password'}->[0];
3256 my $loginticketid = $loginticket->{'Session'}->[0];
3257 $sessionkey = `bash -c 'echo -n $loginticketid$storedpassword| $ENV{"SHASUMCMD
"}'`;
3261 # Convert Authorization content to Session content
3262 my $sessionContent = {};
3263 $sessionContent->{IPaddress} = $loginticket->{'IPaddress'};
3264 $sessionContent->{AllowedPaths} = $authorization->{'AllowedPaths'};
3265 $sessionContent->{DeniedPaths} = $authorization->{'DeniedPaths'};
3266 $sessionContent->{Expires} = $authorization->{'MaxLifetime'};
3267 $sessionContent->{Capabilities} = $authorization->{'Capabilities'};
3268 foreach my $pattern (keys(%TicketRequiredPatterns))
3270 if($path =~ m#$pattern#)
3272 my ($SessionPath, $PasswordsPath, $Login, $validtime) = split(/\t/, $TicketRequiredPatterns{$pattern});
3273 push(@{$sessionContent->{Expires}}, $validtime);
3277 # Write Session Ticket
3278 open(SESSION, ">$sessionfile") || die "$sessionfile: $!\n";
3279 if($authorization->{'Session'} && $authorization->{'Session'}->[0])
3281 print SESSION "Type
: ", $authorization->{'Session'}->[0], "\n";
3285 print SESSION "Type
: SESSION
\n";
3287 foreach my $list ('IPaddress', 'AllowedPaths', 'DeniedPaths', 'Expires', 'Capabilities')
3289 foreach my $entry (@{$sessionContent->{$list}})
3291 print SESSION "$list: $entry\n";
3296 print SESSION "Username
: ", lc($authorization->{'Username'}->[0]), "\n";
3297 print SESSION "Key
: $sessionkey\n" if $sessionkey;
3300 # Login file should now be removed
3301 return unlink($loginfile);
3304 sub check_ticket_validity # ($type, $ticketfile, $address, $path)
3306 my $type = shift || "SESSION
";
3307 my $ticketfile = shift || "";
3308 my $address = shift || "";
3309 my $path = shift || "";
3311 # Is there a session ticket of this name?
3312 return 0 unless -s "$ticketfile";
3314 # There is a session ticket, is it linked to this IP address?
3315 my $ticket = read_ticket($ticketfile);
3317 # Is this the right type of ticket
3318 return unless $ticket->{"Type
"}->[0] eq $type;
3320 # Does the IP address match?
3322 for $IPpattern (@{$ticket->{"IPaddress
"}})
3324 ++$IPmatches if $address =~ m#^$IPpattern#ig;
3326 return 0 unless !$ticket->{"IPaddress
"} || $IPmatches;
3328 # Is the path denied
3329 my $Pathmatches = 0;
3330 foreach $Pathpattern (@{$ticket->{"DeniedPaths
"}})
3332 ++$Pathmatches if $path =~ m#$Pathpattern#ig;
3334 return 0 if @{$ticket->{"DeniedPaths
"}} && $Pathmatches;
3336 # Is the path allowed
3338 foreach $Pathpattern (@{$ticket->{"AllowedPaths
"}})
3340 ++$Pathmatches if $path =~ m#$Pathpattern#ig;
3342 return 0 unless !@{$ticket->{"AllowedPaths
"}} || $Pathmatches;
3344 # Is the ticket expired?
3346 if($ticket->{"Expires
"} && @{$ticket->{"Expires
"}})
3348 my $CurrentTime = time();
3349 ++$Expired if($CurrentTime > $ticket->{"Expires
"}->[0]);
3351 return 0 if $Expired;
3353 # Make login values available
3354 $ENV{"LOGINUSERNAME
"} = lc($ticket->{'Username'}->[0]);
3355 $ENV{"LOGINIPADDRESS
"} = $address;
3356 $ENV{"LOGINPATH
"} = $path;
3357 $ENV{"SESSIONTYPE
"} = $type unless $type eq "PASSWORD
";
3359 # Set Capabilities, if present
3360 if($ticket->{'Username'}->[0] && @{$ticket->{'Capabilities'}})
3362 $ENV{'CAPABILITIES'} = $ticket->{'Username'}->[0];
3363 CGIexecute::defineCGIvariableList('CAPABILITIES', "");
3364 @{"CGIexecute
::CAPABILITIES
"} = @{$ticket->{'Capabilities'}};
3365 # Capabilities should not be changed anymore by CGI query!
3367 # Capabilities are NOT to be set by the query
3368 CGIexecute::ProtectCGIvariable('CAPABILITIES');
3374 sub remove_expired_tickets # ($path) -> number of tickets removed
3376 my $path = shift || "";
3377 return 0 unless $path;
3379 my $removed_tickets = 0;
3380 my @ticketlist = glob("$path/*");
3381 foreach my $ticketfile (@ticketlist)
3383 my $ticket = read_ticket($ticketfile);
3384 if(@{$ticket->{'Expires'}} && $ticket->{'Expires'}->[0] < time)
3390 return $removed_tickets;
3393 sub read_ticket # ($ticketfile) -> &%ticket
3395 my $ticketfile = shift || "";
3397 if($ticketfile && -s $ticketfile)
3399 open(TICKETFILE, "<$ticketfile") || die "$ticketfile: $!\n";
3400 my @alllines = <TICKETFILE>;
3402 foreach my $currentline (@alllines)
3404 if($currentline =~ /^\s*(\S[^\:]+)\:\s+(.*)\s*$/)
3408 # Recalculate expire date from relative time
3409 if($Label =~ /^Expires$/ig && $Value =~ /^\+/)
3411 # Get SessionTicket file stats
3412 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks)
3413 = stat("$ticketfile");
3414 if($Value =~ /^\+(\d+)\s*d(ays)?\s*$/)
3416 $ExpireTime = 24*3600*$1;
3418 elsif($Value =~ /^\+(\d+)\s*m(inutes)?\s*$/)
3420 $ExpireTime = 60*$1;
3422 elsif($Value =~ /^\+(\d+)\s*h(ours)?\s*$/)
3424 $ExpireTime = 3600*$1;
3426 elsif($Value =~ /^\+(\d+)\s*s(econds)?\s*$/)
3430 elsif($Value =~ /^\+(\d+)\s*$/)
3435 my $ActualExpireTime = $ExpireTime + $ctime;
3436 $Value = $ActualExpireTime;
3438 $ticket->{$Label} = () unless exists($ticket->{$Label});
3439 push(@{$ticket->{$Label}}, $Value);
3443 if(exists($ticket->{Expires}))
3445 @{$ticket->{Expires}} = sort(@{$ticket->{Expires}});
3450 # End of Handle login access
3453 ############################################################################
3455 # Handle foreign interpreters (i.e., scripting languages)
3457 # Insert perl code to execute scripts in foreign scripting languages.
3458 # Actually, the scripts inside the <SCRIPT></SCRIPT> blocks are piped
3459 # into an interpreter.
3460 # The code presented here is fairly confusing because it
3461 # actually writes perl code code to the output.
3463 # A table with the file handles
3464 %SCRIPTINGINPUT = ();
3466 # A function to clean up Client delivered CGI parameter values
3467 # (i.e., quote all odd characters)
3477 sub shrubCGIparameter # ($String) -> Cleaned string
3479 my $String = shift || "";
3481 # Change all quotes [`'"] into HTML character entities
3482 my ($Char, $Transcript) = ('&', $SHRUBcharacterTR{'&'});
3485 $String =~ s/\Q$Char\E/$Transcript/isg if $Transcript;
3487 while( ($Char, $Transcript) = each %SHRUBcharacterTR)
3489 next if $Char eq '&';
3490 $String =~ s/\Q$Char\E/$Transcript/isg;
3494 $String =~ s/[\n]/\\n/g;
3495 # Replace control characters with their backslashed octal ordinal numbers
3496 $String =~ s/([^\S \t])/(sprintf("\\0%o", ord($1)))/eisg; #
3497 $String =~ s/([\x00-\x08\x0A-\x1F])/(sprintf("\\0%o", ord($1)))/eisg; #
3503 # The initial open statements: Open a pipe to the foreign script interpreter
3504 sub OpenForeignScript # ($ContentType) -> $DirectivePrefix
3506 my $ContentType = lc(shift) || return "";
3507 my $NewDirective = "";
3509 return $NewDirective if($SCRIPTINGINPUT{$ContentType});
3511 # Construct a unique file handle name
3512 $SCRIPTINGFILEHANDLE = uc($ContentType);
3513 $SCRIPTINGFILEHANDLE =~ s/\W/\_/isg;
3514 $SCRIPTINGINPUT{$ContentType} = $SCRIPTINGFILEHANDLE
3515 unless $SCRIPTINGINPUT{$ContentType};
3517 # Create the relevant script: Open the pipe to the interpreter
3518 $NewDirective .= <<"BLOCKCGISCRIPTOROPEN";
3519 # Open interpreter for '$ContentType'
3520 # Open pipe to interpreter (if it isn't
open already
)
3521 open($SCRIPTINGINPUT{$ContentType}, "|$ScriptingLanguages{$ContentType}") || main
::dieHandler
(14, "$ContentType: \$!\\n");
3522 BLOCKCGISCRIPTOROPEN
3524 # Insert Initialization code and CGI variables
3525 $NewDirective .= InitializeForeignScript
($ContentType);
3528 return $NewDirective;
3532 # The final closing code to stop the interpreter
3533 sub CloseForeignScript
# ($ContentType) -> $DirectivePrefix
3535 my $ContentType = lc(shift) || return "";
3536 my $NewDirective = "";
3538 # Do nothing unless the pipe realy IS open
3539 return "" unless $SCRIPTINGINPUT{$ContentType};
3542 $NewDirective .= "\# Close interpreter for '$ContentType'\n";
3545 # Write the Postfix code
3546 $NewDirective .= CleanupForeignScript
($ContentType);
3548 # Create the relevant script: Close the pipe to the interpreter
3549 $NewDirective .= <<"BLOCKCGISCRIPTORCLOSE";
3550 close($SCRIPTINGINPUT{$ContentType}) || main::dieHandler(15, \"$ContentType: \$!\\n\");
3551 select(STDOUT); \$|=1;
3553 BLOCKCGISCRIPTORCLOSE
3555 # Remove the file handler of the foreign script
3556 delete($SCRIPTINGINPUT{$ContentType});
3558 return $NewDirective;
3562 # The initialization code for the foreign script interpreter
3563 sub InitializeForeignScript
# ($ContentType) -> $DirectivePrefix
3565 my $ContentType = lc(shift) || return "";
3566 my $NewDirective = "";
3568 # Add initialization code
3569 if($ScriptingInitialization{$ContentType})
3571 $NewDirective .= <<"BLOCKCGISCRIPTORINIT";
3572 # Initialization Code for '$ContentType'
3573 # Select relevant output filehandle
3574 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3576 # The Initialization code (if any)
3577 print $SCRIPTINGINPUT{$ContentType} <<'${ContentType}INITIALIZATIONCODE';
3578 $ScriptingInitialization{$ContentType}
3579 ${ContentType}INITIALIZATIONCODE
3581 BLOCKCGISCRIPTORINIT
3584 # Add all CGI variables defined
3585 if(exists($ScriptingCGIvariables{$ContentType}))
3587 # Start writing variable definitions to the Interpreter
3588 if($ScriptingCGIvariables{$ContentType})
3590 $NewDirective .= <<"BLOCKCGISCRIPTORVARDEF";
3591 # CGI variables (from the %default_values table)
3592 print $SCRIPTINGINPUT{$ContentType} << '${ContentType}CGIVARIABLES';
3593 BLOCKCGISCRIPTORVARDEF
3597 foreach $N (keys(%default_values))
3599 # Determine whether the parameter has been defined
3600 # (the eval is a workaround to get at the variable value)
3601 next unless eval("defined(\$CGIexecute::$N)");
3603 # Get the value from the EXECUTION environment
3604 $V = eval("\$CGIexecute::$N");
3605 # protect control characters (i.e., convert them to \0.. form)
3606 $V = shrubCGIparameter
($V);
3608 # Protect interpolated variables
3609 eval("\$CGIexecute::$N = '$V';") unless $ScriptingCGIvariables{$ContentType};
3611 # Print the actual declaration for this scripting language
3612 if($ScriptingCGIvariables{$ContentType})
3614 $NewDirective .= sprintf($ScriptingCGIvariables{$ContentType}, $N, $V);
3615 $NewDirective .= "\n";
3619 # Stop writing variable definitions to the Interpreter
3620 if($ScriptingCGIvariables{$ContentType})
3622 $NewDirective .= <<"BLOCKCGISCRIPTORVARDEFEND";
3623 ${ContentType}CGIVARIABLES
3624 BLOCKCGISCRIPTORVARDEFEND
3629 $NewDirective .= << "BLOCKCGISCRIPTOREND";
3631 # Select STDOUT filehandle
3632 select(STDOUT
); \
$|=1;
3636 return $NewDirective;
3640 # The cleanup code for the foreign script interpreter
3641 sub CleanupForeignScript
# ($ContentType) -> $DirectivePrefix
3643 my $ContentType = lc(shift) || return "";
3644 my $NewDirective = "";
3646 # Return if not needed
3647 return $NewDirective unless $ScriptingCleanup{$ContentType};
3649 # Create the relevant script: Open the pipe to the interpreter
3650 $NewDirective .= <<"BLOCKCGISCRIPTORSTOP";
3651 # Cleanup Code for '$ContentType'
3652 # Select relevant output filehandle
3653 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3654 # Print Cleanup code to foreign script
3655 print $SCRIPTINGINPUT{$ContentType} <<'${ContentType}SCRIPTSTOP';
3656 $ScriptingCleanup{$ContentType}
3657 ${ContentType}SCRIPTSTOP
3659 # Select STDOUT filehandle
3660 select(STDOUT); \$|=1;
3661 BLOCKCGISCRIPTORSTOP
3663 return $NewDirective;
3667 # The prefix code for each <script></script> block
3668 sub PrefixForeignScript
# ($ContentType) -> $DirectivePrefix
3670 my $ContentType = lc(shift) || return "";
3671 my $NewDirective = "";
3673 # Return if not needed
3674 return $NewDirective unless $ScriptingPrefix{$ContentType};
3677 # If the CGIvariables parameter is defined, but empty, interpolate
3678 # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END')
3679 $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) &&
3680 !$ScriptingCGIvariables{$ContentType};
3682 # Add initialization code
3683 $NewDirective .= <<"BLOCKCGISCRIPTORPREFIX";
3684 # Prefix Code for '$ContentType'
3685 # Select relevant output filehandle
3686 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3688 # The block Prefix code (if any)
3689 print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}PREFIXCODE$Quote;
3690 $ScriptingPrefix{$ContentType}
3691 ${ContentType}PREFIXCODE
3692 # Select STDOUT filehandle
3693 select(STDOUT); \$|=1;
3694 BLOCKCGISCRIPTORPREFIX
3696 return $NewDirective;
3700 # The postfix code for each <script></script> block
3701 sub PostfixForeignScript
# ($ContentType) -> $DirectivePrefix
3703 my $ContentType = lc(shift) || return "";
3704 my $NewDirective = "";
3706 # Return if not needed
3707 return $NewDirective unless $ScriptingPostfix{$ContentType};
3710 # If the CGIvariables parameter is defined, but empty, interpolate
3711 # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END')
3712 $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) &&
3713 !$ScriptingCGIvariables{$ContentType};
3715 # Create the relevant script: Open the pipe to the interpreter
3716 $NewDirective .= <<"BLOCKCGISCRIPTORPOSTFIX";
3717 # Postfix Code for '$ContentType'
3718 # Select filehandle to interpreter
3719 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3720 # Print postfix code to foreign script
3721 print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}SCRIPTPOSTFIX$Quote;
3722 $ScriptingPostfix{$ContentType}
3723 ${ContentType}SCRIPTPOSTFIX
3724 # Select STDOUT filehandle
3725 select(STDOUT); \$|=1;
3726 BLOCKCGISCRIPTORPOSTFIX
3728 return $NewDirective;
3731 sub InsertForeignScript
# ($ContentType, $directive, @SRCfile) -> $NewDirective
3733 my $ContentType = lc(shift) || return "";
3734 my $directive = shift || return "";
3736 my $NewDirective = "";
3739 # If the CGIvariables parameter is defined, but empty, interpolate
3740 # code string (i.e., $var .= << "END" i.s.o. $var .= << 'END')
3741 $Quote = '"' if exists($ScriptingCGIvariables{$ContentType}) &&
3742 !$ScriptingCGIvariables{$ContentType};
3744 # Create the relevant script
3745 $NewDirective .= <<"BLOCKCGISCRIPTORINSERT";
3746 # Insert Code for '$ContentType'
3747 # Select filehandle to interpreter
3748 select($SCRIPTINGINPUT{$ContentType}); \$|=1;
3749 BLOCKCGISCRIPTORINSERT
3751 # Use SRC feature files
3753 while($ThisSRCfile = shift(@_))
3756 if($ThisSRCfile =~ /^\s*\{\s*/)
3759 $Block = $` if $Block =~ /\s*\}\s*$/;
3760 $NewDirective .= <<"BLOCKCGISCRIPTORSRCBLOCK";
3761 print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}SRCBLOCKCODE$Quote;
3763 ${ContentType}SRCBLOCKCODE
3764 BLOCKCGISCRIPTORSRCBLOCK
3770 $NewDirective .= <<"BLOCKCGISCRIPTORSRCFILES";
3772 open(SCRIPTINGSOURCE, "<$ThisSRCfile") || main::dieHandler(16, "$ThisSRCfILE: \$!");
3773 while(<SCRIPTINGSOURCE>)
3775 print $SCRIPTINGINPUT{$ContentType} \$_;
3777 close(SCRIPTINGSOURCE);
3779 BLOCKCGISCRIPTORSRCFILES
3786 $NewDirective .= <<"BLOCKCGISCRIPTORINSERT";
3787 print $SCRIPTINGINPUT{$ContentType} <<$Quote${ContentType}DIRECTIVECODE$Quote;
3789 ${ContentType}DIRECTIVECODE
3790 BLOCKCGISCRIPTORINSERT
3794 $NewDirective .= <<"BLOCKCGISCRIPTORSELECT";
3795 # Select STDOUT filehandle
3796 select(STDOUT); \$|=1;
3797 BLOCKCGISCRIPTORSELECT
3800 return $NewDirective;
3803 sub CloseAllForeignScripts
# Call CloseForeignScript on all open scripts
3806 foreach $ContentType (keys(%SCRIPTINGINPUT))
3808 my $directive = CloseForeignScript
($ContentType);
3809 print STDERR
"\nDirective $CGI_Date: ", $directive;
3810 CGIexecute
->evaluate($directive);
3815 # End of handling foreign (external) scripting languages.
3817 ############################################################################
3819 # A subroutine to handle "nested" quotes, it cuts off the leading
3820 # item or quoted substring
3822 # ' A_word and more words' -> @('A_word', ' and more words')
3823 # '"quoted string" The rest' -> @('quoted string', ' The rest')
3824 # (this is needed for parsing the <TAGS> and their attributes)
3825 my $SupportedQuotes = "\'\"\`\(\{\[";
3826 my %QuotePairs = ('('=>')','['=>']','{'=>'}'); # Brackets
3827 sub ExtractQuotedItem
# ($String) -> @($QuotedString, $RestOfString)
3830 my $String = shift || return @Result;
3832 if($String =~ /^\s*([\w\/\
-\
.]+)/is
)
3834 push(@Result, $1, $');
3836 elsif($String =~ /^\s*(\\?)([\Q$SupportedQuotes\E])/is)
3838 my $BackSlash = $1 || "";
3840 my $CloseQuote = $OpenQuote;
3841 $CloseQuote = $QuotePairs{$OpenQuote} if $QuotePairs{$OpenQuote};
3845 $String =~ /^\s*\\\Q$OpenQuote\E/i;
3847 $Onset =~ /\\\Q$CloseQuote\E/i;
3850 push(@Result, $Item, $Rest);
3855 $String =~ /^\s*\Q$OpenQuote\E([^\Q$CloseQuote\E]*)\Q$CloseQuote\E/i;
3856 push(@Result, $1, $');
3861 push(@Result, "", $String);
3866 # Now, start with the real work
3868 # Control the output of the Content-type: text/html\n\n message
3869 my $SupressContentType = 0;
3872 sub ProcessFile
# ($file_path)
3874 my $file_path = shift || return 0;
3877 # Generate a unique file handle (for recursions)
3879 my $FileHandle = "file";
3881 while(!eof($FileHandle.$n)) {++$n;};
3885 # Use the default Content-type if this is NOT a raw file
3886 unless(($RawFilePattern && $ENV{'PATH_INFO'} =~ m@
($RawFilePattern)$@i)
3887 || $SupressContentType)
3889 $ENV{'PATH_INFO'} =~ m@
($FilePattern)$@i;
3890 my $ContentType = $ContentTypeTable{$1};
3891 print "Content-type: $ContentType\n";
3892 if(%SETCOOKIELIST && keys(%SETCOOKIELIST))
3894 foreach my $name (keys(%SETCOOKIELIST))
3896 my $value = $SETCOOKIELIST{$name};
3897 print "Set-Cookie: $name=$value\n";
3899 # Cookies are set only ONCE
3900 %SETCOOKIELIST = ();
3903 $SupressContentType = 1; # Content type has been printed
3907 # Get access to the actual data. This can be from RAM (by way of an
3908 # environment variable) or by opening a file.
3910 # Handle the use of RAM images (file-data is stored in the
3911 # $CGI_FILE_CONTENTS environment variable)
3912 # Note that this environment variable will be cleared, i.e., it is strictly for
3914 if($ENV{$CGI_FILE_CONTENTS})
3916 # File has been read already
3917 $_ = $ENV{$CGI_FILE_CONTENTS};
3918 # Sorry, you have to do the reading yourself (dynamic document creation?)
3919 # NOTE: you must read the whole document at once
3922 $_ = eval("\@_=('$file_path'); do{$ENV{$CGI_DATA_ACCESS_CODE}}");
3924 else # Clear environment variable
3926 $ENV{$CGI_FILE_CONTENTS} = '-';
3929 # Open Only PLAIN TEXT files (or STDIN) and NO executable files (i.e., scripts).
3930 # THIS IS A SECURITY FEATURE!
3931 elsif($file_path eq '-' || (-e
"$file_path" && -r _
&& -T _
&& -f _
&& ! (-x _
|| -X _
) ))
3933 open($FileHandle, $file_path) || dieHandler
(17, "<h2>File not found</h2>\n");
3934 push(@OpenFiles, $file_path);
3935 $_ = <$FileHandle>; # Read first line
3939 print "<h2>File not found</h2>\n";
3940 dieHandler
(18, "$file_path\n");
3943 $| = 1; # Flush output buffers
3945 # Initialize variables
3946 my $METAarguments = ""; # The CGI arguments from the latest META tag
3947 my @METAvalues = (); # The ''-quoted CGI values from the latest META tag
3948 my $ClosedTag = 0; # <TAG> </TAG> versus <TAG/>
3951 # Send document to output
3952 # Process the requested document.
3953 # Do a loop BEFORE reading input again (this catches the RAM/Database
3954 # type of documents).
3958 # Handle translations if needed
3960 performTranslation
(\
$_) if $TranslationPaths;
3962 # Catch <SCRIPT LANGUAGE="PERL" TYPE="text/ssperl" > directives in $_
3963 # There can be more than 1 <SCRIPT> or META tags on a line
3964 while(/\<\s*(SCRIPT|META|DIV|INS)\s/is)
3967 # Store rest of line
3971 my $TagType = uc($1);
3972 # The before part can be send to the output
3975 # Read complete Tag from after and/or file
3976 until($After =~ /([^\\])\>/)
3978 $After .= <$FileHandle>;
3979 performTranslation(\$After) if $TranslationPaths;
3982 if($After =~ /([^\\])\>/)
3984 $ScriptTag .= $`.$&; # Keep the Script Tag intact
3989 dieHandler(19, "Closing > not found\n");
3992 # The tag could be closed by />, we handle this in the XML way
3993 # and don't process any content
(we ignore whitespace
)
3994 $ClosedTag = ($ScriptTag =~ m@
[^\\]/\s
*\
>\s
*$@
) ?
1 : 0;
3998 my $TypeName = ($TagType =~ /META/is) ?
"CONTENT" : "TYPE";
3999 $TypeName = "CLASS" if $TagType eq 'DIV' || $TagType eq 'INS';
4001 # Parse <SCRIPT> or <META> directive
4002 # If NOT (TYPE|CONTENT)="text/ssperl" (i.e., $ServerScriptContentType),
4003 # send the line to the output and go to the next loop
4004 my $CurrentContentType = "";
4005 if($ScriptTag =~ /(^|\s)$TypeName\s*=\s*/is)
4007 my ($Type) = ExtractQuotedItem
($');
4008 $Type =~ /^\s*([\w\/\-]+)\s*[\,\;]?/;
4009 $CurrentContentType = lc($1); # Note: mime-types are "case-less"
4010 # CSS classes are aliases of $ServerScriptContentType
4011 if($TypeName eq "CLASS" && $CurrentContentType eq $ServerScriptContentClass)
4013 $CurrentContentType = $ServerScriptContentType;
4018 # Not a known server-side content type, print and continue
4019 unless(($CurrentContentType =~
4020 /$ServerScriptContentType|$ShellScriptContentType/is) ||
4021 $ScriptingLanguages{$CurrentContentType})
4029 # A known server-side content type, evaluate
4031 # First, handle \> and \<
4032 $ScriptTag =~ s/\\\>/\>/isg;
4033 $ScriptTag =~ s/\\\</\</isg;
4035 # Extract the CGI, SRC, ID, IF and UNLESS attributes
4036 my %ScriptTagAttributes = ();
4037 while($ScriptTag =~ /(^|\s)(CGI|IF|UNLESS|SRC|ID)\s*=\s*/is)
4042 ($Value, $ScriptTag) = ExtractQuotedItem
($Rest);
4043 $ScriptTagAttributes{uc($Attribute)} = $Value;
4047 # The attribute used to define the CGI variables
4048 # Extract CGI-variables from
4049 # <META CONTENT="text/ssperl; CGI='' SRC=''">
4050 # <SCRIPT TYPE='text/ssperl' CGI='' SRC=''>
4051 # <DIV CLASS='ssperl' CGI='' SRC='' ID=""> tags
4052 # <INS CLASS='ssperl' CGI='' SRC='' ID=""> tags
4053 if($ScriptTagAttributes{'CGI'})
4055 @ARGV = (); # Reset ARGV
4057 $METAarguments = ""; # Reset the META CGI arguments
4059 my $Meta_CGI = $ScriptTagAttributes{'CGI'};
4061 # Process default values of variables ($<name> = 'default value')
4062 # Allowed quotes are '', "", ``, (), [], and {}
4063 while($Meta_CGI =~ /(^\s*|[^\\])([\$\@\%]?)([\w\-]+)\s*/is)
4065 my $varType = $2 || '$'; # Variable or list
4066 my $name = $3; # The Name
4070 if($Meta_CGI =~ /^\s*\=\s*/is)
4072 # Locate (any) default value
4073 ($default, $Meta_CGI) = ExtractQuotedItem($'); # Cut the parameter from the CGI
4075 $RemainingTag = $Meta_CGI;
4078 # Define CGI (or ENV) variable, initalize it from the
4079 # Query string or the default value
4081 # Also construct the @ARGV and @_ arrays. This allows other (SRC=) Perl
4082 # scripts to access the CGI arguments defined in the META tag
4083 # (Not for CGI inside <SCRIPT> tags)
4086 CGIexecute
::defineCGIvariable
($name, $default)
4087 || dieHandler
(20, "INVALID CGI name/value pair ($name, $default)\n");
4088 push(@METAvalues, "'".${"CGIexecute::$name"}."'");
4089 # Add value to the @ARGV list
4090 push(@ARGV, ${"CGIexecute::$name"});
4093 elsif($varType eq '@')
4095 CGIexecute
::defineCGIvariableList
($name, $default)
4096 || dieHandler
(21, "INVALID CGI name/value list pair ($name, $default)\n");
4097 push(@METAvalues, "'".join("'", @
{"CGIexecute::$name"})."'");
4098 # Add value to the @ARGV list
4099 push(@ARGV, @
{"CGIexecute::$name"});
4100 $ARGC = scalar(@CGIexecute::ARGV
);
4102 elsif($varType eq '%')
4104 CGIexecute
::defineCGIvariableHash
($name, $default)
4105 || dieHandler
(22, "INVALID CGI name/value hash pair ($name, $default)\n");
4106 my @PairList = map {"$_ => ".${"CGIexecute::$name"}{$_}} keys(%{"CGIexecute::$name"});
4107 push(@METAvalues, "'".join("'", @PairList)."'");
4108 # Add value to the @ARGV list
4109 push(@ARGV, %{"CGIexecute::$name"});
4110 $ARGC = scalar(@CGIexecute::ARGV
);
4113 # Store the values for internal and later use
4114 $METAarguments .= "$varType".$name.","; # A string of CGI variable names
4116 push(@METAvalues, "\'".eval("\"$varType\{CGIexecute::$name\}\"")."\'"); # ALWAYS add '-quotes around values
4121 # The IF (conditional execution) Attribute
4122 # Evaluate the condition and stop unless it evaluates to true
4123 if($ScriptTagAttributes{'IF'})
4125 my $IFcondition = $ScriptTagAttributes{'IF'};
4127 # Convert SCRIPT calls, ./<script>
4128 $IFcondition =~ s@
([\W
]|^)\
./([\S
])@
$1$SCRIPT_SUB$2@g;
4130 # Convert FILE calls, ~/<file>
4131 $IFcondition =~ s@
([\W
])\
~/([\S
])@
$1$HOME_SUB$2@g;
4133 # Block execution if necessary
4134 unless(CGIexecute
->evaluate($IFcondition))
4136 %ScriptTagAttributes = ();
4137 $CurrentContentType = "";
4141 # The UNLESS (conditional execution) Attribute
4142 # Evaluate the condition and stop if it evaluates to true
4143 if($ScriptTagAttributes{'UNLESS'})
4145 my $UNLESScondition = $ScriptTagAttributes{'UNLESS'};
4147 # Convert SCRIPT calls, ./<script>
4148 $UNLESScondition =~ s@
([\W
]|^)\
./([\S
])@
$1$SCRIPT_SUB$2@g;
4150 # Convert FILE calls, ~/<file>
4151 $UNLESScondition =~ s@
([\W
])\
~/([\S
])@
$1$HOME_SUB$2@g;
4153 # Block execution if necessary
4154 if(CGIexecute
->evaluate($UNLESScondition))
4156 %ScriptTagAttributes = ();
4157 $CurrentContentType = "";
4161 # The SRC (Source File) Attribute
4162 # Extract any source script files and add them in
4163 # front of the directive
4164 # The SRC list should be emptied
4168 my $PrefixDirective = "";
4169 my $PostfixDirective = "";
4170 # There is a SRC attribute
4171 if($ScriptTagAttributes{'SRC'})
4173 $SRCtag = $ScriptTagAttributes{'SRC'};
4174 # Remove "file://" prefixes
4175 $SRCtag =~ s@
([^\w\
/\\]|^)file\://([^\s\/\@\
=])@
$1$2@gis;
4176 # Expand script filenames "./Script"
4177 $SRCtag =~ s@
([^\w\
/\\]|^)\./([^\s\
/\@\=])@$1$SCRIPT_SUB/$2@gis;
4178 # Expand script filenames "~/Script"
4179 $SRCtag =~ s@
([^\w\
/\\]|^)\~/([^\s\
/\@\=])@$1$HOME_SUB/$2@gis;
4183 while($SRCtag =~ /\S/is)
4185 my $SRCdirective = "";
4187 # Pseudo file, just a switch to go from PREFIXING to POSTFIXING
4189 if($SRCtag =~ /^[\s\;\,]*(POSTFIX|PREFIX)([^$FileAllowedChars]|$)/is)
4191 my $InsertionPlace = $1;
4194 $Prefix = $InsertionPlace =~ /POSTFIX/i ? 0 : 1;
4198 # {}-blocks are just evaluated by "do"
4199 elsif($SRCtag =~ /^[\s\;\,]*\{/is)
4202 if($SRCblock =~ /\}[\s\;\,]*([^\}]*)$/is)
4206 # SAFEqx shell script blocks
4207 if($CurrentContentType =~ /$ShellScriptContentType/is)
4209 # Handle ''-quotes inside the script
4210 $SRCblock =~ s/[\']/\\$&/gis;
4212 $SRCblock = "print do { SAFEqx(\'".$SRCblock."\'); };'';";
4213 $SRCdirective .= $SRCblock."\n";
4216 elsif($CurrentContentType =~ /$ServerScriptContentType/is)
4218 $SRCblock = "print do { $SRCblock };'';";
4219 $SRCdirective .= $SRCblock."\n";
4221 else # The interpreter should handle this
4223 push(@SRClist, "{ $SRCblock }");
4228 { dieHandler(23, "Closing \} missing\n");};
4230 # Files are processed as Text or Executable files
4231 elsif($SRCtag =~ /[\s\;\,]*([$FileAllowedChars]+)[\;\,\s]*/is)
4236 # We are handling one of the external interpreters
4237 if($ScriptingLanguages{$CurrentContentType})
4239 push(@SRClist, $SrcFile);
4241 # We are at the start of a DIV tag, just load all SRC files and/or URL's
4242 elsif($TagType eq 'DIV' || $TagType eq 'INS') # All files are prepended in DIV's
4244 # $SrcFile is a URL pointing to an HTTP or FTP server
4245 if($SrcFile =~ m!^([a-z]+)\://!)
4247 my $URLoutput = CGIscriptor::read_url($SrcFile);
4248 $SRCdirective .= $URLoutput;
4250 # SRC file is an existing file
4251 elsif(-e "$SrcFile")
4253 open(DIVSOURCE, "<$SrcFile") || dieHandler(24, "<$SrcFile: $!\n");
4255 while(sysread(DIVSOURCE, $Content, 1024) > 0)
4257 $SRCdirective .= $Content;
4262 # Executable files are executed as
4263 # `$SrcFile 'ARGV[0]' 'ARGV[1]'`
4264 elsif(-x "$SrcFile")
4266 $SRCdirective .= "print \`$SrcFile @METAvalues\
`;'';\n";
4268 # Handle 'standard' files, using ProcessFile
4269 elsif((-T "$SrcFile" || $ENV{$CGI_FILE_CONTENTS})
4270 && $SrcFile =~ m@($FilePattern)$@) # A recursion
4273 # Do not process still open files because it can lead
4274 # to endless recursions
4275 if(grep(/^$SrcFile$/, @OpenFiles))
4276 { dieHandler(25, "$SrcFile allready opened (endless recursion)\n")};
4277 # Prepare meta arguments
4278 $SRCdirective .= '@ARGV = (' .$METAarguments.");\n" if $METAarguments;
4280 $SRCdirective .= "main::ProcessFile(\'$SrcFile\');'';\n";
4282 elsif($SrcFile =~ m!^([a-z]+)\://!) # URL's are loaded and printed
4284 $SRCdirective .= GET_URL($SrcFile);
4286 elsif(-T "$SrcFile") # Textfiles are "do"-ed (Perl execution)
4288 $SRCdirective .= '@ARGV = (' .$METAarguments.");\n" if $METAarguments;
4289 $SRCdirective .= "do \'$SrcFile\';'';\n";
4291 else # This one could not be resolved (should be handled by BinaryMapFile)
4293 $SRCdirective .= 'print "'.$SrcFile.' cannot be used"'."\n";
4301 $PrefixDirective .= $SRCdirective;
4305 $PostfixDirective .= $SRCdirective;
4308 # The prefix should be handled immediately
4309 $directive .= $PrefixDirective;
4310 $PrefixDirective = "";
4314 # Handle the content of the <SCRIPT></SCRIPT> tags
4315 # Do not process the content of <SCRIPT/>
4316 if($TagType =~ /SCRIPT/is && !$ClosedTag) # The <SCRIPT> TAG
4318 my $EndScriptTag = "";
4320 # Execute SHELL scripts with SAFEqx()
4321 if($CurrentContentType =~ /$ShellScriptContentType/is)
4323 $directive .= "SAFEqx(\'";
4327 while($After !~ /\<\s*\/SCRIPT[^\>]*\>/is && !eof($FileHandle))
4329 $After .= <$FileHandle>;
4330 performTranslation(\$After) if $TranslationPaths;
4333 if($After =~ /\<\s*\/SCRIPT[^\>]*\>/is)
4341 dieHandler(26, "Missing </SCRIPT> end tag in $ENV{'PATH_INFO
'}\n");
4344 # Process only when content should be executed
4345 if($CurrentContentType)
4348 # Remove all comments from Perl scripts
4349 # (NOT from OS shell scripts)
4350 $directive =~ s/[^\\\$]\#[^\n\f\r]*([\n\f\r])/$1/g
4351 if $CurrentContentType =~ /$ServerScriptContentType/i;
4353 # Convert SCRIPT calls, ./<script>
4354 $directive =~ s@([\W]|^)\./([\S])@$1$SCRIPT_SUB$2@g;
4356 # Convert FILE calls, ~/<file>
4357 $directive =~ s@([\W])\~/([\S])@$1$HOME_SUB$2@g;
4359 # Execute SHELL scripts with SAFEqx(), closing bracket
4360 if($CurrentContentType =~ /$ShellScriptContentType/i)
4362 # Handle ''-quotes inside the script
4363 $directive =~ /SAFEqx\(\'/;
4365 my $Executable = $';
4366 $Executable =~ s/[\']/\\$&/gs;
4368 $directive .= $Executable."\');"; # Closing bracket
4376 # Handle the content of the <DIV></DIV> tags
4377 # Do not process the content of <DIV/>
4378 elsif(($TagType eq 'DIV' || $TagType eq 'INS') && !$ClosedTag) # The <DIV> TAGs
4380 my $EndScriptTag = "";
4383 while($After !~ /\<\s*\/$TagType[^\
>]*\
>/is
&& !eof($FileHandle))
4385 $After .= <$FileHandle>;
4386 performTranslation
(\
$After) if $TranslationPaths;
4389 if($After =~ /\<\s*\/$TagType[^\
>]*\
>/is
)
4397 dieHandler(27, "Missing </$TagType> end tag in $ENV{'PATH_INFO'}\n");
4400 # Add the Postfixed directives (but only when it contains something printable)
4401 $directive .= "\n".$PostfixDirective if $PostfixDirective =~ /\S/;
4402 $PostfixDirective = "";
4405 # Process only when content should be handled
4406 if($CurrentContentType)
4409 # Get the name (ID), and clean it (i.e., remove anything that is NOT part of
4410 # a valid Perl name). Names should not contain $, but we can handle it.
4411 my $name = $ScriptTagAttributes{'ID'};
4412 $name =~ /^\s*[\$\@\%]?([\w\-]+)/;
4415 # Assign DIV contents to $NAME value OUTSIDE the CGI values!
4416 CGIexecute::defineCGIexecuteVariable($name, $directive);
4420 # Nothing to execute
4425 # Handle Foreign scripting languages
4426 if($ScriptingLanguages{$CurrentContentType})
4428 my $newDirective = "";
4429 $newDirective .= OpenForeignScript($CurrentContentType); # Only if not already done
4430 $newDirective .= PrefixForeignScript($CurrentContentType);
4431 $newDirective .= InsertForeignScript($CurrentContentType, $directive, @SRClist);
4432 $newDirective .= PostfixForeignScript($CurrentContentType);
4433 $newDirective .= CloseForeignScript($CurrentContentType); # This shouldn't be necessary
4435 $newDirective .= '"";';
4437 $directive = $newDirective;
4441 # Add the Postfixed directives (but only when it contains something printable)
4442 $directive .= "\n".$PostfixDirective if $PostfixDirective =~ /\S/;
4443 $PostfixDirective = "";
4446 # EXECUTE the script and print the results
4448 # Use this to debug the program
4449 # print STDERR "Directive $CGI_Date: \n", $directive, "\n\n";
4451 my $Result = CGIexecute->evaluate($directive) if $directive; # Evaluate as PERL code
4452 $Result =~ s/\n$//g; # Remove final newline
4454 # Print the Result of evaluating the directive
4455 # (this will handle LARGE, >64 kB output)
4456 my $BytesWritten = 1;
4457 while($Result && $BytesWritten)
4459 $BytesWritten = syswrite(STDOUT, $Result, 64);
4460 $Result = substr($Result, $BytesWritten);
4462 # print $Result; # Could be used instead of above code
4464 # Store result if wanted, i.e., if $CGIscriptorResults has been
4465 # defined in a <META> tag.
4466 push(@CGIexecute::CGIscriptorResults, $Result)
4467 if exists($default_values{'CGIscriptorResults'});
4469 # Process the rest of the input line (this could contain
4470 # another directive)
4474 } while(<$FileHandle>); # Read and Test AFTER first loop!
4476 close ($FileHandle);
4477 dieHandler(28, "Error in recursion\n") unless pop(@OpenFiles) == $file_path;
4481 ###############################################################################
4483 # Call the whole package
4489 # Initialization Code
4490 Initialize_Request();
4492 # SECURITY: ACCESS CONTROL
4495 # Read the POST part of the query, if there is one
4496 Get_POST_part_of_query();
4498 # Start (HTML) output and logging
4499 $file_path = Initialize_output();
4501 # Check login access or divert to login procedure
4502 $Use_Login = Log_In_Access();
4503 $file_path = $Use_Login if $Use_Login;
4505 # Record which files are still open (to avoid endless recursions)
4508 # Record whether the default HTML ContentType has already been printed
4509 # but only if the SERVER uses HTTP or some other protocol that might interpret
4510 # a content MIME type.
4512 $SupressContentType = !("$ENV{'SERVER_PROTOCOL'}" =~ /($ContentTypeServerProtocols)/i);
4514 # Process the specified file
4515 ProcessFile($file_path) if $file_path ne $SS_PUB;
4517 # Cleanup all open external (foreign) interpreters
4518 CloseAllForeignScripts();
4524 # Make a single call to handle an (empty) request
4528 # END OF PACKAGE MAIN
4531 ####################################################################################
4533 # The CGIEXECUTE PACKAGE
4535 ####################################################################################
4537 # Isolate the evaluation of directives as PERL code from the rest of the program.
4538 # Remember that each package has its own name space.
4539 # Note that only the FIRST argument of execute->evaluate is actually evaluated,
4540 # all other arguments are accessible inside the first argument as $_[0] to $_[$#_].
4547 my $directive = shift;
4548 $directive = eval($directive);
4549 warn $@ if $@; # Write an error message to STDERR
4550 $directive; # Return value of directive
4554 # defineCGIexecuteVariable($name [, $value]) -> 0/1
4556 # Define and intialize variables inside CGIexecute
4557 # Does no sanity checking, for internal use only
4559 sub defineCGIexecuteVariable # ($name [, $value]) -> 0/1
4561 my $name = shift || return 0; # The Name
4562 my $value = shift || ""; # The value
4569 # Protect certain CGI variables values when set internally
4570 my %CGIprotectedVariable = ();
4571 sub ProtectCGIvariable # ($name) -> 0/1
4573 my $name = shift || "";
4574 return 0 unless $name && $name =~ /\w/;
4576 ++$CGIprotectedVariable{$name};
4578 return $CGIprotectedVariable{$name};
4581 # defineCGIvariable($name [, $default]) -> 0/1
4583 # Define and intialize CGI variables
4584 # Tries (in order) $ENV{$name}, the Query string and the
4586 # Removes all '-quotes etc.
4588 sub defineCGIvariable # ($name [, $default]) -> 0/1
4590 my $name = shift || return 0; # The Name
4591 my $default = shift || ""; # The default value
4593 # Protect variables set internally
4594 return 1 if !$name || exists($CGIprotectedVariable{$name});
4596 # Remove \-quoted characters
4597 $default =~ s/\\(.)/$1/g;
4598 # Store default values
4599 $::default_values{$name} = $default if $default;
4603 # If there is a user supplied value, it replaces the
4606 # Environment values have precedence
4607 if(exists($ENV{$name}))
4609 $temp = $ENV{$name};
4611 # Get name and its value from the query string
4612 elsif($ENV{QUERY_STRING} =~ /$name/) # $name is in the query string
4614 $temp = ::YOUR_CGIPARSE($name);
4616 # Defined values must exist for security
4617 elsif(!exists($::default_values{$name}))
4619 $::default_values{$name} = undef;
4622 # SECURITY, do not allow '- and `-quotes
in
4624 # Remove all existing '-quotes
4625 $temp =~ s/([\r\f]+\n)/\n/g; # Only \n is allowed
4626 $temp =~ s/[\']/’/igs; # Remove all single quotes
4627 $temp =~ s/[\`]/‘/igs; # Remove all backtick quotes
4628 # If $temp is empty, use the default value (if it exists)
4629 unless($temp =~ /\S/ || length($temp) > 0) # I.e., $temp is empty
4631 $temp = $::default_values
{$name};
4632 # Remove all existing '-quotes
4633 $temp =~ s/([\r\f]+\n)/\n/g; # Only \n is allowed
4634 $temp =~ s/[\']/’/igs; # Remove all single quotes
4635 $temp =~ s/[\`]/‘/igs; # Remove all backtick quotes
4637 else # Store current CGI values and remove defaults
4639 $::default_values
{$name} = $temp;
4641 # Define the CGI variable and its value (in the execute package)
4648 sub defineCGIvariableList
# ($name [, $default]) -> 0/1)
4650 my $name = shift || return 0; # The Name
4651 my $default = shift || ""; # The default value
4653 # Protect variables set internally
4654 return 1 if !$name || exists($CGIprotectedVariable{$name});
4656 # Defined values must exist for security
4657 if(!exists($::default_values
{$name}))
4659 $::default_values
{$name} = $default;
4666 # Environment values have precedence
4667 if(exists($ENV{$name}))
4669 push(@temp, $ENV{$name});
4671 # Get name and its values from the query string
4672 elsif($ENV{QUERY_STRING
} =~ /$name/) # $name is in the query string
4674 push(@temp, ::YOUR_CGIPARSE
($name, 1)); # Extract LIST
4678 push(@temp, $::default_values
{$name});
4682 # SECURITY, do not allow '- and `-quotes in
4684 # Remove all existing '-quotes
4685 @temp = map {s/([\r\f]+\n)/\n/g; $_} @temp; # Only \n is allowed
4686 @temp = map {s/[\']/’/igs; $_} @temp; # Remove all single quotes
4687 @temp = map {s/[\`]/‘/igs; $_} @temp; # Remove all backtick quotes
4689 # Store current CGI values and remove defaults
4690 $::default_values
{$name} = $temp[0];
4692 # Define the CGI variable and its value (in the execute package)
4699 sub defineCGIvariableHash
# ($name [, $default]) -> 0/1) Note: '$name{""} = $default';
4701 my $name = shift || return 0; # The Name
4702 my $default = shift || ""; # The default value
4704 # Protect variables set internally
4705 return 1 if !$name || exists($CGIprotectedVariable{$name});
4707 # Defined values must exist for security
4708 if(!exists($::default_values
{$name}))
4710 $::default_values
{$name} = $default;
4717 # Environment values have precedence
4718 if(exists($ENV{$name}))
4720 $temp{""} = $ENV{$name};
4722 # Get name and its values from the query string
4723 elsif($ENV{QUERY_STRING
} =~ /$name/) # $name is in the query string
4725 %temp = ::YOUR_CGIPARSE
($name, -1); # Extract HASH table
4727 elsif($::default_values
{$name} ne "")
4729 $temp{""} = $::default_values
{$name};
4733 # SECURITY, do not allow '- and `-quotes in
4735 # Remove all existing '-quotes
4737 foreach $Key (keys(%temp))
4739 $temp{$Key} =~ s/([\r\f]+\n)/\n/g; # Only \n is allowed
4740 $temp{$Key} =~ s/[\']/’/igs; # Remove all single quotes
4741 $temp{$Key} =~ s/[\`]/‘/igs; # Remove all backtick quotes
4744 # Store current CGI values and remove defaults
4745 $::default_values
{$name} = $temp{""};
4747 # Define the CGI variable and its value (in the execute package)
4750 foreach $tempKey (keys(%temp))
4752 ${$name}{$tempKey} = $temp{$tempKey};
4760 # SAFEqx('CommandString')
4762 # A special function that is a safe alternative to backtick quotes (and qx//)
4763 # with client-supplied CGI values. All CGI variables are surrounded by
4764 # single ''-quotes (except between existing \'\'-quotes, don't try to be
4765 # too smart). All variables are then interpolated. Simple (@) lists are
4766 # expanded with join(' ', @List), and simple (%) hash tables expanded
4767 # as a list of "key=value" pairs. Complex variables, e.g., @$var, are
4768 # evaluated in a scalar context (e.g., as scalar(@$var)). All occurrences of
4769 # $@% that should NOT be interpolated must be preceeded by a "\".
4770 # If the first line of the String starts with "#! interpreter", the
4771 # remainder of the string is piped into interpreter (after interpolation), i.e.,
4772 # open(INTERPRETER, "|interpreter");print INTERPRETER remainder;
4773 # just like in UNIX. There are some problems with quotes. Be carefull in
4774 # using them. You do not have access to the output of any piped (#!)
4775 # process! If you want such access, execute
4776 # <SCRIPT TYPE="text/osshell">echo "script"|interpreter</SCRIPT> or
4777 # <SCRIPT TYPE="text/ssperl">$resultvar = SAFEqx('echo "script"|interpreter');
4780 # SAFEqx ONLY WORKS WHEN THE STRING ITSELF IS SURROUNDED BY SINGLE QUOTES
4781 # (SO THAT IT IS NOT INTERPOLATED BEFORE IT CAN BE PROTECTED)
4782 sub SAFEqx
# ('String') -> result of executing qx/"String"/
4784 my $CommandString = shift;
4785 my $NewCommandString = "";
4787 # Only interpolate when required (check the On/Off switch)
4788 unless($CGIscriptor::NoShellScriptInterpolation
)
4791 # Handle existing single quotes around CGI values
4792 while($CommandString =~ /\'[^\']+\'/s)
4794 my $CurrentQuotedString = $&;
4795 $NewCommandString .= $`;
4796 $CommandString = $'; # The remaining string
4797 # Interpolate CGI variables between quotes
4798 # (e.g., '$CGIscriptorResults[-1]')
4799 $CurrentQuotedString =~
4800 s/(^|[^\\])([\$\@])((\w*)([\{\[][\$\@\%]?[\:\w\-]+[\}\]])*)/if(exists($main::default_values{$4})){
4801 "$1".eval("$2$3")}else{"$&"}/egs;
4803 # Combine result with previous result
4804 $NewCommandString .= $CurrentQuotedString;
4806 $CommandString = $NewCommandString.$CommandString;
4808 # Select known CGI variables and surround them with single quotes,
4809 # then interpolate all variables
4811 s/(^|[^\\])([\$\@\%]+)((\w*)([\{\[][\w\:\$\"\-]+[\}\]])*)/
4812 if($2 eq '$' && exists($main::default_values{$4}))
4813 {"$1\'".eval("\$$3")."\'";}
4814 elsif($2 eq '@'){$1.join(' ', @{"$3"});}
4815 elsif($2 eq '%'){my $t=$1;map {$t.=" $_=".${"$3"}{$_}}
4817 else{$1.eval("${2}$3");
4820 # Remove backslashed [$@%]
4821 $CommandString =~ s/\\([\$\@\%])/$1/gs;
4825 # return $CommandString;
4827 # Handle UNIX style "#! shell command\n" constructs as
4828 # a pipe into the shell command. The output cannot be tapped.
4829 my $ReturnValue = "";
4830 if($CommandString =~ /^\s*\#\!([^\f\n\r]+)[\f\n\r]/is)
4832 my $ShellScripts = $';
4833 my $ShellCommand = $1;
4834 open(INTERPRETER, "|$ShellCommand") || dieHandler(29, "\'$ShellCommand\' PIPE not opened: &!\n");
4835 select(INTERPRETER);$| = 1;
4836 print INTERPRETER $ShellScripts;
4838 select(STDOUT);$| = 1;
4840 # Shell scripts which are redirected to an existing named pipe.
4841 # The output cannot be tapped.
4842 elsif($CGIscriptor::ShellScriptPIPE)
4844 CGIscriptor::printSAFEqxPIPE($CommandString);
4846 else # Plain ``-backtick execution
4848 # Execute the commands
4849 $ReturnValue = qx/$CommandString/;
4851 return $ReturnValue;
4854 ####################################################################################
4856 # The CGIscriptor PACKAGE
4858 ####################################################################################
4860 # Isolate the evaluation of CGIscriptor functions, i.e., those prefixed with
4863 package CGIscriptor;
4866 # The Interpolation On/Off switch
4867 my $NoShellScriptInterpolation = undef;
4868 # The ShellScript redirection pipe
4869 my $ShellScriptPIPE = undef;
4871 # Open a named PIPE for SAFEqx to receive ALL shell scripts
4872 sub RedirectShellScript # ('CommandString')
4874 my $CommandString = shift || undef;
4878 $ShellScriptPIPE = "ShellScriptNamedPipe";
4879 open($ShellScriptPIPE, "|$CommandString")
4880 || main::dieHandler(30, "\'|$CommandString\' PIPE open failed: $!\n");
4884 close($ShellScriptPIPE);
4885 $ShellScriptPIPE = undef;
4887 return $ShellScriptPIPE;
4890 # Print to redirected shell script pipe
4891 sub printSAFEqxPIPE # ("String") -> print return value
4893 my $String = shift || undef;
4895 select($ShellScriptPIPE); $| = 1;
4896 my $returnvalue = print $ShellScriptPIPE ($String);
4897 select(STDOUT); $| = 1;
4899 return $returnvalue;
4902 # a pointer to CGIexecute::SAFEqx
4903 sub SAFEqx # ('String') -> result of qx/"String"/
4905 my $CommandString = shift;
4906 return CGIexecute::SAFEqx($CommandString);
4910 # a pointer to CGIexecute::defineCGIvariable
4911 sub defineCGIvariable # ($name[, $default]) ->0/1
4914 my $default = shift;
4915 return CGIexecute::defineCGIvariable($name, $default);
4919 # a pointer to CGIexecute::defineCGIvariable
4920 sub defineCGIvariableList # ($name[, $default]) ->0/1
4923 my $default = shift;
4924 return CGIexecute::defineCGIvariableList($name, $default);
4928 # a pointer to CGIexecute::defineCGIvariable
4929 sub defineCGIvariableHash # ($name[, $default]) ->0/1
4932 my $default = shift;
4933 return CGIexecute::defineCGIvariableHash($name, $default);
4937 # Decode URL encoded arguments
4938 sub URLdecode # (URL encoded input) -> string
4945 my $EncodedValue = $Value; # Do not change the loop variable
4946 # Convert all "+" to " "
4947 $EncodedValue =~ s/\+/ /g;
4948 # Convert all hexadecimal codes (%FF) to their byte values
4949 while($EncodedValue =~ /\%([0-9A-F]{2})/i)
4951 $output .= $`.chr(hex($1));
4954 $output .= $EncodedValue; # The remaining part of $Value
4959 # Encode arguments as URL codes.
4960 sub URLencode # (input) -> URL encoded string
4967 my @CharList = split('', $Value);
4968 foreach $char (@CharList)
4972 elsif($char =~ /\w\-/)
4973 { $output .= $char;}
4976 $output .= uc(sprintf("%%%2.2x", ord($char)));
4983 # Extract the value of a CGI variable from the URL-encoded $string
4984 # Also extracts the data blocks from a multipart request. Does NOT
4985 # decode the multipart blocks
4986 sub CGIparseValue # (ValueName [, URL_encoded_QueryString [, \$QueryReturnReference]]) -> Decoded value
4988 my $ValueName = shift;
4989 my $QueryString = shift || $main::ENV{'QUERY_STRING
'};
4990 my $ReturnReference = shift || undef;
4993 if($QueryString =~ /(^|\&)$ValueName\=([^\&]*)(\&|$)/)
4995 $output = URLdecode($2);
4996 $$ReturnReference = $' if ref($ReturnReference);
4998 # Get multipart POST or PUT methods
4999 elsif($main::ENV
{'CONTENT_TYPE'} =~ m@
(multipart
/([\w\
-]+)\
;\s
+boundary\
=([\S
]+))@i)
5001 my $MultipartType = $2;
5002 my $BoundaryString = $3;
5003 # Remove the boundary-string
5004 my $temp = $QueryString;
5005 $temp =~ /^\Q--$BoundaryString\E/m;
5008 # Identify the newline character(s), this is the first character in $temp
5009 my $NewLine = "\r\n"; # Actually, this IS the correct one
5010 unless($temp =~ /^(\-\-|\r\n)/) # However, you never realy can be sure
5012 # Is this correct??? I have to check.
5013 $NewLine = "\r\n" if $temp =~ /^(\r\n)/; # Double (CRLF, the correct one)
5014 $NewLine = "\n\r" if $temp =~ /^(\n\r)/; # Double
5015 $NewLine = "\n" if $temp =~ /^([\n])/; # Single Line Feed
5016 $NewLine = "\r" if $temp =~ /^([\r])/; # Single Return
5019 # search through all data blocks
5020 while($temp =~ /^\Q--$BoundaryString\E/m)
5024 # Get the empty line after the header
5025 $DataBlock =~ /$NewLine$NewLine/;
5031 # Remove newlines from the header
5032 $Header =~ s/$NewLine/ /g;
5034 # Look whether this block is the one you are looking for
5035 # Require the quotes!
5036 if($Header =~ /name\s*=\s*[\"\']$ValueName[\"\']/m)
5039 for($i=length($NewLine); $i; --$i)
5046 # reinitialize the output
5049 $$ReturnReference = $temp if ref($ReturnReference);
5051 elsif($QueryString !~ /(^|\&)$ValueName\=/) # The value simply isn't there
5054 $$ReturnReference = undef if ref($ReturnReference);
5058 print "ERROR: $ValueName $main::ENV{'CONTENT_TYPE'}\n";
5064 # Get a list of values for the same ValueName. Uses CGIparseValue
5066 sub CGIparseValueList
# (ValueName [, URL_encoded_QueryString]) -> List of decoded values
5068 my $ValueName = shift;
5069 my $QueryString = shift || $main::ENV
{'QUERY_STRING'};
5071 my $RestQueryString;
5073 while($QueryString &&
5074 (($Value = CGIparseValue
($ValueName, $QueryString, \
$RestQueryString))
5075 || defined($Value)))
5077 push(@output, $Value);
5078 $QueryString = $RestQueryString; # QueryString is consumed!
5080 # ready, return list with values
5084 sub CGIparseValueHash
# (ValueName [, URL_encoded_QueryString]) -> Hash table of decoded values
5086 my $ValueName = shift;
5087 my $QueryString = shift || $main::ENV
{'QUERY_STRING'};
5088 my $RestQueryString;
5090 while($QueryString && $QueryString =~ /(^|\&)$ValueName([\w]*)\=/)
5093 my $Value = CGIparseValue
("$ValueName$Key", $QueryString, \
$RestQueryString);
5094 $output{$Key} = $Value;
5095 $QueryString = $RestQueryString; # QueryString is consumed!
5097 # ready, return list with values
5101 sub CGIparseForm
# ([URL_encoded_QueryString]) -> Decoded Form (NO multipart)
5103 my $QueryString = shift || $main::ENV
{'QUERY_STRING'};
5106 $QueryString =~ s/\&/\n/g;
5107 $output = URLdecode
($QueryString);
5112 # Extract the header of a multipart CGI variable from the POST input
5113 sub CGIparseHeader
# (ValueName [, URL_encoded_QueryString]) -> Decoded value
5115 my $ValueName = shift;
5116 my $QueryString = shift || $main::ENV
{'QUERY_STRING'};
5119 if($main::ENV
{'CONTENT_TYPE'} =~ m@
(multipart
/([\w\
-]+)\
;\s
+boundary\
=([\S
]+))@i)
5121 my $MultipartType = $2;
5122 my $BoundaryString = $3;
5123 # Remove the boundary-string
5124 my $temp = $QueryString;
5125 $temp =~ /^\Q--$BoundaryString\E/m;
5128 # Identify the newline character(s), this is the first character in $temp
5129 my $NewLine = "\r\n"; # Actually, this IS the correct one
5130 unless($temp =~ /^(\-\-|\r\n)/) # However, you never realy can be sure
5132 $NewLine = "\n" if $temp =~ /^([\n])/; # Single Line Feed
5133 $NewLine = "\r" if $temp =~ /^([\r])/; # Single Return
5134 $NewLine = "\r\n" if $temp =~ /^(\r\n)/; # Double (CRLF, the correct one)
5135 $NewLine = "\n\r" if $temp =~ /^(\n\r)/; # Double
5138 # search through all data blocks
5139 while($temp =~ /^\Q--$BoundaryString\E/m)
5143 # Get the empty line after the header
5144 $DataBlock =~ /$NewLine$NewLine/;
5148 # Remove newlines from the header
5149 $Header =~ s/$NewLine/ /g;
5151 # Look whether this block is the one you are looking for
5152 # Require the quotes!
5153 if($Header =~ /name\s*=\s*[\"\']$ValueName[\"\']/m)
5158 # reinitialize the output
5166 # Checking variables for security (e.g., file names and email addresses)
5167 # File names are tested against the $::FileAllowedChars and $::BlockPathAccess variables
5168 sub CGIsafeFileName
# FileName -> FileName or ""
5170 my $FileName = shift || "";
5171 return "" if $FileName =~ m?[^$::FileAllowedChars]?;
5172 return "" if $FileName =~ m!(^|/|\:)[\-\.]!;
5173 return "" if $FileName =~ m@\
.\
.\Q
$::DirectorySeparator\E@
; # Higher directory not allowed
5174 return "" if $FileName =~ m@\Q
$::DirectorySeparator\E\
.\
.@
; # Higher directory not allowed
5175 return "" if $::BlockPathAccess
&& $FileName =~ m@
$::BlockPathAccess@
; # Invisible (blocked) file
5180 sub CGIsafeEmailAddress
# email -> email or ""
5182 my $Email = shift || "";
5183 return "" unless $Email =~ m/^[\w\.\-]+[\@][\w\.\-\:]+$/;
5187 # Get a URL from the web. Needs main::GET_URL($URL) function
5188 # (i.e., curl, snarf, or wget)
5189 sub read_url
# ($URL) -> page/file
5191 my $URL = shift || return "";
5193 # Get the commands to read the URL, do NOT add a print command
5194 my $URL_command = main
::GET_URL
($URL, 1);
5195 # execute the commands, i.e., actually read it
5196 my $URLcontent = CGIexecute
->evaluate($URL_command);
5198 # Ready, return the content.
5202 ################################################>>>>>>>>>>Start Remove
5204 # BrowseAllDirs(Directory, indexfile)
5207 # <SCRIPT TYPE='text/ssperl'>
5208 # CGIscriptor::BrowseAllDirs('Sounds', 'index.html', '\.wav$')
5211 # Allows to browse all directories. Stops at '/'. If the directory contains
5212 # an indexfile, eg, index.html, that file will be used instead. Files must match
5213 # the $Pattern, if it is given. Default is
5214 # CGIscriptor::BrowseAllDirs('/', 'index.html', '')
5216 sub BrowseAllDirs
# (Directory, indexfile, $Pattern) -> Print HTML code
5218 my $Directory = shift || '/';
5219 my $indexfile = shift || 'index.html';
5220 my $Pattern = shift || '';
5221 $Directory =~ s!/$!!g;
5223 # If the index directory exists, use that one
5224 if(-s
"$::CGI_HOME$Directory/$indexfile")
5226 return main
::ProcessFile
("$::CGI_HOME$Directory/$indexfile");
5229 # No indexfile, continue
5230 my @DirectoryList = glob("$::CGI_HOME$Directory");
5231 $CurrentDirectory = shift(@DirectoryList);
5232 $CurrentDirectory = $' if $CurrentDirectory =~ m@(/\.\./)+@;
5233 $CurrentDirectory =~ s@^$::CGI_HOME@@g;
5235 print "$CurrentDirectory" if $CurrentDirectory;
5238 opendir(BROWSE, "$::CGI_HOME$Directory") || main::dieHandler(31, "$::CGI_HOME$Directory $!");
5239 my @AllFiles = sort grep(!/^([\.]+[^\.]|\~)/, readdir(BROWSE));
5243 print "<pre><ul TYPE='NONE
'>\n";
5244 foreach $file (@AllFiles)
5246 next unless -d "$::CGI_HOME$Directory/$file";
5247 # Check whether this file should be visible
5248 next if $::BlockPathAccess &&
5249 "$Directory/$file/" =~ m@$::BlockPathAccess@;
5250 print "<dt><a href='$Directory/$file'>$file</a></dt>\n";
5252 print "</ul></pre>\n";
5255 print "<pre><ul TYPE='CIRCLE
'>\n";
5257 foreach $file (@AllFiles)
5259 next if $file =~ /^\./;
5260 next if -d "$::CGI_HOME$Directory/$file";
5261 next if -l "$::CGI_HOME$Directory/$file";
5262 # Check whether this file should be visible
5263 next if $::BlockPathAccess &&
5264 "$Directory/$file" =~ m@$::BlockPathAccess@;
5266 if(!$Pattern || $file =~ m@$Pattern@)
5268 my $Date = localtime($^T - (-M "$::CGI_HOME$Directory/$file")*3600*24);
5269 my $Size = -s "$::CGI_HOME$Directory/$file";
5270 $Size = sprintf("%6.0F kB", $Size/1024);
5271 my $Type = `file $::CGI_HOME$Directory/$file`;
5272 $Type =~ s@\s*$::CGI_HOME$Directory/$file\s*\:\s*@@ig;
5276 print "<a href='$Directory/$file'>";
5277 printf("%-40s", "$file</a>");
5278 print "\t$Size\t$Date\t$Type";
5282 print "</ul></pre>";
5288 ################################################
5290 # BrowseDirs(RootDirectory [, Pattern, Start])
5293 # <SCRIPT TYPE='text
/ssperl
'>
5294 # CGIscriptor::BrowseDirs('Sounds
', '\
.aifc
$', 'Speech
', 'DIRECTORY
')
5297 # Allows to browse subdirectories. Start should be relative to the RootDirectory,
5298 # e.g., the full path of the directory 'Speech
' is '~/Sounds/Speech
'.
5299 # Only files which fit /$Pattern/ and directories are displayed.
5300 # Directories down or up the directory tree are supplied with a
5301 # GET request with the name of the CGI variable in the fourth argument (default
5302 # is 'BROWSEDIRS
'). So the correct call for a subdirectory could be:
5303 # CGIscriptor::BrowseDirs('Sounds
', '\
.aifc
$', $DIRECTORY, 'DIRECTORY
')
5305 sub BrowseDirs # (RootDirectory [, Pattern, Start, CGIvariable, HTTPserver]) -> Print HTML code
5307 my $RootDirectory = shift; # || return 0;
5308 my $Pattern = shift || '\S
';
5309 my $Start = shift || "";
5310 my $CGIvariable = shift || "BROWSEDIRS";
5311 my $HTTPserver = shift || '';
5313 $Start = CGIscriptor::URLdecode($Start); # Sometimes, too much has been encoded
5314 $Start =~ s@//+@/@g;
5315 $Start =~ s@[^/]+/\.\.@@ig;
5316 $Start =~ s@^\.\.@@ig;
5317 $Start =~ s@/\.$@@ig;
5319 $Start .= "/" if $Start;
5321 my @Directory = glob("$::CGI_HOME/$RootDirectory/$Start");
5322 $CurrentDirectory = shift(@Directory);
5323 $CurrentDirectory = $' if $CurrentDirectory =~ m@
(/\.\./)+@
;
5324 $CurrentDirectory =~ s@
^$::CGI_HOME@
@g;
5326 print "$CurrentDirectory" if $CurrentDirectory;
5328 opendir(BROWSE
, "$::CGI_HOME/$RootDirectory/$Start") || main
::dieHandler
(31, "$::CGI_HOME/$RootDirectory/$Start $!");
5329 my @AllFiles = sort grep(!/^([\.]+[^\.]|\~)/, readdir(BROWSE
));
5333 print "<pre><ul TYPE='NONE'>\n";
5334 foreach $file (@AllFiles)
5336 next unless -d
"$::CGI_HOME/$RootDirectory/$Start$file";
5337 # Check whether this file should be visible
5338 next if $::BlockPathAccess
&&
5339 "/$RootDirectory/$Start$file/" =~ m@
$::BlockPathAccess@
;
5341 my $NewURL = $Start ?
"$Start$file" : $file;
5342 $NewURL = CGIscriptor
::URLencode
($NewURL);
5343 print "<dt><a href='";
5344 print "$ENV{SCRIPT_NAME}" if $ENV{SCRIPT_NAME
} !~ m@
[^\w
+\
-/]@
;
5345 print "$ENV{PATH_INFO}?$CGIvariable=$NewURL'>$file</a></dt>\n";
5347 print "</ul></pre>\n";
5350 print "<pre><ul TYPE='CIRCLE'>\n";
5352 foreach $file (@AllFiles)
5354 next if $file =~ /^\./;
5355 next if -d
"$::CGI_HOME/$RootDirectory/$Start$file";
5356 next if -l
"$::CGI_HOME/$RootDirectory/$Start$file";
5357 # Check whether this file should be visible
5358 next if $::BlockPathAccess
&&
5359 "$::CGI_HOME/$RootDirectory/$Start$file" =~ m@
$::BlockPathAccess@
;
5361 if($file =~ m@
$Pattern@
)
5363 my $Date = localtime($^T
- (-M
"$::CGI_HOME/$RootDirectory/$Start$file")*3600*24);
5364 my $Size = -s
"$::CGI_HOME/$RootDirectory/$Start$file";
5365 $Size = sprintf("%6.0F kB", $Size/1024);
5366 my $Type = `file $::CGI_HOME/$RootDirectory/$Start$file`;
5367 $Type =~ s@\s
*$::CGI_HOME
/$RootDirectory/$Start$file\s
*\
:\s
*@
@ig;
5371 if($HTTPserver =~ /^\s*[\.\~]\s*$/)
5373 print "<a href='$RootDirectory/$Start$file'>";
5377 print "<a href='$HTTPserver/$RootDirectory/$Start$file'>";
5379 printf("%-40s", "$file</a>") if $HTTPserver;
5380 printf("%-40s", "$file") unless $HTTPserver;
5381 print "\t$Size\t$Date\t$Type";
5385 print "</ul></pre>";
5391 # ListDocs(Pattern [,ListType])
5394 # <SCRIPT TYPE=text/ssperl>
5395 # CGIscriptor::ListDocs("/*", "dl");
5398 # This subroutine is very usefull to manage collections of independent
5399 # documents. The resulting list will display the tree-like directory
5400 # structure. If this routine is too slow for online use, you can
5401 # store the result and use a link to that stored file.
5403 # List HTML and Text files with title and first header (HTML)
5404 # or filename and first meaningfull line (general text files).
5405 # The listing starts at the ServerRoot directory. Directories are
5406 # listed recursively.
5408 # You can change the list type (default is dl).
5410 # <dt><a href=<file.html>>title</a>
5412 # <dt><a href=<file.txt>>file.txt</a>
5413 # <dd>First meaningfull line of text
5415 sub ListDocs
# ($Pattern [, prefix]) e.g., ("/Books/*", [, "dl"])
5417 my $Pattern = shift;
5419 my $ListType = shift || "dl";
5420 my $Prefix = lc($ListType) eq "dl" ?
"dt" : "li";
5421 my $URL_root = "http://$::ENV{'SERVER_NAME'}\:$::ENV{'SERVER_PORT'}";
5422 my @FileList = glob("$::CGI_HOME$Pattern");
5423 my ($FileName, $Path, $Link);
5425 # Print List markers
5426 print "<$ListType>\n";
5429 File
: foreach $FileName (@FileList)
5431 # Check whether this file should be visible
5432 next if $::BlockPathAccess
&& $FileName =~ m@
$::BlockPathAccess@
;
5434 # Recursively list files in all directories
5437 $FileName =~ m@
([^/]*)$@
;
5439 print "<$Prefix>$DirName\n";
5440 $Pattern =~ m@
([^/]*)$@
;
5441 &ListDocs
("$`$DirName/$1", $ListType);
5445 elsif(-T
"$FileName")
5447 open(TextFile
, $FileName) || next;
5449 # Ignore all other file types
5453 # Get file path for link
5454 $FileName =~ /$::CGI_HOME/;
5455 print "<$Prefix><a href=$URL_root$'>";
5456 # Initialize all variables
5461 # Read file and step through
5467 if($FileName =~ /\.ht[a-zA-Z]*$/i)
5472 if($Line =~ m@
<title
>([^<]*)</title
>@i)
5479 $Line .= <TextFile> || goto Print;
5483 # Catch First Header
5486 if($Line =~ m@</h1>@i)
5490 $Caption =~ m@
<h1
>@i;
5492 $Line = $`.$Caption.$Line;
5496 $Line .= <TextFile> || goto Print;
5504 # Title equals file name
5505 $FileName =~ /([^\/]+)$/;
5507 # Catch equals First Meaningfull line
5510 if($Line =~ /[A-Z]/ &&
5511 ($Line =~ /subject|title/i || $Line =~ /^[\w,\.\s\?\:]+$/)
5512 && $Line !~ /Newsgroup/ && $Line !~ /\:\s*$/)
5514 $Line =~ s/\<[^\>]+\>//g;
5519 $Line = <TextFile> || goto Print;
5523 Print: # Print title and subject
5524 print "$Title</a>\n";
5525 print "<dd>$Caption\n" if $ListType eq "dl";
5532 # Print Closing List Marker
5533 print "</$ListType>\n";
5534 ""; # Empty return value
5538 # HTMLdocTree(Pattern [,ListType])
5541 # <SCRIPT TYPE=text/ssperl>
5542 # CGIscriptor::HTMLdocTree("/Welcome.html", "dl");
5545 # The following subroutine is very usefull for checking large document
5546 # trees. Starting from the root (s), it reads all files and prints out
5547 # a nested list of links to all attached files. Non-existing or misplaced
5548 # files are flagged. This is quite a file-i/o intensive routine
5549 # so you would not like it to be accessible to everyone. If you want to
5550 # use the result, save the whole resulting page to disk and use a link
5553 # HTMLdocTree takes an HTML file or file pattern and constructs nested lists
5554 # with links to *local* files (i.e., only links to the local server are
5555 # followed). The list entries are the document titles.
5556 # If the list type is <dl>, the first <H1> header is used too.
5557 # For each file matching the pattern, a list is made recursively of all
5558 # HTML documents that are linked from it and are stored in the same directory
5559 # or a sub-directory. Warnings are given for missing files.
5560 # The listing starts for the ServerRoot directory.
5561 # You can change the default list type <dl> (<dl>, <ul>, <ol>).
5565 sub HTMLdocTree # ($Pattern [, listtype])
5566 # e.g., ("/Welcome.html", [, "ul"])
5568 my $Pattern = shift;
5569 my $ListType = shift || "dl";
5570 my $Prefix = lc($ListType) eq "dl" ? "dt" : "li";
5571 my $URL_root = "http://$::ENV{'SERVER_NAME
'}\:$::ENV{'SERVER_PORT
'}";
5572 my ($Filename, $Path, $Link);
5573 my %LocalLinks = {};
5575 # Read files (glob them for expansion of wildcards)
5576 my @FileList = glob("$::CGI_HOME$Pattern");
5577 foreach $Path (@FileList)
5580 $Path =~ /$::CGI_HOME/;
5582 # Check whether this file should be visible
5583 next if $::BlockPathAccess
&& $URL_path =~ m@
$::BlockPathAccess@
;
5585 my $Title = $URL_path;
5587 # Current file should not be used again
5588 ++$LinkUsed{$URL_path};
5590 unless(open(TextFile
, $Path))
5592 print "<$Prefix>$Title <blink>(not found)</blink><br>\n";
5600 while($Line =~ m@
<title
>@i)
5602 if($Line =~ m@
<title
>([^<]*)</title
>@i)
5609 $Line .= <TextFile>;
5613 # Catch First Header
5614 while(!$Caption && $Line =~ m@<h1>@i)
5616 if($Line =~ m@</h[1-9]>@i)
5620 $Caption =~ m@
<h1
>@i;
5622 $Line = $`.$Caption.$Line;
5626 $Line .= <TextFile>;
5630 # Catch and print Links
5631 while($Line =~ m@<a href\=([^>]*)>@i)
5638 $Link =~ s/[\#\?].*$//g;
5640 if($Link =~ m@
(http
://|^)@i)
5643 # Only build tree for current server
5644 next unless $Link =~ m@$::ENV{'SERVER_NAME
'}|^/@;
5645 # Remove server name and port
5646 $Link =~ s@^[^\/]*@@g;
5648 # Store the current link
5649 next if $LinkUsed{$Link} || $Link eq $URL_path;
5651 ++$LocalLinks{$Link};
5657 print "<a href=http://";
5658 print "$::ENV{'SERVER_NAME
'}\:$::ENV{'SERVER_PORT
'}$URL_path>";
5659 print "$Title</a>\n";
5660 print "<br>$Caption\n"
5661 if $Caption && $Caption ne $Title && $ListType =~ /dl/i;
5662 print "<$ListType>\n";
5663 foreach $Link (keys(%LocalLinks))
5665 &HTMLdocTree($Link, $ListType);
5667 print "</$ListType>\n";
5671 ###########################<<<<<<<<<<End Remove
5673 # Make require happy
5682 A flexible HTML 4 compliant script/module for CGI-aware
5683 embeded Perl, shell-scripts, and other scripting languages,
5684 executed at the server side.
5688 Executes embeded Perl code in HTML pages with easy
5689 access to CGI variables. Also processes embeded shell
5690 scripts and scripts in any other language with an
5691 interactive interpreter (e.g., in-line Python, Tcl,
5692 Ruby, Awk, Lisp, Xlispstat, Prolog, M4, R, REBOL, Praat,
5693 sh, bash, csh, ksh).
5695 CGIscriptor is very flexible and hides all the specifics
5696 and idiosyncrasies of correct output and CGI coding and naming.
5697 CGIscriptor complies with the W3C HTML 4.0 recommendations.
5699 This Perl program will run on any WWW server that runs
5700 Perl scripts, just add a line like the following to your
5701 srm.conf file (Apache example):
5703 ScriptAlias /SHTML/ /real-path/CGIscriptor.pl/
5705 URL's that refer to http
://www
.your
.address
/SHTML/... will
5706 now be handled by CGIscriptor
.pl
, which can
use a private
5707 directory tree
(default is the DOCUMENT_ROOT directory tree
,
5708 but it can be anywhere
).
5710 =head1 PREREQUISITES
5718 Linux, *BSD, *nix, MS WinXP
5720 =pod SCRIPT CATEGORIES