home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / LWP / Protocol / file.pm < prev    next >
Text File  |  1997-01-13  |  4KB  |  155 lines
  1. #
  2. # $Id: file.pm,v 1.16 1997/01/13 14:23:16 aas 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.         my $furl = URI::Escape::uri_escape($_);
  108.         my $desc = HTML::Entities::encode($_);
  109.         $_ = qq{<LI><A HREF="$furl">$desc</A>};
  110.     }
  111.     # Ensure that the base URL is "/" terminated
  112.     my $base = $url->clone;
  113.     unless ($base->epath =~ m|/$|) {
  114.         $base->epath($base->epath . "/");
  115.     }
  116.     my $html = join("\n",
  117.             "<HTML>\n<HEAD>",
  118.             "<TITLE>Directory $path</TITLE>",
  119.             "<BASE HREF=\"$base\">",
  120.             "</HEAD>\n<BODY>",
  121.             "<H1>Directory listing of $path</H1>",
  122.             "<UL>", @files, "</UL>",
  123.             "</BODY>\n</HTML>\n");
  124.  
  125.     $response->header('Content-Type',   'text/html');
  126.     $response->header('Content-Length', length $html);
  127.  
  128.     return $self->collect_once($arg, $response, $html);
  129.  
  130.     } else {            # path is a regular file
  131.     my($type, @enc) = LWP::MediaTypes::guess_media_type($path);
  132.     $response->header('Content-Type',   $type) if $type;
  133.     $response->header('Content-Length', $filesize);
  134.     for (@enc) {
  135.         $response->push_header('Content-Encoding', $_);
  136.     }
  137.  
  138.     # read the file
  139.     open(F, $path) or return new
  140.        HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  141.               "Cannot read file '$path': $!");
  142.     $response =  $self->collect($arg, $response, sub {
  143.         my $content = "";
  144.         my $bytes = sysread(F, $content, $size);
  145.         return \$content if $bytes > 0;
  146.         return \ "";
  147.     });
  148.     close(F);
  149.     }
  150.  
  151.     $response;
  152. }
  153.  
  154. 1;
  155.