view release on metacpan or  search on metacpan

examples/p5httpd  view on Meta::CPAN

sub print_direntry {
  my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  my ($file) = @_;
  my ( undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime ) =
    stat $file;
  my ( $icon, $type );
  if ($show_icons) {
    $type = filetype($file);
    $type =~ s/\//_/g;
    -r "$server_root/$icondir/$type.gif" or $type = "unknown";
    $icon = "$icondir/$type.gif";
    $icon = ( -r "$server_root/$icon" ? "<img src=\"/$icon\">" : "" );
  }
  my $filename = ( $file eq ".." ? "Parent directory" : $file );
  $filename = (
    length($filename) > 18
    ? sprintf( "%18.18s", $filename ) . ".."
    : $filename
  );
  $filename .= "/" if $type eq "folder_normal";
  my ( $x, $min, $hour, $mday, $mon, $year ) = localtime $mtime;
  $year += 1900;
  $min  = sprintf "%2.2d", $min;
  $hour = sprintf "%2.2d", $hour;
  my $date = "$mday-$months[$mon]-$year $hour:$min";
  my $spacing = " " x ( 25 - length($filename) );
  printf Client "%s <a href=\"%s\">%s</a>%s  %20.20s   %8.8s\n", $icon, $file,
    $filename, $spacing, $date, $size;
}

sub redirect {
  my ($redir) = @_;
  print Client "HTTP/1.0 301 Moved Permanently\nLocation: $redir\n\n";
  logmsg "-> 301 Moved Permanently to $redir";
}

sub challenge {
  my ( $realm, $file ) = @_;
  print Client
"HTTP/1.0 401 Access Denied\nContent-type: text/html\nWWW-Authenticate: Basic realm=\"$realm\"\n\n";
  logmsg "-> Authentication requested for $file";
}

sub authorized {
  my ( $file, $passphrase ) = @_;
  my $parent = $file;
  do {    # check whether $file is public or private
          # by stripping away final path components until
    return ""
      if $public{
      "$parent/"};    # either a public or a private directory is reached
    goto PROTECTED
      if $private{"$parent/"};    # "last" would test the wile clause once more
  } while ( $parent =~ s#/[^/]*$## );
PROTECTED:
  logmsg "checking password";
  $passphrase =~ tr#A-Za-z0-9+/##cd;     # remove non-base64 chars
  $passphrase =~ tr#A-Za-z0-9+/# -_#;    # convert to uuencoded format
  my $len = pack( "c", 32 + 0.75 * length($passphrase) );  # compute length byte
  my $decoded = unpack( "u", $len . $passphrase );         # uudecode and print
  my ( $name, $password ) = split /:/, $decoded;

  if ( my $encrypted_password = $encrypted_passwords{$name} ) {
    return $name
      if crypt( $password, $encrypted_password ) eq
      $encrypted_password;                                 # check password
  }
  return undef;                                            # failed
}

__END__


=head1 NAME

p5httpd - tiny perl http server

=head1 SYNOPSIS

path/to/p5httpd.pl (or click on the icon)

=head1 DESCRIPTION

p5httpd is a simple HTTP 1.0 server written as a single perl
file. Written for use on a hand-held machine, it should be useful on
any machine as a quick and dirty, non-secure webserver for occasional
use.

Understands PUT, GET, and HEAD, can do basic authentication and
directory listings. CGI scripts can be executed or, if they are perl
scripts, eval'ed.



=head1 INSTALLATION AND CONFIGURATION

p5httpd.pl is a single file, containing a small configuration section
at the beginning, and this POD documentation at the end. This single
file, unedited, is already functional, but it will be more useful if
you unzip the whole distribution and edit the first few lines of the
server program to adapt it to your installation

=head1 FORKING POLICY

Unix servers typically use fork() in order to be ready for the next
request as soon as possible, delegating the hard work to a child
process. This may result in better performance (e.g. when requesting a
page with a lot of images), but perl CGI scripts will have to load all
their modules every time they're run.

A non-forking server will run all scripts in the same interpreter
process, an thus will have to load the modules ony once. For
heavyweight modules like CGI.pm this may make a big difference.

p5httpd can be configured (with the config variable $when_to_fork) to
fork always, never, or always except the first time a particular
script is run.  This last policy combines the advantages of the
always-forking and never-forking policies, as the server (and hence
its children) will have the script's required modules loaded after its
first (non-forking) run. In this case, expensive re-initialisations
can also be avoided.