Hi,

Am new to perlmonks.org and to Perl. Currently going through 'Intermediate Perl'. To keep me motivated I started a project - a simple/basic web server. I know that re-inventing the wheel is not a good idea but I figured it could be a good learning process. So please give me suggestions on how to improve my code. It's not complete yet, but I want to know if am in the right direction.

Here is the code.

PS: Am posting a link as am not sure if its allowed to post around 100+ lines of code in a post. 
#!/usr/local/bin/perl -w

#Caution: Big mess ahead
#TODO: 
#    get .. working in dir listing
#    implement Getopt::Long
#    usage() function
#    log to syslog
#    daemonize 
#    persistent connections

use strict;
use IO::Socket;

my (@files, $req, $client);

my $DOCROOT = '/home/arun/site/';
my %error_page = (
    403 => $DOCROOT.'403.html',    # forbidden
    404 => $DOCROOT.'404.html',    # not found
    406 => $DOCROOT.'406.html',    # not acceptable
    501 => $DOCROOT.'501.html'    # not implemented
);

$SIG{'INT'} = \&cleanup;

my $socket = new IO::Socket::INET ( 
    LocalAddr => '172.17.1.50',
    LocalPort => (shift || 4321),
    Proto     => 'tcp',
    Listen    => 5,
    ReuseAddr => 1
) or die "$! \n";

$socket->listen();
&log("Listening on ".$socket->sockhost().":".$socket->sockport."\n");

while ($client = $socket->accept()) {
    &log("Connection from ".$client->peerhost().":".$client->peerport(
+)."\n");

    # get http request - first line
    $req = <$client>;
    &log($client->peerhost()." ".$req);
    &respond_to( &handle_req($req) );

    close $client;
}

sub cleanup { close $socket; die "Interrupted. Exiting...\n"; }

sub log {
    my $msg = shift;
    print scalar localtime," ", $msg;
}
sub getfiles {
    my $dir = shift; 
    opendir DIR, $dir or die "open:$!\n";
    # remove . and .. from list of files
    @files = grep { !/^\.(\.)?$/ } readdir DIR;
    closedir DIR;
    return \@files;
}
sub handle_req {
    my ($method, $uri) = split / +/, shift;

    if ($method !~ /^GET/) {
        &log("501 Not Implemented\nr");
        return 501;    
    }

    $uri =~ s/\/(.*)/$1/;                                # strip the f
+irst slash

    if (-e $DOCROOT.$uri) {
        if (-f $DOCROOT.$uri) {
            &log("200 HTTP OK\n");
            return 200;
        } elsif (-d $DOCROOT.$uri) {
            &log("200 HTTP OK\n");
            return 200;
        } else {
            &log("406 Not Acceptable\n");
            return 406;
        }
    } else {
        &log("404 Not Found\n");
        return 404;
    }
}
sub respond_to {
    my $status_code = shift; 
    unless ($status_code == 200) {
        &display($error_page{$status_code}) if (-f $error_page{$status
+_code});
        return;
    }

    my $uri = (split / +/, $req)[1];
    $uri =~ s/\/(.*)/$1/;

    my $path = $DOCROOT.$uri;
    if (-f $path) {
        &display($path) ;
        return;
    }
    if (-d $path) {
        if (-f $path.'index.html') {
            &display($path.'index.html');
        } else {
            &gen_dir_list($uri, &getfiles($path));
        }
    }
}
sub display {
    my $file = shift;
    open RES, $file or die "open: $file: $!";
    &log("Sending $file\n");
    print $client $_ while (<RES>);
    close RES;
}
sub gen_dir_list {
    my ($uri, $files) = @_;
    &log("[info] dir listing request\n");

    # print html header
    print $client <<HEADER;
    <html>
        <head><title>dir listing for: /$uri</title></head>
        <body>
        <table cellpadding=5>
HEADER

    my ($count, $modification_time);
    foreach my $f (@$files) {

        # open $f to get its modification time
        if (-f $DOCROOT.$uri.'/'.$f) {
            open my $handle, $DOCROOT.$uri.'/'.$f or &log("open: $!\n"
+);
            $modification_time = scalar localtime((stat $handle)[9]); 
        } else {
            opendir my $handle, $DOCROOT.$uri.'/'.$f or &log("opendir:
+ $!\n");
            $modification_time = scalar localtime((stat $handle)[9]); 
        }

        printf $client "%s<td><a href=\"%s\">%s</a></td><td>%s</td></t
+r>",
                # different colours for alternate rows
                (++$count % 2 ? '<tr bgcolor="#e0ffd6">' : '<tr bgcolo
+r="#ffdcd6">'),
                # generate href links
                   (-d $DOCROOT.$uri.'/'.$f ?  '/'.$uri.$f.'/' : '/'.$
+uri.$f),
                # append a '/' to the end of dir names
                   (-d $DOCROOT.$uri.'/'.$f ?  $f.'/' : $f),
                  $modification_time;
    }

    #print html footer
    print $client <<FOOTER;
    </table>
    <p>-- httpserv v0.1 --</p>
    </body>
    </html>
FOOTER
}

[download]

In reply to how to improve my script by agn

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


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.