148 lines
3.8 KiB
Perl
148 lines
3.8 KiB
Perl
package LWP::Protocol::file;
|
|
|
|
use base qw(LWP::Protocol);
|
|
|
|
use strict;
|
|
|
|
our $VERSION = '6.36';
|
|
|
|
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 HTTP::Response->new( 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 HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
|
|
'Library does not allow method ' .
|
|
"$method for 'file:' URLs");
|
|
}
|
|
|
|
# check url
|
|
my $url = $request->uri;
|
|
|
|
my $scheme = $url->scheme;
|
|
if ($scheme ne 'file') {
|
|
return HTTP::Response->new( 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 HTTP::Response->new( HTTP::Status::RC_NOT_FOUND,
|
|
"File `$path' does not exist");
|
|
}
|
|
unless (-r _) {
|
|
return HTTP::Response->new( 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 HTTP::Response->new( HTTP::Status::RC_NOT_MODIFIED,
|
|
"$method $path");
|
|
}
|
|
}
|
|
|
|
# Ok, should be an OK response by now...
|
|
my $response = HTTP::Response->new( 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 HTTP::Response->new( 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(my $fh, '<', $path) or return new
|
|
HTTP::Response(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
|
|
"Cannot read file '$path': $!");
|
|
binmode($fh);
|
|
$response = $self->collect($arg, $response, sub {
|
|
my $content = "";
|
|
my $bytes = sysread($fh, $content, $size);
|
|
return \$content if $bytes > 0;
|
|
return \ "";
|
|
});
|
|
close($fh);
|
|
}
|
|
|
|
$response;
|
|
}
|
|
|
|
1;
|