home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / LWP / Protocol / file.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  3.6 KB  |  139 lines
  1.  
  2. package LWP::Protocol::file;
  3.  
  4. require LWP::Protocol;
  5. require LWP::MediaTypes;
  6. require HTTP::Request;
  7. require HTTP::Response;
  8. require HTTP::Status;
  9. require HTTP::Date;
  10.  
  11. require URI::Escape;
  12. require HTML::Entities;
  13.  
  14. use Carp;
  15.  
  16. @ISA = qw(LWP::Protocol);
  17.  
  18.  
  19. sub request
  20. {
  21.     my($self, $request, $proxy, $arg, $size) = @_;
  22.  
  23.     LWP::Debug::trace('()');
  24.  
  25.     $size = 4096 unless defined $size and $size > 0;
  26.  
  27.     if (defined $proxy)
  28.     {
  29.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  30.                   'You can not proxy through the filesystem';
  31.     }
  32.  
  33.     $method = $request->method;
  34.  
  35.     unless ($method eq 'GET' || $method eq 'HEAD') {
  36.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  37.                   'Library does not allow method ' .
  38.                   "$method for 'file:' URLs";
  39.     }
  40.  
  41.     my $url = $request->url;
  42.  
  43.     my $scheme = $url->scheme;
  44.     if ($scheme ne 'file') {
  45.     return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  46.                   "LWP::file::request called for '$scheme'";
  47.     }
  48.  
  49.     my $host = $url->host;
  50.     if ($host and $host !~ /^localhost$/i) {
  51.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST_CLIENT,
  52.                   'Only file://localhost/ allowed';
  53.     }
  54.  
  55.     my $path  = $url->local_path;
  56.  
  57.     unless (-e $path) {
  58.     return new HTTP::Response &HTTP::Status::RC_NOT_FOUND,
  59.                   "File `$path' does not exist";
  60.     }
  61.     unless (-r _) {
  62.     return new HTTP::Response &HTTP::Status::RC_FORBIDDEN,
  63.                   'User does not have read permission';
  64.     }
  65.  
  66.     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
  67.        $atime,$mtime,$ctime,$blksize,$blocks)
  68.         = stat(_);
  69.  
  70.  
  71.     my $ims = $request->header('If-Modified-Since');
  72.     if (defined $ims) {
  73.     my $time = HTTP::Date::str2time($ims);
  74.     if (defined $time and $time >= $mtime) {
  75.         return new HTTP::Response &HTTP::Status::RC_NOT_MODIFIED,
  76.                       "$method $path";
  77.     }
  78.     }
  79.  
  80.     $response = new HTTP::Response &HTTP::Status::RC_OK;
  81.  
  82.     $response->header('Last-Modified', HTTP::Date::time2str($mtime));
  83.  
  84.     if (-d _) {         # If the path is a directory, process it
  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.     for (@files) {
  92.         $_ .= "/" if -d "$path/$_";
  93.         my $furl = URI::Escape::uri_escape($_);
  94.         my $desc = HTML::Entities::encode($_);
  95.         $_ = qq{<LI><A HREF="$furl">$desc</A>};
  96.     }
  97.     my $base = $url->clone;
  98.     unless ($base->epath =~ m|/$|) {
  99.         $base->epath($base->epath . "/");
  100.     }
  101.     my $html = join("\n",
  102.             "<HTML>\n<HEAD>",
  103.             "<TITLE>Directory $path</TITLE>",
  104.             "<BASE HREF=\"$base\">",
  105.             "</HEAD>\n<BODY>",
  106.             "<H1>Directory listing of $path</H1>",
  107.             "<UL>", @files, "</UL>",
  108.             "</BODY>\n</HTML>\n");
  109.  
  110.     $response->header('Content-Type',   'text/html');
  111.     $response->header('Content-Length', length $html);
  112.  
  113.     return $self->collect_once($arg, $response, $html);
  114.  
  115.     } else {            # path is a regular file
  116.     my($type, @enc) = LWP::MediaTypes::guess_media_type($path);
  117.     $response->header('Content-Type',   $type) if $type;
  118.     $response->header('Content-Length', $filesize);
  119.     for (@enc) {
  120.         $response->push_header('Content-Encoding', $_);
  121.     }
  122.  
  123.     open(F, $path) or return new
  124.        HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  125.               "Cannot read file '$path': $!");
  126.     $response =  $self->collect($arg, $response, sub {
  127.         my $content = "";
  128.         my $bytes = sysread(F, $content, $size);
  129.         return \$content if $bytes > 0;
  130.         return \ "";
  131.     });
  132.     close(F);
  133.     }
  134.  
  135.     $response;
  136. }
  137.  
  138. 1;
  139.