]>
Commit | Line | Data |
---|---|---|
b1832b9e NB |
1 | package HTTP::Daemon; |
2 | ||
3 | use strict; | |
4 | use vars qw($VERSION @ISA $PROTO $DEBUG); | |
5 | ||
22a693eb | 6 | $VERSION = "6.01"; |
b1832b9e | 7 | |
22a693eb | 8 | use IO::Socket qw(AF_INET INADDR_ANY INADDR_LOOPBACK inet_ntoa); |
b1832b9e NB |
9 | @ISA=qw(IO::Socket::INET); |
10 | ||
11 | $PROTO = "HTTP/1.1"; | |
12 | ||
13 | ||
14 | sub new | |
15 | { | |
16 | my($class, %args) = @_; | |
17 | $args{Listen} ||= 5; | |
18 | $args{Proto} ||= 'tcp'; | |
19 | return $class->SUPER::new(%args); | |
20 | } | |
21 | ||
22 | ||
23 | sub accept | |
24 | { | |
25 | my $self = shift; | |
26 | my $pkg = shift || "HTTP::Daemon::ClientConn"; | |
27 | my ($sock, $peer) = $self->SUPER::accept($pkg); | |
28 | if ($sock) { | |
29 | ${*$sock}{'httpd_daemon'} = $self; | |
30 | return wantarray ? ($sock, $peer) : $sock; | |
31 | } | |
32 | else { | |
33 | return; | |
34 | } | |
35 | } | |
36 | ||
37 | ||
38 | sub url | |
39 | { | |
40 | my $self = shift; | |
41 | my $url = $self->_default_scheme . "://"; | |
42 | my $addr = $self->sockaddr; | |
43 | if (!$addr || $addr eq INADDR_ANY) { | |
44 | require Sys::Hostname; | |
45 | $url .= lc Sys::Hostname::hostname(); | |
46 | } | |
22a693eb AG |
47 | elsif ($addr eq INADDR_LOOPBACK) { |
48 | $url .= inet_ntoa($addr); | |
49 | } | |
b1832b9e NB |
50 | else { |
51 | $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr); | |
52 | } | |
53 | my $port = $self->sockport; | |
54 | $url .= ":$port" if $port != $self->_default_port; | |
55 | $url .= "/"; | |
56 | $url; | |
57 | } | |
58 | ||
59 | ||
60 | sub _default_port { | |
61 | 80; | |
62 | } | |
63 | ||
64 | ||
65 | sub _default_scheme { | |
66 | "http"; | |
67 | } | |
68 | ||
69 | ||
70 | sub product_tokens | |
71 | { | |
72 | "libwww-perl-daemon/$HTTP::Daemon::VERSION"; | |
73 | } | |
74 | ||
75 | ||
76 | ||
77 | package HTTP::Daemon::ClientConn; | |
78 | ||
79 | use vars qw(@ISA $DEBUG); | |
80 | use IO::Socket (); | |
81 | @ISA=qw(IO::Socket::INET); | |
82 | *DEBUG = \$HTTP::Daemon::DEBUG; | |
83 | ||
84 | use HTTP::Request (); | |
85 | use HTTP::Response (); | |
86 | use HTTP::Status; | |
87 | use HTTP::Date qw(time2str); | |
88 | use LWP::MediaTypes qw(guess_media_type); | |
89 | use Carp (); | |
90 | ||
91 | my $CRLF = "\015\012"; # "\r\n" is not portable | |
92 | my $HTTP_1_0 = _http_version("HTTP/1.0"); | |
93 | my $HTTP_1_1 = _http_version("HTTP/1.1"); | |
94 | ||
95 | ||
96 | sub get_request | |
97 | { | |
98 | my($self, $only_headers) = @_; | |
99 | if (${*$self}{'httpd_nomore'}) { | |
100 | $self->reason("No more requests from this connection"); | |
101 | return; | |
102 | } | |
103 | ||
104 | $self->reason(""); | |
105 | my $buf = ${*$self}{'httpd_rbuf'}; | |
106 | $buf = "" unless defined $buf; | |
107 | ||
108 | my $timeout = $ {*$self}{'io_socket_timeout'}; | |
109 | my $fdset = ""; | |
110 | vec($fdset, $self->fileno, 1) = 1; | |
111 | local($_); | |
112 | ||
113 | READ_HEADER: | |
114 | while (1) { | |
115 | # loop until we have the whole header in $buf | |
116 | $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines | |
117 | if ($buf =~ /\012/) { # potential, has at least one line | |
118 | if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) { | |
119 | if ($buf =~ /\015?\012\015?\012/) { | |
120 | last READ_HEADER; # we have it | |
121 | } | |
122 | elsif (length($buf) > 16*1024) { | |
123 | $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE | |
124 | $self->reason("Very long header"); | |
125 | return; | |
126 | } | |
127 | } | |
128 | else { | |
129 | last READ_HEADER; # HTTP/0.9 client | |
130 | } | |
131 | } | |
132 | elsif (length($buf) > 16*1024) { | |
133 | $self->send_error(414); # REQUEST_URI_TOO_LARGE | |
134 | $self->reason("Very long first line"); | |
135 | return; | |
136 | } | |
137 | print STDERR "Need more data for complete header\n" if $DEBUG; | |
138 | return unless $self->_need_more($buf, $timeout, $fdset); | |
139 | } | |
140 | if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { | |
141 | ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0"); | |
142 | $self->send_error(400); # BAD_REQUEST | |
143 | $self->reason("Bad request line: $buf"); | |
144 | return; | |
145 | } | |
146 | my $method = $1; | |
147 | my $uri = $2; | |
148 | my $proto = $3 || "HTTP/0.9"; | |
149 | $uri = "http://$uri" if $method eq "CONNECT"; | |
150 | $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url); | |
151 | my $r = HTTP::Request->new($method, $uri); | |
152 | $r->protocol($proto); | |
153 | ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto); | |
154 | ${*$self}{'httpd_head'} = ($method eq "HEAD"); | |
155 | ||
156 | if ($proto >= $HTTP_1_0) { | |
157 | # we expect to find some headers | |
158 | my($key, $val); | |
159 | HEADER: | |
160 | while ($buf =~ s/^([^\012]*)\012//) { | |
161 | $_ = $1; | |
162 | s/\015$//; | |
163 | if (/^([^:\s]+)\s*:\s*(.*)/) { | |
164 | $r->push_header($key, $val) if $key; | |
165 | ($key, $val) = ($1, $2); | |
166 | } | |
167 | elsif (/^\s+(.*)/) { | |
168 | $val .= " $1"; | |
169 | } | |
170 | else { | |
171 | last HEADER; | |
172 | } | |
173 | } | |
174 | $r->push_header($key, $val) if $key; | |
175 | } | |
176 | ||
177 | my $conn = $r->header('Connection'); | |
178 | if ($proto >= $HTTP_1_1) { | |
179 | ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/; | |
180 | } | |
181 | else { | |
182 | ${*$self}{'httpd_nomore'}++ unless $conn && | |
183 | lc($conn) =~ /\bkeep-alive\b/; | |
184 | } | |
185 | ||
186 | if ($only_headers) { | |
187 | ${*$self}{'httpd_rbuf'} = $buf; | |
188 | return $r; | |
189 | } | |
190 | ||
191 | # Find out how much content to read | |
192 | my $te = $r->header('Transfer-Encoding'); | |
193 | my $ct = $r->header('Content-Type'); | |
194 | my $len = $r->header('Content-Length'); | |
195 | ||
196 | # Act on the Expect header, if it's there | |
197 | for my $e ( $r->header('Expect') ) { | |
198 | if( lc($e) eq '100-continue' ) { | |
199 | $self->send_status_line(100); | |
200 | $self->send_crlf; | |
201 | } | |
202 | else { | |
203 | $self->send_error(417); | |
204 | $self->reason("Unsupported Expect header value"); | |
205 | return; | |
206 | } | |
207 | } | |
208 | ||
209 | if ($te && lc($te) eq 'chunked') { | |
210 | # Handle chunked transfer encoding | |
211 | my $body = ""; | |
212 | CHUNK: | |
213 | while (1) { | |
214 | print STDERR "Chunked\n" if $DEBUG; | |
215 | if ($buf =~ s/^([^\012]*)\012//) { | |
216 | my $chunk_head = $1; | |
217 | unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) { | |
218 | $self->send_error(400); | |
219 | $self->reason("Bad chunk header $chunk_head"); | |
220 | return; | |
221 | } | |
222 | my $size = hex($1); | |
223 | last CHUNK if $size == 0; | |
224 | ||
225 | my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end | |
226 | # must read until we have a complete chunk | |
227 | while ($missing > 0) { | |
228 | print STDERR "Need $missing more bytes\n" if $DEBUG; | |
229 | my $n = $self->_need_more($buf, $timeout, $fdset); | |
230 | return unless $n; | |
231 | $missing -= $n; | |
232 | } | |
233 | $body .= substr($buf, 0, $size); | |
234 | substr($buf, 0, $size+2) = ''; | |
235 | ||
236 | } | |
237 | else { | |
238 | # need more data in order to have a complete chunk header | |
239 | return unless $self->_need_more($buf, $timeout, $fdset); | |
240 | } | |
241 | } | |
242 | $r->content($body); | |
243 | ||
244 | # pretend it was a normal entity body | |
245 | $r->remove_header('Transfer-Encoding'); | |
246 | $r->header('Content-Length', length($body)); | |
247 | ||
248 | my($key, $val); | |
249 | FOOTER: | |
250 | while (1) { | |
251 | if ($buf !~ /\012/) { | |
252 | # need at least one line to look at | |
253 | return unless $self->_need_more($buf, $timeout, $fdset); | |
254 | } | |
255 | else { | |
256 | $buf =~ s/^([^\012]*)\012//; | |
257 | $_ = $1; | |
258 | s/\015$//; | |
259 | if (/^([\w\-]+)\s*:\s*(.*)/) { | |
260 | $r->push_header($key, $val) if $key; | |
261 | ($key, $val) = ($1, $2); | |
262 | } | |
263 | elsif (/^\s+(.*)/) { | |
264 | $val .= " $1"; | |
265 | } | |
266 | elsif (!length) { | |
267 | last FOOTER; | |
268 | } | |
269 | else { | |
270 | $self->reason("Bad footer syntax"); | |
271 | return; | |
272 | } | |
273 | } | |
274 | } | |
275 | $r->push_header($key, $val) if $key; | |
276 | ||
277 | } | |
278 | elsif ($te) { | |
279 | $self->send_error(501); # Unknown transfer encoding | |
280 | $self->reason("Unknown transfer encoding '$te'"); | |
281 | return; | |
282 | ||
283 | } | |
284 | elsif ($len) { | |
285 | # Plain body specified by "Content-Length" | |
286 | my $missing = $len - length($buf); | |
287 | while ($missing > 0) { | |
288 | print "Need $missing more bytes of content\n" if $DEBUG; | |
289 | my $n = $self->_need_more($buf, $timeout, $fdset); | |
290 | return unless $n; | |
291 | $missing -= $n; | |
292 | } | |
293 | if (length($buf) > $len) { | |
294 | $r->content(substr($buf,0,$len)); | |
295 | substr($buf, 0, $len) = ''; | |
296 | } | |
297 | else { | |
298 | $r->content($buf); | |
299 | $buf=''; | |
300 | } | |
301 | } | |
302 | elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) { | |
303 | # Handle multipart content type | |
304 | my $boundary = "$CRLF--$2--"; | |
305 | my $index; | |
306 | while (1) { | |
307 | $index = index($buf, $boundary); | |
308 | last if $index >= 0; | |
309 | # end marker not yet found | |
310 | return unless $self->_need_more($buf, $timeout, $fdset); | |
311 | } | |
312 | $index += length($boundary); | |
313 | $r->content(substr($buf, 0, $index)); | |
314 | substr($buf, 0, $index) = ''; | |
315 | ||
316 | } | |
317 | ${*$self}{'httpd_rbuf'} = $buf; | |
318 | ||
319 | $r; | |
320 | } | |
321 | ||
322 | ||
323 | sub _need_more | |
324 | { | |
325 | my $self = shift; | |
326 | #my($buf,$timeout,$fdset) = @_; | |
327 | if ($_[1]) { | |
328 | my($timeout, $fdset) = @_[1,2]; | |
329 | print STDERR "select(,,,$timeout)\n" if $DEBUG; | |
330 | my $n = select($fdset,undef,undef,$timeout); | |
331 | unless ($n) { | |
332 | $self->reason(defined($n) ? "Timeout" : "select: $!"); | |
333 | return; | |
334 | } | |
335 | } | |
336 | print STDERR "sysread()\n" if $DEBUG; | |
337 | my $n = sysread($self, $_[0], 2048, length($_[0])); | |
338 | $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n; | |
339 | $n; | |
340 | } | |
341 | ||
342 | ||
343 | sub read_buffer | |
344 | { | |
345 | my $self = shift; | |
346 | my $old = ${*$self}{'httpd_rbuf'}; | |
347 | if (@_) { | |
348 | ${*$self}{'httpd_rbuf'} = shift; | |
349 | } | |
350 | $old; | |
351 | } | |
352 | ||
353 | ||
354 | sub reason | |
355 | { | |
356 | my $self = shift; | |
357 | my $old = ${*$self}{'httpd_reason'}; | |
358 | if (@_) { | |
359 | ${*$self}{'httpd_reason'} = shift; | |
360 | } | |
361 | $old; | |
362 | } | |
363 | ||
364 | ||
365 | sub proto_ge | |
366 | { | |
367 | my $self = shift; | |
368 | ${*$self}{'httpd_client_proto'} >= _http_version(shift); | |
369 | } | |
370 | ||
371 | ||
372 | sub _http_version | |
373 | { | |
374 | local($_) = shift; | |
375 | return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i; | |
376 | $1 * 1000 + $2; | |
377 | } | |
378 | ||
379 | ||
380 | sub antique_client | |
381 | { | |
382 | my $self = shift; | |
383 | ${*$self}{'httpd_client_proto'} < $HTTP_1_0; | |
384 | } | |
385 | ||
386 | ||
387 | sub force_last_request | |
388 | { | |
389 | my $self = shift; | |
390 | ${*$self}{'httpd_nomore'}++; | |
391 | } | |
392 | ||
393 | sub head_request | |
394 | { | |
395 | my $self = shift; | |
396 | ${*$self}{'httpd_head'}; | |
397 | } | |
398 | ||
399 | ||
400 | sub send_status_line | |
401 | { | |
402 | my($self, $status, $message, $proto) = @_; | |
403 | return if $self->antique_client; | |
404 | $status ||= RC_OK; | |
405 | $message ||= status_message($status) || ""; | |
406 | $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1"; | |
407 | print $self "$proto $status $message$CRLF"; | |
408 | } | |
409 | ||
410 | ||
411 | sub send_crlf | |
412 | { | |
413 | my $self = shift; | |
414 | print $self $CRLF; | |
415 | } | |
416 | ||
417 | ||
418 | sub send_basic_header | |
419 | { | |
420 | my $self = shift; | |
421 | return if $self->antique_client; | |
422 | $self->send_status_line(@_); | |
423 | print $self "Date: ", time2str(time), $CRLF; | |
424 | my $product = $self->daemon->product_tokens; | |
425 | print $self "Server: $product$CRLF" if $product; | |
426 | } | |
427 | ||
428 | ||
429 | sub send_header | |
430 | { | |
431 | my $self = shift; | |
432 | while (@_) { | |
433 | my($k, $v) = splice(@_, 0, 2); | |
434 | $v = "" unless defined($v); | |
435 | print $self "$k: $v$CRLF"; | |
436 | } | |
437 | } | |
438 | ||
439 | ||
440 | sub send_response | |
441 | { | |
442 | my $self = shift; | |
443 | my $res = shift; | |
444 | if (!ref $res) { | |
445 | $res ||= RC_OK; | |
446 | $res = HTTP::Response->new($res, @_); | |
447 | } | |
448 | my $content = $res->content; | |
449 | my $chunked; | |
450 | unless ($self->antique_client) { | |
451 | my $code = $res->code; | |
452 | $self->send_basic_header($code, $res->message, $res->protocol); | |
453 | if ($code =~ /^(1\d\d|[23]04)$/) { | |
454 | # make sure content is empty | |
455 | $res->remove_header("Content-Length"); | |
456 | $content = ""; | |
457 | } | |
458 | elsif ($res->request && $res->request->method eq "HEAD") { | |
459 | # probably OK | |
460 | } | |
461 | elsif (ref($content) eq "CODE") { | |
462 | if ($self->proto_ge("HTTP/1.1")) { | |
463 | $res->push_header("Transfer-Encoding" => "chunked"); | |
464 | $chunked++; | |
465 | } | |
466 | else { | |
467 | $self->force_last_request; | |
468 | } | |
469 | } | |
470 | elsif (length($content)) { | |
471 | $res->header("Content-Length" => length($content)); | |
472 | } | |
473 | else { | |
474 | $self->force_last_request; | |
475 | $res->header('connection','close'); | |
476 | } | |
477 | print $self $res->headers_as_string($CRLF); | |
478 | print $self $CRLF; # separates headers and content | |
479 | } | |
480 | if ($self->head_request) { | |
481 | # no content | |
482 | } | |
483 | elsif (ref($content) eq "CODE") { | |
484 | while (1) { | |
485 | my $chunk = &$content(); | |
486 | last unless defined($chunk) && length($chunk); | |
487 | if ($chunked) { | |
488 | printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF; | |
489 | } | |
490 | else { | |
491 | print $self $chunk; | |
492 | } | |
493 | } | |
494 | print $self "0$CRLF$CRLF" if $chunked; # no trailers either | |
495 | } | |
496 | elsif (length $content) { | |
497 | print $self $content; | |
498 | } | |
499 | } | |
500 | ||
501 | ||
502 | sub send_redirect | |
503 | { | |
504 | my($self, $loc, $status, $content) = @_; | |
505 | $status ||= RC_MOVED_PERMANENTLY; | |
506 | Carp::croak("Status '$status' is not redirect") unless is_redirect($status); | |
507 | $self->send_basic_header($status); | |
508 | my $base = $self->daemon->url; | |
509 | $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc); | |
510 | $loc = $loc->abs($base); | |
511 | print $self "Location: $loc$CRLF"; | |
512 | if ($content) { | |
513 | my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain"; | |
514 | print $self "Content-Type: $ct$CRLF"; | |
515 | } | |
516 | print $self $CRLF; | |
517 | print $self $content if $content && !$self->head_request; | |
518 | $self->force_last_request; # no use keeping the connection open | |
519 | } | |
520 | ||
521 | ||
522 | sub send_error | |
523 | { | |
524 | my($self, $status, $error) = @_; | |
525 | $status ||= RC_BAD_REQUEST; | |
526 | Carp::croak("Status '$status' is not an error") unless is_error($status); | |
527 | my $mess = status_message($status); | |
528 | $error ||= ""; | |
529 | $mess = <<EOT; | |
530 | <title>$status $mess</title> | |
531 | <h1>$status $mess</h1> | |
532 | $error | |
533 | EOT | |
534 | unless ($self->antique_client) { | |
535 | $self->send_basic_header($status); | |
536 | print $self "Content-Type: text/html$CRLF"; | |
537 | print $self "Content-Length: " . length($mess) . $CRLF; | |
538 | print $self $CRLF; | |
539 | } | |
540 | print $self $mess unless $self->head_request; | |
541 | $status; | |
542 | } | |
543 | ||
544 | ||
545 | sub send_file_response | |
546 | { | |
547 | my($self, $file) = @_; | |
548 | if (-d $file) { | |
549 | $self->send_dir($file); | |
550 | } | |
551 | elsif (-f _) { | |
552 | # plain file | |
553 | local(*F); | |
554 | sysopen(F, $file, 0) or | |
555 | return $self->send_error(RC_FORBIDDEN); | |
556 | binmode(F); | |
557 | my($ct,$ce) = guess_media_type($file); | |
558 | my($size,$mtime) = (stat _)[7,9]; | |
559 | unless ($self->antique_client) { | |
560 | $self->send_basic_header; | |
561 | print $self "Content-Type: $ct$CRLF"; | |
562 | print $self "Content-Encoding: $ce$CRLF" if $ce; | |
563 | print $self "Content-Length: $size$CRLF" if $size; | |
564 | print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime; | |
565 | print $self $CRLF; | |
566 | } | |
567 | $self->send_file(\*F) unless $self->head_request; | |
568 | return RC_OK; | |
569 | } | |
570 | else { | |
571 | $self->send_error(RC_NOT_FOUND); | |
572 | } | |
573 | } | |
574 | ||
575 | ||
576 | sub send_dir | |
577 | { | |
578 | my($self, $dir) = @_; | |
579 | $self->send_error(RC_NOT_FOUND) unless -d $dir; | |
580 | $self->send_error(RC_NOT_IMPLEMENTED); | |
581 | } | |
582 | ||
583 | ||
584 | sub send_file | |
585 | { | |
586 | my($self, $file) = @_; | |
587 | my $opened = 0; | |
588 | local(*FILE); | |
589 | if (!ref($file)) { | |
590 | open(FILE, $file) || return undef; | |
591 | binmode(FILE); | |
592 | $file = \*FILE; | |
593 | $opened++; | |
594 | } | |
595 | my $cnt = 0; | |
596 | my $buf = ""; | |
597 | my $n; | |
598 | while ($n = sysread($file, $buf, 8*1024)) { | |
599 | last if !$n; | |
600 | $cnt += $n; | |
601 | print $self $buf; | |
602 | } | |
603 | close($file) if $opened; | |
604 | $cnt; | |
605 | } | |
606 | ||
607 | ||
608 | sub daemon | |
609 | { | |
610 | my $self = shift; | |
611 | ${*$self}{'httpd_daemon'}; | |
612 | } | |
613 | ||
614 | ||
615 | 1; | |
616 | ||
617 | __END__ | |
618 | ||
619 | =head1 NAME | |
620 | ||
621 | HTTP::Daemon - a simple http server class | |
622 | ||
623 | =head1 SYNOPSIS | |
624 | ||
625 | use HTTP::Daemon; | |
626 | use HTTP::Status; | |
627 | ||
628 | my $d = HTTP::Daemon->new || die; | |
629 | print "Please contact me at: <URL:", $d->url, ">\n"; | |
630 | while (my $c = $d->accept) { | |
631 | while (my $r = $c->get_request) { | |
632 | if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") { | |
633 | # remember, this is *not* recommended practice :-) | |
634 | $c->send_file_response("/etc/passwd"); | |
635 | } | |
636 | else { | |
637 | $c->send_error(RC_FORBIDDEN) | |
638 | } | |
639 | } | |
640 | $c->close; | |
641 | undef($c); | |
642 | } | |
643 | ||
644 | =head1 DESCRIPTION | |
645 | ||
646 | Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that | |
647 | listen on a socket for incoming requests. The C<HTTP::Daemon> is a | |
648 | subclass of C<IO::Socket::INET>, so you can perform socket operations | |
649 | directly on it too. | |
650 | ||
651 | The accept() method will return when a connection from a client is | |
652 | available. The returned value will be an C<HTTP::Daemon::ClientConn> | |
653 | object which is another C<IO::Socket::INET> subclass. Calling the | |
654 | get_request() method on this object will read data from the client and | |
655 | return an C<HTTP::Request> object. The ClientConn object also provide | |
656 | methods to send back various responses. | |
657 | ||
658 | This HTTP daemon does not fork(2) for you. Your application, i.e. the | |
659 | user of the C<HTTP::Daemon> is responsible for forking if that is | |
660 | desirable. Also note that the user is responsible for generating | |
661 | responses that conform to the HTTP/1.1 protocol. | |
662 | ||
663 | The following methods of C<HTTP::Daemon> are new (or enhanced) relative | |
664 | to the C<IO::Socket::INET> base class: | |
665 | ||
666 | =over 4 | |
667 | ||
668 | =item $d = HTTP::Daemon->new | |
669 | ||
670 | =item $d = HTTP::Daemon->new( %opts ) | |
671 | ||
672 | The constructor method takes the same arguments as the | |
673 | C<IO::Socket::INET> constructor, but unlike its base class it can also | |
674 | be called without any arguments. The daemon will then set up a listen | |
675 | queue of 5 connections and allocate some random port number. | |
676 | ||
677 | A server that wants to bind to some specific address on the standard | |
678 | HTTP port will be constructed like this: | |
679 | ||
680 | $d = HTTP::Daemon->new( | |
681 | LocalAddr => 'www.thisplace.com', | |
682 | LocalPort => 80, | |
683 | ); | |
684 | ||
685 | See L<IO::Socket::INET> for a description of other arguments that can | |
686 | be used configure the daemon during construction. | |
687 | ||
688 | =item $c = $d->accept | |
689 | ||
690 | =item $c = $d->accept( $pkg ) | |
691 | ||
692 | =item ($c, $peer_addr) = $d->accept | |
693 | ||
694 | This method works the same the one provided by the base class, but it | |
695 | returns an C<HTTP::Daemon::ClientConn> reference by default. If a | |
696 | package name is provided as argument, then the returned object will be | |
697 | blessed into the given class. It is probably a good idea to make that | |
698 | class a subclass of C<HTTP::Daemon::ClientConn>. | |
699 | ||
700 | The accept method will return C<undef> if timeouts have been enabled | |
701 | and no connection is made within the given time. The timeout() method | |
702 | is described in L<IO::Socket>. | |
703 | ||
704 | In list context both the client object and the peer address will be | |
705 | returned; see the description of the accept method L<IO::Socket> for | |
706 | details. | |
707 | ||
708 | =item $d->url | |
709 | ||
710 | Returns a URL string that can be used to access the server root. | |
711 | ||
712 | =item $d->product_tokens | |
713 | ||
714 | Returns the name that this server will use to identify itself. This | |
715 | is the string that is sent with the C<Server> response header. The | |
716 | main reason to have this method is that subclasses can override it if | |
717 | they want to use another product name. | |
718 | ||
719 | The default is the string "libwww-perl-daemon/#.##" where "#.##" is | |
720 | replaced with the version number of this module. | |
721 | ||
722 | =back | |
723 | ||
724 | The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET> | |
725 | subclass. Instances of this class are returned by the accept() method | |
726 | of C<HTTP::Daemon>. The following methods are provided: | |
727 | ||
728 | =over 4 | |
729 | ||
730 | =item $c->get_request | |
731 | ||
732 | =item $c->get_request( $headers_only ) | |
733 | ||
734 | This method reads data from the client and turns it into an | |
735 | C<HTTP::Request> object which is returned. It returns C<undef> | |
736 | if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn> | |
737 | object ($c) should be discarded, and you should not try call this | |
738 | method again on it. The $c->reason method might give you some | |
739 | information about why $c->get_request failed. | |
740 | ||
741 | The get_request() method will normally not return until the whole | |
742 | request has been received from the client. This might not be what you | |
743 | want if the request is an upload of a large file (and with chunked | |
744 | transfer encoding HTTP can even support infinite request messages - | |
745 | uploading live audio for instance). If you pass a TRUE value as the | |
746 | $headers_only argument, then get_request() will return immediately | |
747 | after parsing the request headers and you are responsible for reading | |
748 | the rest of the request content. If you are going to call | |
749 | $c->get_request again on the same connection you better read the | |
750 | correct number of bytes. | |
751 | ||
752 | =item $c->read_buffer | |
753 | ||
754 | =item $c->read_buffer( $new_value ) | |
755 | ||
756 | Bytes read by $c->get_request, but not used are placed in the I<read | |
757 | buffer>. The next time $c->get_request is called it will consume the | |
758 | bytes in this buffer before reading more data from the network | |
759 | connection itself. The read buffer is invalid after $c->get_request | |
760 | has failed. | |
761 | ||
762 | If you handle the reading of the request content yourself you need to | |
763 | empty this buffer before you read more and you need to place | |
764 | unconsumed bytes here. You also need this buffer if you implement | |
765 | services like I<101 Switching Protocols>. | |
766 | ||
767 | This method always returns the old buffer content and can optionally | |
768 | replace the buffer content if you pass it an argument. | |
769 | ||
770 | =item $c->reason | |
771 | ||
772 | When $c->get_request returns C<undef> you can obtain a short string | |
773 | describing why it happened by calling $c->reason. | |
774 | ||
775 | =item $c->proto_ge( $proto ) | |
776 | ||
777 | Return TRUE if the client announced a protocol with version number | |
778 | greater or equal to the given argument. The $proto argument can be a | |
779 | string like "HTTP/1.1" or just "1.1". | |
780 | ||
781 | =item $c->antique_client | |
782 | ||
783 | Return TRUE if the client speaks the HTTP/0.9 protocol. No status | |
784 | code and no headers should be returned to such a client. This should | |
785 | be the same as !$c->proto_ge("HTTP/1.0"). | |
786 | ||
787 | =item $c->head_request | |
788 | ||
789 | Return TRUE if the last request was a C<HEAD> request. No content | |
790 | body must be generated for these requests. | |
791 | ||
792 | =item $c->force_last_request | |
793 | ||
794 | Make sure that $c->get_request will not try to read more requests off | |
795 | this connection. If you generate a response that is not self | |
796 | delimiting, then you should signal this fact by calling this method. | |
797 | ||
798 | This attribute is turned on automatically if the client announces | |
799 | protocol HTTP/1.0 or worse and does not include a "Connection: | |
800 | Keep-Alive" header. It is also turned on automatically when HTTP/1.1 | |
801 | or better clients send the "Connection: close" request header. | |
802 | ||
803 | =item $c->send_status_line | |
804 | ||
805 | =item $c->send_status_line( $code ) | |
806 | ||
807 | =item $c->send_status_line( $code, $mess ) | |
808 | ||
809 | =item $c->send_status_line( $code, $mess, $proto ) | |
810 | ||
811 | Send the status line back to the client. If $code is omitted 200 is | |
812 | assumed. If $mess is omitted, then a message corresponding to $code | |
813 | is inserted. If $proto is missing the content of the | |
814 | $HTTP::Daemon::PROTO variable is used. | |
815 | ||
816 | =item $c->send_crlf | |
817 | ||
818 | Send the CRLF sequence to the client. | |
819 | ||
820 | =item $c->send_basic_header | |
821 | ||
822 | =item $c->send_basic_header( $code ) | |
823 | ||
824 | =item $c->send_basic_header( $code, $mess ) | |
825 | ||
826 | =item $c->send_basic_header( $code, $mess, $proto ) | |
827 | ||
828 | Send the status line and the "Date:" and "Server:" headers back to | |
829 | the client. This header is assumed to be continued and does not end | |
830 | with an empty CRLF line. | |
831 | ||
832 | See the description of send_status_line() for the description of the | |
833 | accepted arguments. | |
834 | ||
835 | =item $c->send_header( $field, $value ) | |
836 | ||
837 | =item $c->send_header( $field1, $value1, $field2, $value2, ... ) | |
838 | ||
839 | Send one or more header lines. | |
840 | ||
841 | =item $c->send_response( $res ) | |
842 | ||
843 | Write a C<HTTP::Response> object to the | |
844 | client as a response. We try hard to make sure that the response is | |
845 | self delimiting so that the connection can stay persistent for further | |
846 | request/response exchanges. | |
847 | ||
848 | The content attribute of the C<HTTP::Response> object can be a normal | |
849 | string or a subroutine reference. If it is a subroutine, then | |
850 | whatever this callback routine returns is written back to the | |
851 | client as the response content. The routine will be called until it | |
852 | return an undefined or empty value. If the client is HTTP/1.1 aware | |
853 | then we will use chunked transfer encoding for the response. | |
854 | ||
855 | =item $c->send_redirect( $loc ) | |
856 | ||
857 | =item $c->send_redirect( $loc, $code ) | |
858 | ||
859 | =item $c->send_redirect( $loc, $code, $entity_body ) | |
860 | ||
861 | Send a redirect response back to the client. The location ($loc) can | |
862 | be an absolute or relative URL. The $code must be one the redirect | |
863 | status codes, and defaults to "301 Moved Permanently" | |
864 | ||
865 | =item $c->send_error | |
866 | ||
867 | =item $c->send_error( $code ) | |
868 | ||
869 | =item $c->send_error( $code, $error_message ) | |
870 | ||
871 | Send an error response back to the client. If the $code is missing a | |
872 | "Bad Request" error is reported. The $error_message is a string that | |
873 | is incorporated in the body of the HTML entity body. | |
874 | ||
875 | =item $c->send_file_response( $filename ) | |
876 | ||
877 | Send back a response with the specified $filename as content. If the | |
878 | file is a directory we try to generate an HTML index of it. | |
879 | ||
880 | =item $c->send_file( $filename ) | |
881 | ||
882 | =item $c->send_file( $fd ) | |
883 | ||
884 | Copy the file to the client. The file can be a string (which | |
885 | will be interpreted as a filename) or a reference to an C<IO::Handle> | |
886 | or glob. | |
887 | ||
888 | =item $c->daemon | |
889 | ||
890 | Return a reference to the corresponding C<HTTP::Daemon> object. | |
891 | ||
892 | =back | |
893 | ||
894 | =head1 SEE ALSO | |
895 | ||
896 | RFC 2616 | |
897 | ||
898 | L<IO::Socket::INET>, L<IO::Socket> | |
899 | ||
900 | =head1 COPYRIGHT | |
901 | ||
902 | Copyright 1996-2003, Gisle Aas | |
903 | ||
904 | This library is free software; you can redistribute it and/or | |
905 | modify it under the same terms as Perl itself. | |
906 |