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