home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _c4c3e162326d540bbac54db43c7cd30c < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.9 KB  |  155 lines
  1. #
  2. # $Id: file.pm,v 1.21 2003/10/23 19:11:32 uid39246 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.         }
  103.         else {
  104.         $_ .= "/" if -d "$path/$_";
  105.         }
  106.         my $furl = URI::Escape::uri_escape($_);
  107.         my $desc = HTML::Entities::encode($_);
  108.         $_ = qq{<LI><A HREF="$furl">$desc</A>};
  109.     }
  110.     # Ensure that the base URL is "/" terminated
  111.     my $base = $url->clone;
  112.     unless ($base->path =~ m|/$|) {
  113.         $base->path($base->path . "/");
  114.     }
  115.     my $html = join("\n",
  116.             "<HTML>\n<HEAD>",
  117.             "<TITLE>Directory $path</TITLE>",
  118.             "<BASE HREF=\"$base\">",
  119.             "</HEAD>\n<BODY>",
  120.             "<H1>Directory listing of $path</H1>",
  121.             "<UL>", @files, "</UL>",
  122.             "</BODY>\n</HTML>\n");
  123.  
  124.     $response->header('Content-Type',   'text/html');
  125.     $response->header('Content-Length', length $html);
  126.     $html = "" if $method eq "HEAD";
  127.  
  128.     return $self->collect_once($arg, $response, $html);
  129.  
  130.     }
  131.  
  132.     # path is a regular file
  133.     $response->header('Content-Length', $filesize);
  134.     LWP::MediaTypes::guess_media_type($path, $response);
  135.  
  136.     # read the file
  137.     if ($method ne "HEAD") {
  138.     open(F, $path) or return new
  139.         HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  140.                "Cannot read file '$path': $!");
  141.     binmode(F);
  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.