diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP/Protocol/file.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/LWP/Protocol/file.pm | 146 |
1 files changed, 146 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/file.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/file.pm new file mode 100644 index 00000000000..f2887f4b2f3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/file.pm @@ -0,0 +1,146 @@ +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 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(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; |