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