File Coverage

blib/lib/MojoX/DirectoryListing.pm
Criterion Covered Total %
statement 198 223 88.7
branch 80 106 75.4
condition 30 37 81.0
subroutine 23 23 100.0
pod 2 2 100.0
total 333 391 85.1


line stmt bran cond sub pod time code
1             package MojoX::DirectoryListing;
2              
3 6     6   2965992 use 5.010;
  6         60  
4 6     6   2667 use MojoX::DirectoryListing::Icons;
  6         17  
  6         415  
5 6     6   93 use strict;
  6         12  
  6         158  
6 6     6   43 use warnings FATAL => 'all';
  6         12  
  6         255  
7 6     6   33 use base 'Exporter';
  6         12  
  6         510  
8 6     6   41 use Cwd;
  6         19  
  6         498  
9              
10             our @EXPORT = ('serve_directory_listing');
11             our $VERSION = '0.10';
12              
13 6     6   36 use constant TEXT_403 => 'Forbidden';
  6         11  
  6         336  
14 6     6   36 use constant TEXT_404 => 'File not found';
  6         12  
  6         17756  
15              
16             # FIXME: see @{app->static->paths} for list of public directories
17             our $public_dir = "public";
18             our %icon_server_set = ();
19              
20             sub set_public_app_dir {
21 10     10 1 783686 $public_dir = shift;
22 10         66 $public_dir =~ s{/+$}{};
23             }
24              
25             my %realpaths;
26              
27             sub serve_directory_listing {
28 24     24 1 2236 %realpaths = ();
29 24         53 my $route = shift;
30 24         44 my $local;
31 24 100       88 if (@_ % 2 == 1) {
32 5         13 $local = shift;
33             }
34 24         112 _serve_directory_listing($route, $local, 'caller', caller, @_);
35             }
36              
37             sub _serve_directory_listing {
38 28     28   60 my $route = shift;
39 28         46 my $local = shift;
40 28         125 my %options = @_;
41 28         63 my $caller = $options{caller};
42              
43 28 50       140 if ($route !~ m{^/}) {
44 0         0 $caller->app->log->error(
45             "MojoX::DirectoryListing: route in serve_directory_listing() "
46             . "must have a leading / !" );
47 0         0 return;
48             }
49              
50 28         113 my $listing_sub = _mk_dir_listing($route,$local,%options);
51              
52 28         154 $caller->app->routes->get( $route, $listing_sub );
53 28 100       7606 $icon_server_set{$caller}++ or
54             # route was /directory-listing-icons/#icon
55             # but that was not compatible with some older libraries.
56             # :icon is ok because we expect icon param to never
57             # contain '/' or '.'
58             $caller->app->routes->get( "/directory-listing-icons/:icon",
59             \&_serve_icon );
60              
61 28 100       4068 if ($options{recursive}) {
62 10         29 my $dh;
63 10   66     48 my $actual = $local // $public_dir . $route;
64 10         402 opendir $dh, $actual;
65             my @subdirs = grep {
66 10 100 100     286 $_ ne '.' && $_ ne '..' && -d "$actual/$_"
  62         972  
67             } readdir($dh);
68 10         107 closedir($dh);
69 10   33     49 $options{caller} //= $caller;
70 10 100       39 my $route1 = $route eq '/' ? '' : $route;
71 10         50 foreach my $subdir (@subdirs) {
72 4 100       10 if ($local) {
73 1         58 my $real = Cwd::realpath("$local/$subdir");
74 1 50       8 next if $realpaths{$real}++;
75 1         11 _serve_directory_listing( "$route1/$subdir",
76             "$local/$subdir", %options );
77             } else {
78 3         26 _serve_directory_listing( "$route1/$subdir", undef, %options );
79             }
80             }
81             }
82              
83 28 100       475 if ($local) {
84             # route was $route/#file in 0.06, but that caused test
85             # failures on some systems, mainly with older Perl (but
86             # not necessarily older Mojolicious?)
87 6         42 $caller->app->routes->get( "$route/#file",
88             _mk_fileserver($local) );
89 6         2012 $caller->app->routes->get( "$route/*file",
90             _mk_fileserver($local) );
91             }
92             }
93              
94             sub _mk_fileserver {
95 12     12   119 my ($local) = @_;
96             return sub {
97 9     9   92638 my $self = shift;
98 9         34 my $file = $self->param('file');
99              
100 9 50       1035 if (! -r "$local/$file") {
    100          
    50          
101 0         0 $self->render( text => TEXT_403, status => 403 );
102             } elsif (-d "$local/$file") {
103 1         22 $self->render( status => 403, text => TEXT_403 );
104             } elsif (open my $fh, '<', "$local/$file") {
105 8         295 my $output = join '', <$fh>;
106 8         110 close $fh;
107 8         81 my ($type) = $file =~ /.*\.(\S+)$/;
108 8 100       31 if ($type) {
109 7         34 my $format = $self->app->types->type($type);
110 7 100 66     204 if ($format && $format =~ /te?xt/i) {
    50          
111 5         28 $self->render( format => $type, text => $output );
112             } elsif ($format) {
113 0         0 $self->render( format => $type, data => $output );
114             } else {
115 2         8 $self->render( data => $output );
116             }
117             } else {
118 1         7 $self->render( data => $output );
119             }
120             } else {
121 0         0 $self->render( text => TEXT_404, status => 404 );
122             }
123 12         135 };
124             }
125              
126             sub _mk_dir_listing {
127 28     28   108 my ($route, $local, %options) = @_;
128 28 50       107 die "Expect leading slash in route $route"
129             unless $route =~ m#^/#;
130 28   66     177 $local //= $public_dir . $route;
131             return sub {
132 32     32   784714 my $self = shift;
133 32         186 $self->stash( "actual-dir", $local );
134 32         725 $self->stash( "virtual-dir", $route );
135 32         626 $self->stash( $_ => $options{$_} ) for keys %options;
136 32         1457 _render_directory( $self );
137 28         198 };
138             }
139              
140             sub _directory_listing_link {
141 289     289   588 my ($href, $text) = @_;
142 289         915 return sprintf '%s',
143             "directory-listing-link", $href, $text;
144             }
145              
146             sub _render_directory {
147 32     32   73 my $self = shift;
148 32         88 my $output;
149 32         116 my $virtual_dir = $self->stash("virtual-dir");
150 32         333 my $actual_dir = $self->stash("actual-dir");
151              
152             # sort column: [N]ame, Last [M]odified, [S]ize, [D]escription
153 32   100     318 my $sort_column = $self->param('C') || $self->stash('sort-column') || 'N';
154              
155             # support Apache style ?C=x;O=y query string or ?C=x&O=y
156 32 50       8793 if ($sort_column =~ /^(\w);O=(\w)/) {
157 0         0 $sort_column = $1;
158 0         0 $self->param("O", $2);
159             }
160             # sort order: [A]scending, [D]escending
161 32   100     100 my $sort_order = $self->param('O') || $self->stash('sort-order') || 'A';
162              
163 32   100     2177 my $show_file_time = $self->stash("show-file-time") // 1;
164 32   100     375 my $show_file_size = $self->stash("show-file-size") // 1;
165 32   100     362 my $show_file_type = $self->stash("show-file-type") // 1;
166 32   100     347 my $show_forbidden = $self->stash("show-forbidden") // 0;
167 32   100     348 my $show_icon = $self->stash("show-icon") // 0; # TODO
168 32         416 my $stylesheet = $self->stash("stylesheet");
169              
170 32 100       349 $virtual_dir =~ s{/$}{} unless $virtual_dir eq '/';
171 32         65 my $dh;
172 32 50       2164 if (!opendir $dh, $actual_dir) {
173 0         0 $self->app->log->error(
174             "MojoX::DirectoryListing: opendir failed on $actual_dir" );
175 0 0       0 if (-d $actual_dir) {
176 0         0 $self->render( text => TEXT_403, status => 403 );
177             } else {
178 0         0 $self->render( text => TEXT_404, status => 404 );
179             }
180 0         0 return;
181             }
182             my @items = map {
183 32         1120 my @stat = stat("$actual_dir/$_");
  199         2974  
184 199         510 my $modtime = $stat[9];
185 199         333 my $size = $stat[7];
186 199         2267 my $is_dir = -d "$actual_dir/$_";
187 199 100       702 $size = -1 if $is_dir;
188 199         2451 my $forbidden = ! -r "$actual_dir/$_";
189              
190             # another way this item can be forbidden is if
191             # * it is a directory
192             # * that directory is not served
193            
194             +{
195 199 100       1345 name => $_,
196             is_dir => $is_dir,
197             modtime => $modtime,
198             size => $size,
199             forbidden => $forbidden,
200             type => $is_dir ? "Directory" : _filetype("$_")
201             };
202             } readdir($dh);
203 32         490 closedir $dh;
204              
205 32 100       255 if ($sort_column eq 'S') {
    100          
    100          
206 4         41 @items = sort { $a->{size} <=> $b->{size}
207 54 50       142 || $a->{name} cmp $b->{name} } @items;
208             } elsif ($sort_column eq 'M') {
209 2         21 @items = sort { $a->{modtime} <=> $b->{modtime}
210 30 0       76 || $a->{name} cmp $b->{name} } @items;
211             } elsif ($sort_column eq 'T') {
212 3         29 @items = sort { $a->{type} cmp $b->{type}
213 42 50       108 || $a->{name} cmp $b->{name} } @items;
214             } else {
215 23         152 @items = sort { $a->{name} cmp $b->{name} } @items;
  212         478  
216             }
217 32 100       144 if ($sort_order eq 'D') {
218 5         14 @items = reverse @items;
219             }
220              
221 32         111 $output = "";
222 32         119 $output .= _add_style($self, $stylesheet);
223 32         149 $output .= qq[
224            
225            
226            
227            
231             ];
232              
233 32   100     136 my $header = $self->stash("header") //
234             qq[

Index of __DIR__

];
235 32         641 $header =~ s/__DIR__/$virtual_dir/g;
236 32         98 $output .= $header . "\n";
237              
238 32         104 $output .= "
\n";
239              
240 32         80 $output .= qq[
241             \n]; \n\n"; \n]; \n"; \n"; \n
242            
243             ];
244              
245 32         291 for ( [$show_icon, "Icon", ""],
246             [1,'Name','N'], [$show_file_time,'Last Modified','M'],
247             [$show_file_size,'Size','S'], [$show_file_type,'Type','T'] ) {
248 160         320 my ($show, $text, $col_code) = @$_;
249 160 100       335 next if !$show;
250 132         227 my $sortind = "";
251 132         175 my $order_code = 'A';
252 132 100       311 if ($sort_column eq $col_code) {
253 31 100       77 if ($sort_order eq 'D') {
254 5         12 $sortind = "v";
255             } else {
256 26         53 $sortind = "^";
257 26         41 $order_code = 'D';
258             }
259             }
260 132 100       245 if ($text eq 'Icon') {
261 10         27 $output .= qq[  
262             } else {
263              
264 122         328 my $link = _directory_listing_link(
265             "$virtual_dir?C=$col_code;O=$order_code", $text);
266 122         416 $output .= qq[
267             $link $sortind
268            
269             ];
270             }
271             }
272              
273 32         118 $output .= "
274              
275 32         66 my $table_element_template = qq[  %s 
276              
277 32         71 foreach my $item (@items) {
278 199 100       502 next if $item->{name} eq '.';
279 167 50 33     358 next if $item->{forbidden} && !$show_forbidden;
280 167         308 $output .= "
281              
282 167 100       312 if ($show_icon) {
283 62         193 my $icon = choose_icon($item);
284 62         252 $output .= sprintf $table_element_template,
285             "icon", "";
286             }
287              
288 167 50       359 if ($item->{forbidden}) {
289             $output .= sprintf $table_element_template,
290 0         0 "forbidden-name", $item->{name};
291             } else {
292 167         280 my $name = $item->{name};
293 167 100       337 $name = 'Parent Directory' if $name eq '..';
294 167         354 my $href = "$virtual_dir/$item->{name}";
295 167         456 $href =~ s{^//}{/};
296 167         345 my $link = _directory_listing_link($href, $name);
297 167         511 $output .= sprintf $table_element_template, "name", $link;
298             }
299              
300              
301 167 100       372 if ($show_file_time) {
302             $output .= sprintf $table_element_template,
303 155         366 "time", _render_modtime($item->{modtime});
304             }
305 167 100       417 if ($show_file_size) {
306 156         375 $output .= sprintf $table_element_template,
307             "size", _render_size($item);
308             }
309 167 100       397 if ($show_file_type) {
310             $output .= sprintf $table_element_template,
311 157         403 "type", $item->{type};
312             }
313 167         366 $output .= "
314             }
315 32         99 $output .= "
\n";
316              
317 32 100       118 if ($self->stash("footer")) {
318 2         22 $output .= "
\n";
319 2         11 my $footer = $self->stash("footer");
320 2         33 $footer =~ s/__DIR__/$virtual_dir/g;
321 2         6 $output .= $footer . "\n";
322             }
323              
324 32         425 $output .= "\n\n";
325 32         145 $self->render( text => $output );
326             }
327              
328             sub _add_style {
329             # output either a tag or a
330             # tag
331              
332 32     32   90 my ($self, $stylesheet) = @_;
333 32 100 100     141 if (defined($stylesheet) && !ref($stylesheet)) {
334 2         10 return qq[\n];
335             }
336              
337 30         66 my $style = "";
338 30 100       90 if (!defined $stylesheet) {
    50          
    50          
    50          
339 29         77 $style = _default_style();
340             } elsif (ref $stylesheet eq 'ARRAY') {
341 0         0 $style = join "\n", @$stylesheet;
342             } elsif (ref $stylesheet eq 'HASH') {
343 0         0 while (my ($selector,$attrib) = each %$stylesheet) {
344 0         0 $style .= "$selector $attrib\n";
345             }
346             } elsif (ref $stylesheet eq 'SCALAR') {
347 1         3 $style = $$stylesheet;
348             } else {
349 0         0 $self->app->log->warn( "MojoX::DirectoryListing: Invalid ref type "
350             . (ref $stylesheet) . " for stylesheet" );
351 0         0 $style = _default_style();
352             }
353 30         199 return "\n";
354             }
355              
356             sub _default_style {
357             # inspired by/borrowed from app-dirserve
358 29     29   75 return qq~~;
375             }
376              
377             sub _render_size {
378 156     156   262 my $item = shift;
379 156 100       354 if ($item->{is_dir}) {
380 58         250 return "--";
381             }
382 98         193 my $s = $item->{size};
383 98 50       209 if ($s < 100000) {
384 98         354 return $s;
385             }
386 0 0       0 if ($s < 1024 * 999.5) {
387 0         0 return sprintf "%.3gK", $s/1024;
388             }
389 0 0       0 if ($s < 1024 * 1024 * 999.5) {
390 0         0 return sprintf "%.3gM", $s/1024/1024;
391             }
392 0 0       0 if ($s < 1024 * 1024 * 1024 * 999.5) {
393 0         0 return sprintf "%.3gG", $s/1024/1024/1024;
394             }
395 0         0 return sprintf "%.3gT", $s/1024/1024/1024/1024;
396             }
397              
398             sub _render_modtime {
399 155     155   254 my $t = shift;
400 155         3360 my @gt = localtime($t);
401 155         1755 sprintf ( "%04d-%s-%02d %02d:%02d:%02d",
402             $gt[5]+1900,
403             [qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)]->[$gt[4]],
404             @gt[3,2,1,0] );
405             }
406              
407             sub _filetype {
408 106     106   213 my $file = shift;
409 106 100       675 if ($file =~ s/.*\.//) {
410 103         848 return $file;
411             }
412 3         34 return "Unknown";
413             }
414              
415             sub _serve_icon {
416 4     4   33946 my $self = shift;
417 4         13 my $icon = $self->param('icon');
418 4         133 my $bytes = MojoX::DirectoryListing::Icons::get_icon( $icon );
419 4         15 $self->render( format => 'gif',
420             data => $bytes );
421             }
422              
423             1;
424              
425             __END__