stat\( results from the CPAN

CGI-ExtDirect
view release on metacpan or search on metacpan
}

# logmsg "Couldn't frob the gnargle: $!"; logs a time-stamped message,
# folowed by newline, to STDERR. No return value.

sub logmsg ($) {
  my ($text) = (@_);
  my $fulltime = localtime();
  my $PID = sprintf "%5d", $$;
  my ($hms) = ( $fulltime =~ /(\d\d:\d\d:\d\d)/ );
  my @text = split /\n/, $text;
  foreach my $line (@text) {
    print STDERR "$PID $hms $line\n";
  }
}

sub log_and_die ($) {
  my ($text) = (@_);
  logmsg "FATAL: $text";
  die "\n";
}

# logerr 404, "No gnargles here, sorry!"; signals error to browser,
# logging it to STDERR as well.  No return value.

sub logerr ($$) {
  my ( $code, $detail ) = @_;
  my %codes = (
    200 => 'OK',
    400 => 'Bad Request',
    403 => 'Access Denied',
    404 => 'Not Found',
    500 => 'Internal Server Error',
    501 => 'Not Implemented',
  );
  my $msg = "$code " . $codes{$code};
  logmsg "-> $msg $detail";
  print Client <<EOF;
    HTTP/1.0 $msg
    Content-type: text/html

    <html><body>
    <h1>$msg</h1>
    <p>$detail</p>
    <hr>
    <p><I>p5httpd/$version server at $localname port $port</I></p>
    </body></html>
EOF
}

# cat "relative/path", "text/html", $method; writes the appropriate
# response headers to STDOUT. If $method == GET (which is the default)
# then the file is dumped on STDOUT as well.

sub cat($$;$) {
  my ( $file, $mimetype, $method ) = @_;
  $method = "GET" unless $method;
  my $fullpath = "$server_root$file";

  my ( undef, undef, undef, undef, undef, undef, undef, $length, undef, $mtime )
    = stat($fullpath);
  $mtime = gmtime $mtime;
  my ( $day, $mon, $dm, $tm, $yr ) =
    ( $mtime =~ m/(...) (...) (..) (..:..:..) (....)/ );

  print Client "Content-length: $length\n";
  print Client "Last-Modified: $day, $dm $mon $yr $tm GMT\n";
  print Client "Content-type: $mimetype\n\n";
  my $sent = 0;
  if ( $method eq "GET" ) {
    local $INPUT_RECORD_SEPARATOR = undef;   # gobble whole files, but only here
    open IN, "<$fullpath" || return 0;
    my $content = <IN>;
    close IN;
    $sent = length($content);
    print Client $content;
  }
  logmsg "-> 200 OK $file: $sent bytes sent as $mimetype";
  return 1;
}

# cgi_run("relative/path.cgi", "encoded%20arglist", $method) changes to directory
# where script lives, and then either evals or executes it.

sub cgi_run {
  my ( $script, $arglist, $method ) = @_;
  my ($dir) = ( $script =~ /^(.*\/)/ );
  my $script_path = "$server_root$script";
  my $script_text;
  my $old_chdir = cwd();
  chdir "$server_root$dir"
    or return logerr 500, "Cannot chdir to $server_root$dir: $!";
  $script_path =~ s/[A-Z]://;

# command line decoding, cf description at http://hoohoo.ncsa.uiuc.edu/cgi/cl.html:
  local @ARGV;
  unless ( $arglist =~ /=/ ) {
    $arglist =~
      s/%([\dA-Fa-f]{2})/chr(hex($1))/eg;    # decode arglist, e.g. %20 -> space
    @ARGV = split /\s+/, $arglist;
  }
  my $file_tastes_like_perl = 1;
  if ( $eval_or_execute != $cgis_are_executed ) {

    open CGI, $script_path
        or return do {
            chdir $old_chdir;
            logerr 500, "Cannot read $script_path: $!";
        };
    my ( $script_text, $nread );
    if ( $eval_or_execute == $only_perl_is_evaled ) {
      logmsg "sniffing and tasting $script...";
      $nread = read CGI, $script_text, 100, 0;    # taste first 100 bytes
      defined $nread
        or return do {
            chdir $old_chdir;
            logerr 500, "Read error reading $script_path: $!";
        };
      if ( $script_text !~ /#!.*perl/i )
      {    # No #!/.../perl? Then it's not a perl script.
        logmsg "yeachh! $script doesn't taste like perl!";
( run in 1.034 second using v1.01-cache-2.11-cpan-39bf76dae61 )