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