git.maemo.org Git - pkg-perl/blob - deb-src/libwww-mechanize-perl/libwww-mechanize-perl-1.34/t/local/log-server

   1 # vi: ft=perl
   2 # Thanks to merlyn for nudging me and giving me this snippet!
   3 use strict;
   4 use HTTP::Daemon;
   5 use CGI;
   6
   7 $|++;
   8
   9 my $d = HTTP::Daemon->new or die;
  10 print $d->url, "\n";
  11
  12 my ($filename,$logfile) = @ARGV[0,1];
  13 if ($filename) {
  14   open DATA, "< $filename"
  15     or die "Couldn't read page '$filename' : $!\n";
  16 };
  17 open LOG, ">", $logfile
  18   or die "Couldn't create logfile '$logfile' : $!\n";
  19 my $body = join "", <DATA>;
  20
  21 sub debug($) {
  22   my $message = $_[0];
  23   $message =~ s!\n!\n#SERVER:!g;
  24   warn "#SERVER: $message"
  25     if $ENV{TEST_HTTP_VERBOSE};
  26 };
  27
  28 SERVERLOOP: {
  29   my $quitserver;
  30   while (my $c = $d->accept) {
  31     debug "New connection";
  32     while (my $r = $c->get_request) {
  33       print LOG "Request:\n" . $r->as_string . "\n";
  34       debug "Request:\n" . $r->as_string;
  35       my $location = ($r->uri->path || "/");
  36       my ($link1,$link2) = ('','');
  37       if ($location =~ m!^/link/([^/]+)/(.*)$!) {
  38         ($link1,$link2) = ($1,$2);
  39       };
  40       my $res;
  41       if ($location =~ m!^/redirect/(.*)$!) {
  42         $res = HTTP::Response->new(302);
  43                                 $res->header('location', $d->url . $1);
  44       } else {
  45         my $q = CGI->new($r->uri->query);
  46
  47         # Make sticky form fields
  48         my ($query,$session,%cat);
  49         $query = defined $q->param('query') ? $q->param('query') : "(empty)";
  50         $session = defined $q->param('session') ? $q->param('session') : 1;
  51         %cat = map { $_ => 1 } (defined $q->param('cat') ? $q->param('cat') : qw( cat_foo cat_bar ));
  52         my @categories = map { $cat{$_} ? "checked" : "" } qw( cat_foo cat_bar cat_baz );
  53         $res = HTTP::Response->new(200, "OK", undef, sprintf($body,$location,$session,$query,@categories));
  54         $res->content_type('text/html; charset=utf8');
  55         debug "Request " . ($r->uri->path || "/");
  56         if ( $location eq '/quit_server') {
  57           debug "Quitting";
  58           $c->force_last_request;
  59           $quitserver = 1;
  60           close LOG;
  61         };
  62       };
  63       debug "Response:\n" . $res->as_string;
  64       $c->send_response($res);
  65       last if $quitserver;
  66     }
  67     $c->close;
  68     undef($c);
  69     last SERVERLOOP
  70       if $quitserver;
  71   }
  72 };
  73 END { debug "Server stopped" };
  74
  75 __DATA__
  76 <html>
  77 <head>
  78 <title>WWW::Mechanize::Shell test page</title>
  79 </head>
  80 <body>
  81 <h1>Location: %s</h1>
  82 <p>
  83   <a href="/test">Link /test</a>
  84   <a href="/foo">Link /foo</a>
  85   <a href="/slash_end">Link /</a>
  86   <a href="/slash_front">/Link </a>
  87   <a href="/slash_both">/Link in slashes/</a>
  88   <a href="/foo1.save_log_server_test.tmp">Link foo1.save_log_server_test.tmp</a>
  89   <a href="/foo2.save_log_server_test.tmp">Link foo2.save_log_server_test.tmp</a>
  90   <a href="/foo3.save_log_server_test.tmp">Link foo3.save_log_server_test.tmp</a>
  91   <a href="/o-umlaut">Löschen -- testing for o-umlaut.</a>
  92   <a href="/o-umlaut-encoded">St&ouml;sberg -- testing for encoded o-umlaut.</a>
  93
  94   <table>
  95     <tr><th>Col1</th><th>Col2</th><th>Col3</th></tr>
  96     <tr><td>A1</td><td>A2</td><td>A3</td></tr>
  97     <tr><td>B1</td><td>B2</td><td>B3</td></tr>
  98     <tr><td>C1</td><td>C2</td><td>C3</td></tr>
  99   </table>
 100   <form name="f" action="/formsubmit">
 101     <input type="hidden" name="session" value="%s"/>
 102     <input type="text" name="query" value="%s"/>
 103     <input type="submit" name="submit" value="Go"/>
 104     <input type="checkbox" name="cat" value="cat_foo" %s />
 105     <input type="checkbox" name="cat" value="cat_bar" %s />
 106     <input type="checkbox" name="cat" value="cat_baz" %s />
 107     <input type="file" name="upload" value="README" />
 108   </form>
 109 </p>
 110 </body>
 111 </html>