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