Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
    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: }
    

In reply to Simple HTTP in under 100 lines by Corion

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • 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.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others having an uproarious good time at the Monastery: (6)
As of 2024-03-28 14:52 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found