"Fossies" - the Fresh Open Source Software Archive

Member "libwww-perl-6.43/t/local/http.t" (26 Nov 2019, 24167 Bytes) of package /linux/www/libwww-perl-6.43.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "http.t": 6.42_vs_6.43.

    1 use strict;
    2 use warnings;
    3 use Test::More;
    4 use Test::Fatal;
    5 
    6 use Config;
    7 use FindBin qw($Bin);
    8 use HTTP::Daemon;
    9 use HTTP::Request;
   10 use IO::Socket;
   11 use LWP::UserAgent;
   12 use URI;
   13 use utf8;
   14 
   15 delete $ENV{PERL_LWP_ENV_PROXY};
   16 $| = 1; # autoflush
   17 
   18 my $DAEMON;
   19 
   20 # allow developer to manually run the daemon and the tests
   21 # separately.  Particularly useful for running with the perl
   22 # debugger.
   23 #
   24 # Run the server like this,
   25 #
   26 # PERL_LWP_ENV_HTTP_TEST_SERVER_TIMEOUT=10000 perl -I lib t/local/http.t daemon
   27 #
   28 # Then the tests like this,
   29 #
   30 # PERL_LWP_ENV_HTTP_TEST_URL=http://127.0.0.1:56957/ perl -I lib t/local/http.t
   31 my $base;
   32 if($ENV{PERL_LWP_ENV_HTTP_TEST_URL})
   33 {
   34     $base = URI->new($ENV{PERL_LWP_ENV_HTTP_TEST_URL});
   35     $DAEMON = 1;
   36 }
   37 my $CAN_TEST = (0==system($^X, "$Bin/../../talk-to-ourself"))? 1: 0;
   38 
   39 my $D = shift(@ARGV) || '';
   40 if ($D eq 'daemon') {
   41     daemonize();
   42 }
   43 else {
   44     # start the daemon and the testing
   45     if ( $^O ne 'MacOS' and $CAN_TEST and !$base ) {
   46         my $perl = $Config{'perlpath'};
   47         $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
   48         open($DAEMON, "$perl $0 daemon |") or die "Can't exec daemon: $!";
   49         my $greeting = <$DAEMON> || '';
   50         if ( $greeting =~ /(<[^>]+>)/ ) {
   51             $base = URI->new($1);
   52         }
   53     }
   54     _test();
   55 }
   56 exit(0);
   57 
   58 sub _test {
   59     # First we make ourself a daemon in another process
   60     # listen to our daemon
   61     return plan skip_all => "Can't test on this platform" if $^O eq 'MacOS';
   62     return plan skip_all => 'We cannot talk to ourselves' unless $CAN_TEST;
   63     return plan skip_all => 'We could not talk to our daemon' unless $DAEMON;
   64     return plan skip_all => 'No base URI' unless $base;
   65 
   66     plan tests => 109;
   67 
   68     my $ua = LWP::UserAgent->new;
   69     $ua->agent("Mozilla/0.01 " . $ua->agent);
   70     $ua->from('gisle@aas.no');
   71 
   72     { # bad request
   73         my $req = HTTP::Request->new(GET => url("/not_found", $base));
   74         $req->header(X_Foo => "Bar");
   75         my $res = $ua->request($req);
   76         isa_ok($res, 'HTTP::Response', 'bad: got a response');
   77 
   78         ok($res->is_error, 'bad: is_error');
   79         is($res->code, 404, 'bad: code 404');
   80         like($res->message, qr/not\s+found/i, 'bad: 404 message');
   81         # we also expect a few headers
   82         ok($res->server, 'bad: got server header');
   83         ok($res->date, 'bad: got date header');
   84     }
   85     { # simple echo
   86         my $req = HTTP::Request->new(GET => url("/echo/path_info?query", $base));
   87         $req->push_header(Accept => 'text/html');
   88         $req->push_header(Accept => 'text/plain; q=0.9');
   89         $req->push_header(Accept => 'image/*');
   90         $req->push_header(':foo_bar' => 1);
   91         $req->if_modified_since(time - 300);
   92         $req->header(Long_text => "This is a very long header line
   93             which is broken between
   94             more than one line."
   95         );
   96         $req->header(X_Foo => "Bar");
   97 
   98         my $res = $ua->request($req);
   99         isa_ok($res, 'HTTP::Response', 'simple echo: got a response');
  100 
  101         ok($res->is_success, 'simple echo: is_success');
  102         is($res->code, 200, 'simple echo: code 200');
  103         is($res->message, "OK", 'simple echo: message OK');
  104 
  105         my $content = $res->content;
  106         my @accept = ($content =~ /^Accept:\s*(.*)/mg);
  107 
  108         like($content, qr/^From:\s*gisle\@aas\.no\n/m, 'simple echo: From good');
  109         like($content, qr/^Host:/m, 'simple echo: Host good');
  110         is(@accept, 3, 'simple echo: 3 Accepts');
  111         like($content, qr/^Accept:\s*text\/html/m, 'simple echo: Accept text/html good');
  112         like($content, qr/^Accept:\s*text\/plain/m, 'simple echo: Accept text/plain good');
  113         like($content, qr/^Accept:\s*image\/\*/m, 'simple echo: Accept image good');
  114         like($content, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m, 'simple echo: modified good');
  115         like($content, qr/^Long-Text:\s*This.*broken between/m, 'simple echo: long-text good');
  116         like($content, qr/^Foo-Bar:\s*1\n/m, 'simple echo: Foo-Bar good');
  117         like($content, qr/^X-Foo:\s*Bar\n/m, 'simple echo: X-Foo good');
  118         like($content, qr/^User-Agent:\s*Mozilla\/0.01/m, 'simple echo: UserAgent good');
  119     }
  120     { # echo with higher level 'get' interface
  121         my $res = $ua->get(url("/echo/path_info?query", $base),
  122             Accept => 'text/html',
  123             Accept => 'text/plain; q=0.9',
  124             Accept => 'image/*',
  125             X_Foo => "Bar",
  126         );
  127         isa_ok($res, 'HTTP::Response', 'simple echo 2: good response object');
  128         is($res->code, 200, 'simple echo 2: code 200');
  129     }
  130     { # patch
  131         my $res = $ua->patch(url("/echo/path_info?query", $base),
  132             Accept => 'text/html',
  133             Accept => 'text/plain; q=0.9',
  134             Accept => 'image/*',
  135             X_Foo => "Bar",
  136         );
  137         isa_ok($res, 'HTTP::Response', 'patch: good response object');
  138         is($res->code, 200, 'put: code 200');
  139         like($res->content, qr/^From: gisle\@aas.no$/m, 'patch: good From');
  140     }
  141     { # put
  142         my $res = $ua->put(url("/echo/path_info?query", $base),
  143             Accept => 'text/html',
  144             Accept => 'text/plain; q=0.9',
  145             Accept => 'image/*',
  146             X_Foo => "Bar",
  147         );
  148         isa_ok($res, 'HTTP::Response', 'put: good response object');
  149         is($res->code, 200, 'put: code 200');
  150         like($res->content, qr/^From: gisle\@aas.no$/m, 'put: good From');
  151     }
  152     { # delete
  153         my $res = $ua->delete(url("/echo/path_info?query", $base),
  154             Accept => 'text/html',
  155             Accept => 'text/plain; q=0.9',
  156             Accept => 'image/*',
  157             X_Foo => "Bar",
  158         );
  159         isa_ok($res, 'HTTP::Response', 'delete: good response object');
  160         is($res->code, 200, 'delete: code 200');
  161         like($res->content, qr/^From: gisle\@aas.no$/m, 'delete: good From');
  162     }
  163     { # send file
  164         my $file = "test-$$.html";
  165         open(my $fh, '>', $file) or die "Can't create $file: $!";
  166         binmode $fh or die "Can't binmode $file: $!";
  167         print {$fh} qq(<html><title>En prøve</title>\n<h1>Dette er en testfil</h1>\nJeg vet ikke hvor stor fila behøver å være heller, men dette\ner sikkert nok i massevis.\n);
  168         close($fh);
  169 
  170         my $req = HTTP::Request->new(GET => url("/file?name=$file", $base));
  171         my $res = $ua->request($req);
  172         isa_ok($res, 'HTTP::Response', 'get file: good response object');
  173 
  174         ok($res->is_success, 'get file: is_success');
  175         is($res->content_type, 'text/html', 'get file: content type text/html');
  176         is($res->content_length, 147, 'get file: 147 content length');
  177         is($res->title, 'En prøve', 'get file: good title');
  178         like($res->content, qr/å være/, 'get file: good content');
  179 
  180         # A second try on the same file, should fail because we unlink it
  181         $res = $ua->request($req);
  182         isa_ok($res, 'HTTP::Response', 'get file 2nd: good response object');
  183 
  184         ok($res->is_error, 'get file 2nd: is_error');
  185         is($res->code, 404, 'get file 2nd: code 404');   # not found
  186     }
  187     { # try to list current directory
  188         my $req = HTTP::Request->new(GET => url("/file?name=.", $base));
  189         my $res = $ua->request($req);
  190         isa_ok($res, 'HTTP::Response', 'dir list .: good response object');
  191 
  192         # NYI
  193         is($res->code, 501, 'dir list .: code 501');
  194     }
  195     { # redirect
  196         my $req = HTTP::Request->new(GET => url("/redirect/foo", $base));
  197         my $res = $ua->request($req);
  198         isa_ok($res, 'HTTP::Response', 'redirect: good response object');
  199 
  200         ok($res->is_success, 'redirect: is_success');
  201         like($res->content, qr|/echo/redirect|, 'redirect: content good');
  202         ok($res->previous->is_redirect, 'redirect: is_redirect');
  203         is($res->previous->code, 301, 'redirect: code 301');
  204 
  205         # Let's test a redirect loop too
  206         $req->uri(url("/redirect2", $base));
  207         $ua->max_redirect(5);
  208         is($ua->max_redirect(), 5, 'redirect loop: max redirect 5');
  209         $res = $ua->request($req);
  210         isa_ok($res, 'HTTP::Response', 'redirect loop: good response object');
  211 
  212         ok($res->is_redirect, 'redirect loop: is_redirect');
  213         like($res->header("Client-Warning"), qr/loop detected/i, 'redirect loop: client warning');
  214         is($res->redirects, 5, 'redirect loop: 5 redirects');
  215 
  216         $ua->max_redirect(0);
  217         is($ua->max_redirect(), 0, 'redirect loop: max redirect 0');
  218         $res = $ua->request($req);
  219         isa_ok($res, 'HTTP::Response', 'redirect loop: good response object');
  220         is($res->previous, undef, 'redirect loop: undefined previous');
  221         is($res->redirects, 0, 'redirect loop: zero redirects');
  222         $ua->max_redirect(5);
  223         is($ua->max_redirect(), 5, 'redirect loop: max redirects set back to 5');
  224     }
  225     { # basic auth
  226         my $req = HTTP::Request->new(GET => url("/basic", $base));
  227         my $res = MyUA->new->request($req);
  228         isa_ok($res, 'HTTP::Response', 'basicAuth: good response object');
  229 
  230         ok($res->is_success, 'basicAuth: is_success');
  231 
  232         # Let's try with a $ua that does not pass out credentials
  233         $res = $ua->request($req);
  234         isa_ok($res, 'HTTP::Response', 'basicAuth: good response object');
  235         is($res->code, 401, 'basicAuth: code 401');
  236 
  237         # Let's try to set credentials for this realm
  238         $ua->credentials($req->uri->host_port, "libwww-perl", "ok 12", "xyzzy");
  239         $res = $ua->request($req);
  240         isa_ok($res, 'HTTP::Response', 'basicAuth: good response object');
  241         ok($res->is_success, 'basicAuth: is_success');
  242 
  243         # Then illegal credentials
  244         $ua->credentials($req->uri->host_port, "libwww-perl", "user", "passwd");
  245         $res = $ua->request($req);
  246         isa_ok($res, 'HTTP::Response', 'basicAuth: good response object');
  247         is($res->code, 401, 'basicAuth: code 401');
  248     }
  249     { # digest
  250         my $req = HTTP::Request->new(GET => url("/digest", $base));
  251         my $res = MyUA2->new->request($req);
  252         isa_ok($res, 'HTTP::Response', 'digestAuth: good response object');
  253 
  254         ok($res->is_success, 'digestAuth: is_success');
  255 
  256         # Let's try with a $ua that does not pass out credentials
  257         $ua->{basic_authentication}=undef;
  258         $res = $ua->request($req);
  259         isa_ok($res, 'HTTP::Response', 'digestAuth: good response object');
  260         is($res->code, 401, 'digestAuth: code 401');
  261 
  262         # Let's try to set credentials for this realm
  263         $ua->credentials($req->uri->host_port, "libwww-perl-digest", "ok 23", "xyzzy");
  264         $res = $ua->request($req);
  265         isa_ok($res, 'HTTP::Response', 'digestAuth: good response object');
  266         ok($res->is_success, 'digestAuth: is_success');
  267 
  268         # Now check expired nonce
  269         # - get the right request_prepare handler
  270         my ($digest)
  271             = grep { $$_{realm} eq "libwww-perl-digest" }
  272             @{$$ua{handlers}{request_prepare}};
  273 
  274         # - and force the next request to send the wrongnonce first
  275         $$digest{auth_param}{nonce} = "my_stale_nonce";
  276 
  277         # - set up the nonce count for the stale nonce and lose it for the real nonce (to make it match later (server expects 1))
  278         $$ua{authen_md5_nonce_count} = {my_stale_nonce => 3};
  279 
  280         # - perform the request with the stale nonce
  281         $ua->credentials($req->uri->host_port, "libwww-perl-digest", "ok 23",
  282             "xyzzy");
  283         $res = $ua->request($req);
  284         isa_ok($res, 'HTTP::Response', 'digestAuth: good response object');
  285         ok($res->is_success, 'digestAuth: is_success');
  286 
  287         is($$ua{authen_md5_nonce_count}{12345},
  288             1, 'The nonce count is recorded for the new nonce');
  289         ok(
  290             !defined $$ua{authen_md5_nonce_count}{my_stale_nonce},
  291             'The nonce count is deleted for the stale nonce'
  292         );
  293         is(@{$$digest{m_path_prefix}}, 1,
  294             'The path prefix list is not clobbered with extra copies of the path'
  295         );
  296 
  297         # - perform the request with a wrong nonce
  298         $$digest{auth_param}{nonce} = "my_wrong_nonce";
  299 
  300         # - lose the nonce count, to make it match later (server expects 1)
  301         $$ua{authen_md5_nonce_count} = {};
  302 
  303         # - perform the request with the wrong nonce
  304         $ua->credentials($req->uri->host_port, "libwww-perl-digest", "ok 23",
  305             "xyzzy");
  306         $res = $ua->request($req);
  307         isa_ok($res, 'HTTP::Response', 'digestAuth: good response object');
  308         is($res->code, 401, 'No retry if the nonce is not marked stale');
  309 
  310         # Then illegal credentials
  311         $ua->credentials($req->uri->host_port, "libwww-perl-digest", "user2", "passwd");
  312         $res = $ua->request($req);
  313         isa_ok($res, 'HTTP::Response', 'digestAuth: good response object');
  314         is($res->code, 401, 'digestAuth: code 401');
  315     }
  316     { # basic and digest both allowed
  317         my $req = HTTP::Request->new(GET => url("/multi_auth", $base));
  318         my $res = MyUA3->new->request($req);
  319         isa_ok($res, 'HTTP::Response', 'multiAuth: good response object');
  320         ok($res->is_success, 'multiAuth: is_success with digestAuth');
  321         is($res->header('X-Basic-Called'), 1, 'multiAuth: basicAuth was tried first');
  322     }
  323     { # proxy
  324         $ua->proxy(ftp => $base);
  325         my $req = HTTP::Request->new(GET => "ftp://ftp.perl.com/proxy");
  326         my $res = $ua->request($req);
  327         isa_ok($res, 'HTTP::Response', 'proxy: good response object');
  328         ok($res->is_success, 'proxy: is_success');
  329     }
  330     { # post
  331         my $req = HTTP::Request->new(POST => url("/echo/foo", $base));
  332         $req->content_type("application/x-www-form-urlencoded");
  333         $req->content("foo=bar&bar=test");
  334         my $res = $ua->request($req);
  335         isa_ok($res, 'HTTP::Response', 'post: good response object');
  336 
  337         my $content = $res->content;
  338         ok($res->is_success, 'post: is_success');
  339         like($content, qr/^Content-Length:\s*16$/mi, 'post: content length good');
  340         like($content, qr/^Content-Type:\s*application\/x-www-form-urlencoded$/mi, 'post: application/x-www-form-urlencoded');
  341         like($content, qr/^foo=bar&bar=test$/m, 'post: foo=bar&bar=test');
  342 
  343         $req = HTTP::Request->new(POST => url("/echo/foo", $base));
  344         $req->content_type("multipart/form-data");
  345         $req->add_part(HTTP::Message->new(["Content-Type" => "text/plain"], "Hi\n"));
  346         $req->add_part(HTTP::Message->new(["Content-Type" => "text/plain"], "there\n"));
  347         $res = $ua->request($req);
  348         isa_ok($res, 'HTTP::Response', 'post: good response object');
  349         ok($res->is_success, 'post: is_success');
  350         ok($res->content =~ /^Content-Type: multipart\/form-data; boundary=/m, 'post: multipart good');
  351     }
  352     { # mirror
  353         ok(exception { $ua->mirror(url("/echo/foo", $base)) }, 'mirror: filename required');
  354         ok(exception { $ua->mirror(url("/echo/foo", $base), q{}) }, 'mirror: non empty filename required');
  355         my $copy = "lwp-base-test-$$"; # downloaded copy
  356         my $res = $ua->mirror(url("/echo/foo", $base), $copy);
  357         isa_ok($res, 'HTTP::Response', 'mirror: good response object');
  358         ok($res->is_success, 'mirror: is_success');
  359 
  360         ok(-s $copy, 'mirror: file exists and is not empty');
  361         unlink($copy);
  362 
  363         $ua->mirror(url("/echo/foo", $base),q{0});
  364         ok(1, 'can write to a file called 0');
  365         unlink('0');
  366     }
  367     { # partial
  368         my $req = HTTP::Request->new(  GET => url("/partial", $base) );
  369         my $res = $ua->request($req);
  370         isa_ok($res, 'HTTP::Response', 'partial: good response object');
  371         ok($res->is_success, 'partial: is_success'); # "a 206 response is considered successful"
  372 
  373         $ua->max_size(3);
  374         $req = HTTP::Request->new(  GET => url("/partial", $base) );
  375         $res = $ua->request($req);
  376         isa_ok($res, 'HTTP::Response', 'partial: good response object');
  377         ok($res->is_success, 'partial: is_success'); # "a 206 response is considered successful"
  378         # Put max_size back how we found it.
  379         $ua->max_size(undef);
  380         like($res->as_string, qr/Client-Aborted: max_size/, 'partial: aborted'); # Client-Aborted is returned when max_size is given
  381     }
  382     { # terminate server
  383         my $req = HTTP::Request->new(GET => url("/quit", $base));
  384         my $res = $ua->request($req);
  385         isa_ok($res, 'HTTP::Response', 'terminate: good response object');
  386 
  387         is($res->code, 503, 'terminate: code is 503');
  388         like($res->content, qr/Bye, bye/, 'terminate: bye bye');
  389     }
  390     {
  391         my $ua = LWP::UserAgent->new(
  392             send_te => 0,
  393         );
  394         my $res = $ua->request( HTTP::Request->new( GET => url("/echo", $base) ) );
  395         ok( $res->decoded_content !~ /^TE:/m, "TE header not added" );
  396     }
  397 }
  398 
  399 {
  400     package MyUA;
  401     use base 'LWP::UserAgent';
  402     sub get_basic_credentials {
  403         my($self, $realm, $uri, $proxy) = @_;
  404         if ($realm eq "libwww-perl" && $uri->rel($base) eq "basic") {
  405             return ("ok 12", "xyzzy");
  406         }
  407         return undef;
  408     }
  409 }
  410 {
  411     package MyUA2;
  412     use base 'LWP::UserAgent';
  413     sub get_basic_credentials {
  414         my($self, $realm, $uri, $proxy) = @_;
  415         if ($realm eq "libwww-perl-digest" && $uri->rel($base) eq "digest") {
  416             return ("ok 23", "xyzzy");
  417         }
  418         return undef;
  419     }
  420 }
  421 {
  422     package MyUA3;
  423     use base 'LWP::UserAgent';
  424     sub get_basic_credentials {
  425         my($self, $realm, $uri, $proxy) = @_;
  426         return ("irrelevant", "xyzzy");
  427     }
  428 }
  429 sub daemonize {
  430     my %router;
  431     $router{delete_echo} = sub {
  432         my($c, $req) = @_;
  433         $c->send_basic_header(200);
  434         $c->print("Content-Type: message/http\015\012");
  435         $c->send_crlf;
  436         $c->print($req->as_string);
  437     };
  438     $router{get_basic} = sub {
  439         my($c, $r) = @_;
  440         my($u,$p) = $r->authorization_basic;
  441         if (defined($u) && $u eq 'ok 12' && $p eq 'xyzzy') {
  442             $c->send_basic_header(200);
  443             $c->print("Content-Type: text/plain");
  444             $c->send_crlf;
  445             $c->send_crlf;
  446             $c->print("$u\n");
  447         }
  448         else {
  449             $c->send_basic_header(401);
  450             $c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012");
  451             $c->send_crlf;
  452         }
  453     };
  454     $router{get_digest} = sub {
  455         my($c, $r) = @_;
  456         my $auth = $r->authorization;
  457         my %auth_params;
  458         if ( defined($auth) && $auth =~ /^Digest\s+(.*)$/ ) {
  459             %auth_params = map { split /=/ } split /,\s*/, $1;
  460         }
  461         if ( %auth_params &&
  462                 $auth_params{username} eq q{"ok 23"} &&
  463                 $auth_params{realm} eq q{"libwww-perl-digest"} &&
  464                 $auth_params{qop} eq "auth" &&
  465                 $auth_params{algorithm} eq q{"MD5"} &&
  466                 $auth_params{uri} eq q{"/digest"} &&
  467                 $auth_params{nonce} eq q{"12345"} &&
  468                 $auth_params{nc} eq "00000001" &&
  469                 defined($auth_params{cnonce}) &&
  470                 defined($auth_params{response})
  471              ) {
  472             $c->send_basic_header(200);
  473             $c->print("Content-Type: text/plain");
  474             $c->send_crlf;
  475             $c->send_crlf;
  476             $c->print("ok\n");
  477         }
  478         else {
  479             $c->send_basic_header(401);
  480             $c->print(
  481                 "WWW-Authenticate: Digest realm=\"libwww-perl-digest\", nonce=\"12345\"",
  482                 defined($auth_params{nonce})
  483                     && $auth_params{nonce} eq '"my_stale_nonce"'
  484                 ? ', stale=true'
  485                 : '',
  486                 ", qop=auth\015\012"
  487             );
  488             $c->send_crlf;
  489         }
  490     };
  491     my $multi_auth_basic_was_called = 0;
  492     $router{get_multi_auth} = sub {
  493         my($c, $r) = @_;
  494 
  495         my($u,$p) = $r->authorization_basic;
  496         $multi_auth_basic_was_called = 1 if $u && $p;
  497 
  498         my $auth = $r->authorization;
  499         my %auth_params;
  500         if ( defined($auth) && $auth =~ /^Digest\s+(.*)$/ ) {
  501             %auth_params = map { split /=/ } split /,\s*/, $1;
  502         }
  503         if ( %auth_params &&
  504                 $auth_params{username} eq q{"irrelevant"} &&
  505                 $auth_params{realm} eq q{"libwww-perl-digest"}
  506              ) {
  507             # We don't care about the correctness of the headers here.
  508             # The get_digest test already does that. This one is for
  509             # asserting multiple different auth attempts.
  510             $c->send_basic_header(200);
  511             $c->print("X-Basic-Called: $multi_auth_basic_was_called\015\012");
  512             $c->print("Content-Type: text/plain");
  513             $c->send_crlf;
  514             $c->send_crlf;
  515             $c->print("ok\n");
  516         }
  517         else {
  518             $c->send_basic_header(401);
  519             $c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012");
  520             $c->print(
  521                 "WWW-Authenticate: Digest realm=\"libwww-perl-digest\", nonce=\"12345\"",
  522                 ", qop=auth\015\012"
  523             );
  524             $c->send_crlf;
  525         }
  526     };
  527     $router{get_echo} = sub {
  528         my($c, $req) = @_;
  529         $c->send_basic_header(200);
  530         print $c "Content-Type: message/http\015\012";
  531         $c->send_crlf;
  532         print $c $req->as_string;
  533     };
  534     $router{get_file} = sub {
  535         my($c, $r) = @_;
  536         my %form = $r->uri->query_form;
  537         my $file = $form{'name'};
  538         $c->send_file_response($file);
  539         unlink($file) if $file =~ /^test-/;
  540     };
  541     $router{get_partial} = sub {
  542         my($c) = @_;
  543         $c->send_basic_header(206);
  544         print $c "Content-Type: image/jpeg\015\012";
  545         $c->send_crlf;
  546         print $c "some fake JPEG content";
  547     };
  548     $router{get_proxy} = sub {
  549         my($c,$r) = @_;
  550         if ($r->method eq "GET" and $r->uri->scheme eq "ftp") {
  551             $c->send_basic_header(200);
  552             $c->send_crlf;
  553         }
  554         else {
  555             $c->send_error;
  556         }
  557     };
  558     $router{get_quit} = sub {
  559         my($c) = @_;
  560         $c->send_error(503, "Bye, bye");
  561         exit;  # terminate HTTP server
  562     };
  563     $router{get_redirect} = sub {
  564         my($c) = @_;
  565         $c->send_redirect("/echo/redirect");
  566     };
  567     $router{get_redirect2} = sub { shift->send_redirect("/redirect3/") };
  568     $router{get_redirect3} = sub { shift->send_redirect("/redirect2/") };
  569     $router{post_echo} = sub {
  570         my($c,$r) = @_;
  571         $c->send_basic_header;
  572         $c->print("Content-Type: text/plain");
  573         $c->send_crlf;
  574         $c->send_crlf;
  575 
  576         # Do it the hard way to test the send_file
  577         open(my $fh, '>', "tmp$$") || die;
  578         binmode($fh);
  579         print {$fh} $r->as_string;
  580         close($fh) || die;
  581 
  582         $c->send_file("tmp$$");
  583 
  584         unlink("tmp$$");
  585     };
  586     $router{patch_echo} = sub {
  587         my($c, $req) = @_;
  588         $c->send_basic_header(200);
  589         $c->print("Content-Type: message/http\015\012");
  590         $c->send_crlf;
  591         $c->print($req->as_string);
  592     };
  593     $router{put_echo} = sub {
  594         my($c, $req) = @_;
  595         $c->send_basic_header(200);
  596         $c->print("Content-Type: message/http\015\012");
  597         $c->send_crlf;
  598         $c->print($req->as_string);
  599     };
  600 
  601     # Note: tiemout of 0 is not infinite, so no point in special casing
  602     # timeout logic.
  603     my $d = HTTP::Daemon->new(Timeout => $ENV{PERL_LWP_ENV_HTTP_TEST_SERVER_TIMEOUT} || 10, LocalAddr => '127.0.0.1') || die $!;
  604     print "Pleased to meet you at: <URL:", $d->url, ">\n";
  605     open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/dev/null");
  606 
  607     while (my $c = $d->accept) {
  608         while (my $r = $c->get_request) {
  609             my $p = ($r->uri->path_segments)[1];
  610             my $func = lc($r->method . "_$p");
  611             if ( $router{$func} ) {
  612                 $router{$func}->($c, $r);
  613             }
  614             else {
  615                 $c->send_error(404);
  616             }
  617         }
  618         $c->close;
  619         undef($c);
  620     }
  621     print STDERR "HTTP Server terminated\n";
  622     exit;
  623 }
  624 sub url {
  625     my $u = URI->new(@_);
  626     $u = $u->abs($_[1]) if @_ > 1;
  627     $u->as_string;
  628 }