ACE/apps/JAWS/clients/WebSTONE/bin/webstone-gui.pl

   1 #!/pkg/gnu/bin//perl5
   2 #
   3
   4 require 'conf/paths.pl';
   5
   6 #$debug = 1;
   7 $HELPME="http://reality.sgi.com/employees/mblakele_engr/WebStone/";
   8 $| =  1; # set pipes to hot
   9
  10 &html();
  11
  12 sub html {
  13         local($helper, $wd);
  14
  15         &start_html_server();
  16         # These strings are used in, among others, PERL-to-HTML scripts.
  17         #
  18         $wd = `pwd`;
  19         chop $wd;
  20
  21         print "$html_port\n" if $debug;
  22
  23         $HTML_STARTPAGE = "http://localhost:$html_port$wd/doc/WebStone.html";
  24
  25         #
  26         # Fork off the HTML client, and fork off a server process that
  27         # handles requests from that client. The parent process waits
  28         # until the client exits and terminates the server.
  29         #
  30         print "Starting $MOSAIC...\n" if $debug;
  31
  32         if (($client = fork()) == 0) {
  33                 foreach (keys %ENV) {
  34                         delete $ENV{$_} if (/proxy/i && !/no_proxy/i);
  35                 }
  36                 exec($MOSAIC, "$HTML_STARTPAGE")
  37                         || die "cannot exec $MOSAIC: $!";
  38         }
  39
  40         if (($server = fork()) == 0) {
  41                 if (($helper = fork()) == 0) {
  42                         alarm 3600;
  43                         &patience();
  44                 }
  45                 kill 'TERM',$helper;
  46                 $SIG{'PIPE'} = 'IGNORE';
  47                 for (;;) {
  48                         accept(CLIENT, SOCK) || die "accept: $!";
  49                         select((select(CLIENT), $| = 1)[0]);
  50                         &process_html_request();
  51                         close(CLIENT);
  52                 }
  53         }
  54
  55         #
  56         # Wait until the client terminates, then terminate the server.
  57         #
  58         close(SOCK);
  59         waitpid($client, 0);
  60         kill('TERM', $server);
  61         exit;
  62 }
  63
  64 #
  65 # Set up a listener on an arbitrary port. There is no good reason to
  66 # listen on a well-known port number.
  67 #
  68 sub start_html_server {
  69         local($sockaddr, $proto, $junk);
  70
  71         $AF_INET = 2;
  72         $SOCK_STREAM = 2;
  73         $PORT = 0; #1024;
  74
  75         $sockaddr = 'S n a4 x8';
  76         $this = pack($sockaddr, $AF_INET, $PORT, "\0\0\0\0");
  77         ($junk, $junk, $proto) = getprotobyname('tcp');
  78         socket(SOCK, $AF_INET, $SOCK_STREAM, $proto) || die "socket: $!";
  79         setsockopt(SOCK, 0xffff, 0x0004, 1) || die "setsockopt: $!";
  80         bind(SOCK, $this) || die "bind: $!";
  81         listen(SOCK, 1) || die "listen: $!";
  82         ($junk, $html_port) = unpack($sockaddr, getsockname(SOCK));
  83 }
  84
  85
  86 #
  87 # Process one client request.  We expect the client to send stuff that
  88 # begins with:
  89 #
  90 #       command /password/perl_script junk
  91 #
  92 # Where perl_script is the name of a perl file that is executed via
  93 # do "perl_script";
  94 #
  95 # In case of a POST command the values in the client's attribute-value
  96 # list are assigned to the corresponding global PERL variables.
  97 #
  98 sub process_html_request {
  99         local($request, $command, $script, $magic, $url, $peer);
 100         local(%args);
 101
 102         #
 103         # Parse the command and URL. Update the default file prefix.
 104         #
 105         $request = <CLIENT>;
 106         print $request if $debug;
 107         ($command, $url) = split(/\s+/, $request);
 108         if ($command eq "" || $command eq "QUIT") {
 109                 return;
 110         }
 111
 112         #($junk, $script) = split(/\//, $url, 2);
 113         #($script, $html_script_args) = split(',', $script, 2);
 114         #($HTML_CWD = "file:$script") =~ s/\/[^\/]*$//;
 115         $script = $url;
 116
 117         while (<CLIENT>) {
 118                 last if (/^\s+$/);
 119         }
 120
 121         if ($command eq "GET") {
 122                 if (-d $script) {
 123                         get_dir($script);
 124                 }
 125                 elsif ($script =~ /\.pl\b/) {
 126                         perl_html_script($script);
 127                 }
 128                 else {
 129                 get_file($script);
 130                 }
 131         } elsif ($command eq "POST") {
 132
 133                 print $request if $debug;
 134                 flush;
 135                 #
 136                 # Process the attribute-value list.
 137                 #
 138                 if ($_ = <CLIENT>) {
 139                         print "Hi $_" if $debug;
 140                         flush;
 141                         s/\s+$//;
 142                         s/^/\n/;
 143                         s/&/\n/g;
 144                         $html_post_attributes = '';
 145                         $* = 1;
 146                         for (split(/(%[0-9][0-9A-Z])/, $_)) {
 147                                 $html_post_attributes .= (/%([0-9][0-9A-Z])/) ?
 148                                         pack('c',hex($1)) : $_;
 149                         }
 150                         %args = ('_junk_', split(/\n([^=]+)=/, $html_post_attributes));
 151                         delete $args{'_junk_'};
 152                         for (keys %args) {
 153                                 print "\$$_ = $args{$_}\n" if $debug;
 154                                 ${$_} = $args{$_};
 155                         }
 156                         perl_html_script($script);
 157                 } else {
 158                         &bad_html_form($script);
 159                 }
 160         } else {
 161                 &bad_html_command($request);
 162         }
 163 }
 164
 165
 166 #
 167 # Unexpected HTML command.
 168 #
 169 sub bad_html_command {
 170         local($request) = @_;
 171
 172         print CLIENT <<EOF
 173 <HTML>
 174 <HEAD>
 175 <TITLE>Unknown command</TITLE>
 176 <LINK REV="made" HREF=$HELPME>
 177 </HEAD>
 178 <BODY>
 179 <H1>Unknown command</H1>
 180 The command <TT>$request<TT> was not recognized.
 181 </BODY>
 182 </HTML>
 183 EOF
 184 ;
 185 }
 186
 187 #
 188 # Execute PERL script
 189 #
 190 sub perl_html_script {
 191         local($script) = @_;
 192
 193         if (! -e $script) {
 194                 print CLIENT <<EOF
 195 <HTML>
 196 <HEAD>
 197 <TITLE>File not found</TITLE>
 198 <LINK REV="made" HREF=$HELPME>
 199 </HEAD>
 200 <BODY>
 201 <H1>File not found</H1>
 202 The file <TT>$script</TT> does not exist or is not accessible.
 203 </BODY>
 204 </HTML>
 205 EOF
 206 ;               return;
 207         }
 208         do $script;
 209         if ($@ && ($@ ne "\n")) {
 210                 print CLIENT <<EOF
 211 <HTML>
 212 <HEAD>
 213 <TITLE>Command failed</TITLE>
 214 <LINK REV="made" HREF=$HELPME>
 215 </HEAD>
 216 <BODY>
 217 <H1>Command failed</H1>
 218 $@
 219 </BODY>
 220 </HTML>
 221 EOF
 222 ;
 223         }
 224 }
 225
 226 #
 227 # Missing attribute list
 228 #
 229 sub bad_html_form {
 230         local($script) = @_;
 231
 232         print CLIENT <<EOF
 233 <HTML>
 234 <HEAD>
 235 <TITLE>No attribute list</TITLE>
 236 <LINK REV="made" HREF=$HELPME>
 237 </HEAD>
 238 <BODY>
 239 <H1>No attribute list</H1>
 240
 241 No attribute list was found.
 242 </BODY>
 243 </HTML>
 244 EOF
 245 ;
 246 }
 247
 248 #
 249 # Give them something to read while the server is initializing.
 250 #
 251 sub patience {
 252         for (;;) {
 253                 accept(CLIENT, SOCK) || die "accept: $!";
 254                 <CLIENT>;
 255                 print CLIENT <<EOF
 256 <HTML>
 257 <HEAD>
 258 <TITLE>Initializing...</TITLE>
 259 <LINK REV="made" HREF=$HELPME>
 260 </HEAD>
 261 <BODY>
 262 <H1>Initializing...</H1>
 263 WebStone is initializing...
 264 </BODY>
 265 </HTML>
 266 EOF
 267 ;
 268                 close(CLIENT);
 269         }
 270 }
 271
 272 sub get_file {
 273         local($file) = @_;
 274
 275         print CLIENT <<EOF
 276 <HTML>
 277 <HEAD>
 278 <TITLE>$file</TITLE>
 279 </HEAD>
 280 <H1>$file</H1>
 281 <BODY><PRE>
 282 EOF
 283         unless ($file =~ /(html|htm|gif|jpeg|jpg)\b/);
 284
 285         open(FILE, $file);
 286         while (<FILE>) {
 287                 print CLIENT $_;
 288         }
 289         close(FILE);
 290
 291         print CLIENT <<EOF
 292 </PRE>
 293 </HTML>
 294 EOF
 295         unless ($file =~ /(html|htm|gif|jpeg|jpg)\b/);
 296 }
 297
 298 sub get_dir {
 299         local($dir) = @_;
 300         opendir(DIRECTORY, $dir);
 301         @listing = readdir(DIRECTORY);
 302         closedir(DIRECTORY);
 303         print CLIENT <<EOF
 304 <HTML>
 305 <HEAD>
 306 <TITLE>$dir</TITLE>
 307 </HEAD>
 308 <H1>$dir</H1>
 309 <BODY>
 310 EOF
 311    ;
 312
 313         while (<@listing>) {
 314                 print CLIENT "<P><A HREF=$dir/$_>$_</A>";
 315         }
 316         print CLIENT "</HTML>";
 317 }