4 package HTTP::Server::Simple;
10 use vars qw($VERSION $bad_request_doc);
15 HTTP::Server::Simple - Lightweight HTTP server
22 use HTTP::Server::Simple;
24 my $server = HTTP::Server::Simple->new();
27 However, normally you will sub-class the HTTP::Server::Simple::CGI
28 module (see L<HTTP::Server::Simple::CGI>);
30 package Your::Web::Server;
31 use base qw(HTTP::Server::Simple::CGI);
34 my ($self, $cgi) = @_;
36 #... do something, print output to default
37 # selected filehandle...
45 This is a simple standalone HTTP server. By default, it doesn't thread
46 or fork. It does, however, act as a simple frontend which can be used
47 to build a standalone web-based application or turn a CGI into one.
49 It is possible to use L<Net::Server> classes to create forking,
50 pre-forking, and other types of more complicated servers; see
53 By default, the server traps a few signals:
59 When you C<kill -HUP> the server, it lets the current request finish being
60 processed, then uses the C<restart> method to re-exec itself. Please note that
61 in order to provide restart-on-SIGHUP, HTTP::Server::Simple sets a SIGHUP
62 handler during initialisation. If your request handling code forks you need to
63 make sure you reset this or unexpected things will happen if somebody sends a
64 HUP to all running processes spawned by your app (e.g. by "kill -HUP <script>")
68 If the server detects a broken pipe while writing output to the client,
69 it ignores the signal. Otherwise, a client closing the connection early
70 could kill the server.
80 use HTTP::Server::Simple::CGI;
81 use base qw(HTTP::Server::Simple::CGI);
84 '/hello' => \&resp_hello,
92 my $path = $cgi->path_info();
93 my $handler = $dispatch{$path};
95 if (ref($handler) eq "CODE") {
96 print "HTTP/1.0 200 OK\r\n";
100 print "HTTP/1.0 404 Not found\r\n";
102 $cgi->start_html('Not found'),
103 $cgi->h1('Not found'),
109 my $cgi = shift; # CGI.pm object
112 my $who = $cgi->param('name');
115 $cgi->start_html("Hello"),
116 $cgi->h1("Hello $who!"),
122 # start the server on port 8080
123 my $pid = MyWebServer->new(8080)->background();
124 print "Use 'kill $pid' to stop server.\n";
128 =head2 HTTP::Server::Simple->new($port)
130 API call to start a new server. Does not actually start listening
131 until you call C<-E<gt>run()>. If omitted, C<$port> defaults to 8080.
136 my ( $proto, $port ) = @_;
137 my $class = ref($proto) || $proto;
139 if ( $class eq __PACKAGE__ ) {
140 require HTTP::Server::Simple::CGI;
141 return HTTP::Server::Simple::CGI->new( @_[ 1 .. $#_ ] );
145 bless( $self, $class );
146 $self->port( $port || '8080' );
152 =head2 lookup_localhost
154 Looks up the local host's IP address, and returns it. For most hosts,
155 this is C<127.0.0.1>.
159 sub lookup_localhost {
162 my $local_sockaddr = getsockname( $self->stdio_handle );
163 my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
164 $self->host( gethostbyaddr( $localiaddr, AF_INET ) || "localhost");
165 $self->{'local_addr'} = inet_ntoa($localiaddr) || "127.0.0.1";
171 Takes an optional port number for this server to listen on.
173 Returns this server's port. (Defaults to 8080)
179 $self->{'port'} = shift if (@_);
180 return ( $self->{'port'} );
184 =head2 host [address]
186 Takes an optional host address for this server to bind to.
188 Returns this server's bound address (if any). Defaults to C<undef>
189 (bind to all interfaces).
195 $self->{'host'} = shift if (@_);
196 return ( $self->{'host'} );
200 =head2 background [ARGUMENTS]
202 Runs the server in the background, and returns the process ID of the
203 started process. Any arguments will be passed through to L</run>.
210 croak "Can't fork: $!" unless defined($child);
211 return $child if $child;
213 srand(); # after a fork, we need to reset the random seed
214 # or we'll get the same numbers in both branches
215 if ( $^O !~ /MSWin32/ ) {
218 or croak "Can't start a new session: $!";
220 $self->run(@_); # should never return
221 exit; # just to be sure
224 =head2 run [ARGUMENTS]
226 Run the server. If all goes well, this won't ever return, but it will
227 start listening for C<HTTP> requests. Any arguments passed to this
228 will be passed on to the underlying L<Net::Server> implementation, if
229 one is used (see L</net_server>).
233 my $server_class_id = 0;
235 use vars '$SERVER_SHOULD_RUN';
236 $SERVER_SHOULD_RUN = 1;
240 my $server = $self->net_server;
242 local $SIG{CHLD} = 'IGNORE'; # reap child processes
244 # $pkg is generated anew for each invocation to "run"
245 # Just so we can use different net_server() implementations
247 my $pkg = join '::', ref($self), "NetServer" . $server_class_id++;
250 *{"$pkg\::process_request"} = $self->_process_request;
253 require join( '/', split /::/, $server ) . '.pm';
254 *{"$pkg\::ISA"} = [$server];
256 # clear the environment before every request
257 require HTTP::Server::Simple::CGI;
258 *{"$pkg\::post_accept"} = sub {
259 HTTP::Server::Simple::CGI::Environment->setup_environment;
260 # $self->SUPER::post_accept uses the wrong super package
261 $server->can('post_accept')->(@_);
265 $self->setup_listener;
266 $self->after_setup_listener();
267 *{"$pkg\::run"} = $self->_default_run;
270 local $SIG{HUP} = sub { $SERVER_SHOULD_RUN = 0; };
272 $pkg->run( port => $self->port, @_ );
277 User-overridable method. If you set it to a L<Net::Server> subclass,
278 that subclass is used for the C<run> method. Otherwise, a minimal
279 implementation is used as default.
283 sub net_server {undef}
288 # Default "run" closure method for a stub, minimal Net::Server instance.
294 while ($SERVER_SHOULD_RUN) {
295 local $SIG{PIPE} = 'IGNORE'; # If we don't ignore SIGPIPE, a
296 # client closing the connection before we
297 # finish sending will cause the server to exit
298 while ( accept( my $remote = new FileHandle, HTTPDaemon ) ) {
299 $self->stdio_handle($remote);
300 $self->lookup_localhost() unless ($self->host);
301 $self->accept_hook if $self->can("accept_hook");
304 *STDIN = $self->stdin_handle();
305 *STDOUT = $self->stdout_handle();
306 select STDOUT; # required for HTTP::Server::Simple::Recorder
307 # XXX TODO glasser: why?
308 $pkg->process_request;
313 # Got here? Time to restart, due to SIGHUP
320 Restarts the server. Usually called by a HUP signal, not directly.
329 $SIG{CHLD} = 'DEFAULT';
332 ### if the standalone server was invoked with perl -I .. we will loose
333 ### those include dirs upon re-exec. So add them to PERL5LIB, so they
334 ### are available again for the exec'ed process --kane
336 $ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
339 # do the exec. if $0 is not executable, try running it with $^X.
340 exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @ARGV );
344 sub _process_request {
347 # Create a callback closure that is invoked for each incoming request;
348 # the $self above is bound into the closure.
351 $self->stdio_handle(*STDIN) unless $self->stdio_handle;
353 # Default to unencoded, raw data out.
354 # if you're sending utf8 and latin1 data mixed, you may need to override this
355 binmode STDIN, ':raw';
356 binmode STDOUT, ':raw';
358 # The ternary operator below is to protect against a crash caused by IE
359 # Ported from Catalyst::Engine::HTTP (Originally by Jasper Krogh and Peter Edwards)
360 # ( http://dev.catalyst.perl.org/changeset/5195, 5221 )
362 my $remote_sockaddr = getpeername( $self->stdio_handle );
363 my ( undef, $iaddr ) = $remote_sockaddr ? sockaddr_in($remote_sockaddr) : (undef,undef);
364 my $peeraddr = $iaddr ? ( inet_ntoa($iaddr) || "127.0.0.1" ) : '127.0.0.1';
366 my ( $method, $request_uri, $proto ) = $self->parse_request;
368 unless ($self->valid_http_method($method) ) {
373 $proto ||= "HTTP/0.9";
375 my ( $file, $query_string )
376 = ( $request_uri =~ /([^?]*)(?:\?(.*))?/s ); # split at ?
381 query_string => ( defined($query_string) ? $query_string : '' ),
382 request_uri => $request_uri,
384 localname => $self->host,
385 localport => $self->port,
386 peername => $peeraddr,
387 peeraddr => $peeraddr,
390 # HTTP/0.9 didn't have any headers (I think)
391 if ( $proto =~ m{HTTP/(\d(\.\d)?)$} and $1 >= 1 ) {
393 my $headers = $self->parse_headers
394 or do { $self->bad_request; return };
396 $self->headers($headers);
400 $self->post_setup_hook if $self->can("post_setup_hook");
406 =head2 stdio_handle [FILEHANDLE]
408 When called with an argument, sets the socket to the server to that arg.
410 Returns the socket to the server; you should only use this for actual socket-related
411 calls like C<getsockname>. If all you want is to read or write to the socket,
412 you should use C<stdin_handle> and C<stdout_handle> to get the in and out filehandles
419 $self->{'_stdio_handle'} = shift if (@_);
420 return $self->{'_stdio_handle'};
425 Returns a filehandle used for input from the client. By default,
426 returns whatever was set with C<stdio_handle>, but a subclass could do
427 something interesting here.
433 return $self->stdio_handle;
438 Returns a filehandle used for output to the client. By default,
439 returns whatever was set with C<stdio_handle>, but a subclass
440 could do something interesting here.
446 return $self->stdio_handle;
449 =head1 IMPORTANT SUB-CLASS METHODS
451 A selection of these methods should be provided by sub-classes of this
456 This method is called after setup, with no parameters. It should
457 print a valid, I<full> HTTP response to the default selected
464 if ( ref($self) ne __PACKAGE__ ) {
465 croak "do not call " . ref($self) . "::SUPER->handler";
468 croak "handler called out of context";
472 =head2 setup(name =E<gt> $value, ...)
474 This method is called with a name =E<gt> value list of various things
475 to do with the request. This list is given below.
477 The default setup handler simply tries to call methods with the names
478 of keys of this list.
480 ITEM/METHOD Set to Example
481 ----------- ------------------ ------------------------
482 method Request Method "GET", "POST", "HEAD"
483 protocol HTTP version "HTTP/1.1"
484 request_uri Complete Request URI "/foobar/baz?foo=bar"
485 path Path part of URI "/foobar/baz"
486 query_string Query String undef, "foo=bar"
487 port Received Port 80, 8080
488 peername Remote name "200.2.4.5", "foo.com"
489 peeraddr Remote address "200.2.4.5", "::1"
490 localname Local interface "localhost", "myhost.com"
496 while ( my ( $item, $value ) = splice @_, 0, 2 ) {
497 $self->$item($value) if $self->can($item);
501 =head2 headers([Header =E<gt> $value, ...])
503 Receives HTTP headers and does something useful with them. This is
504 called by the default C<setup()> method.
506 You have lots of options when it comes to how you receive headers.
508 You can, if you really want, define C<parse_headers()> and parse them
511 Secondly, you can intercept them very slightly cooked via the
512 C<setup()> method, above.
514 Thirdly, you can leave the C<setup()> header as-is (or calling the
515 superclass C<setup()> for unknown request items). Then you can define
516 C<headers()> in your sub-class and receive them all at once.
518 Finally, you can define handlers to receive individual HTTP headers.
519 This can be useful for very simple SOAP servers (to name a
520 crack-fueled standard that defines its own special HTTP headers).
522 To do so, you'll want to define the C<header()> method in your subclass.
523 That method will be handed a (key,value) pair of the header name and the value.
532 my $can_header = $self->can("header");
533 return unless $can_header;
534 while ( my ( $header, $value ) = splice @$headers, 0, 2 ) {
535 $self->header( $header => $value );
541 If defined by a sub-class, this method is called directly after an
542 accept happens. An accept_hook to add SSL support might look like this:
546 my $fh = $self->stdio_handle;
548 $self->SUPER::accept_hook(@_);
551 IO::Socket::SSL->start_SSL( $fh,
554 SSL_cert_file => 'myserver.crt',
555 SSL_key_file => 'myserver.key',
557 or warn "problem setting up SSL socket: " . IO::Socket::SSL::errstr();
559 $self->stdio_handle($newfh) if $newfh;
562 =head2 post_setup_hook
564 If defined by a sub-class, this method is called after all setup has
565 finished, before the handler method.
569 This routine prints a banner before the server request-handling loop
572 Methods below this point are probably not terribly useful to define
573 yourself in subclasses.
581 . ": You can connect to your server at "
582 . "http://localhost:"
590 Parse the HTTP request line. Returns three values, the request
591 method, request URI and the protocol.
598 while ( sysread( STDIN, my $buff, 1 ) ) {
599 last if $buff eq "\n";
602 defined($chunk) or return undef;
605 m/^(\w+)\s+(\S+)(?:\s+(\S+))?\r?$/;
606 my $method = $1 || '';
608 my $protocol = $3 || '';
610 return ( $method, $uri, $protocol );
615 Parses incoming HTTP headers from STDIN, and returns an arrayref of
616 C<(header =E<gt> value)> pairs. See L</headers> for possibilities on
617 how to inspect headers.
627 while ( sysread( STDIN, my $buff, 1 ) ) {
628 if ( $buff eq "\n" ) {
629 $chunk =~ s/[\r\l\n\s]+$//;
630 if ( $chunk =~ /^([^()<>\@,;:\\"\/\[\]?={} \t]+):\s*(.*)/i ) {
631 push @headers, $1 => $2;
633 last if ( $chunk =~ /^$/ );
636 else { $chunk .= $buff }
639 return ( \@headers );
642 =head2 setup_listener
644 This routine binds the server to a port and interface.
651 my $tcp = getprotobyname('tcp');
652 socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or croak "socket: $!";
653 setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
654 or warn "setsockopt: $!";
659 ? inet_aton( $self->host )
664 or croak "bind to @{[$self->host||'*']}:@{[$self->port]}: $!";
665 listen( HTTPDaemon, SOMAXCONN ) or croak "listen: $!";
669 =head2 after_setup_listener
671 This method is called immediately after setup_listener. It's here just
676 sub after_setup_listener {
681 This method should print a valid HTTP response that says that the
686 $bad_request_doc = join "", <DATA>;
691 print "HTTP/1.0 400 Bad request\r\n"; # probably OK by now
692 print "Content-Type: text/html\r\nContent-Length: ",
693 length($bad_request_doc), "\r\n\r\n", $bad_request_doc;
696 =head2 valid_http_method($method)
698 Given a candidate HTTP method in $method, determine if it is valid.
699 Override if, for example, you'd like to do some WebDAV. The default
700 implementation only accepts C<GET>, C<POST>, C<HEAD>, C<PUT>, and
705 sub valid_http_method {
707 my $method = shift or return 0;
708 return $method =~ /^(?:GET|POST|HEAD|PUT|DELETE)$/;
713 Copyright (c) 2004-2008 Jesse Vincent, <jesse@bestpractical.com>.
716 Marcus Ramberg <drave@thefeed.no> contributed tests, cleanup, etc
718 Sam Vilain, <samv@cpan.org> contributed the CGI.pm split-out and
721 Example section by almut on perlmonks, suggested by Mark Fuller.
725 There certainly are some. Please report them via rt.cpan.org
729 This library is free software; you can redistribute it and/or modify
730 it under the same terms as Perl itself.
739 <title>Bad Request</title>
744 <p>Your browser sent a request which this web server could not