| 1 | package LWP::Protocol::file;
|
|---|
| 2 |
|
|---|
| 3 | require LWP::Protocol;
|
|---|
| 4 | @ISA = qw(LWP::Protocol);
|
|---|
| 5 |
|
|---|
| 6 | use strict;
|
|---|
| 7 |
|
|---|
| 8 | require LWP::MediaTypes;
|
|---|
| 9 | require HTTP::Request;
|
|---|
| 10 | require HTTP::Response;
|
|---|
| 11 | require HTTP::Status;
|
|---|
| 12 | require HTTP::Date;
|
|---|
| 13 |
|
|---|
| 14 |
|
|---|
| 15 | sub request
|
|---|
| 16 | {
|
|---|
| 17 | my($self, $request, $proxy, $arg, $size) = @_;
|
|---|
| 18 |
|
|---|
| 19 | $size = 4096 unless defined $size and $size > 0;
|
|---|
| 20 |
|
|---|
| 21 | # check proxy
|
|---|
| 22 | if (defined $proxy)
|
|---|
| 23 | {
|
|---|
| 24 | return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
|
|---|
| 25 | 'You can not proxy through the filesystem');
|
|---|
| 26 | }
|
|---|
| 27 |
|
|---|
| 28 | # check method
|
|---|
| 29 | my $method = $request->method;
|
|---|
| 30 | unless ($method eq 'GET' || $method eq 'HEAD') {
|
|---|
| 31 | return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
|
|---|
| 32 | 'Library does not allow method ' .
|
|---|
| 33 | "$method for 'file:' URLs");
|
|---|
| 34 | }
|
|---|
| 35 |
|
|---|
| 36 | # check url
|
|---|
| 37 | my $url = $request->uri;
|
|---|
| 38 |
|
|---|
| 39 | my $scheme = $url->scheme;
|
|---|
| 40 | if ($scheme ne 'file') {
|
|---|
| 41 | return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
|
|---|
| 42 | "LWP::Protocol::file::request called for '$scheme'");
|
|---|
| 43 | }
|
|---|
| 44 |
|
|---|
| 45 | # URL OK, look at file
|
|---|
| 46 | my $path = $url->file;
|
|---|
| 47 |
|
|---|
| 48 | # test file exists and is readable
|
|---|
| 49 | unless (-e $path) {
|
|---|
| 50 | return HTTP::Response->new( &HTTP::Status::RC_NOT_FOUND,
|
|---|
| 51 | "File `$path' does not exist");
|
|---|
| 52 | }
|
|---|
| 53 | unless (-r _) {
|
|---|
| 54 | return HTTP::Response->new( &HTTP::Status::RC_FORBIDDEN,
|
|---|
| 55 | 'User does not have read permission');
|
|---|
| 56 | }
|
|---|
| 57 |
|
|---|
| 58 | # looks like file exists
|
|---|
| 59 | my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
|
|---|
| 60 | $atime,$mtime,$ctime,$blksize,$blocks)
|
|---|
| 61 | = stat(_);
|
|---|
| 62 |
|
|---|
| 63 | # XXX should check Accept headers?
|
|---|
| 64 |
|
|---|
| 65 | # check if-modified-since
|
|---|
| 66 | my $ims = $request->header('If-Modified-Since');
|
|---|
| 67 | if (defined $ims) {
|
|---|
| 68 | my $time = HTTP::Date::str2time($ims);
|
|---|
| 69 | if (defined $time and $time >= $mtime) {
|
|---|
| 70 | return HTTP::Response->new( &HTTP::Status::RC_NOT_MODIFIED,
|
|---|
| 71 | "$method $path");
|
|---|
| 72 | }
|
|---|
| 73 | }
|
|---|
| 74 |
|
|---|
| 75 | # Ok, should be an OK response by now...
|
|---|
| 76 | my $response = HTTP::Response->new( &HTTP::Status::RC_OK );
|
|---|
| 77 |
|
|---|
| 78 | # fill in response headers
|
|---|
| 79 | $response->header('Last-Modified', HTTP::Date::time2str($mtime));
|
|---|
| 80 |
|
|---|
| 81 | if (-d _) { # If the path is a directory, process it
|
|---|
| 82 | # generate the HTML for directory
|
|---|
| 83 | opendir(D, $path) or
|
|---|
| 84 | return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
|
|---|
| 85 | "Cannot read directory '$path': $!");
|
|---|
| 86 | my(@files) = sort readdir(D);
|
|---|
| 87 | closedir(D);
|
|---|
| 88 |
|
|---|
| 89 | # Make directory listing
|
|---|
| 90 | require URI::Escape;
|
|---|
| 91 | require HTML::Entities;
|
|---|
| 92 | my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
|
|---|
| 93 | for (@files) {
|
|---|
| 94 | my $furl = URI::Escape::uri_escape($_);
|
|---|
| 95 | if ( -d "$pathe$_" ) {
|
|---|
| 96 | $furl .= '/';
|
|---|
| 97 | $_ .= '/';
|
|---|
| 98 | }
|
|---|
| 99 | my $desc = HTML::Entities::encode($_);
|
|---|
| 100 | $_ = qq{<LI><A HREF="$furl">$desc</A>};
|
|---|
| 101 | }
|
|---|
| 102 | # Ensure that the base URL is "/" terminated
|
|---|
| 103 | my $base = $url->clone;
|
|---|
| 104 | unless ($base->path =~ m|/$|) {
|
|---|
| 105 | $base->path($base->path . "/");
|
|---|
| 106 | }
|
|---|
| 107 | my $html = join("\n",
|
|---|
| 108 | "<HTML>\n<HEAD>",
|
|---|
| 109 | "<TITLE>Directory $path</TITLE>",
|
|---|
| 110 | "<BASE HREF=\"$base\">",
|
|---|
| 111 | "</HEAD>\n<BODY>",
|
|---|
| 112 | "<H1>Directory listing of $path</H1>",
|
|---|
| 113 | "<UL>", @files, "</UL>",
|
|---|
| 114 | "</BODY>\n</HTML>\n");
|
|---|
| 115 |
|
|---|
| 116 | $response->header('Content-Type', 'text/html');
|
|---|
| 117 | $response->header('Content-Length', length $html);
|
|---|
| 118 | $html = "" if $method eq "HEAD";
|
|---|
| 119 |
|
|---|
| 120 | return $self->collect_once($arg, $response, $html);
|
|---|
| 121 |
|
|---|
| 122 | }
|
|---|
| 123 |
|
|---|
| 124 | # path is a regular file
|
|---|
| 125 | $response->header('Content-Length', $filesize);
|
|---|
| 126 | LWP::MediaTypes::guess_media_type($path, $response);
|
|---|
| 127 |
|
|---|
| 128 | # read the file
|
|---|
| 129 | if ($method ne "HEAD") {
|
|---|
| 130 | open(F, $path) or return new
|
|---|
| 131 | HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
|
|---|
| 132 | "Cannot read file '$path': $!");
|
|---|
| 133 | binmode(F);
|
|---|
| 134 | $response = $self->collect($arg, $response, sub {
|
|---|
| 135 | my $content = "";
|
|---|
| 136 | my $bytes = sysread(F, $content, $size);
|
|---|
| 137 | return \$content if $bytes > 0;
|
|---|
| 138 | return \ "";
|
|---|
| 139 | });
|
|---|
| 140 | close(F);
|
|---|
| 141 | }
|
|---|
| 142 |
|
|---|
| 143 | $response;
|
|---|
| 144 | }
|
|---|
| 145 |
|
|---|
| 146 | 1;
|
|---|
