[Bio] / FigKernelScripts / exec-cgi.pl Repository:
ViewVC logotype

Annotation of /FigKernelScripts/exec-cgi.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (view) (download) (as text)

1 : olson 1.1 #!/usr/bin/perl
2 :    
3 :     #
4 :     # Simple web server for the mac app.
5 :     # Original version courtesy one of the folks at perlmonks.org, hacked
6 :     # to fork the cgi instead of running inline and for serving up
7 :     # static files.
8 :     #
9 :    
10 :     # This is a SAS component.
11 :    
12 :     use strict;
13 :     use warnings;
14 :     use IO::Socket::INET;
15 :     use IO::String;
16 :     use IO::Pipe;
17 :    
18 :     my $sgv = "sgv.cgi";
19 :    
20 :     if ($ENV{SAS_HOME})
21 :     {
22 :     $sgv = "$ENV{SAS_HOME}/bin/sgv.cgi";
23 :     $ENV{PATH} .= ":$ENV{SAS_HOME}/bin";
24 :     }
25 :    
26 :     my %type_map = (jpg => 'image/jpeg',
27 :     jpeg => 'image/jpeg',
28 :     png => 'image/png',
29 :     gif => 'image/gif',
30 :     html => 'text/html',
31 :     txt => 'text/plain');
32 :    
33 :     my $tmpdir = "/tmp";
34 :    
35 :     my $port = shift(@ARGV) || 9000;
36 :     my $listen = IO::Socket::INET->new(
37 :     Listen => 5,
38 :     LocalAddr => 'localhost',
39 :     LocalPort => $port,
40 :     Proto => 'tcp',
41 :     ReuseAddr => 1
42 :     );
43 :    
44 :     unless ($listen) {
45 :     die "unable to listen on port $port: $!\n"
46 :     };
47 :    
48 :     $ENV{SERVER_NAME} = "localhost";
49 :     $ENV{SERVER_PORT} = $port;
50 :     $ENV{SERVER_SOFTWARE} = "exec-cgi.pl/1.0";
51 :    
52 :     while (1) {
53 :     print STDERR "waiting for connection on port $port\n";
54 :     my $s = $listen->accept();
55 :    
56 :     my ($req, $content);
57 :     delete $ENV{CONTENT_LENGTH};
58 :     {
59 :     local ($/) = "\r\n";
60 :     while (<$s>) {
61 :     $req .= $_;
62 :     chomp;
63 :     # print STDERR "got: $_\n";
64 :     last unless /\S/;
65 :     if (/^GET\s*(\S+)/) {
66 :     $ENV{REQUEST_METHOD} = 'GET';
67 :     (my $qs = $1) =~ m/\?(.*)/;
68 :     $ENV{'QUERY_STRING'} = $1;
69 :     } elsif (/^POST/) {
70 :     $ENV{REQUEST_METHOD} = 'POST';
71 :     $ENV{'QUERY_STRING'} = '';
72 :     } elsif (/^Content-Type:\s*(.*)/) {
73 :     $ENV{CONTENT_TYPE} = $1;
74 :     } elsif (/^Content-Length:\s*(.*)/) {
75 :     $ENV{CONTENT_LENGTH} = $1;
76 :     }
77 :     }
78 :     }
79 :     $content = '';
80 :     if (my $size = $ENV{CONTENT_LENGTH}) {
81 :     while (length($content) < $size) {
82 :     my $nr = read($s, $content, $size-length($content),
83 :     length($content));
84 :     die "read error" unless $nr;
85 :     }
86 :     }
87 :    
88 :     #
89 :     # Wow this is a hack. Personalized HTTP server for SEED.
90 :     #
91 :    
92 :     if ($ENV{QUERY_STRING} =~ m,FIG-Tmp/(.*)$,)
93 :     {
94 :     my $path = "$tmpdir/$1";
95 :     print "For query $ENV{QUERY_STRING} opening $path\n";
96 :     if (!open(TMP, "<", $path))
97 :     {
98 :     warn "Error opening $path: $!\n";
99 :     print $s "HTTP/1.0 404\r\n\r\n";
100 :     close($s);
101 :     next;
102 :     }
103 :    
104 :     my $buf;
105 :     my $sz = -s $path;
106 :     print $s "HTTP/1.0 200\r\n";
107 :     my $type = 'text/plain';
108 :     if ($path =~ /\.([^.]+)$/)
109 :     {
110 :     $type = $type_map{$1};
111 :     $type = 'text/plain' if $type eq '';
112 :     }
113 :     print $s "Content-type: $type\r\n";
114 :     print $s "Content-length: $sz\r\n";
115 :     print $s "\r\n";
116 :    
117 :     while (read(TMP, $buf, 4096))
118 :     {
119 :     print $s $buf;
120 :     }
121 :     close(TMP);
122 :     }
123 :     else
124 :     {
125 :     # can save $req, $content here:
126 :     # open(F, ">request"); print F $req, $content; close(F);
127 :    
128 :     my $stdin_pipe = IO::Pipe->new();
129 :     my $stdout_pipe = IO::Pipe->new();
130 :    
131 :     my $child_pid = fork;
132 :     if ($child_pid == 0)
133 :     {
134 :     $stdin_pipe->reader();
135 :     open(STDIN, "<&", $stdin_pipe);
136 :     $stdout_pipe->writer();
137 :     open(STDOUT, ">&", $stdout_pipe);
138 :     exec $sgv;
139 :     }
140 :     $stdin_pipe->writer();
141 :     $stdout_pipe->reader();
142 :    
143 :     print $stdin_pipe $content;
144 :     close($stdin_pipe);
145 :     my $buf;
146 :     print $s "HTTP/1.0 200\r\n";
147 :     while (read($stdout_pipe, $buf, 4096))
148 :     {
149 :     print $s $buf;
150 :     # print STDERR $buf;
151 :     }
152 :     close($stdout_pipe);
153 :     print STDERR "waiting for $child_pid\n";
154 :     my $rc = waitpid $child_pid, 0;
155 :     print "child status $rc $?\n";
156 :     }
157 :     close($s);
158 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3