"Fossies" - the Fresh Open Source Software Archive

Member "libwww-perl-6.43/lib/LWP/Protocol/file.pm" (26 Nov 2019, 3843 Bytes) of package /linux/www/libwww-perl-6.43.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "file.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 6.42_vs_6.43.

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