From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

GAAS / libwww-perl-5.810 / lib / LWP / Protocol / file.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148

              
package LWP::Protocol::file;
require LWP::Protocol;
@ISA = qw(LWP::Protocol);
use strict;
require LWP::MediaTypes;
require HTTP::Request;
require HTTP::Response;
require HTTP::Status;
require HTTP::Date;
sub request
{
    my($self, $request, $proxy, $arg, $size) = @_;
    LWP::Debug::trace('()');
    $size = 4096 unless defined $size and $size > 0;
    # check proxy
    if (defined $proxy)
    {
        return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
                                  'You can not proxy through the filesystem';
    }
    # check method
    my $method = $request->method;
    unless ($method eq 'GET' || $method eq 'HEAD') {
        return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
                                  'Library does not allow method ' .
                                  "$method for 'file:' URLs";
    }
    # check url
    my $url = $request->url;
    my $scheme = $url->scheme;
    if ($scheme ne 'file') {
        return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
                           "LWP::Protocol::file::request called for '$scheme'";
    }
    # URL OK, look at file
    my $path  = $url->file;
    # test file exists and is readable
    unless (-e $path) {
        return new HTTP::Response &HTTP::Status::RC_NOT_FOUND,
                                  "File `$path' does not exist";
    }
    unless (-r _) {
        return new HTTP::Response &HTTP::Status::RC_FORBIDDEN,
                                  'User does not have read permission';
    }
    # looks like file exists
    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
       $atime,$mtime,$ctime,$blksize,$blocks)
            = stat(_);
    # XXX should check Accept headers?
    # check if-modified-since
    my $ims = $request->header('If-Modified-Since');
    if (defined $ims) {
        my $time = HTTP::Date::str2time($ims);
        if (defined $time and $time >= $mtime) {
            return new HTTP::Response &HTTP::Status::RC_NOT_MODIFIED,
                                      "$method $path";
        }
    }
    # Ok, should be an OK response by now...
    my $response = new HTTP::Response &HTTP::Status::RC_OK;
    # fill in response headers
    $response->header('Last-Modified', HTTP::Date::time2str($mtime));
    if (-d _) {         # If the path is a directory, process it
        # generate the HTML for directory
        opendir(D, $path) or
           return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
                                     "Cannot read directory '$path': $!";
        my(@files) = sort readdir(D);
        closedir(D);
        # Make directory listing
        require URI::Escape;
        require HTML::Entities;
        my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
        for (@files) {
            my $furl = URI::Escape::uri_escape($_);
            if ( -d "$pathe$_" ) {
                $furl .= '/';
                $_ .= '/';
            }
            my $desc = HTML::Entities::encode($_);
            $_ = qq{<LI><A HREF="$furl">$desc</A>};
        }
        # Ensure that the base URL is "/" terminated
        my $base = $url->clone;
        unless ($base->path =~ m|/$|) {
            $base->path($base->path . "/");
        }
        my $html = join("\n",
                        "<HTML>\n<HEAD>",
                        "<TITLE>Directory $path</TITLE>",
                        "<BASE HREF=\"$base\">",
                        "</HEAD>\n<BODY>",
                        "<H1>Directory listing of $path</H1>",
                        "<UL>", @files, "</UL>",
                        "</BODY>\n</HTML>\n");
        $response->header('Content-Type',   'text/html');
        $response->header('Content-Length', length $html);
        $html = "" if $method eq "HEAD";
        return $self->collect_once($arg, $response, $html);
    }
    # path is a regular file
    $response->header('Content-Length', $filesize);
    LWP::MediaTypes::guess_media_type($path, $response);
    # read the file
    if ($method ne "HEAD") {
        open(F, $path) or return new
            HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
                           "Cannot read file '$path': $!");
        binmode(F);
        $response =  $self->collect($arg, $response, sub {
            my $content = "";
            my $bytes = sysread(F, $content, $size);
            return \$content if $bytes > 0;
            return \ "";
        });
        close(F);
    }
    $response;
}
1;