CGIservlet.pl

   1 #! /usr/bin/perl
   2 #
   3 # Put the full path to perl on the first line, run the program with
   4 # `perl CGIservlet`, or put a symbolic link to perl in
   5 # the startup directory if you need a special version of perl.
   6 #
   7 if(grep(/\-\-help/i, @ARGV))
   8 {
   9     print << 'ENDOFHELPTEXT';
  10 # CGIservlet:
  11 #         A HTTPd "connector" for running CGI scripts on unix systems as WWW
  12 #         accessible Web sites. The servlet starts a true HTTP daemon that channels
  13 #         HTTP requests to forked daughter processes. CGIservlet.pl is NOT a
  14 #         full fledged server. Moreover, this servlet is definitely NOT intended
  15 #         as a replacement of a real server (e.g., Apache). It's design goal was
  16 #         SIMPLICITY, and not mileage.
  17 #
  18 #         Note that a HTTP server can be accessed on your local machine WITHOUT
  19 #         internet access (but WITH a DNS?):
  20 #         use "http://localhost[:port]/[path]" or "http://127.0.0.1[:port]/[path]"
  21 #         as the URL. It is also easy to restrict access to the servlet to localhost
  22 #         users (i.e., the computer running the servlet).
  23 #
  24 #         Suggested uses:
  25 #         - A testbed for CGI-scripts and document-trees outside the primary server.
  26 #           When developing new scripts and services, you don't want to mess up your
  27 #           current Web-site. CGIservlet is an easy way to start a temporary (private)
  28 #           server. CGIservlet allows to test separate HTTP server components, e.g.,
  29 #           user authentication, in isolation.
  30 #
  31 #         - A special purpose temporary server (WWW everywhere/anytime).
  32 #           We run identification and other experiments over the inter-/intra-net using
  33 #           CGI-scripts. This means a lot of development and changes and only little
  34 #           actual run-time. The people doing this do not want "scripting" access to our
  35 #           departmental server with all its restrictions and security. So we need a
  36 #           small, lightweigth, easy-to-configure server that can be run by each
  37 #           investigator on her own account (and risk).
  38 #
  39 #         - Interactive WWW presentations.
  40 #           Not everyone is content with the features of "standard" office presentation
  41 #           software. HTML and its associated browsers are an alternative (especially
  42 #           under Linux). However, you need a server to realize the full interactive
  43 #           nature of the WWW. CGIservlet with the necessary scripts can be run from
  44 #           a floppie (a Web server in 100 kB). The CGIservlet can actually run a
  45 #           (small) web site from RAM, without disk access (if you DO NOT use the
  46 #           2>pid.log redirection on startup).
  47 #           With the "localhost" or "127.0.0.1" id in your browser you can use the
  48 #           servlet standalone.
  49 #
  50 #         When the servlet is started with the -r option, only requests from "localhost"
  51 #         or "127.0.0.1" are accepted (default) or from addresses indicated after the
  52 #         -r switch.
  53 #
  54 #         Running demo's and more information can be found at
  55 #         http://www.fon.hum.uva.nl/rob/OSS/OSS.html
  56 #
  57 #
  58 ############################################################################
  59 #
  60 # Changes (document ALL changes with date, name and email here):
  61 #
  62 # 06 Jun 2012 - Added HTTP Cookie string to an Environment variable: COOKIE_JAR
  63 # 29 May 2012 - Added .log -> / to @RegAliasTranslation, blocks attempts to read
  64 #               log files.
  65 # 22 May 2012 - Blocked "hidden" files and directories starting with "." in
  66 #               default @RegAliasTranslation. Removed obsolete CVS reference.
  67 # 21 May 2012 - Inserted the -m[emory] switch for loading and serving from RAM.
  68 #               The option was mentioned in the manual, but the cli switch was
  69 #               never added.
  70 # 22 Jul 2003 - Plain output using binary print io. `cat ...`
  71 # 22 Jul 2003 - Added 'use CGI::Carp qw(fatalsToBrowser);' line
  72 #               for debugging. Standard this is commented out
  73 #               for security reasons (suggested by Jochen_Hayek@ACM.org).
  74 # 22 Jul 2003 - Added error checking to doarg (suggested by Jochen_Hayek@ACM.org)
  75 # 22 Jul 2003 - Removed SERVER_PORT from HTTP_HOST (Bug found by Jochen_Hayek@ACM.org)
  76 # 22 Jul 2003 - Updated documentation. Added CGIservlet directory
  77 #               to the search path of CGIservletSETUP.pl
  78 # 20 May 2003 - Made sure recycled (double) pid's do not mess up the
  79 #               @brood list and added a --help switch.
  80 # 20 May 2003 - Added a maximum running time for child processes
  81 #               with command line switch -xterm.
  82 # 15 Jan 2002 - Version 1.3
  83 # 19 Oct 2001 - Included browsing of directories and a new -s
  84 #               security switch. With security toggled of
  85 #               directories can be browsed and all mime-types
  86 #               are served, either as 'text/plain' or as
  87 #               'application/octed-stream'.
  88 # 18 May 2001 - Added some HTTP HTTP lines.
  89 # 13 Jun 2000 - Included the possibility to add POST request
  90 #               to GET query-strings (and change the request
  91 #               method). The -l ($Maxlength) maximum length
  92 #               option now covers POST requests too.
  93 #  8 Dec 1999 - Included hooks for compression when running from RAM.
  94 #  2 Dec 1999 - Autoflush enabled.
  95 #  2 Dec 1999 - Allow running a Web Site from RAM.
  96 #  2 Dec 1999 - Changed the behavior of CGIservletSETUP. CGIservlet
  97 #               will eval ALL setup files, the one in the CGIscriptor
  98 #               subdirectory (if any) AND the one in the current
  99 #               directory. (also added a close(SETUP) command)
 100 # 26 Nov 1999 - Added some minimal security for 'automatic', out of
 101 #                       the box installation.
 102 # 26 Nov 1999 - Made the text/osshell mime-type functional (i.e.,
 103 #                       without any scripts, implement a dynamic web server)
 104 #               Linited to '.cgi' extension.
 105 # 26 Nov 1999 - Added aliasing of URL paths, both one-to-one lookups
 106 #                and full regular expression, i.e., $Path =~ s/.../.../g
 107 #                replace commands
 108 # 28 Sep 1999 - Made all client supplied HTTP parameter names lowercase
 109 #                       to handle inconsistencies in case use.
 110 # 29 Jul 1999 - Allowed for a SETUP configuration file 'CGIservletSETUP.pl'.
 111 #               Use $beginarg from the 'CGIscriptor/' directory if it exists.
 112 #               (R.J.J.H.vanSon@uva.nl)
 113 #
 114 #
 115 ############################################################################
 116 #
 117 # Known bugs
 118 #
 119 # 23 Mar 2000 - An odd server side network error is reported by Netscape
 120 #               when a Post is initiated from a Javascript Submit of a
 121 #               <FORM>. This was found on Red Hat 6.1 Linux with perl 5.00503,
 122 #               5.00503 and 5.6.0. But not on IRIX or Red Hat 5.0, 7.x.
 123 #
 124 ############################################################################
 125 #
 126 #
 127 # Inner workings:
 128 #         Whenever an HTTP request is received, the specified CGI script is
 129 #         started inside a child process as if it was inside a real server (e.g.,
 130 #         Apache). The evironment variables are set more or less as in Apache.
 131 #         Note that CGIservlet only uses a SINGLE script for ALL requests.
 132 #         No attemps for security are made, it is the script's responsibility to
 133 #         check access rights and the validity of the request.
 134 #         When no scripts are given, CGIservlet runs as a bare bone WWW server
 135 #         configurable to execute scripts (the default setting is as a
 136 #         STATIC server).
 137 #
 138 # Author and copyright (c) :
 139 #         Rob van Son
 140 #         email:
 141 #         R.J.J.H.vanSon@gmail.com
 142 #         r.v.son@nki.nl
 143 #         NKI/AVL Amsterdam
 144 #
 145 #         copying freely from the mhttpd server by Jerry LeVan (levan@eagle.eku.edu)
 146 # Date:   July 22, 2012
 147 # Version:1.301
 148 # Env:    Perl 5.002 and later
 149 #
 150 #
 151 ################################################################################
 152 #                                                                              #
 153 #          LICENSE                                                             #
 154 #                                                                              #
 155 #          This program is free software; you can redistribute it and/or       #
 156 #          modify it under the terms of the GNU General Public License         #
 157 #          as published by the Free Software Foundation; either version 2      #
 158 #          of the License, or (at your option) any later version.              #
 159 #                                                                              #
 160 #          This program is distributed in the hope that it will be useful,     #
 161 #          but WITHOUT ANY WARRANTY; without even the implied warranty of      #
 162 #          MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       #
 163 #          GNU General Public License for more details.                        #
 164 #                                                                              #
 165 #          You should have received a copy of the GNU General Public License   #
 166 #          along with this program; if not, write to the Free Software         #
 167 #          Foundation, Inc., 59 Temple Place - Suite 330,                      #
 168 #          Boston, MA  02111-1307, USA.                                        #
 169 #                                                                              #
 170 ################################################################################
 171 #
 172 # Note:   CGIservlet.pl was directly inspired by Jerry LeVan's
 173 #         (levan@eagle.eku.edu) simple mhttpd server which again was
 174 #         inspired by work of others. CGIservlet is used as a bare bones
 175 #         socket server for a single CGI script at a time.
 176 #
 177 # Use:    CGIservlet.pl -<switch> <argument> 2>pid.log &     (sh/bash)
 178 #         CGIservlet.pl -<switch> <argument> >&pid.log &     (csh)
 179 #
 180 #         The servlet prints out pid and port number on STDERR. It is
 181 #         adviced to store these in a separate file (this will become the
 182 #         error log).
 183 #         NOTE: When running CGIservlet from a Memmory Image (i.e. RAM),
 184 #         do NOT redirect the error output to a file, but use something
 185 #         like MAILTO or /dev/null!
 186 #
 187 # Stop:   sh pid.log                    (kills the server process)
 188 #
 189 #         The first line in the file that receives STDERR output is a command
 190 #         to stop CGIservlet.
 191 #
 192 #         examples:
 193 #         CGIservlet.pl -p 2345 -d /cgi-bin/CGIscriptor.pl -t /WWW 2>pid.log &
 194 #         CGIservlet.pl -p 8080 -b 'require "CGIscriptor.pl";' -t $PWD -e \
 195 #         'Handle_Request();' 2>pid.log &
 196 #
 197 #         The following example settings implement a static WWW server using 'cat'
 198 #         (and prohibiting Queries):
 199 #         -p 8008
 200 #         -t `pwd`
 201 #         -b ''
 202 #         -e
 203 # '$ENV{QUERY_STRING}="";$ENV{PATH_INFO}=~/\.([\w]+)$/; "Content-type: ".$mimeType{uc($1)}."\n\n";'
 204 #         -d 'cat -u -s'
 205 #         -w '/index.html'
 206 #         -c 32
 207 #         -l 512
 208 #
 209 #         This is identical to the (static) behaviour of CGIservlet when
 210 #         -e '' -d '' -x '' is used.
 211 #         The CGIservlet command should be run from the intended server-root directory.
 212 #
 213 #         Another setting will use a package 'CGIscriptor.pl' with a function
 214 #         'HandleRequest()' to implement an interactive WWW server with inline
 215 #         Perl scripting:
 216 #         -p 8080
 217 #         -t `pwd`
 218 #         -b 'require "CGIscriptor.pl";'
 219 #         -e 'HandleRequest();'
 220 #         -d ''
 221 #         -w '/index.html'
 222 #         -c 32
 223 #         -l 32767
 224 #
 225 #         Look below or in the CGIservletSETUP.pl file for the current default
 226 #         settings.
 227 #
 228 #
 229 # ###############################################################################
 230 #
 231 #         There are many switches to tailor the workings of CGIservlet.pl.
 232 #         Some are fairly esoteric and you should only look for them if you
 233 #         need something special urgently. When building a Web site,
 234 #         the specific options you need will "suggest" themselves (e.g., port
 235 #         number, script, or server-root directory). Most default settings
 236 #         should work fine.
 237 #
 238 #         You can add your own configuration in a file called
 239 #         'CGIservletSETUP.pl'. This file will be executed ("eval"-ed)
 240 #         after the default setup, but before the command line options take
 241 #         effect. CGIservlet looks for the SETUP file in the startup directory
 242 #         and in the CGIscriptor subdirectory.
 243 #         (Note that the $beginarg variable is evaluated AFTER the setup file).
 244 #
 245 #         In any case, it is best to change the default settings instead of
 246 #         using the option switches. All defaults are put in a single block.
 247 #
 248 #         switches and arguments:
 249 #         Realy important
 250 #         -p[ort] port number
 251 #          For example -p 2345
 252 #          Obviously the port CGIservlet listenes to. Suggested Default: -p 8008
 253 #
 254 #         -a[lias] Alias1 RealURL1 ...
 255 #          For example -a '/Stimulus.aifc' '/catAIFC.xmr'
 256 #          Replaces the given Alias URL path by its real URL path. Accepts full
 257 #          regular expressions too (identified by NON-URL characters).
 258 #          That is, on each request it performs (in order):
 259 #          if($AliasTranslation{$Path})
 260 #          {
 261 #              $Path = $AliasTranslation{$Path};
 262 #          }
 263 #          elsif(@RegAliasTranslation)
 264 #          {
 265 #             my $i;
 266 #             for($i=0; $i<scalar(@RegAliasTranslation); ++$i)
 267 #             {
 268 #                 my $Alias   = $RegAliasTranslation[$i];
 269 #                 my $RealURL = $RegURLTranslation[$i];
 270 #                 last if ($Path =~ s#$Alias#$RealURL#g);
 271 #             };
 272 #          };
 273 #          The effects can be quite drastic, so be
 274 #          carefull. Note also, that entering many Regular Expression
 275 #          aliases could slow down your servlet. Checking stops after
 276 #          the first match.
 277 #          Full regular expression alias translations are done in the
 278 #          order given! They are recognized as Aliases containing
 279 #          regexp's (i.e., non-URL) operator characters like '^' and
 280 #          '$'.
 281 #          Note: The command line is NOT a good place for entering
 282 #          Aliases, change the code below or add aliases to
 283 #          CGIservletSETUP.pl.
 284 #
 285 #         --help
 286 #          Prints the manual
 287 #
 288 #         Script related
 289 #         -b[egin] perl commands
 290 #          For example -b 'require "CGIscriptor.pl";' or
 291 #          'require "/WWW/cgi-bin/XMLelement.pl";'
 292 #          Perl commands evaluated at server startup
 293 #
 294 #         -d[o] perl script file
 295 #          For example -d '/WWW/cgi-bin/CGIscriptor.pl'
 296 #          The actual CGI-script started as a perl {do "scriptfile"} command.
 297 #          The PATH_INFO and the QUERY are pushed on @ARGV.
 298 #
 299 #         -x shell command
 300 #         -qx shell command
 301 #         -exec shell command
 302 #          OS shell script or command, e.g., -x 'CGIscriptor.pl' or
 303 #          -x '/WWW/cgi-bin/my-script'
 304 #          The actual CGI-script started as `my-script \'$Path\' \'$QueryString\'`.
 305 #          -qx and -exec[ute] are aliases of -x. For security reasons, Paths or
 306 #          queries containing '-quotes are rejected.
 307 #
 308 #         -e[val] perl commands
 309 #          For example -e 'Handle_Request();'
 310 #          The argument is evaluated as perl code. The actual CGI-script
 311 #          can be loaded once with -b 'require module.pm' and you only have to
 312 #          call the central function(s).
 313 #
 314 #         WWW-tree related
 315 #         -t[extroot] path
 316 #          For example -t "$PWD" or -t "/WWW/documents"
 317 #          The root of the server hierachy. Defaults to the working directory
 318 #          at startup time (`pwd`)
 319 #
 320 #         -w[elcome] filepath
 321 #          For example -w "/index.html"   (default)
 322 #          The default welcome page used when no path is entered. Note that
 323 #          this path can point to anything (or nothing real at all).
 324 #
 325 #         Security related
 326 #         The following arguments supply some rudimentary security. It is the
 327 #         responsibility of the script to ensure that the requests are indeed
 328 #         "legal".
 329 #
 330 #         -c[hildren] maximum child processes
 331 #          For example -c 32
 332 #          The maximum number of subprocesses started. If there are more requests,
 333 #          the oldest requests are "killed". This should take care of "zombie"
 334 #          processes and server overloading. Note that new requests will be
 335 #          serviced irrespective of the success of killing it's older siblings.
 336 #
 337 #         -xtime maximum running time of a child
 338 #          For example -xtime 36000
 339 #          The maximum time a child may run in seconds. After a new request has
 340 #          been servised, all children that have run for longer than this time
 341 #          will be killed. This stops runaway processes, often connected to
 342 #          web-crawlers.
 343 #
 344 #         -l[ength] maximum length of HTTP request in bytes
 345 #          For example -l 32768
 346 #          This prevents overloading the server with enormous queries. Reading of
 347 #          requests simply stops when this limit is reached. This DOES affect
 348 #          POST requests.  If the combined length of the COMPLETE HTTP request,
 349 #          including headers, exceeds this limit, the whole request is dropped.
 350 #
 351 #         -r[estrict] [Remote-address [Remote-host]]
 352 #          For example -r 127.0.0.1          (default of -r)
 353 #          A space separated list of client IP addresses and/or domain names that
 354 #          should be serviced. Default, i.e., '-r' without any addresses or domain
 355 #          names, is the localhost IP address '127.0.0.1'.
 356 #          When using CGIservlet for local purposes only (e.g., development or a
 357 #          presentation), it would be unsafe to allow others to access the servlet.
 358 #          If -r is used (or the corresponding @RemoteAddr or @RemoteHost lists are
 359 #          filled in the code below), all requests from clients whose Remote-address
 360 #          or Remote-host do not match the indicated addresses will be rejected.
 361 #          Partial addresses and domain names are allowed. Matching is done according
 362 #          to Remote-addr =~ /^\Q$pattern\E/ (front to back) and
 363 #          Remote-host =~ /\Q$pattern\E$/ (back to front)
 364 #
 365 #         -s[ecure]
 366 #          No arguments.
 367 #          A toggle switch that blocks all access to files with undefined
 368 #          mime-types (or to serve ascii files as "text/plain"), and blocking directory
 369 #          browsing. Defaults to blocking what is not explicitely allowed.
 370 #
 371 #         -m[emory]
 372 #          No arguments.
 373 #          Reads complete Web site into memory and runs from this image.
 374 #          Set $UseRAMimage = 1; to activate memory-only running.
 375 #          Under certain circumstance, this can improve security.
 376 #          Note, however, that running osshellscripts from this image
 377 #          makes any "security" related claims very shaky.
 378 #
 379 #         Speedup
 380 #         -n[oname]
 381 #          No arguments.
 382 #          Retrieving the domain name of the Client (i.e., Remote-host) is a
 383 #          very slow process and normally useless. To skip it, enter this
 384 #          option. Note that you cannot use '-r Remote-host' anymore after
 385 #          you enter -n, only IP addresses will work.
 386 #
 387 #     Configuration with the CGIservletSETUP.pl file
 388 #
 389 #     You can add your own configuration in a file
 390 #     called 'CGIservletSETUP.pl'. This file will be executed ("eval"-ed)
 391 #     after the default setup, but before the command line options take
 392 #     effect. CGIservlet looks for the SETUP file in the startup directory
 393 #     and in the CGIservlet and CGIscriptor subdirectories.
 394 #     (Note that the $beginarg variable is evaluated even later).
 395 #
 396 #         Changing POST to GET requests
 397 #
 398 #         CGIservlet normally only handles requests with the GET method. Processing
 399 #         the input from POST requests is left to the reading application. POST
 400 #         requests add some extra complexity to processing requests. Sometimes,
 401 #         the reading application doesn't handle POST requests. CGIservlet
 402 #         already has to manage the HTTP request. Therefore, it can easily
 403 #         handle the POST request. If the variable $POSTtoGET is set to any
 404 #         non-false value, the content of whole POST request is added to the
 405 #         QUERY_STRING environment variable (preceeded by a '&' if necessary).
 406 #         The content-length is set to 0. If $POSTtoGET equals 'GET', the method
 407 #         will also be changed to 'GET'.
 408
 409 #          remarks:
 410 #          All of the arguments of -d, -e, and -x are processed sequentially
 411 #          in this order. This might not be what you want so you should be
 412 #          carefull when using multiple executable arguments.
 413 #          If none of the executable arguments is DEFINED (i.e., they are entered
 414 #          as -d '' -e '' -x ''), each request is treated as a simple
 415 #          text-retrieval. THIS CAN BE A SECURITY RISK!
 416 #
 417 #          The wiring of an interactive web-server, which also calls shell
 418 #          scripts with the extension '.cgi', is in place. You can
 419 #          "activate" it by changing the "my $ExecuteOSshell = 0;" line to
 420 #          "my $ExecuteOSshell = 1;".
 421 #          If you have trouble doing this, it might be a good idea
 422 #          to reconsider using a dynamic web server. Executing shell
 423 #          scripts inside a web server is a rather dangerous practise.
 424 #
 425 #          CGIservlet can run its "standard" web server from memory.
 426 #          At startup, all files are read into a hash table. Upon
 427 #          request, the contents of the file are placed in the
 428 #          environment variable: CGI_FILE_CONTENTS.
 429 #          No further disk access is necessary. This means that:
 430 #          1 CGIservlet can run a WWW site from a removable disk,
 431 #            e.g., a floppy
 432 #          2 The web servlet can run without any read or write privilege.
 433 #          3 The integrity of the Web-site contents can be secured at the
 434 #            level you want
 435 #
 436 #          To compres the memory (RAM) immage, you should hook the
 437 #          compression function to
 438 #          $CompressRAMimage = sub { return shift;};
 439 #          and the decompression function to
 440 #          $DecompressRAMimage = sub { return shift;};
 441 #
 442 #
 443 ENDOFHELPTEXT
 444     exit;
 445 };
 446 ###################################################################################
 447 #
 448 require 5.002;
 449 use strict;  # Should realy be used!
 450 use Socket;
 451 use Carp;    # could come in handy (can be missed, I think)
 452
 453 # For debugging: uncommenting the use-line below will send
 454 # nicely formanted output to the client. However, it is
 455 # generally not a good idea to enable clients to test your
 456 # scripts and look for holes (SECURITY).
 457 # use CGI::Carp qw(fatalsToBrowser);
 458
 459 $| = 1;      # Autoflush (i'm not sure whether this is usefull)
 460
 461 my $version = "1.301";
 462 my $program = "CGIservlet.pl";
 463
 464 ##################################################################
 465 #                                                                #
 466 #   print some information to STDERR, e.g., the process number   #
 467 #                                                                #
 468 ##################################################################
 469 sub logmsg { print STDERR "kill -KILL $$;exit;\n",   # Stop CGIservlet
 470 "$0 $$: @_ at ", scalar localtime, "\n" }
 471
 472 ############################################################
 473 #                                                          #
 474 #   Parse arguments (you can define DEFAULT VALUES here)   #
 475 #                                                          #
 476 ############################################################
 477
 478 my $port      = 8008;        # The port number
 479
 480 # Add POST requests to the QUERY_STRING, change method to
 481 # GET if the value is 'GET'
 482 my $POSTtoGET = 0;                      # Add POST requests to the query string
 483
 484 # (Fast) direct translation of full URL paths
 485 my %AliasTranslation = ();   # Alias => RealURL pairs (ONLY paths)
 486 # Regular expression alias translation, in order of application
 487 # (this can be quite slow)
 488 my @RegAliasTranslation = ('^(\..*|.*/\..*)$','\.htm$', '^.*\.log$'); # Full regular expression alias/url pairs: URL
 489 my @RegURLTranslation = ('/','.html', '/');   # Full regular expression alias/url pairs: PATH
 490
 491 my $textroot  = $ENV{'PWD'} || `pwd`; # current working directory
 492 chomp($textroot);            # Remove nasty newline, if present
 493 my $doarg     = '';          # do "filename",
 494
 495 my $beginarg  = '';          # eval($Argument) at the start of the program
 496 my $evalarg   = '';          # eval($Argument) for each request
 497 my $execarg   = '';          # execute `command \'$textroot$Path\' \'$QueryString\'`
 498
 499 my $welcome   = '/index.html';  # Default path
 500
 501 #  Rudimentary security, overflow detection
 502 my $MaxBrood  = 32;          # Maximum number of running children
 503 my $MaxTime  = 36000;        # Maximum time a child may run in seconds
 504 my $MaxLength = 2**15;       # Maximum Request Length
 505 my $Secure = 1;                 # Block browsing directories and text files or not
 506
 507 # If one of the following lists contains any client addresses or names, all others are
 508 # blocked (be carefull, your site will be inaccessible if you misspell them).
 509 my @RemoteHost = ();         # Accepted Hosts, suggest: localhost
 510 my @RemoteAddr = ();         # Accepted IP addresses, suggest: @RemoteAddr=('127.0.0.1')
 511 my $DefaultRemoteAddr = '127.0.0.1';  # default, use localhost IP address
 512 my $NONAME = 0;              # if 1, do NOT ask for REMOTE_HOST (faster)
 513
 514 # Store the whole Web Site in a hash table and use this RAM memory image (if non-zero)
 515 my $UseRAMimage = 0;
 516 # Empty function handlers for data compression
 517 # In general, these must be redefined in the $beginarg
 518 my $CompressRAMimage = sub { return shift;};
 519 my $DecompressRAMimage = sub { return shift;};
 520
 521 # Execute shell CGI scripts when no -d, -e, or -x are supplied
 522 my $ExecuteOSshell = 0;      # Do you REALY want this? It is dangerous
 523
 524 #################################################################
 525 #                                                               #
 526 #   Configure CGIservlet with a setup file (overides the        #
 527 #   default settings, but not the command line options).        #
 528 #   Note that, if it exists, the setup file in the CGIscriptor  #
 529 #   subdirectory is processed EVEN if there is a SETUP file     #
 530 #   in the current directory.                                   #
 531 #                                                               #
 532 #################################################################
 533 # There exists a CGIservlet subdirectory and it contains
 534 # a CGIservletSETUP.pl file
 535 if((-e './CGIservlet/CGIservletSETUP.pl') &&
 536    open(SETUP, '<./CGIservlet/CGIservletSETUP.pl'))
 537 {
 538     # Get the setup code
 539     my $SetupCode = join("", <SETUP>);
 540     # 'Eval' is used to ensure that the values are entered in the current
 541     # package (contrary to what 'do' and 'require' do).
 542     (eval $SetupCode) || die "$! $@\n";
 543     close(SETUP);
 544 };
 545 # There exists a CGIscriptor subdirectory and it contains
 546 # a CGIservletSETUP.pl file
 547 if((-e './CGIscriptor/CGIservletSETUP.pl') &&
 548    open(SETUP, '<./CGIscriptor/CGIservletSETUP.pl'))
 549 {
 550     # Get the setup code
 551     my $SetupCode = join("", <SETUP>);
 552     # 'Eval' is used to ensure that the values are entered in the current
 553     # package (contrary to what 'do' and 'require' do).
 554     (eval $SetupCode) || die "$! $@\n";
 555     close(SETUP);
 556 };
 557 # There is a CGIservletSETUP.pl file in the current directory
 558 if((-e './CGIservletSETUP.pl') &&
 559    open(SETUP, '<./CGIservletSETUP.pl'))
 560 {
 561     # Get the setup code
 562     my $SetupCode = join("", <SETUP>);
 563     # 'Eval' is used to ensure that the values are entered in the current
 564     # package (contrary to what 'do' and 'require' do).
 565     (eval $SetupCode) || die "-e $SetupCode: $! $@\n";
 566     close(SETUP);
 567 };
 568
 569 ######################################
 570 #                                    #
 571 #   process arguments and defaults   #
 572 #                                    #
 573 ######################################
 574
 575 while ($_ = shift(@ARGV))
 576 {
 577     # With switches
 578     if(/\-p/is)               # Port
 579     {
 580         $port = shift(@ARGV);
 581     }
 582     elsif(/\-d/is)            # Do
 583     {
 584         $doarg = shift(@ARGV);
 585     }
 586     elsif(/\-(x|qx|exec)/is)  # Execute
 587     {
 588         $execarg = shift(@ARGV);
 589     }
 590     elsif(/\-b/is)            # Begin
 591     {
 592         $beginarg = shift(@ARGV);
 593     }
 594     elsif(/\-e/is)            # Evaluate
 595     {
 596         $evalarg = shift(@ARGV);
 597     }
 598     elsif(/\-t/is)            # Textroot
 599     {
 600         $textroot = shift(@ARGV);
 601     }
 602     elsif(/\-w/is)            # Default welcome page
 603     {
 604         $welcome = shift(@ARGV);
 605     }
 606     elsif(/\-c/is)            # Maximum Children
 607     {
 608         $MaxBrood = shift(@ARGV) || $MaxBrood;
 609     }
 610     elsif(/\-xtime/is)        # Maximum running time
 611     {
 612         $MaxTime = shift(@ARGV) || $MaxTime;
 613     }
 614     elsif(/\-l/is)            # Maximum Length
 615     {
 616         $MaxLength = shift(@ARGV) || $MaxLength;
 617     }
 618     elsif(/\-m/is)            # Run from RAM
 619     {
 620         $UseRAMimage = 1;
 621     }
 622     elsif(/\-a/is)            # Aliases
 623     {
 624         while(@ARGV && $ARGV[0] !~ /^\-/) # while not a parameter
 625         {
 626             my $Alias = shift(@ARGV);
 627             my $RealURL = $ARGV[0] !~ /^\-/ ? shift(@ARGV) : "";
 628             next unless $Alias && $RealURL;
 629             # Store the alias
 630             # Simple straight translations
 631             unless($Alias =~ m/[\Q^$*&@!\?(){}[];:\E]/)
 632             {
 633                 $AliasTranslation{$Alias} = $RealURL;
 634             }
 635             else  # Full regular expressions
 636             {
 637                 push(@RegAliasTranslation, $Alias);
 638                 push(@RegURLTranslation, $RealURL);
 639             };
 640
 641         };
 642     }
 643     elsif(/\-r/is)            # Remote host or address
 644     {
 645         while(@ARGV && $ARGV[0] !~ /^\-/) # while not a parameter
 646         {
 647             my $Remote = shift(@ARGV);
 648             if($Remote =~ /[\d\.]+/) # A host IP address
 649             {
 650                 push(@RemoteAddr, $Remote);
 651             }
 652             else                     # A host domain name, less secure
 653             {
 654                 push(@RemoteHost, $Remote);
 655             };
 656         };
 657         #
 658         # Use the default Remote Host (Client) IP address (e.g., localhost)
 659         # if no addresses or domain names are entered.
 660         push(@RemoteAddr, $DefaultRemoteAddr) unless @RemoteAddr || @RemoteHost;
 661     }
 662     elsif(/\-s/is)            # Secure or not
 663     {
 664                 $Secure = !$Secure;     # Toggle blocking directory browsing and ASCII file access
 665     }
 666     elsif(/\-n/is)            # Do NOT extract Remote host
 667     {
 668                 $NONAME = 1;
 669     }
 670     else        # perform unreliable magick without switches
 671     {
 672         if(/^[0-9]+$/ && $_ > 1024)     # A (large) number must be a port
 673         {
 674             $port = $_;
 675         }
 676         elsif(-T && /\.pl$/)    # Text file with extension .pl is a Perl file
 677         {
 678             $doarg = $_;
 679         }
 680         elsif(-T && /\.pm$/)    # Text file with extension .pm is a Perl module file
 681         {
 682             $beginarg = $_;
 683         }
 684         elsif(-x)       # Executables can be executed
 685         {
 686             $execarg = $_;
 687         }
 688         elsif(-d)       # A directory can only be the root
 689         {
 690             $textroot = $_;
 691         }
 692         elsif(-T && /^\// && /\.html$/) # An html file path is the default path
 693         {
 694             $welcome = $_;
 695         }
 696         elsif(-T)       # A text file is something to do
 697         {
 698             $doarg = $_;
 699         }
 700         elsif(/[\s\{\`\[\@\%]/)         # I give up, just try it
 701         {
 702             $evalarg = shift(@ARGV);
 703         };
 704     };
 705 };
 706
 707 ################################################
 708 #                                              #
 709 #   All argument values are known.             #
 710 #   Initialize environment variables.          #
 711 #   (should be accessible to eval($beginarg))  #
 712 #                                              #
 713 ################################################
 714 #
 715 # Initialize %ENV
 716 $ENV{'SERVER_SOFTWARE'} = "$program $version";
 717 $ENV{'GATEWAY_INTERFACE'} = "CGI/1.1";
 718 $ENV{'SERVER_PORT'} = "$port";
 719 $ENV{'CGI_HOME'} = $textroot;
 720 $ENV{'SERVER_ROOT'} = $textroot;                # Server Root Directory
 721 $ENV{'DOCUMENT_ROOT'} = $textroot;              # Server Root Directory
 722 $ENV{'SCRIPT_NAME'} = $doarg.$execarg.$evalarg;  # Combine executable arguments
 723
 724 ################################################
 725 #                                              #
 726 #   The initial argument should be evaluated   #
 727 #                                              #
 728 ################################################
 729
 730 eval($beginarg) if $beginarg;
 731
 732 ################################################
 733 #                                              #
 734 #   The initial argument has been evaluated    #
 735 #                                              #
 736 ################################################
 737 #
 738 # Socket related code
 739 my $proto = getprotobyname('tcp');
 740 $port = $1 if $port =~ /(\d+)/; # untaint port number
 741
 742 socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
 743 setsockopt(Server, &SOL_SOCKET, &SO_REUSEADDR,
 744 pack("l", 1))                               || die "setsockopt: $!";
 745 bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
 746 listen(Server,SOMAXCONN)                            || die "listen: $!";
 747
 748 #
 749 # Report start of server
 750 logmsg "server started on port $port";
 751
 752 # Set up SIG vector (every signal will kill the process that receives it)
 753 $SIG{CHLD} = 'IGNORE';
 754 $SIG{'KILL'} = "SigHandler";
 755 $SIG{'TERM'} = "SigHandler";
 756 $SIG{'QUIT'} = "SigHandler";
 757 $SIG{'HUP'}  = "SigHandler";
 758
 759 # Define text mime types served if no scripts are defined
 760 # Note that the "text/osshell" mime-type is executed by CGIservlet ITSELF!
 761 # You should remove it if you don't want that!
 762 my %mimeType = (
 763 'HTML'=> "text/html",
 764 'TXT' => "text/plain",
 765 'PL'  => "text/plain",    # This is incorrect, of course
 766 'JPG'  => "image/jpeg",
 767 'JPEG' => "image/jpeg",
 768 'GIF'  => "image/gif",
 769 'AU'   => "audio/basic",
 770 'AIF'  => "audio/aiff",
 771 'AIFC' => "audio/aiff",
 772 'AIFF' => "audio/aiff",
 773 'GZ'   => "application/gzip",
 774 'TGZ'   => "application/tar",
 775 #'CGI'  => "text/osshell",       # Executes SERVER side shell scripts, HIGHLY DANGEROUS
 776 'WAV'  => "audio/wav",
 777 'OGG'  => "audio/x-vorbis",
 778 'PDF'  => "application/pdf",
 779 'PS'  => "application/postscript"
 780 );
 781
 782 ################################################
 783 #                                              #
 784 #   Fill the RAM image of the web site         #
 785 #                                              #
 786 ################################################
 787
 788 my %WWWramImage = ();
 789 if($UseRAMimage)
 790 {
 791         my  $TotalSize = 0;
 792         my @WWWfilelist = `find $textroot ! -type l ! -type d -print`;
 793         my $WWWfile;
 794         foreach $WWWfile (@WWWfilelist)
 795         {
 796                 chomp($WWWfile);
 797                 # Skip unsupported file types
 798                 $WWWfile =~ /\.(\w+)$/;
 799                 my $WWWfileExtension = uc($1);
 800                 next unless $mimeType{$WWWfileExtension};
 801                 # Store GnuZipped image of file
 802                 $WWWramImage{$WWWfile} = "";
 803                 open(FILEIN, "<$WWWfile") || die "$WWWfile could not be opened: $!\n";
 804                 my $Buffer;
 805                 while(sysread(FILEIN, $Buffer, 1024))
 806                 {
 807                     $WWWramImage{$WWWfile} .= $Buffer;
 808                 };
 809                 # Apply compression
 810                 my $CompressedPtr = &$CompressRAMimage(\${WWWramImage{$WWWfile}});
 811                 $WWWramImage{$WWWfile} = $$CompressedPtr;
 812                 $TotalSize += length($WWWramImage{$WWWfile});
 813         };
 814         #
 815         # Report size of Web RAM image
 816         print STDERR "Total number of $TotalSize bytes read in memory image\n";
 817 };
 818
 819 ################################################
 820 #                                              #
 821 #   The RAM image of the web site has been     #
 822 #   filled.                                    #
 823 #                                              #
 824 ################################################
 825
 826 # Map HTTP request parameters to Environment variables
 827 # HTTP request => Environment variable
 828 my %HTTPtype = (
 829 'content-length'  => 'CONTENT_LENGTH',    # Necessary for POST
 830 'user-agent'      => 'HTTP_USER_AGENT',
 831 'accept'          => 'HTTP_ACCEPT',
 832 'content-type'    => 'CONTENT_TYPE',
 833 'auth-type'       => 'AUTH_TYPE',
 834 'ident'           => 'REMOTE_IDENT',
 835 'referer'         => 'HTTP_REFERER',
 836 'user'            => 'REMOTE_USER',
 837 'address'         => 'REMOTE_ADDR',
 838 'connection'      => 'HTTP_CONNECTION',
 839 'accept-language' => 'HTTP_ACCEPT_LANGUAGE',
 840 'accept-encoding' => 'HTTP_ACCEPT_ENCODING',
 841 'accept-charset'  => 'HTTP_ACCEPT_CHARSET',
 842 'host'            => 'HTTP_HOST',
 843 'cookie'          => 'COOKIE_JAR'
 844 );
 845
 846 ###############################################################################
 847 #                                                                             #
 848 #  Now we start with the real work. When there is a request, get the required #
 849 #  values and fork a child to service it.                                     #
 850 #                                                                             #
 851 ###############################################################################
 852
 853 my @brood = ();
 854 my %StartTime = ();             # Start time of the children
 855 my $child;
 856
 857 # When someone knocks on the door
 858 for (;;)
 859 {
 860     my $paddr;
 861
 862     if(!($paddr = accept(Client,Server)) ) # Knock knock
 863     {
 864         exit 1; # This went terrribly wrong
 865     };
 866
 867     # Fork to child and parent
 868     if(($child =fork()) == 0)
 869     {
 870         # this is the child
 871         my ($port,$iaddr) = sockaddr_in($paddr);
 872         my $address = inet_ntoa($iaddr);  # The IP address of the Client
 873         # The following is EXTREMELY slow and generally unnecessary.
 874         # Use -n  or set $NONAME = 1; if you don't need it.
 875         my $name = $NONAME ? '' : gethostbyaddr($iaddr,AF_INET);
 876         my @Input = ();
 877
 878         #
 879         # Before doing anything else, check whether the client should be
 880         # served at all.
 881         # Is IP addr on the list?
 882         if(@RemoteAddr && !grep(/^\Q$address\E/, @RemoteAddr))
 883         {
 884             print STDERR "Reject $address $name\n";
 885             exit 1;
 886         };
 887         # Is name on the list?
 888         if(@RemoteHost && !grep(/\Q$name\E$/, @RemoteHost))
 889         {
 890             print STDERR "Reject $name $address\n";
 891             exit 1;
 892         };
 893
 894         #
 895         # Grab a line without using buffered input... Important for
 896         # Post methods since they have to read the Client input stream.
 897         #
 898         my $string = "";
 899         my $ch = "";
 900         my $HTTPlength = 0;
 901         alarm 120 ;     # prevent deadly spin if other end goes away
 902         while(sysread(Client, $ch, 1)>0)
 903         {
 904             $string .= $ch;
 905             ++$HTTPlength;
 906             last if $HTTPlength > $MaxLength;  # Protect against overflow
 907
 908             next if $ch eq "\r"; # skip <cr>
 909             if($ch eq "\n")
 910             {
 911                         last unless $string =~ /\S/;        # stop if empty line
 912                         push (@Input, split(' ', $string)); # Collect input in list
 913                         $string = "";
 914             };
 915         };
 916         alarm 0;    # clear alarm
 917
 918         # Extract input arguments
 919         my $method   = shift(@Input);
 920         my $Request  = shift(@Input);
 921         my $protocol = shift(@Input);
 922         my ($Path, $QueryString) = split('\?', $Request);
 923
 924         # Get rest of Input
 925         my $HTTPparameter;
 926         my %HTTPtable = ();
 927         while($HTTPparameter = lc(shift(@Input)))
 928         {
 929             chop($HTTPparameter);
 930             $HTTPtable{$HTTPparameter} = "";
 931             while(@Input && $Input[0] !~ /\:$/)
 932             {
 933                 $HTTPtable{$HTTPparameter} .= " " if  $HTTPtable{$HTTPparameter};
 934                 $HTTPtable{$HTTPparameter} .= shift(@Input);
 935             };
 936         };
 937         # Host can get the :SERVER_PORT appended. Set the correct SERVER_PORT
 938         # and remove it from the host.
 939         if($HTTPtable{'host'})
 940         {
 941             # Store current port number
 942             if($HTTPtable{'host'} =~ /\:(\d+)\s*$/)
 943             {
 944                 $ENV{'SERVER_PORT'} = $1;
 945             };
 946             # Remove port number from host
 947             $HTTPtable{'host'} =~ s/\:(\d+)\s*$//g;
 948         };
 949
 950         # Translate the Aliases
 951             $Path = GetAlias($Path);
 952
 953         # HTTP servers should always add the default path
 954         $Path = $welcome if !$Path || $Path eq '/';     # The common default path
 955
 956         # Set fixed environment variables
 957         $ENV{'PATH_INFO'}       = "$Path";
 958         $ENV{'QUERY_STRING'}    = "$QueryString";
 959         $ENV{'PATH_TRANSLATED'} = "$textroot$Path";
 960         $ENV{'SERVER_PROTOCOL'} = "$protocol";
 961         $ENV{'REQUEST_METHOD'}  = "$method";
 962         $ENV{'REMOTE_ADDR'}     = "$address";  # The IP address of the Client
 963         $ENV{'REMOTE_HOST'}     = "$name";
 964
 965         # Load all request information in the %ENV.
 966         # MUST be done with a pre-defined list of parameter names (security).
 967         foreach $HTTPparameter (keys(%HTTPtype))
 968         {
 969             my $Label = $HTTPtype{$HTTPparameter};
 970             # The following adds environment variables FROM THE REQUEST.
 971             # It is a VERY, VERY bad idea to just use the client supplied
 972             # parameter names!
 973             $ENV{$Label} = $HTTPtable{$HTTPparameter} unless exists($ENV{$Label});
 974             # (The last part prevents overwriting existing environment variables)
 975         };
 976
 977         # SECURITY: Check length of POST request. Stop if request is too long
 978         die if $HTTPlength + $ENV{'CONTENT_LENGTH'} > $MaxLength;
 979
 980         # If POST requests are unwanted, they can be added tot the query string
 981         # NOTE: the method is set to GET if $POSTtoGET equals 'GET', otherwise,
 982         # the method stays POST and only the content length is set to 0
 983         if($POSTtoGET && $ENV{'REQUEST_METHOD'} =~ /^POST$/i)
 984         {
 985                 my $POSTlength = $ENV{'CONTENT_LENGTH'} || 0;
 986                 my $ReadBytes = 1;
 987
 988                 # Add '&' if there is a query string already
 989                 if($ENV{'QUERY_STRING'})
 990                 {
 991                         # Before we add something to the string, check length again
 992                 die if $HTTPlength + $ENV{'CONTENT_LENGTH'} + 1 > $MaxLength;
 993                         # Now add the '&'
 994                         $ENV{'QUERY_STRING'} .= '&';
 995                 };
 996
 997                 # Read Client
 998                 while($POSTlength > 0 && $ReadBytes > 0)
 999                 {
1000                         my $Read = "";
1001                         $ReadBytes = sysread(Client, $Read, $POSTlength);
1002                         $ENV{'QUERY_STRING'} .= $Read;
1003                         $POSTlength -= $ReadBytes;
1004                 };
1005
1006                 # All has been read, the content length becomes 0
1007                 $ENV{'CONTENT_LENGTH'} = 0;
1008                 # Method can change
1009                 $ENV{'REQUEST_METHOD'} = 'GET' if $POSTtoGET eq 'GET';
1010         };
1011
1012         #
1013         # Connect STDOUT and STDIN to the client
1014         open(STDIN, "<&Client");
1015         open(STDOUT, ">&Client");
1016         print STDOUT "HTTP/1.1 200 OK\n";       # Supply HTTP protocol information
1017             print STDOUT "Date: ".gmtime()." GMT\n"; # Current date
1018             print STDOUT "Server: $program $version\n"; # This program
1019             print STDOUT "Connection: close\n"; # Don't allow persistent connections
1020
1021         # Start processing of request (note that ALL scripts will be executed if
1022         # present, i.e., if -d, -x, and -e are entered, they are alle processed).
1023
1024         # If in memory-only mode, store the requested file in an environment
1025         # variable: CGI_FILE_CONTENTS
1026         undef($ENV{'CGI_FILE_CONTENTS'}); # Make sure the ENV var doesn't exist
1027         if($UseRAMimage)
1028         {
1029             my $DecompressedPtr = &$DecompressRAMimage(\${WWWramImage{"$textroot$Path"}});
1030             $ENV{'CGI_FILE_CONTENTS'} = $$DecompressedPtr;
1031             # Decompression does not seem to work
1032         };
1033
1034         # do perl script
1035         @ARGV = ("$textroot$Path", $QueryString);
1036         # This was suggested by Jochen_Hayek@ACM.org
1037         if($doarg)
1038         {
1039             # The perl script should do the printing
1040             my ($return) = do "$doarg";
1041
1042             warn "couldn't parse $doarg: $@" if $@;
1043             warn "couldn't $doarg: $!" unless defined $return;
1044             warn "couldn't run $doarg" unless $return;
1045         };
1046
1047         # evaluate perl command
1048         print STDOUT eval($evalarg) if $evalarg;
1049
1050         # execute shell command
1051         if($execarg)
1052         {
1053             my $shellscript = $execarg;
1054
1055             # Attempts to use Paths or Queries containing '-quotes are rejected.
1056             # Executing these would compromise security.
1057             die "Quotes in path: $textroot$Path\n" if "$textroot$Path" =~ /\'/;
1058             $shellscript .= " '$textroot$Path'" if $Path;
1059
1060             die "Quotes in query: $QueryString\n" if $QueryString =~ /\'/;
1061             $shellscript .= " '$QueryString'" if $QueryString;
1062             $shellscript = qx{$shellscript};
1063             print STDOUT $shellscript;
1064         };
1065
1066         # Output files if no scripts are given (actually, this should be
1067         # handled by a script). Unknown mimetypes are killed.
1068         # This is more or less a functional (dynamic) Web server in itself.
1069         unless($doarg || $execarg || $evalarg) # Request not already handled
1070         {
1071             die ".. trick: $address $name $Path $QueryString\n"
1072                 if $Path =~ m@\.\./@ ;      # No tricks!
1073
1074                 # Handle mime-types and directory browsing
1075             $Path =~ /\.([\w]+)$/;      # Get extension
1076             my $extension = uc($1);
1077                 my $browse = ($Path =~ m@/\s*$@ || -d "$textroot$Path") ? 1 : 0;
1078             my $mime = $browse ? "" : $mimeType{$extension};
1079
1080                 # Serve up text and binary files unless they the $Secure option is given
1081                 $mime = "text/plain" if !$mime && !$browse && (-T "$textroot$Path") && !$Secure;
1082                 $mime = "application/octet-stream" if !$mime && !$browse && (-B "$textroot$Path") && !$Secure;
1083
1084                 # Remove final / in directory paths
1085                 $Path =~ s@/\s*$@@g;
1086
1087                 # Block illegal mime-types
1088                 die "Illegal mime type:$extension\n" unless $mime || $browse; # illegal mime's are killed
1089
1090             # Print out the document
1091             if(($mime eq 'text/osshell') && $ExecuteOSshell) # Don't use this unless you know what you're doing
1092             {
1093                 # Note that CGI scripts must supply their own content type
1094                 # Some rudimentary security tests
1095                 # Kill child if the path contains any non-URL characters
1096                 die "ATTACK: ADDR:$ENV{'REMOTE_ADDR'} HOST:$ENV{'REMOTE_HOST'} URL=$Path '$QueryString'\n"
1097                 if $Path =~ m@[^\w\-\.\/]@;     # Exclusive list of allowed characters
1098                 # If you want to execute server side shell scripts, use the 'text/osshell'
1099                 # mime-type (see above) but remember that there is NO SECURITY implemented
1100                 # whatsoever.
1101                 # IF YOU DIDN'T GET THE MESSAGE YET, YOU COULD NOW OPEN YOUR COMPUTER TO THE WHOLE
1102                 # INTERNET TO PLAY WITH!
1103                 # Plain Web site from DISK
1104                 unless($UseRAMimage)
1105                 {
1106                     print STDOUT `$textroot$Path`;  # This is Russian Roulette
1107                 }
1108                 else  # Use a RAM image of the web site
1109                 {
1110                     my $ShellInterpreter = '/usr/bin/sh';
1111                     if($ENV{'CGI_FILE_CONTENTS'} =~ /^\#\!\s*([^\r\n]+)/isg)
1112                     {
1113                         $ShellInterpreter = $1;
1114                     };
1115                     # Execute shell script
1116                     open(RAMOUT, "| $ShellInterpreter") || die "ERROR open RAMOUT  $ShellInterpreter $textroot$Path $! $@\n";
1117                     (print RAMOUT $ENV{'CGI_FILE_CONTENTS'}) || die "ERROR print RAMOUT $ShellInterpreter $textroot$Path $! $@\n";
1118                     close(RAMOUT);
1119                 };
1120             }
1121             elsif($mime)
1122             {
1123                 # Content-type and document
1124                 print STDOUT "Content-type: $mime\n\n";
1125                 # Plain Web site from DISK
1126                 unless($UseRAMimage)
1127                 {
1128                     my $String = "";
1129                     my $number_of_bytes = 0;
1130                     open(BINARY, "<$textroot$Path") || die "$textroot$Path: $!";
1131
1132                     # read and write block of 1024 bytes
1133                     while($number_of_bytes = sysread(BINARY, $String, 1024))
1134                     {
1135                             syswrite(STDOUT, $String, $number_of_bytes); # Actually print the file content
1136                     };
1137                     close(BINARY);
1138
1139 #                   Alternative output using the UNIX shell
1140 #                   print STDOUT `cat '$textroot$Path'`; # lazy, let the OS do the work
1141                 }
1142                 else  # Use a RAM image of the web site
1143                 {
1144                     print STDOUT $ENV{'CGI_FILE_CONTENTS'};
1145
1146                 };
1147                     }
1148                     elsif($browse && !$Secure)  # Block directory browsing in the Secure setup
1149                     {
1150                                 # Content-type and document
1151                     print STDOUT "Content-type: text/html\n\n";
1152                                 opendir(BROWSE, "$textroot$Path") || die "<$textroot$Path: $!\n";
1153
1154                                 print "<HTML>\n<HEAD>\n<TITLE>$Path</TITLE></HEAD>\n<BODY>\n<H1>$Path</H1>\n<pre>\n<dl>";
1155
1156                                 my $DirEntry;
1157                                 foreach $DirEntry (sort {lc($a) cmp lc($b)} readdir(BROWSE))
1158                                 {
1159                                         my $CurrentPath = $Path;
1160                                         # Handle '..'
1161                                         if($DirEntry eq '..')
1162                                         {
1163                                                 my $ParentDir = $CurrentPath;
1164                                                 $ParentDir =~ s@/[^/]+$@@g;
1165                                                 $ParentDir = '/' unless $ParentDir;
1166                                                 print "<dt> <a href='$ParentDir'><h3>Parent directory</h3></a></dt>\n";
1167                                         };
1168                                         next if $DirEntry !~ /[^\.\/\\\:]/;
1169
1170                                         # Get aliases
1171                                         my $Alias = GetAlias("$CurrentPath/$DirEntry");
1172                                         if($Alias ne "$CurrentPath/$DirEntry")
1173                                         {
1174                                                 $Alias =~ m@/([^/]+)$@;
1175                                                 $CurrentPath = $`;
1176                                                 $DirEntry = $1;
1177                                         };
1178                                         #
1179                                         my $Date = localtime($^T - (-M "$textroot$CurrentPath/$DirEntry")*3600*24);
1180                                         my $Size = -s "$textroot$CurrentPath/$DirEntry";
1181                                         $Size = sprintf("%6.0F kB", $Size/1024);
1182                                         my $Type = `file $textroot$CurrentPath/$DirEntry`;
1183                                         $Type =~ s@\s*$textroot$CurrentPath/$DirEntry\s*\:\s*@@ig;
1184                                         chomp($Type);
1185                                         print "<dt> <a href='$CurrentPath/$DirEntry'>";
1186                                         printf("%-40s", $DirEntry."</a>");
1187                                         print "\t$Size\t$Date\t$Type</dt>\n";
1188                                 };
1189                                 close(BROWSE);
1190                                 print "</dl></pre></BODY>\n</HTML>\n";
1191
1192                 };
1193         };
1194
1195         close(STDOUT) || die "STDOUT: $!\n";
1196         close(STDIN) || die "STDIN: $!\n";
1197             close(Client) || die "Client: $!\n";
1198         #
1199         exit 0; # Kill Child
1200     }
1201     else
1202     {
1203         #
1204         # parent code...some systems will have to worry about waiting
1205         # before they can actually close the link to the Client
1206         my $current_time = time();
1207
1208         # Determine which of the children are actually still alive
1209         # and kill those that have run for too long (probably not connected anymore)
1210         my @old_brood = @brood;
1211         @brood = ();    # empty brood
1212         foreach (@old_brood)
1213         {
1214             # Kill the child if it runs for longer than MaxTime
1215             if(($StartTime{$_} - $current_time) > $MaxTime)
1216             {
1217                 kill "KILL", $_;
1218             };
1219
1220             # Store children that are alive
1221             if(kill (0, $_)) # Alive?
1222             {
1223                 push(@brood, $_);
1224             }
1225             else
1226             {
1227                 delete($StartTime{$_});
1228             };
1229         };
1230
1231         # Weed out overflow of children (zombies etc.), keep pid for
1232         # removing the StartTime later on
1233         my $oldest;
1234         for($oldest=0; $oldest < scalar(@brood)-$MaxBrood; ++$oldest)
1235         {
1236             kill "KILL", $brood[$oldest] if $brood[$oldest]; # Remove
1237         };
1238
1239         # Child pid could be recycled, i.e., $child could be stored
1240         # in @brood already. Remove it
1241         @brood = grep($_ != $child, @brood);
1242
1243         # Push new child on the list
1244         push (@brood, $child);
1245         $StartTime{$child} = $current_time;
1246
1247         close Client;  # This is it, ready!
1248     };
1249 };
1250
1251 # Interupt handler for shutting down
1252 sub SigHandler
1253 {
1254     my $sig = shift;
1255     exit 1;
1256 }
1257
1258 # Subroutine for Aliases
1259 # Uses Global variables: %AliasTranslation, @RegAliasTranslation, and @RegURLTranslation
1260 sub GetAlias    # ($Path)->AliasURL
1261 {
1262     my $Path = shift;
1263
1264     # Translate the Aliases
1265     if($AliasTranslation{$Path})
1266     {
1267         $Path = $AliasTranslation{$Path};
1268     }
1269     elsif(@RegAliasTranslation)
1270     {
1271        my $i;
1272        for($i=0; $i<scalar(@RegAliasTranslation); ++$i)
1273        {
1274            my $Alias   = $RegAliasTranslation[$i];
1275            my $RealURL = $RegURLTranslation[$i];
1276            last if ($Path =~ s#$Alias#$RealURL#g);
1277        };
1278     };
1279     return $Path;
1280 }
1281
1282 =head1 NAME
1283
1284 CGIservlet - a HTTPd "connector" for running CGI scripts on unix systems as WWW
1285 accessible Web sites.
1286
1287 =head1 DESCRIPTION
1288
1289 The servlet starts a true HTTP daemon that channels
1290 HTTP requests to forked daughter processes. Can run
1291 a (small) WWW-site from memory.
1292
1293 =head1 README
1294
1295 Whenever an HTTP request is received, the specified CGI script is
1296 started inside a child process as if it was inside a real server (e.g.,
1297 Apache). The evironment variables are set more or less as in Apache.
1298 Note that CGIservlet only uses a SINGLE script for ALL requests.
1299 No attemps for security are made, it is the script's responsibility to
1300 check access rights and the validity of the request.
1301 Can store the files of Web site in memory and serve them
1302 on request.
1303
1304 =head1 PREREQUISITES
1305
1306 This script requires the C<strict>, Socket and Carp modules.
1307
1308 =head1 COREQUISITES
1309
1310 =pod OSNAMES
1311
1312 Unix
1313
1314 =pod SCRIPT CATEGORIES
1315
1316 CGI
1317 Web
1318
1319 =cut