package LWP::Protocol::file; use base qw(LWP::Protocol); use strict; our $VERSION = '6.33'; 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{

$desc}; } # Ensure that the base URL is "/" terminated my $base = $url->clone; unless ($base->path =~ m|/$|) { $base->path($base->path . "/"); } my $html = join("\n", "\n", "Directory $path", "", "\n", "

Directory listing of $path

", "

", @files, "", "\n\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;