home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 1999 May / APC452.ISO / netkit / xitami / xitami.exe / TESTLRWP.PL < prev    next >
Encoding:
Perl Script  |  1998-05-06  |  9.5 KB  |  379 lines
  1. #! /local/perl5/bin/perl
  2. #
  3. #   Name:       testlrwp
  4. #   Title:      Example of LRWP program in Perl
  5. #   Package:    Xitami web server
  6. #
  7. #   Written:    98/05/06  Xitami team <xitami@imatix.com>
  8. #   Revised:    
  9. #
  10. #   Copyright:  Copyright (c) 1991-98 iMatix
  11. #   License:    This is free software; you can redistribute it and/or modify
  12. #               it under the terms of the License Agreement as provided
  13. #               in the file LICENSE.TXT.  This software is distributed in
  14. #               the hope that it will be useful, but without any warranty.
  15. #
  16. #
  17. #   Usage:
  18. #      testlrwp.pl applicationname lrwpserver lrwpport [virtualhost]
  19.  
  20. require 5;
  21. use strict;
  22. use Socket;
  23. use FileHandle;
  24.  
  25. # Constants: indexes into LRWP "structure"
  26. my $LRWP_SOCKET        = 0;
  27. my $LRWP_CGI           = 1;
  28. my $LRWP_INDATA        = 2;
  29. my $LRWP_OUTDATA       = 3;
  30.  
  31. # Number of bytes sent across for length
  32. my $LRWP_SIZE_BYTES    = 9;
  33.  
  34. # Register as a LRWP process with the main server
  35. # Parameters: arrayref (filled with LRWP details), applicationname, 
  36. #             serveraddress, serverport, virtual host (optional)
  37. # Returns:    undef on success; failure message on failure
  38.  
  39. sub lrwp_connect
  40. {
  41.     my ($lrwpref, $appname, $serveraddr, $serverport, $vhost) = @_;
  42.     if (! defined ($lrwpref)    || ! defined ($appname)
  43.      || ! defined ($serveraddr) || ! defined ($serverport)) {
  44.     return "register_lrwp: insufficient parameters";
  45.     }
  46.  
  47.     if (defined ($lrwpref -> [$LRWP_SOCKET])) {
  48.     close ($lrwpref -> [$LRWP_SOCKET]);
  49.     $lrwpref -> [$LRWP_SOCKET] = undef;
  50.     }
  51.     $lrwpref -> [$LRWP_CGI]     = undef;
  52.     $lrwpref -> [$LRWP_INDATA]  = "";
  53.     $lrwpref -> [$LRWP_OUTDATA] = "";
  54.  
  55.     my ($addr, $port);
  56.     if ($serveraddr =~ /^\d+\.\d+\.\d+\.\d+$/) {
  57.     $addr = inet_aton($serveraddr);       # IP address (dotted quad)
  58.     }
  59.     else {
  60.     $addr = gethostbyname($serveraddr);   # Hostname?
  61.     }
  62.     if (! defined ($addr)) {
  63.     return "lrwp_connect: unable to resolve host: $serveraddr";
  64.     }
  65.  
  66.     if ($serverport =~ /^\d+$/) {
  67.     $port = $serverport;                  # Port number
  68.     }
  69.     else {
  70.     $port = getservbyname($serverport, 'tcp');
  71.     }
  72.     if (! defined ($port)) {
  73.     return "lrwp_connect: unable to resolve port: $serverport";
  74.     }
  75.  
  76.     
  77.     my ($proto) = getprotobyname('tcp');
  78.     my $paddr   = sockaddr_in($port, $addr);
  79.  
  80.     my $SOCKET  = new FileHandle;                    # A local file handle
  81.     if (socket ($SOCKET, PF_INET, SOCK_STREAM, $proto)) {
  82.     $lrwpref -> [$LRWP_SOCKET] = $SOCKET;
  83.     }
  84.     else {
  85.     return "lrwp_connect: Unable to create socket";
  86.     }
  87.  
  88.     if (connect ($SOCKET, $paddr)) {
  89.     }
  90.     else {
  91.     close ($SOCKET);
  92.     $lrwpref -> [$LRWP_SOCKET] = undef;
  93.     return "lrwp_connect: Unable to connect to remote host ($serveraddr, $serverport)";
  94.     }
  95.  
  96.     $SOCKET->autoflush();
  97.  
  98.     # Send LRWP server our identification information
  99.     if (printf $SOCKET "%s\xFF%s\xFF%s", $appname, 
  100.                   (defined($vhost) ? $vhost : ""),
  101.                   "") {
  102.     }
  103.     else {
  104.     close (SOCKET);
  105.     $lrwpref -> [$LRWP_SOCKET] = undef;
  106.     return "lrwp_connect: Unable to identify ourselves to server";
  107.     }
  108.  
  109.     # Wait for LRWP server to acknowledge us
  110.     my $buffer = ' ' x 1024;
  111.     my $bytes  = sysread $SOCKET, $buffer, 1024;
  112.     if ($bytes > 0) {
  113.     substr ($buffer, $bytes) = "";        # Trim string
  114.     
  115.     if ($buffer eq "OK") {
  116.         return undef;                     # All is well
  117.     }
  118.     else {
  119.         return "lrwp_connect: Failed: $buffer";
  120.     }
  121.     }
  122.     else {
  123.     return "lrwp_connect: No response from LRWP server";
  124.     }
  125.  
  126.     # Unreachable
  127.     return "lrwp_connect: internal logic error";
  128. }
  129.  
  130.  
  131. # Accept a request from the LRWP server to process; blocks until it has
  132. # read in the full request.
  133. # Parameters: LRWP array reference
  134. # Returns:    1 on success, undef otherwise
  135.  
  136. sub lrwp_accept_request
  137. {
  138.     my ($lrwpref) = @_;
  139.     if (! defined ($lrwpref)) {
  140.     warn "lrwp_accept_request: insufficient parameters";
  141.     return undef;
  142.     }
  143.  
  144.     my ($environsize) =
  145.     read_all_bytes ($lrwpref -> [$LRWP_SOCKET], $LRWP_SIZE_BYTES);
  146.     if (! defined ($environsize)) {
  147.     return undef;
  148.     }
  149.  
  150.     my ($environment) =
  151.     read_all_bytes ($lrwpref -> [$LRWP_SOCKET], $environsize);
  152.     if (! defined ($environment)) {
  153.     return undef;
  154.     }
  155.     $lrwpref -> [$LRWP_CGI] = string_to_hash_ref($environment);
  156.  
  157.     my ($postsize) =
  158.     read_all_bytes ($lrwpref -> [$LRWP_SOCKET], $LRWP_SIZE_BYTES);
  159.     if (! defined ($postsize)) {
  160.     return undef;
  161.     }
  162.  
  163.     if ($postsize > 0) {
  164.     $lrwpref -> [$LRWP_INDATA] = 
  165.         read_all_bytes ($lrwpref -> [$LRWP_SOCKET], $postsize);
  166.     if (defined ($lrwpref -> [$LRWP_INDATA])) {
  167.         return 1;              # Valid request with posted data
  168.     }
  169.     else {
  170.         return undef;
  171.     }
  172.     }
  173.     else {
  174.     $lrwpref -> [$LRWP_INDATA] = "";
  175.     return 1;                  # Valid request with no data
  176.     }
  177.  
  178.     # Unreachable
  179.     warn "lrwp_accept_request: Internal logic error";
  180.     return undef;
  181. }
  182.  
  183. # Append a string to the outgoing LRWP data buffer
  184. # Parameters: reference to LRWP array, string to append
  185. # Returns:    1, unless missing parameters (then undef)
  186.  
  187. sub lrwp_send_string
  188. {
  189.     if (defined ($_[0]) && defined ($_[1])) {
  190.     $_[0] -> [$LRWP_OUTDATA] .= $_[1];
  191.     return 1;
  192.     }
  193.     else 
  194.     {
  195.     return undef;
  196.     }
  197.     
  198. }
  199.  
  200. # Append general data to end of outgoing LRWP data buffer
  201. # Parameters: reference to LRWP array, string to append
  202. # Returns:    1, unless missing parameters (then undef)
  203.  
  204. sub lrwp_send_data
  205. {
  206.     return lrwp_send_string(@_);
  207. }
  208.  
  209. # Write finished report back out to LRWP server
  210. # Parameters: reference to LRWP array
  211. # Returns:    1 if successful, undef otherwise
  212.  
  213. sub lrwp_finish_request
  214. {
  215.     my ($lrwpref) = @_;
  216.     if (! defined ($lrwpref)) {
  217.     warn "lrwp_finish_report: missing parameters";
  218.     return undef;
  219.     }
  220.  
  221.     my $socket = $lrwpref -> [$LRWP_SOCKET];
  222.     my $pattern = "%0${LRWP_SIZE_BYTES}d";
  223.  
  224.     if (printf ($socket $pattern, length ($lrwpref -> [$LRWP_OUTDATA]))) {
  225.     }
  226.     else {
  227.     lrwp_cleanup ($lrwpref);
  228.     return undef;
  229.     }
  230.  
  231.     if (print $socket $lrwpref -> [$LRWP_OUTDATA]) {
  232.     }
  233.     else {
  234.     lrwp_cleanup ($lrwpref);
  235.     return undef;
  236.     }
  237.  
  238.     lrwp_cleanup ($lrwpref);
  239.     return 1;
  240. }
  241.  
  242. # Close LRWP connection to server
  243. # Parameters: reference to LRWP structure
  244. # Returns:    1 unless missing parameters (then undef)
  245.  
  246. sub lrwp_close
  247. {
  248.     if (! defined ($_[0])) {
  249.     return undef; 
  250.     }
  251.  
  252.     close ($_[0] -> [$LRWP_SOCKET]);
  253.     $_[0] -> [$LRWP_SOCKET] = undef;
  254.     return lrwp_cleanup (@_);
  255. }
  256.  
  257. # Cleanup LRWP session (clear out posted data, environment, etc)
  258. # Parameters: reference to LRWP structure
  259. # Returns:    1 unless missing parameters (then undef)
  260.  
  261. sub lrwp_cleanup 
  262. {
  263.     if (! defined ($_[0])) {
  264.     return undef;
  265.     }
  266.  
  267.     $_[0] -> [$LRWP_CGI]     = undef;
  268.     $_[0] -> [$LRWP_INDATA]  = "";
  269.     $_[0] -> [$LRWP_OUTDATA] = "";
  270. }
  271.  
  272.  
  273. # Read all bytes in from handle -- up to the number specified as required.
  274. # If we don't get all of them return undef; otherwise return the whole
  275. # collection of bytes.
  276. #
  277. # Expects: reference to socket to use, number of bytes required.
  278.  
  279. sub read_all_bytes 
  280. {
  281.     my ($socket, $bytes_required) = @_;
  282.     if (! defined ($socket) || ! defined ($bytes_required)) {
  283.     warn "read_all_bytes: insufficient parameters";
  284.     return undef;
  285.     }
  286.  
  287.     my $buffer = "";
  288.     my $input  = "";
  289.     while ($bytes_required > 0) {
  290.     $input  = " " x $bytes_required;
  291.  
  292.     my $bytes = sysread $socket, $input, $bytes_required;
  293.  
  294.     if ($bytes > 0) {
  295.         $buffer .= substr($input, 0, $bytes);
  296.         $bytes_required -= $bytes;
  297.     }
  298.     else {
  299.         return undef;                      # Error reading from socket
  300.     }
  301.     }
  302.  
  303.     # If we get this far, we've read all the bytes we need without errors
  304.     return $buffer;
  305. }
  306.  
  307. # Convert a string containing a list of x=y strings into a hash keyed on 
  308. # the x values and having the y values as the stored value.
  309. # Parameters: string with the list of x=y bits
  310. # Returns:    reference to hash 
  311.  
  312. sub string_to_hash_ref
  313. {
  314.     my (%hash) = map { split ('=', $_, 2) } (split(/\0/, $_[0]));
  315.     return \%hash;
  316. }
  317.  
  318. #---------------------------------------------------------------------------
  319. # Mainline
  320. #---------------------------------------------------------------------------
  321.  
  322. my @lrwp;
  323. my ($appname, $server, $port, $vhost) = @ARGV;
  324.  
  325. my $statusmsg = lrwp_connect(\@lrwp, @ARGV);
  326. if (defined ($statusmsg)) {
  327.     warn "LRWP error: $statusmsg\n";
  328.     exit 1;
  329. }
  330.  
  331. printf("Waiting for requests from %s:%s\n", $server, $port);
  332. printf("Try hitting http://%s/%s with your browser...\n",
  333.         defined ($vhost) ? $vhost : $server, $appname);
  334.  
  335. my $count = 0;
  336. my $buf;
  337.  
  338. # only handle 5 reqests, then exit 
  339. while ($count < 5 && lrwp_accept_request(\@lrwp)) {
  340.     warn "Accepted new request...\n";
  341.     $count++;
  342.  
  343.     lrwp_send_string(\@lrwp, "Content-type: text/html\r\n\r\n");
  344.     $buf = sprintf(
  345.         "<HTML><HEAD><TITLE>LRWP TestApp (%s)</TITLE></HEAD>\n<BODY>\n",
  346.         $appname);
  347.     lrwp_send_string(\@lrwp, $buf);
  348.  
  349.     $buf = sprintf("<H2>LRWP test app (%s)</H2><P>", $appname);
  350.     lrwp_send_string(\@lrwp, $buf);
  351.  
  352.     $buf = sprintf("<b>request count</b> = %d<br>", $count);
  353.     lrwp_send_string(\@lrwp, $buf);
  354.  
  355.     lrwp_send_string(\@lrwp, "<br><b>post data:</b> ");
  356.     if (length ($lrwp [$LRWP_INDATA])) {
  357.     lrwp_send_string (\@lrwp, "<pre>");
  358.         lrwp_send_string (\@lrwp, $lrwp [$LRWP_INDATA]);
  359.         lrwp_send_string (\@lrwp, "</pre><br>");
  360.     }
  361.  
  362.     lrwp_send_string(\@lrwp, "<P><HR><P><pre>");
  363.  
  364.     my $symbol;
  365.     foreach $symbol (sort keys %{$lrwp [$LRWP_CGI]}) {
  366.     $buf = sprintf("<b>%-20s :</b>  %s\n", 
  367.                $symbol, $lrwp [$LRWP_CGI] -> {$symbol});
  368.         lrwp_send_string(\@lrwp, $buf);
  369.     }
  370.  
  371.     lrwp_send_string(\@lrwp, "\n</pre><P><HR>\n</BODY></HTML>\n");
  372.     lrwp_finish_request(\@lrwp);
  373. }
  374.  
  375. lrwp_close(\@lrwp);
  376.  
  377. exit 0;
  378.  
  379.