File Coverage

blib/lib/LWP/Protocol/file.pm
Criterion Covered Total %
statement 56 64 87.5
branch 20 34 58.8
condition 3 9 33.3
subroutine 4 4 100.0
pod 1 1 100.0
total 84 112 75.0


line stmt bran cond sub pod time code
1             package LWP::Protocol::file;
2             $LWP::Protocol::file::VERSION = '6.29';
3 3     3   359 use base qw(LWP::Protocol);
  3         7  
  3         294  
4              
5 3     3   17 use strict;
  3         5  
  3         1897  
6              
7             require LWP::MediaTypes;
8             require HTTP::Request;
9             require HTTP::Response;
10             require HTTP::Status;
11             require HTTP::Date;
12              
13              
14             sub request
15             {
16 7     7 1 16 my($self, $request, $proxy, $arg, $size) = @_;
17              
18 7 50 33     26 $size = 4096 unless defined $size and $size > 0;
19              
20             # check proxy
21 7 50       16 if (defined $proxy)
22             {
23 0         0 return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
24             'You can not proxy through the filesystem');
25             }
26              
27             # check method
28 7         20 my $method = $request->method;
29 7 50 66     84 unless ($method eq 'GET' || $method eq 'HEAD') {
30 0         0 return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
31             'Library does not allow method ' .
32             "$method for 'file:' URLs");
33             }
34              
35             # check url
36 7         19 my $url = $request->uri;
37              
38 7         55 my $scheme = $url->scheme;
39 7 50       109 if ($scheme ne 'file') {
40 0         0 return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
41             "LWP::Protocol::file::request called for '$scheme'");
42             }
43              
44             # URL OK, look at file
45 7         21 my $path = $url->file;
46              
47             # test file exists and is readable
48 7 50       2756 unless (-e $path) {
49 0         0 return HTTP::Response->new( HTTP::Status::RC_NOT_FOUND,
50             "File `$path' does not exist");
51             }
52 7 50       26 unless (-r _) {
53 0         0 return HTTP::Response->new( HTTP::Status::RC_FORBIDDEN,
54             'User does not have read permission');
55             }
56              
57             # looks like file exists
58 7         24 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
59             $atime,$mtime,$ctime,$blksize,$blocks)
60             = stat(_);
61              
62             # XXX should check Accept headers?
63              
64             # check if-modified-since
65 7         55 my $ims = $request->header('If-Modified-Since');
66 7 50       349 if (defined $ims) {
67 0         0 my $time = HTTP::Date::str2time($ims);
68 0 0 0     0 if (defined $time and $time >= $mtime) {
69 0         0 return HTTP::Response->new( HTTP::Status::RC_NOT_MODIFIED,
70             "$method $path");
71             }
72             }
73              
74             # Ok, should be an OK response by now...
75 7         26 my $response = HTTP::Response->new( HTTP::Status::RC_OK );
76              
77             # fill in response headers
78 7         310 $response->header('Last-Modified', HTTP::Date::time2str($mtime));
79              
80 7 100       426 if (-d _) { # If the path is a directory, process it
81             # generate the HTML for directory
82 2 50       60 opendir(D, $path) or
83             return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
84             "Cannot read directory '$path': $!");
85 2         94 my(@files) = sort readdir(D);
86 2         27 closedir(D);
87              
88             # Make directory listing
89 2         11 require URI::Escape;
90 2         1340 require HTML::Entities;
91 2 50       9475 my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
92 2         8 for (@files) {
93 52         113 my $furl = URI::Escape::uri_escape($_);
94 52 100       924 if ( -d "$pathe$_" ) {
95 16         34 $furl .= '/';
96 16         23 $_ .= '/';
97             }
98 52         157 my $desc = HTML::Entities::encode($_);
99 52         760 $_ = qq{
  • $desc};
  • 100             }
    101             # Ensure that the base URL is "/" terminated
    102 2         28 my $base = $url->clone;
    103 2 50       23 unless ($base->path =~ m|/$|) {
    104 2         34 $base->path($base->path . "/");
    105             }
    106 2         151 my $html = join("\n",
    107             "\n",
    108             "Directory $path",
    109             "",
    110             "\n",
    111             "

    Directory listing of $path

    ",
    112             "
      ", @files, "
    ",
    113             "\n\n");
    114              
    115 2         61 $response->header('Content-Type', 'text/html');
    116 2         129 $response->header('Content-Length', length $html);
    117 2 50       82 $html = "" if $method eq "HEAD";
    118              
    119 2         21 return $self->collect_once($arg, $response, $html);
    120              
    121             }
    122              
    123             # path is a regular file
    124 5         14 $response->header('Content-Length', $filesize);
    125 5         194 LWP::MediaTypes::guess_media_type($path, $response);
    126              
    127             # read the file
    128 5 100       674 if ($method ne "HEAD") {
    129 3 50       57 open(my $fh, '<', $path) or return new
    130             HTTP::Response(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
    131             "Cannot read file '$path': $!");
    132 3         9 binmode($fh);
    133             $response = $self->collect($arg, $response, sub {
    134 6     6   6 my $content = "";
    135 6         49 my $bytes = sysread($fh, $content, $size);
    136 6 100       20 return \$content if $bytes > 0;
    137 3         15 return \ "";
    138 3         21 });
    139 3         20 close($fh);
    140             }
    141              
    142 5         23 $response;
    143             }
    144              
    145             1;