examples/daemon.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use CGI;
   7 use HTTP::Daemon;
   8 use HTTP::Request;
   9 use HTTP::Request::AsCGI;
  10 use HTTP::Response;
  11 use URI;
  12
  13 $SIG{'PIPE'} = 'IGNORE';
  14
  15 my $server = HTTP::Daemon->new( LocalPort => 3000, ReuseAddr => 1 )
  16   or die( "Can't create daemon: $!" );
  17
  18 print "Please contact me at: <URL:", $server->url, ">\n";
  19
  20 while ( my $client = $server->accept ) {
  21
  22     my %e = (
  23         REMOTE_ADDR => $client->peerhost,
  24         REMOTE_HOST => $client->peerhost,
  25         REMOTE_PORT => $client->peerport
  26     );
  27
  28     while ( my $request = $client->get_request ) {
  29
  30         unless ( $request->uri->host ) {
  31             $request->uri( URI->new_abs( $request->uri, $server->url ) );
  32         }
  33
  34         my $c = HTTP::Request::AsCGI->new( $request, %e )->setup;
  35         my $q = CGI->new;
  36
  37         print $q->header( -charset => 'UTF-8' ),
  38               $q->start_html(
  39                   -title    => 'Hello World',
  40                   -encoding => 'UTF-8'
  41               ),
  42               $q->h1('Hello World'),
  43               $q->start_form,
  44               $q->table(
  45                   $q->Tr( [
  46                       $q->td( [ 'Name',  $q->textfield( -name => 'name'  ) ] ),
  47                       $q->td( [ 'Email', $q->textfield( -name => 'email' ) ] ),
  48                       $q->td( [ 'Phone', $q->textfield( -name => 'phone' ) ] ),
  49                       $q->td( [ 'File',  $q->filefield( -name => 'file'  ) ] )
  50                   ] )
  51               ),
  52               $q->submit,
  53               $q->end_form,
  54               $q->h2('Parameters'),
  55               $q->Dump,
  56               $q->h2('Environment'),
  57               $q->table(
  58                   $q->Tr( [
  59                       map{ $q->td( [ $_, $ENV{$_} ] ) } sort keys %ENV
  60                   ] )
  61               ),
  62               $q->end_html;
  63
  64         my $response = $c->restore->response;
  65
  66         # tell client to close socket to prevent blocking problems
  67         # in this single threaded daemon.
  68         $response->header( Connection => 'close' );
  69
  70         $client->send_response($response);
  71     }
  72
  73     $client->close;
  74 }