File Coverage

blib/lib/Plack/App/File.pm
Criterion Covered Total %
statement 75 81 92.5
branch 21 26 80.7
condition 8 11 72.7
subroutine 17 17 100.0
pod 1 8 12.5
total 122 143 85.3


line stmt bran cond sub pod time code
1             package Plack::App::File;
2 8     8   94780 use strict;
  8         17  
  8         263  
3 8     8   41 use warnings;
  8         16  
  8         287  
4 8     8   47 use parent qw/Plack::Component/;
  8         13  
  8         43  
5 8     8   406 use File::Spec::Unix;
  8         13  
  8         335  
6 8     8   48 use Cwd ();
  8         11  
  8         174  
7 8     8   38 use Plack::Util;
  8         29  
  8         154  
8 8     8   3285 use Plack::MIME;
  8         21  
  8         271  
9 8     8   3997 use HTTP::Date;
  8         29570  
  8         540  
10              
11 8     8   1271 use Plack::Util::Accessor qw( root file content_type encoding );
  8         19  
  8         52  
12              
13             sub should_handle {
14 117     117 0 218 my($self, $file) = @_;
15 117         2390 return -f $file;
16             }
17              
18             sub call {
19 130     130 1 192 my $self = shift;
20 130         180 my $env = shift;
21              
22 130   100     355 my($file, $path_info) = $self->file || $self->locate_file($env);
23 130 100       978 return $file if ref $file eq 'ARRAY';
24              
25 19 50       57 if ($path_info) {
26 0         0 $env->{'plack.file.SCRIPT_NAME'} = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
27 0         0 $env->{'plack.file.SCRIPT_NAME'} =~ s/\Q$path_info\E$//;
28 0         0 $env->{'plack.file.PATH_INFO'} = $path_info;
29             } else {
30 19         118 $env->{'plack.file.SCRIPT_NAME'} = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
31 19         54 $env->{'plack.file.PATH_INFO'} = '';
32             }
33              
34 19         110 return $self->serve_path($env, $file);
35             }
36              
37             sub locate_file {
38 126     126 0 260 my($self, $env) = @_;
39              
40 126   50     321 my $path = $env->{PATH_INFO} || '';
41              
42 126 100       322 if ($path =~ /\0/) {
43 1         15 return $self->return_400;
44             }
45              
46 125   50     298 my $docroot = $self->root || ".";
47 125         2065 my @path = split /[\\\/]/, $path, -1; # -1 *MUST* be here to avoid security issues!
48 125 50       338 if (@path) {
49 125 100       298 shift @path if $path[0] eq '';
50             } else {
51 0         0 @path = ('.');
52             }
53              
54 125 100       747 if (grep /^\.{2,}$/, @path) {
55 5         27 return $self->return_403;
56             }
57              
58 120         206 my($file, @path_info);
59 120         266 while (@path) {
60 120         1281 my $try = File::Spec::Unix->catfile($docroot, @path);
61 120 100       348 if ($self->should_handle($try)) {
    50          
62 15         42 $file = $try;
63 15         41 last;
64             } elsif (!$self->allow_path_info) {
65 105         194 last;
66             }
67 0         0 unshift @path_info, pop @path;
68             }
69              
70 120 100       283 if (!$file) {
71 105         212 return $self->return_404;
72             }
73              
74 15 50       219 if (!-r $file) {
75 0         0 return $self->return_403;
76             }
77              
78 15         117 return $file, join("/", "", @path_info);
79             }
80              
81 105     105 0 346 sub allow_path_info { 0 }
82              
83             sub serve_path {
84 16     16 0 45 my($self, $env, $file) = @_;
85              
86 16   100     63 my $content_type = $self->content_type || Plack::MIME->mime_type($file)
87             || 'text/plain';
88              
89 16 100       60 if ("CODE" eq ref $content_type) {
90 1         4 $content_type = $content_type->($file);
91             }
92              
93 16 100       73 if ($content_type =~ m!^text/!) {
94 14   50     51 $content_type .= "; charset=" . ($self->encoding || "utf-8");
95             }
96              
97 16 50       709 open my $fh, "<:raw", $file
98             or return $self->return_403;
99              
100 16         297 my @stat = stat $file;
101              
102 16         668 Plack::Util::set_io_path($fh, Cwd::realpath($file));
103              
104             return [
105 16         87 200,
106             [
107             'Content-Type' => $content_type,
108             'Content-Length' => $stat[7],
109             'Last-Modified' => HTTP::Date::time2str( $stat[9] )
110             ],
111             $fh,
112             ];
113             }
114              
115             sub return_403 {
116 5     5 0 9 my $self = shift;
117 5         54 return [403, ['Content-Type' => 'text/plain', 'Content-Length' => 9], ['forbidden']];
118             }
119              
120             sub return_400 {
121 1     1 0 4 my $self = shift;
122 1         8 return [400, ['Content-Type' => 'text/plain', 'Content-Length' => 11], ['Bad Request']];
123             }
124              
125             # Hint: subclasses can override this to return undef to pass through 404
126             sub return_404 {
127 105     105 0 169 my $self = shift;
128 105         965 return [404, ['Content-Type' => 'text/plain', 'Content-Length' => 9], ['not found']];
129             }
130              
131             1;
132             __END__