1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
#!/usr/bin/perl -w
use strict;
use Net::HTTPServer;
my $server = new Net::HTTPServer();
$server->RegisterURL("/test/env",\&test_env);
$server->RegisterURL("/test/auth",\&test_auth);
$server->RegisterAuth("basic","/test/auth","Test Auth",\&auth);
if ( $server->Start() )
{
$server->Process();
}
else
{
print "Could not start the server.\n";
}
sub test_env
{
my $req = shift; # Net::HTTPServer::Request object
my $res = $req->Response(); # Net::HTTPServer::Response object
$res->Print("<html>\n");
$res->Print(" <head>\n");
$res->Print(" <title>This is a test</title>\n");
$res->Print(" </head>\n");
$res->Print(" <body>\n");
$res->Print(" <pre>\n");
foreach my $var (keys(%{$req->Env()}))
{
$res->Print("$var -> ".$req->Env($var)."\n");
}
$res->Print(" </pre>\n");
$res->Print(" </body>\n");
$res->Print("</html>\n");
return $res;
}
sub auth
{
my $url = shift;
my $user = shift;
if ($user eq "test")
{
return ("200","pass");
}
return ("401");
}
sub test_auth
{
my $req = shift; # Net::HTTPServer::Request object
my $res = $req->Response(); # Net::HTTPServer::Response object
$res->Print("<html>\n");
$res->Print(" <head>\n");
$res->Print(" <title>This is a test</title>\n");
$res->Print(" </head>\n");
$res->Print(" <body>\n");
$res->Print(" This page required authentication.\n");
$res->Print(" </body>\n");
$res->Print("</html>\n");
return $res;
}
|
