File Coverage

blib/lib/MojoX/DirectoryListing.pm
Criterion Covered Total %
statement 198 223 88.7
branch 81 106 76.4
condition 30 37 81.0
subroutine 23 23 100.0
pod 2 2 100.0
total 334 391 85.4


line stmt bran cond sub pod time code
1             package MojoX::DirectoryListing;
2              
3 6     6   3113758 use 5.010;
  6         71  
4 6     6   2838 use MojoX::DirectoryListing::Icons;
  6         21  
  6         487  
5 6     6   156 use strict;
  6         17  
  6         179  
6 6     6   40 use warnings FATAL => 'all';
  6         13  
  6         264  
7 6     6   31 use base 'Exporter';
  6         25  
  6         507  
8 6     6   46 use Cwd;
  6         12  
  6         547  
9              
10             our @EXPORT = ('serve_directory_listing');
11             our $VERSION = '0.12';
12              
13 6     6   40 use constant TEXT_403 => 'Forbidden';
  6         13  
  6         408  
14 6     6   36 use constant TEXT_404 => 'File not found';
  6         14  
  6         18204  
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 3806813 $public_dir = shift;
22 10         142 $public_dir =~ s{/+$}{};
23             }
24              
25             my %realpaths;
26              
27             sub serve_directory_listing {
28 24     24 1 2253 %realpaths = ();
29 24         60 my $route = shift;
30 24         42 my $local;
31 24 100       102 if (@_ % 2 == 1) {
32 5         25 $local = shift;
33             }
34 24         115 _serve_directory_listing($route, $local, 'caller', caller, @_);
35             }
36              
37             sub _serve_directory_listing {
38 28     28   57 my $route = shift;
39 28         53 my $local = shift;
40 28         132 my %options = @_;
41 28         66 my $caller = $options{caller};
42              
43 28 50       147 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         163 $caller->app->routes->get( $route, $listing_sub );
53 28 100       7800 $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       4296 if ($options{recursive}) {
62 10         18 my $dh;
63 10   66     49 my $actual = $local // $public_dir . $route;
64 10         393 opendir $dh, $actual;
65             my @subdirs = grep {
66 10 100 100     325 $_ ne '.' && $_ ne '..' && -d "$actual/$_"
  62         884  
67             } readdir($dh);
68 10         118 closedir($dh);
69 10   33     52 $options{caller} //= $caller;
70 10 100       38 my $route1 = $route eq '/' ? '' : $route;
71 10         51 foreach my $subdir (@subdirs) {
72 4 100       13 if ($local) {
73 1         56 my $real = Cwd::realpath("$local/$subdir");
74 1 50       10 next if $realpaths{$real}++;
75 1         9 _serve_directory_listing( "$route1/$subdir",
76             "$local/$subdir", %options );
77             } else {
78 3         32 _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         50 $caller->app->routes->get( "$route/#file",
88             _mk_fileserver($local) );
89 6         2091 $caller->app->routes->get( "$route/*file",
90             _mk_fileserver($local) );
91             }
92             }
93              
94             sub _mk_fileserver {
95 12     12   120 my ($local) = @_;
96             return sub {
97 9     9   105633 my $self = shift;
98 9         52 my $file = $self->param('file');
99              
100 9 50       1304 if (! -r "$local/$file") {
    100          
    50          
101 0         0 $self->render( text => TEXT_403, status => 403 );
102             } elsif (-d "$local/$file") {
103 1         11 $self->render( status => 403, text => TEXT_403 );
104             } elsif (open my $fh, '<', "$local/$file") {
105 8         333 my $output = join '', <$fh>;
106 8         133 close $fh;
107 8         94 my ($type) = $file =~ /.*\.(\S+)$/;
108 8 100       37 if ($type) {
109 7         38 my $format = $self->app->types->type($type);
110 7 100 66     252 if ($format && $format =~ /te?xt/i) {
    50          
111 5         31 $self->render( format => $type, text => $output );
112             } elsif ($format) {
113 0         0 $self->render( format => $type, data => $output );
114             } else {
115 2         12 $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         151 };
124             }
125              
126             sub _mk_dir_listing {
127 28     28   114 my ($route, $local, %options) = @_;
128 28 50       104 die "Expect leading slash in route $route"
129             unless $route =~ m#^/#;
130 28   66     164 $local //= $public_dir . $route;
131             return sub {
132 33     33   827897 my $self = shift;
133 33         164 $self->stash( "actual-dir", $local );
134 33         723 $self->stash( "virtual-dir", $route );
135 33         647 $self->stash( $_ => $options{$_} ) for keys %options;
136 33         1524 _render_directory( $self );
137 28         175 };
138             }
139              
140             sub _directory_listing_link {
141 298     298   554 my ($href, $text) = @_;
142 298         940 return sprintf '%s',
143             "directory-listing-link", $href, $text;
144             }
145              
146             sub _render_directory {
147 33     33   83 my $self = shift;
148 33         66 my $output;
149 33         100 my $virtual_dir = $self->stash("virtual-dir");
150 33         405 my $actual_dir = $self->stash("actual-dir");
151              
152             # sort column: [N]ame, Last [M]odified, [S]ize, [D]escription
153 33   100     344 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 33 50       9205 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 33   100     111 my $sort_order = $self->param('O') || $self->stash('sort-order') || 'A';
162              
163 33   100     2256 my $show_file_time = $self->stash("show-file-time") // 1;
164 33   100     442 my $show_file_size = $self->stash("show-file-size") // 1;
165 33   100     383 my $show_file_type = $self->stash("show-file-type") // 1;
166 33   100     353 my $show_forbidden = $self->stash("show-forbidden") // 0;
167 33   100     351 my $show_icon = $self->stash("show-icon") // 0; # TODO
168 33         338 my $stylesheet = $self->stash("stylesheet");
169              
170 33 100       404 $virtual_dir =~ s{/$}{} unless $virtual_dir eq '/';
171 33         65 my $dh;
172 33 50       2328 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 33         1391 my @stat = stat("$actual_dir/$_");
  205         3015  
184 205         623 my $modtime = $stat[9];
185 205         308 my $size = $stat[7];
186 205         2337 my $is_dir = -d "$actual_dir/$_";
187 205 100       708 $size = -1 if $is_dir;
188 205         2656 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 205 100       1576 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 33         551 closedir $dh;
204              
205 33 100       247 if ($sort_column eq 'S') {
    100          
    100          
206 4         31 @items = sort { $a->{size} <=> $b->{size}
207 54 50       128 || $a->{name} cmp $b->{name} } @items;
208             } elsif ($sort_column eq 'M') {
209 2         11 @items = sort { $a->{modtime} <=> $b->{modtime}
210 30 50       69 || $a->{name} cmp $b->{name} } @items;
211             } elsif ($sort_column eq 'T') {
212 3         20 @items = sort { $a->{type} cmp $b->{type}
213 42 50       102 || $a->{name} cmp $b->{name} } @items;
214             } else {
215 24         176 @items = sort { $a->{name} cmp $b->{name} } @items;
  221         469  
216             }
217 33 100       136 if ($sort_order eq 'D') {
218 6         14 @items = reverse @items;
219             }
220              
221 33         117 $output = "";
222 33         122 $output .= _add_style($self, $stylesheet);
223 33         169 $output .= qq[
224            
225            
226            
227            
231             ];
232              
233 33   100     167 my $header = $self->stash("header") //
234             qq[

Index of __DIR__

];
235 33         624 $header =~ s/__DIR__/$virtual_dir/g;
236 33         126 $output .= $header . "\n";
237              
238 33         71 $output .= "
\n";
239              
240 33         83 $output .= qq[
241             \n]; \n\n"; \n]; \n"; \n"; \n
242            
243             ];
244              
245 33         265 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 165         333 my ($show, $text, $col_code) = @$_;
249 165 100       347 next if !$show;
250 136         227 my $sortind = "";
251 136         204 my $order_code = 'A';
252 136 100       293 if ($sort_column eq $col_code) {
253 32 100       85 if ($sort_order eq 'D') {
254 6         12 $sortind = "v";
255             } else {
256 26         59 $sortind = "^";
257 26         51 $order_code = 'D';
258             }
259             }
260 136 100       261 if ($text eq 'Icon') {
261 10         30 $output .= qq[  
262             } else {
263              
264 126         329 my $link = _directory_listing_link(
265             "$virtual_dir?C=$col_code;O=$order_code", $text);
266 126         404 $output .= qq[
267             $link $sortind
268            
269             ];
270             }
271             }
272              
273 33         107 $output .= "
274              
275 33         79 my $table_element_template = qq[  %s 
276              
277 33         74 foreach my $item (@items) {
278 205 100       514 next if $item->{name} eq '.';
279 172 50 33     402 next if $item->{forbidden} && !$show_forbidden;
280 172         290 $output .= "
281              
282 172 100       352 if ($show_icon) {
283 62         193 my $icon = choose_icon($item);
284 62         205 $output .= sprintf $table_element_template,
285             "icon", "";
286             }
287              
288 172 50       359 if ($item->{forbidden}) {
289             $output .= sprintf $table_element_template,
290 0         0 "forbidden-name", $item->{name};
291             } else {
292 172         280 my $name = $item->{name};
293 172 100       367 $name = 'Parent Directory' if $name eq '..';
294 172         351 my $href = "$virtual_dir/$item->{name}";
295 172         494 $href =~ s{^//}{/};
296 172         356 my $link = _directory_listing_link($href, $name);
297 172         540 $output .= sprintf $table_element_template, "name", $link;
298             }
299              
300              
301 172 100       354 if ($show_file_time) {
302             $output .= sprintf $table_element_template,
303 160         379 "time", _render_modtime($item->{modtime});
304             }
305 172 100       474 if ($show_file_size) {
306 161         360 $output .= sprintf $table_element_template,
307             "size", _render_size($item);
308             }
309 172 100       405 if ($show_file_type) {
310             $output .= sprintf $table_element_template,
311 162         414 "type", $item->{type};
312             }
313 172         378 $output .= "
314             }
315 33         99 $output .= "
\n";
316              
317 33 100       159 if ($self->stash("footer")) {
318 2         24 $output .= "
\n";
319 2         14 my $footer = $self->stash("footer");
320 2         33 $footer =~ s/__DIR__/$virtual_dir/g;
321 2         7 $output .= $footer . "\n";
322             }
323              
324 33         462 $output .= "\n\n";
325 33         154 $self->render( text => $output );
326             }
327              
328             sub _add_style {
329             # output either a tag or a
330             # tag
331              
332 33     33   97 my ($self, $stylesheet) = @_;
333 33 100 100     147 if (defined($stylesheet) && !ref($stylesheet)) {
334 2         12 return qq[\n];
335             }
336              
337 31         94 my $style = "";
338 31 100       111 if (!defined $stylesheet) {
    50          
    50          
    50          
339 30         88 $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         4 $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 31         222 return "\n";
354             }
355              
356             sub _default_style {
357             # inspired by/borrowed from app-dirserve
358 30     30   99 return qq~~;
375             }
376              
377             sub _render_size {
378 161     161   269 my $item = shift;
379 161 100       383 if ($item->{is_dir}) {
380 59         235 return "--";
381             }
382 102         195 my $s = $item->{size};
383 102 50       209 if ($s < 100000) {
384 102         439 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 160     160   271 my $t = shift;
400 160         3588 my @gt = localtime($t);
401 160         2046 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 110     110   239 my $file = shift;
409 110 100       710 if ($file =~ s/.*\.//) {
410 107         935 return $file;
411             }
412 3         30 return "Unknown";
413             }
414              
415             sub _serve_icon {
416 4     4   33953 my $self = shift;
417 4         15 my $icon = $self->param('icon');
418 4         168 my $bytes = MojoX::DirectoryListing::Icons::get_icon( $icon );
419 4         13 $self->render( format => 'gif',
420             data => $bytes );
421             }
422              
423             1;
424              
425             __END__