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