local-lib5/lib/perl5/LWP/Protocol/file.pm

   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 new HTTP::Response &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 new HTTP::Response &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 new HTTP::Response &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 new HTTP::Response &HTTP::Status::RC_NOT_FOUND,
  51                                   "File `$path' does not exist";
  52     }
  53     unless (-r _) {
  54         return new HTTP::Response &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 new HTTP::Response &HTTP::Status::RC_NOT_MODIFIED,
  71                                       "$method $path";
  72         }
  73     }
  74
  75     # Ok, should be an OK response by now...
  76     my $response = new HTTP::Response &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 new HTTP::Response &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;