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