0: #!/usr/bin/perl -wT
1: use strict;
2: use IO::File;
3: use Cwd;
4: use HTTP::Daemon;
5: use HTTP::Status;
6:
7: $| = 1;
8:
9: # We are quite explicit about where we listen
10: my $d = new HTTP::Daemon
11: Reuse => 1,
12: LocalAddr => '192.168.1.100',
13: LocalPort => 8889;
14:
15: my $nofork = $^O =~ /Win32/i; # For easy testing under Win32
16:
17: $SIG{__WARN__} = sub { warn __stamp(shift) };
18: $SIG{__DIE__} = sub { die __stamp(shift) };
19: $SIG{CHLD} = 'IGNORE';
20:
21: warn "Please contact me at: <URL:" . $d->url . ">\n";
22:
23: $ENV{PATH} = '/bin:/usr/bin'; # Set our path to something secure
24: my $root = $ARGV[0] || cwd;
25: $root = $1 if $root =~ /^(.*)$/; # untaint document root
26: $root .= "/" unless $root =~ m!/$!;
27:
28: # This sub Copyright (c) 1996,97,98,99,2000,01 by Randal L. Schwartz
29: sub __stamp {
30: my ($message) = @_;
31: my $stamp = sprintf "[$$] [%02d@%02d:%02d:%02d] ", (localtime)[3,2,1,0];
32: $message =~ s/^/$stamp/gm;
33: $message;
34: }
35:
36: sub handleConnection {
37: local $SIG{PIPE} = 'IGNORE';
38: my ($connection) = @_;
39: while (my $r = $connection->get_request()) {
40: warn $r->as_string; # Yes, that's verbose.
41:
42: my $url = $r->url->path;
43: $url = "/$url" unless $url =~ m!^/!; # Remove all suspicious paths
44: $url =~ s!/.?.(?=/|$)!/!g;
45: $url =~ tr!\x00-\x1F!!d;
46:
47: my $response = new HTTP::Response( 404,undef,undef,"404 - Not found." );
48: if (-d "$root$url") {
49: $url = "$url/" unless $url =~ m!/$!;
50: opendir DIR, "$root$url";
51: $response->code(200);
52: $response->content(
53: "<html><head><title>$url</title></head><body><h1>$url</h1><tt>"
54: . join( "<br>",
55: map { my ($cmt,$link) = ((-s "$root$url$_")." bytes",$_);
56: -d _ and $cmt = "directory";
57: $link =~ s/([ '"?%&:])/{'%'.unpack("H2",$1)}/eg;
58: "<A href='$url$link'>$_</A> $cmt"
59: } sort grep { /^[^.]/ } readdir DIR )
60: . "</tt></body></html>" );
61: closedir DIR;
62: } else {
63: my $file = new IO::File "< $root$url";
64: if (defined $file) {
65: $response->code( 200 );
66: binmode $file;
67: my $size = -s $file;
68:
69: my ($startrange, $endrange) = (0,$size-1);
70: if (defined $r->header("Range")
71: and $r->header("Range") =~ /bytes\s*=\s*(\d+)-(\d+)?/) {
72: $response->code( 206 );
73: ($startrange,$endrange) = ($1,$2 || $endrange);
74: };
75: $file->seek($startrange,0);
76:
77: $response->header(Content_Length => $endrange-$startrange);
78: $response->header(Content_Range => "bytes $startrange-$endrange/$size");
79: $response->content( sub {
80: sysread($file, my ($buf), 16*1024); # No error checking ???
81: return $buf;
82: });
83: };
84: };
85: warn "Response :",$response->code;
86: $connection->send_response($response);
87: };
88: warn "Handled connection (closed, " . $connection->reason . ")";
89: $connection->close;
90: };
91:
92: while (my $connection = $d->accept) {
93: # Really condensed fork/nofork handler code
94: next unless $nofork || ! fork();
95: warn "Forked child" unless $nofork;
96: handleConnection( $connection );
97: die "Child quit." unless $nofork;
98: }
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.
|