Improved error messages. More tolerant parsing of CGI responses.

[catagits/HTTP-Request-AsCGI.git] / examples / daemon.pl

diff --git a/examples/daemon.pl b/examples/daemon.pl
index 5a16c89..bd4c235 100644 (file)
--- a/examples/daemon.pl
+++ b/examples/daemon.pl
@@ -8,15 +8,17 @@ use HTTP::Daemon;
 use HTTP::Request;
 use HTTP::Request::AsCGI;
 use HTTP::Response;
+use URI;
 
 $SIG{'PIPE'} = 'IGNORE';
 
-my $server = HTTP::Daemon->new( LocalPort => 3000, ReuseAddr => 1 ) || die;
+my $server = HTTP::Daemon->new( LocalPort => 3000, ReuseAddr => 1 )
+  or die( "Can't create daemon: $!" );
 
 print "Please contact me at: <URL:", $server->url, ">\n";
 
 while ( my $client = $server->accept ) {
-    
+
     my %e = (
         REMOTE_ADDR => $client->peerhost,
         REMOTE_HOST => $client->peerhost,
@@ -25,41 +27,48 @@ while ( my $client = $server->accept ) {
 
     while ( my $request = $client->get_request ) {
 
+        unless ( $request->uri->host ) {
+            $request->uri( URI->new_abs( $request->uri, $server->url ) );
+        }
+
         my $c = HTTP::Request::AsCGI->new( $request, %e )->setup;
         my $q = CGI->new;
 
-        print $q->header,
-              $q->start_html('Hello World'),
+        print $q->header( -charset => 'UTF-8' ),
+              $q->start_html( 
+                  -title    => 'Hello World',
+                  -encoding => 'UTF-8'
+              ),
               $q->h1('Hello World'),
+              $q->start_form,
+              $q->table(
+                  $q->Tr( [
+                      $q->td( [ 'Name',  $q->textfield( -name => 'name'  ) ] ),
+                      $q->td( [ 'Email', $q->textfield( -name => 'email' ) ] ),
+                      $q->td( [ 'Phone', $q->textfield( -name => 'phone' ) ] ),
+                      $q->td( [ 'File',  $q->filefield( -name => 'file'  ) ] )
+                  ] )
+              ),
+              $q->submit,
+              $q->end_form,
+              $q->h2('Parameters'),
+              $q->Dump,
+              $q->h2('Environment'),
+              $q->table(
+                  $q->Tr( [
+                      map{ $q->td( [ $_, $ENV{$_} ] ) } sort keys %ENV
+                  ] )
+              ),
               $q->end_html;
 
-        $c->restore;
-
-        my $message = "HTTP/1.1 200\x0d\x0a";
-
-        while ( my $line = $c->stdout->getline ) {
-            $message .= $line;
-            last if $line =~ /^\x0d?\x0a$/;
-        }
-
-        my $response = HTTP::Response->parse($message);
-
-        if ( my $code = $response->header('Status') ) {
-            $response->code($code);
-        }
+        my $response = $c->restore->response;
 
+        # tell client to close socket to prevent blocking problems
+        # in this single threaded daemon.
         $response->header( Connection => 'close' );
-        $response->protocol( $request->protocol );
-        $response->content( sub {
-            if ( $c->stdout->read( my $buffer, 4096 ) ) {
-                return $buffer;
-            }
-            return undef;
-        });
 
         $client->send_response($response);
-        $client->close;
     }
 
-    #$client->close;
+    $client->close;
 }