initial commit
[fcgi] / perl / FCGI.PL
1 use Config;
2 use ExtUtils::MakeMaker;
3
4 do 'FCGI.cfg' or die "no FCGI.cfg";
5
6 open OUT, ">FCGI.pm";
7
8 print "Generating FCGI.pm\n";
9 print OUT <<'EOP';
10 # $Id: FCGI.PL,v 1.37 2002/12/15 20:02:48 skimo Exp $
11
12 package FCGI;
13
14 require Exporter;
15 require DynaLoader;
16
17 @ISA = qw(Exporter DynaLoader);
18 # Items to export into callers namespace by default. Note: do not export
19 # names by default without a very good reason. Use EXPORT_OK instead.
20 # Do not simply export all your public functions/methods/constants.
21 @EXPORT = qw(
22         
23 );
24
25 EOP
26
27 print OUT '$VERSION = '.MM->parse_version('version.pm').";\n\n";
28
29 print OUT "bootstrap FCGI;\n" unless ($pure);
30
31 print OUT <<'EOP' if ($pure);
32 use Symbol;
33 use POSIX 'ENOTCONN';
34
35 use constant VERSION_1 => 1;
36
37 use constant BEGIN_REQUEST => 1;
38 use constant PARAMS => 4;
39 use constant FCGI_STDIN => 5;
40 use constant FCGI_STDOUT => 6;
41 use constant FCGI_STDERR => 7;
42
43 use constant RESPONDER => 1;
44 use constant AUTHORIZER => 2;
45 use constant FILTER => 3;
46
47 %FCGI::rolenames = (RESPONDER, "RESPONDER",
48                       AUTHORIZER, "AUTHORIZER",
49                       FILTER, "FILTER",
50                      );
51
52 # This only works on Unix; anyone familiar with Windows is welcome
53 # to give a hand here
54 sub IsFastCGI {
55     my ($req) = @_;
56     $req->{isfastcgi} =
57         (!defined getpeername shift->{listen_sock}) && $! == ENOTCONN
58         unless exists $req->{isfastcgi};
59     return $req->{isfastcgi};
60 }
61
62 sub GetEnvironment {
63     return shift->{'env'};
64 }
65
66 sub read_nv_len {
67     my ($stream) = @_;
68     my $buf;
69     return undef unless read $stream, $buf, 1, 0;
70     my ($len) = unpack("C", $buf);
71     if ($len & 0x80) {
72         $buf = pack("C", $len & 0x7F);
73         return undef unless read $stream, $buf, 3, 1;
74         $len = unpack("N", $buf);
75     }
76     $len;
77 }
78
79 sub RequestX {
80     my $self = {
81         in => shift,
82         out => shift,
83         err => shift,
84         env => shift,
85         socket => shift,
86         flags => shift,
87         last => 0,
88     };
89     open $self->{listen_sock}, "<&=0";
90     bless $self, "FCGI";
91 }
92
93 my $run_once = 0;
94
95 sub Accept {
96     my ($req) = @_;
97
98     unless ($req->IsFastCGI()) {
99         return -1 if $run_once;
100
101         $run_once = 1;
102         return 0;
103     }
104     $req->Finish();
105     $req->{socket} = gensym();
106     if ($req->{last} || !accept($req->{socket}, $req->{listen_sock})) {
107         $req->{error} = "accept";
108         return -1;
109     }
110     my ($type, $id, $body) = $req->read_record();
111     if ($type != BEGIN_REQUEST) {
112         $req->{error} = "begin request";
113         return -1;
114     }
115     my ($role, $flags) = unpack("nC", $body);
116     $req->{role} = $role;
117     $req->{flags} = $flags;
118     $req->{id} = $id;
119
120     %{$req->{env}} = ();
121     $req->{env}{FCGI_ROLE} = $FCGI::rolenames{$req->{role}};
122     my $param = FCGI::Stream->new($req, PARAMS);
123     my ($nlen, $vlen);
124     while (defined($nlen = read_nv_len($param)) && 
125            defined($vlen = read_nv_len($param))) {
126         my ($name, $val);
127         read $param, $name, $nlen;
128         read $param, $val, $vlen;
129         $req->{env}{$name} = $val;
130     }
131     $req->Bind;
132     $req->{accepted} = 1;
133
134     return 0;
135 }
136
137 sub UndoBindings {
138     my ($req) = @_;
139     untie ${$req->{in}};
140     untie ${$req->{out}};
141     untie ${$req->{err}};
142     $req->{bound} = 0;
143 }
144
145 sub Bind {
146     my ($req) = @_;
147     tie ${$req->{in}}, 'FCGI::Stream', $req, FCGI_STDIN;
148     tie ${$req->{out}}, 'FCGI::Stream', $req, FCGI_STDOUT;
149     tie ${$req->{err}}, 'FCGI::Stream', $req, FCGI_STDERR;
150     $req->{bound} = 1;
151 }
152
153 sub Attach {
154     my ($req) = @_;
155     $req->Bind() if ($req->{accepted} && !$req->{bound});
156 }
157
158 sub Detach {
159     my ($req) = @_;
160     $req->UndoBindings() if ($req->{accepted} && $req->{bound});
161 }
162
163 sub Finish {
164     my ($req) = @_;
165     return unless $req->{accepted};
166     if ($req->{bound}) {
167         $req->UndoBindings();
168         # apparently these are harmful
169         # close ${$req->{out}};
170         # close ${$req->{err}};
171     }
172     $req->{accepted} = 0;
173 }
174
175 sub LastCall {
176     shift->{last} = 1;
177 }
178
179 sub DESTROY {
180     shift->Finish();
181 }
182
183 sub read_record {
184     my ($self) = @_;
185     my ($header, $body);
186
187     read($self->{socket}, $header, 8);
188     my ($version, $type, $id, $clen, $plen) = unpack("CCnnC", $header);
189     read($self->{socket}, $body, $clen+$plen);
190     $body = undef if $clen == 0;
191     ($type, $id, $body);
192 }
193
194 sub read {
195     my ($self, $rtype, $len) = @_;
196     while (length $self->{buf} < $len) {
197         my ($type, $id, $buf) = $self->read_record();
198         return undef unless defined $buf;
199         if ($type != $rtype) {
200             $self->{error} = "unexpected stream type";
201             return 0;
202         }
203         $self->{buf} .= $buf;
204     }
205     my ($newbuf, $result) = (substr($self->{buf}, $len), 
206                              substr($self->{buf}, 0, $len));
207     $self->{buf} = $newbuf;
208     $result;
209 }
210
211 sub Flush {
212     my ($req) = @_;
213 }
214
215 sub write {
216     my ($self, $type, $content, $len) = @_;
217     return unless $len > 0;
218     $self->write_record($type, $content, $len);
219 }
220
221 sub write_record {
222     my ($self, $type, $content, $length) = @_;
223     my $offset = 0;
224     while ($length > 0) {
225         my $len = $length > 32*1024 ? 32*1024 : $length;
226         my $padlen = (8 - ($len % 8)) % 8;
227         my $templ = "CCnnCxa${len}x$padlen";
228         my $data = pack($templ, 
229                         VERSION_1, $type, $self->{id}, $len, $padlen, 
230                         substr($content, $offset, $len));
231         syswrite $self->{socket}, $data;
232         $length -= $len;
233         $offset += $len;
234     }
235 }
236
237 { package FCGI::Stream;
238
239 sub new {
240     my ($class, $src, $type) = @_;
241     my $handle = do { \local *FH };
242     tie($$handle, $class, $src, $type);
243     $handle;
244 }
245
246 sub TIEHANDLE {
247     my ($class, $src, $type) = @_;
248     bless { src => $src, type => $type }, $class;
249 }
250
251 sub READ {
252     my ($stream, undef, $len, $offset) = @_;
253     my ($ref) = \$_[1];
254     my $buf = $stream->{src}->read($stream->{type}, $len);
255     return undef unless defined $buf;
256     substr($$ref, $offset, 0, $buf);
257     length $buf;
258 }
259
260 sub PRINT {
261     my ($stream) = shift;
262     for (@_) {
263         $stream->{src}->write($stream->{type}, $_, length($_));
264     }
265 }
266
267 sub CLOSE {
268     my ($stream) = @_;
269     $stream->{src}->write_record($stream->{type}, undef, 0);
270 }
271
272 }
273
274 EOP
275 print OUT while <DATA>;
276 close OUT;
277 __END__
278
279 # Preloaded methods go here.
280
281 # Autoload methods go after __END__, and are processed by the autosplit program.
282
283 *FAIL_ACCEPT_ON_INTR = sub() { 1 };
284
285 sub Request(;***$*$) {
286     my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, 0);
287     $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4]));
288     splice @defaults,0,@_,@_;
289     RequestX(@defaults);
290 }
291
292 sub accept() {
293     warn "accept called as a method; you probably wanted to call Accept" if @_;
294     if (defined %FCGI::ENV) {
295         %ENV = %FCGI::ENV;
296     } else {
297         %FCGI::ENV = %ENV;
298     }
299     my $rc = Accept($global_request);
300     for (keys %FCGI::ENV) {
301         $ENV{$_} = $FCGI::ENV{$_} unless exists $ENV{$_};
302     }
303
304     # not SFIO
305     $SIG{__WARN__} = $warn_handler if (tied (*STDIN));
306     $SIG{__DIE__} = $die_handler if (tied (*STDIN));
307
308     return $rc;
309 }
310
311 sub finish() {
312     warn "finish called as a method; you probably wanted to call Finish" if @_;
313     %ENV = %FCGI::ENV if (defined %FCGI::ENV);
314
315     # not SFIO
316     if (tied (*STDIN)) {
317         delete $SIG{__WARN__} if ($SIG{__WARN__} == $warn_handler);
318         delete $SIG{__DIE__} if ($SIG{__DIE__} == $die_handler);
319     }
320
321     Finish ($global_request);
322 }
323
324 sub flush() {
325     warn "flush called as a method; you probably wanted to call Flush" if @_;
326     Flush($global_request);
327 }
328
329 sub detach() {
330     warn "detach called as a method; you probably wanted to call Detach" if @_;
331     Detach($global_request);
332 }
333
334 sub attach() {
335     warn "attach called as a method; you probably wanted to call Attach" if @_;
336     Attach($global_request);
337 }
338
339 # deprecated
340 sub set_exit_status {
341 }
342
343 sub start_filter_data() {
344     StartFilterData($global_request);
345 }
346
347 $global_request = Request();
348 $warn_handler = sub { print STDERR @_ };
349 $die_handler = sub { print STDERR @_ unless $^S };
350
351 package FCGI::Stream;
352
353 sub PRINTF {
354   shift->PRINT(sprintf(shift, @_));
355 }
356
357 sub BINMODE {
358 }
359
360 sub READLINE {
361     my $stream = shift;
362     my ($s, $c);
363     my $rs = $/ eq '' ? "\n\n" : $/;
364     my $l = substr $rs, -1;
365     my $len = length $rs;
366
367     $c = $stream->GETC();
368     if ($/ eq '') {
369         while ($c eq "\n") { 
370             $c = $stream->GETC();
371         }
372     }
373     while (defined $c) {
374         $s .= $c;
375         last if $c eq $l and substr($s, -$len) eq $rs;
376         $c = $stream->GETC();
377     }
378     $s;
379 }
380
381 sub OPEN {
382     $_[0]->CLOSE;
383     if (@_ == 2) {
384         return open($_[0], $_[1]);
385     } else {
386         my $rc;
387         eval("$rc = open($_[0], $_[1], $_[2])");
388         die $@ if $@;
389         return $rc;
390     }
391 }
392
393 # Apparently some use fileno to determine if a filehandle is open,
394 # so we might want to return a defined, but meaningless value.
395 # An alternative would be to return the fcgi stream fd.
396 # sub FILENO { -2 }
397
398 1;
399
400 =pod
401
402 =head1 NAME
403
404 FCGI - Fast CGI module
405
406 =head1 SYNOPSIS
407
408     use FCGI;
409
410     my $count = 0;
411     my $request = FCGI::Request();
412
413     while($request->Accept() >= 0) {
414         print("Content-type: text/html\r\n\r\n", ++$count);
415     }
416
417 =head1 DESCRIPTION
418
419 Functions:
420
421 =over 4
422
423 =item FCGI::Request
424
425 Creates a request handle. It has the following optional parameters:
426
427 =over 8
428
429 =item input perl file handle (default: \*STDIN)
430
431 =item output perl file handle (default: \*STDOUT)
432
433 =item error perl file handle (default: \*STDERR)
434
435 These filehandles will be setup to act as input/output/error
436 on succesful Accept.
437
438 =item environment hash reference (default: \%ENV)
439
440 The hash will be populated with the environment.
441
442 =item socket (default: 0)
443
444 Socket to communicate with the server.
445 Can be the result of the OpenSocket function.
446 For the moment, it's the file descriptor of the socket
447 that should be passed. This may change in the future.
448
449 You should only use your own socket if your program
450 is not started by a process manager such as mod_fastcgi
451 (except for the FastCgiExternalServer case) or cgi-fcgi. 
452 If you use the option, you have to let your FastCGI
453 server know which port (and possibly server) your program
454 is listening on.
455 See remote.pl for an example.
456
457 =item flags (default: 0)
458
459 Possible values:
460
461 =over 12
462
463 =item FCGI::FAIL_ACCEPT_ON_INTR
464
465 If set, Accept will fail if interrupted.
466 It not set, it will just keep on waiting.
467
468 =back
469
470 =back
471
472 Example usage:
473     my $req = FCGI::Request;
474
475 or:
476     my %env;
477     my $in = new IO::Handle;
478     my $out = new IO::Handle;
479     my $err = new IO::Handle;
480     my $req = FCGI::Request($in, $out, $err, \%env);
481
482 =item FCGI::OpenSocket(path, backlog)
483
484 Creates a socket suitable to use as an argument to Request.
485
486 =over 8
487
488 =item path
489
490 Pathname of socket or colon followed by local tcp port.
491 Note that some systems take file permissions into account
492 on Unix domain sockets, so you'll have to make sure that
493 the server can write to the created file, by changing
494 the umask before the call and/or changing permissions and/or
495 group of the file afterwards.
496
497 =item backlog
498
499 Maximum length of the queue of pending connections.
500 If a connection
501 request arrives with the queue full the client may receive
502 an  error  with  an  indication of ECONNREFUSED.
503
504 =back
505
506 =item FCGI::CloseSocket(socket)
507
508 Close a socket opened with OpenSocket.
509
510 =item $req->Accept()
511
512 Accepts a connection on $req, attaching the filehandles and
513 populating the environment hash.
514 Returns 0 on success.
515 If a connection has been accepted before, the old
516 one will be finished first.
517
518 Note that unlike with the old interface, no die and warn
519 handlers are installed by default. This means that if
520 you are not running an sfio enabled perl, any warn or
521 die message will not end up in the server's log by default.
522 It is advised you set up die and warn handlers yourself.
523 FCGI.pm contains an example of die and warn handlers.
524
525 =item $req->Finish()
526
527 Finishes accepted connection.
528 Also detaches filehandles.
529
530 =item $req->Flush()
531
532 Flushes accepted connection.
533
534 =item $req->Detach()
535
536 Temporarily detaches filehandles on an accepted connection.
537
538 =item $req->Attach()
539
540 Re-attaches filehandles on an accepted connection.
541
542 =item $req->LastCall()
543
544 Tells the library not to accept any more requests on this handle.
545 It should be safe to call this method from signal handlers.
546
547 Note that this method is still experimental and everything
548 about it, including its name, is subject to change.
549
550 =item $env = $req->GetEnvironment()
551
552 Returns the environment parameter passed to FCGI::Request.
553
554 =item ($in, $out, $err) = $req->GetHandles()
555
556 Returns the file handle parameters passed to FCGI::Request.
557
558 =item $isfcgi = $req->IsFastCGI()
559
560 Returns whether or not the program was run as a FastCGI.
561
562 =back
563
564 =head1 AUTHOR
565
566 Sven Verdoolaege <skimo@kotnet.org>
567
568 =cut
569
570 __END__