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