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
|
|
|
|
|
|
|
"", |
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; |