| Current Path : /usr/local/lib/perl5/site_perl/5.8.9/LWP/Protocol/ |
FreeBSD hs32.drive.ne.jp 9.1-RELEASE FreeBSD 9.1-RELEASE #1: Wed Jan 14 12:18:08 JST 2015 root@hs32.drive.ne.jp:/sys/amd64/compile/hs32 amd64 |
| Current File : //usr/local/lib/perl5/site_perl/5.8.9/LWP/Protocol/file.pm |
package LWP::Protocol::file;
require LWP::Protocol;
@ISA = qw(LWP::Protocol);
use strict;
require LWP::MediaTypes;
require HTTP::Request;
require HTTP::Response;
require HTTP::Status;
require HTTP::Date;
sub request
{
my($self, $request, $proxy, $arg, $size) = @_;
$size = 4096 unless defined $size and $size > 0;
# check proxy
if (defined $proxy)
{
return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
'You can not proxy through the filesystem';
}
# check method
my $method = $request->method;
unless ($method eq 'GET' || $method eq 'HEAD') {
return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
'Library does not allow method ' .
"$method for 'file:' URLs";
}
# check url
my $url = $request->url;
my $scheme = $url->scheme;
if ($scheme ne 'file') {
return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
"LWP::Protocol::file::request called for '$scheme'";
}
# URL OK, look at file
my $path = $url->file;
# test file exists and is readable
unless (-e $path) {
return new HTTP::Response &HTTP::Status::RC_NOT_FOUND,
"File `$path' does not exist";
}
unless (-r _) {
return new HTTP::Response &HTTP::Status::RC_FORBIDDEN,
'User does not have read permission';
}
# looks like file exists
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
$atime,$mtime,$ctime,$blksize,$blocks)
= stat(_);
# XXX should check Accept headers?
# check if-modified-since
my $ims = $request->header('If-Modified-Since');
if (defined $ims) {
my $time = HTTP::Date::str2time($ims);
if (defined $time and $time >= $mtime) {
return new HTTP::Response &HTTP::Status::RC_NOT_MODIFIED,
"$method $path";
}
}
# Ok, should be an OK response by now...
my $response = new HTTP::Response &HTTP::Status::RC_OK;
# fill in response headers
$response->header('Last-Modified', HTTP::Date::time2str($mtime));
if (-d _) { # If the path is a directory, process it
# generate the HTML for directory
opendir(D, $path) or
return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
"Cannot read directory '$path': $!";
my(@files) = sort readdir(D);
closedir(D);
# Make directory listing
require URI::Escape;
require HTML::Entities;
my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
for (@files) {
my $furl = URI::Escape::uri_escape($_);
if ( -d "$pathe$_" ) {
$furl .= '/';
$_ .= '/';
}
my $desc = HTML::Entities::encode($_);
$_ = qq{<LI><A HREF="$furl">$desc</A>};
}
# Ensure that the base URL is "/" terminated
my $base = $url->clone;
unless ($base->path =~ m|/$|) {
$base->path($base->path . "/");
}
my $html = join("\n",
"<HTML>\n<HEAD>",
"<TITLE>Directory $path</TITLE>",
"<BASE HREF=\"$base\">",
"</HEAD>\n<BODY>",
"<H1>Directory listing of $path</H1>",
"<UL>", @files, "</UL>",
"</BODY>\n</HTML>\n");
$response->header('Content-Type', 'text/html');
$response->header('Content-Length', length $html);
$html = "" if $method eq "HEAD";
return $self->collect_once($arg, $response, $html);
}
# path is a regular file
$response->header('Content-Length', $filesize);
LWP::MediaTypes::guess_media_type($path, $response);
# read the file
if ($method ne "HEAD") {
open(F, $path) or return new
HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
"Cannot read file '$path': $!");
binmode(F);
$response = $self->collect($arg, $response, sub {
my $content = "";
my $bytes = sysread(F, $content, $size);
return \$content if $bytes > 0;
return \ "";
});
close(F);
}
$response;
}
1;