|
|
## $Id: file.pm,v 1.19 1999/04/23 17:54:02 gisle Exp $
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;
require URI::Escape;require HTML::Entities;
sub request{ my($self, $request, $proxy, $arg, $size) = @_;
LWP::Debug::trace('()');
$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::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 for (@files) { if($^O eq "MacOS") { $_ .= "/" if -d "$path:$_"; } else { $_ .= "/" if -d "$path/$_"; } my $furl = URI::Escape::uri_escape($_); 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->epath =~ m|/$|) { $base->epath($base->epath . "/"); } 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;
|
