HTTP-Server-Simple-0.50HEADHTTP-Server-Simple-0.50master

1 files changed, 207 insertions, 0 deletions

diff --git a/t/04cgi.t b/t/04cgi.t
new file mode 100644
index 0000000..76b117f
--- /dev/null
+++ b/t/04cgi.t
@@ -0,0 +1,207 @@
+# -*- perl -*-
+
+use Test::More;
+use Socket;
+use strict;
+
+my $PORT = 40000 + int(rand(10000));
+
+my $host = gethostbyaddr(inet_aton('localhost'), AF_INET);
+
+my %methods=(
+              url => "url: http://$host:".$PORT,
+              path_info => 'path_info: /cgitest/path_info',
+              server_name => "server_name: $host",
+              server_port => 'server_port: '.$PORT,
+              server_software => 'server_software: HTTP::Server::Simple/\d+.\d+',
+              request_method => 'request_method: GET',
+              raw_cookie => undef, # do not test
+            );
+
+my %envvars=(
+              SERVER_URL => "SERVER_URL: http://$host:".$PORT.'/',
+              SERVER_PORT => 'SERVER_PORT: '.$PORT,
+              REQUEST_METHOD => 'REQUEST_METHOD: GET',
+              REQUEST_URI => 'REQUEST_URI: /cgitest/REQUEST_URI',
+              SERVER_PROTOCOL => 'SERVER_PROTOCOL: HTTP/1.1',
+              SERVER_NAME => "SERVER_NAME: $host",
+              SERVER_SOFTWARE => 'SERVER_SOFTWARE: HTTP::Server::Simple/\d+.\d+',
+              REMOTE_ADDR => 'REMOTE_ADDR: 127.0.0.1',
+              QUERY_STRING => 'QUERY_STRING: ',
+              PATH_INFO => 'PATH_INFO: /cgitest/PATH_INFO',
+            );
+
+if ($^O eq 'freebsd' && `sysctl -n security.jail.jailed` == 1) {
+    delete @methods{qw(url server_name)};
+    delete @envvars{qw(SERVER_URL SERVER_NAME REMOTE_ADDR)};
+    plan tests => 55;
+}
+else {
+    plan tests => 60;
+}
+
+{
+  my $server=CGIServer->new($PORT);
+  is($server->port(),$PORT,'Constructor set port correctly');
+  sleep(3); # wait just a moment
+
+  my $pid=$server->background;
+
+  like($pid, '/^-?\d+$/', 'pid is numeric');
+
+  select(undef,undef,undef,0.2); # wait a sec
+  my @message_tests = (
+      [["GET / HTTP/1.1",""], '/NOFILE/', '[GET] no file'],
+      [["POST / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[POST] no file'],
+      [["HEAD / HTTP/1.1",""], '/NOFILE/', '[HEAD] no file'],
+      [["PUT / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[PUT] no file'],
+      [["DELETE / HTTP/1.1",""], '/NOFILE/', '[DELETE] no file'],
+      [["PATCH / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[PATCH] no file'],
+  );
+  foreach my $message_test (@message_tests) {
+    my ($message, $expected, $description) = @$message_test;
+    like(fetch(@$message), $expected, $description);
+    select(undef,undef,undef,0.2); # wait a sec
+  }
+
+  foreach my $method (keys(%methods)) {
+    next unless defined $methods{$method};
+    like(
+          fetch("GET /cgitest/$method HTTP/1.1",""),
+          "/$methods{$method}/",
+          "method - $method"
+        );
+    select(undef,undef,undef,0.2); # wait a sec
+  }
+
+  foreach my $envvar (keys(%envvars)) {
+    like(
+          fetch("GET /cgitest/$envvar HTTP/1.1",""),
+          "/$envvars{$envvar}/",
+          "Environment - $envvar"
+        );
+    select(undef,undef,undef,0.2); # wait a sec
+  }
+
+# extra tests for HTTP/1.1 absolute URLs
+
+  foreach my $verb ('GET', 'HEAD') {
+    foreach my $method (keys(%methods)) {
+      next unless defined $methods{$method};
+
+      my $method_value = $methods{$method};
+      $method_value =~ s/\bGET\b/$verb/;
+
+      like(
+            fetch("$verb http://localhost/cgitest/$method HTTP/1.1",""),
+            "/$method_value/",
+            "method (absolute URL) - $method"
+          );
+      select(undef,undef,undef,0.2); # wait a sec
+    }
+
+    foreach my $envvar (keys(%envvars)) {
+      (my $envvar_value = $envvars{$envvar});
+      $envvar_value =~ s/\bGET\b/$verb/;
+
+      like(
+            fetch("$verb http://localhost/cgitest/$envvar HTTP/1.1",""),
+            "/$envvar_value/",
+            "Environment (absolute URL) - $envvar"
+          );
+      select(undef,undef,undef,0.2); # wait a sec
+    }
+  }
+
+  like(
+       fetch("GET /cgitest/REQUEST_URI?foo%3Fbar HTTP/1.0",""),
+       qr/foo%3Fbar/,
+       "Didn't decode already"
+      );
+
+  like(
+       fetch("GET /cgitest/foo%2Fbar/PATH_INFO HTTP/1.0",""),
+       qr|foo/bar|,
+       "Did decode already"
+      );
+
+  like(
+      fetch("GET /cgitest/raw_cookie HTTP/1.0","Cookie: foo=bar",""),
+      qr|foo=bar|,
+      "uses HTTP_COOKIE",
+  );
+
+  is(kill(9,$pid),1,'Signaled 1 process successfully');
+  wait or die "counldn't wait for sub-process completion";
+}
+
+
+sub fetch {
+    my $hostname = "localhost";
+    my $port = $PORT;
+    my $message = join "", map { "$_\015\012" } @_;
+    my $timeout = 5;    
+    my $response;        
+    
+    eval {
+        local $SIG{ALRM} = sub { die "early exit - SIGALRM caught" };
+        alarm $timeout*2; #twice longer than timeout used later by select()  
+ 
+        my $iaddr = inet_aton($hostname) || die "inet_aton: $!";
+        my $paddr = sockaddr_in($port, $iaddr) || die "sockaddr_in: $!";
+        my $proto = getprotobyname('tcp') || die "getprotobyname: $!";
+        socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+        connect(SOCK, $paddr) || die "connect: $!";
+        (send SOCK, $message, 0) || die "send: $!";
+        
+        my $rvec = '';
+        vec($rvec, fileno(SOCK), 1) = 1;
+        die "vec(): $!" unless $rvec; 
+
+        $response = '';
+        for (;;) {        
+            my $r = select($rvec, undef, undef, $timeout);
+            die "select: timeout - no data to read from server" unless ($r > 0);
+            my $l = sysread(SOCK, $response, 1024, length($response));
+            die "sysread: $!" unless defined($l);
+            last if ($l == 0);
+        }
+        $response =~ s/\015\012/\n/g; 
+        (close SOCK) || die "close(): $!";
+        alarm 0;
+    }; 
+    if ($@) {
+      	return "[ERROR] $@";
+    }
+    else {
+        return $response;
+    }    
+}
+
+{
+  package CGIServer;
+  use base qw(HTTP::Server::Simple::CGI);
+
+  sub handle_request {
+    my $self=shift;
+    my $cgi=shift;
+
+
+    my $file=(split('/',$cgi->path_info))[-1]||'NOFILE';
+    $file=~s/\s+//g;
+    $file||='NOFILE';
+    print "HTTP/1.0 200 OK\r\n";    # probably OK by now
+    print "Content-Type: text/html\r\nContent-Length: ";
+    my $response;
+    if(exists $methods{$file}) {
+      $response = "$file: ".$cgi->$file();
+    } elsif($envvars{$file}) {
+      $response="$file: $ENV{$file}";
+    } else {
+      $response=$file;
+    }
+    print length($response), "\r\n\r\n", $response;
+  }
+}
+
+