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   2995944 use 5.010;
  6         71  
4 6     6   2676 use MojoX::DirectoryListing::Icons;
  6         20  
  6         481  
5 6     6   96 use strict;
  6         13  
  6         193  
6 6     6   40 use warnings FATAL => 'all';
  6         12  
  6         246  
7 6     6   33 use base 'Exporter';
  6         13  
  6         493  
8 6     6   43 use Cwd;
  6         11  
  6         490  
9              
10             our @EXPORT = ('serve_directory_listing');
11             our $VERSION = '0.11';
12              
13 6     6   40 use constant TEXT_403 => 'Forbidden';
  6         13  
  6         490  
14 6     6   38 use constant TEXT_404 => 'File not found';
  6         13  
  6         17202  
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 812926 $public_dir = shift;
22 10         73 $public_dir =~ s{/+$}{};
23             }
24              
25             my %realpaths;
26              
27             sub serve_directory_listing {
28 24     24 1 3775 %realpaths = ();
29 24         55 my $route = shift;
30 24         42 my $local;
31 24 100       94 if (@_ % 2 == 1) {
32 5         10 $local = shift;
33             }
34 24         121 _serve_directory_listing($route, $local, 'caller', caller, @_);
35             }
36              
37             sub _serve_directory_listing {
38 28     28   55 my $route = shift;
39 28         51 my $local = shift;
40 28         114 my %options = @_;
41 28         71 my $caller = $options{caller};
42              
43 28 50       141 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         124 my $listing_sub = _mk_dir_listing($route,$local,%options);
51              
52 28         160 $caller->app->routes->get( $route, $listing_sub );
53 28 100       7929 $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       4122 if ($options{recursive}) {
62 10         21 my $dh;
63 10   66     49 my $actual = $local // $public_dir . $route;
64 10         347 opendir $dh, $actual;
65             my @subdirs = grep {
66 10 100 100     303 $_ ne '.' && $_ ne '..' && -d "$actual/$_"
  62         811  
67             } readdir($dh);
68 10         111 closedir($dh);
69 10   33     49 $options{caller} //= $caller;
70 10 100       37 my $route1 = $route eq '/' ? '' : $route;
71 10         47 foreach my $subdir (@subdirs) {
72 4 100       10 if ($local) {
73 1         45 my $real = Cwd::realpath("$local/$subdir");
74 1 50       8 next if $realpaths{$real}++;
75 1         9 _serve_directory_listing( "$route1/$subdir",
76             "$local/$subdir", %options );
77             } else {
78 3         25 _serve_directory_listing( "$route1/$subdir", undef, %options );
79             }
80             }
81             }
82              
83 28 100       476 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         36 $caller->app->routes->get( "$route/#file",
88             _mk_fileserver($local) );
89 6         2116 $caller->app->routes->get( "$route/*file",
90             _mk_fileserver($local) );
91             }
92             }
93              
94             sub _mk_fileserver {
95 12     12   123 my ($local) = @_;
96             return sub {
97 9     9   97176 my $self = shift;
98 9         39 my $file = $self->param('file');
99              
100 9 50       1119 if (! -r "$local/$file") {
    100          
    50          
101 0         0 $self->render( text => TEXT_403, status => 403 );
102             } elsif (-d "$local/$file") {
103 1         7 $self->render( status => 403, text => TEXT_403 );
104             } elsif (open my $fh, '<', "$local/$file") {
105 8         320 my $output = join '', <$fh>;
106 8         121 close $fh;
107 8         81 my ($type) = $file =~ /.*\.(\S+)$/;
108 8 100       30 if ($type) {
109 7         38 my $format = $self->app->types->type($type);
110 7 100 66     222 if ($format && $format =~ /te?xt/i) {
    50          
111 5         30 $self->render( format => $type, text => $output );
112             } elsif ($format) {
113 0         0 $self->render( format => $type, data => $output );
114             } else {
115 2         10 $self->render( data => $output );
116             }
117             } else {
118 1         8 $self->render( data => $output );
119             }
120             } else {
121 0         0 $self->render( text => TEXT_404, status => 404 );
122             }
123 12         108 };
124             }
125              
126             sub _mk_dir_listing {
127 28     28   108 my ($route, $local, %options) = @_;
128 28 50       97 die "Expect leading slash in route $route"
129             unless $route =~ m#^/#;
130 28   66     158 $local //= $public_dir . $route;
131             return sub {
132 32     32   796118 my $self = shift;
133 32         129 $self->stash( "actual-dir", $local );
134 32         670 $self->stash( "virtual-dir", $route );
135 32         591 $self->stash( $_ => $options{$_} ) for keys %options;
136 32         1504 _render_directory( $self );
137 28         150 };
138             }
139              
140             sub _directory_listing_link {
141 289     289   540 my ($href, $text) = @_;
142 289         876 return sprintf '%s',
143             "directory-listing-link", $href, $text;
144             }
145              
146             sub _render_directory {
147 32     32   61 my $self = shift;
148 32         64 my $output;
149 32         94 my $virtual_dir = $self->stash("virtual-dir");
150 32         348 my $actual_dir = $self->stash("actual-dir");
151              
152             # sort column: [N]ame, Last [M]odified, [S]ize, [D]escription
153 32   100     323 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       8983 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     104 my $sort_order = $self->param('O') || $self->stash('sort-order') || 'A';
162              
163 32   100     2234 my $show_file_time = $self->stash("show-file-time") // 1;
164 32   100     394 my $show_file_size = $self->stash("show-file-size") // 1;
165 32   100     346 my $show_file_type = $self->stash("show-file-type") // 1;
166 32   100     358 my $show_forbidden = $self->stash("show-forbidden") // 0;
167 32   100     397 my $show_icon = $self->stash("show-icon") // 0; # TODO
168 32         333 my $stylesheet = $self->stash("stylesheet");
169              
170 32 100       325 $virtual_dir =~ s{/$}{} unless $virtual_dir eq '/';
171 32         66 my $dh;
172 32 50       2310 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         1518 my @stat = stat("$actual_dir/$_");
  199         2856  
184 199         537 my $modtime = $stat[9];
185 199         351 my $size = $stat[7];
186 199         2144 my $is_dir = -d "$actual_dir/$_";
187 199 100       657 $size = -1 if $is_dir;
188 199         2612 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       1389 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         569 closedir $dh;
204              
205 32 100       213 if ($sort_column eq 'S') {
    100          
    100          
206 4         46 @items = sort { $a->{size} <=> $b->{size}
207 54 50       132 || $a->{name} cmp $b->{name} } @items;
208             } elsif ($sort_column eq 'M') {
209 2         20 @items = sort { $a->{modtime} <=> $b->{modtime}
210 30 0       75 || $a->{name} cmp $b->{name} } @items;
211             } elsif ($sort_column eq 'T') {
212 3         25 @items = sort { $a->{type} cmp $b->{type}
213 42 50       100 || $a->{name} cmp $b->{name} } @items;
214             } else {
215 23         157 @items = sort { $a->{name} cmp $b->{name} } @items;
  212         432  
216             }
217 32 100       136 if ($sort_order eq 'D') {
218 5         21 @items = reverse @items;
219             }
220              
221 32         110 $output = "";
222 32         132 $output .= _add_style($self, $stylesheet);
223 32         167 $output .= qq[
224            
225            
226            
227            
231             ];
232              
233 32   100     158 my $header = $self->stash("header") //
234             qq[

Index of __DIR__

];
235 32         601 $header =~ s/__DIR__/$virtual_dir/g;
236 32         100 $output .= $header . "\n";
237              
238 32         79 $output .= "
\n";
239              
240 32         72 $output .= qq[
241             \n]; \n\n"; \n]; \n"; \n"; \n
242            
243             ];
244              
245 32         292 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         330 my ($show, $text, $col_code) = @$_;
249 160 100       325 next if !$show;
250 132         234 my $sortind = "";
251 132         188 my $order_code = 'A';
252 132 100       269 if ($sort_column eq $col_code) {
253 31 100       79 if ($sort_order eq 'D') {
254 5         12 $sortind = "v";
255             } else {
256 26         44 $sortind = "^";
257 26         43 $order_code = 'D';
258             }
259             }
260 132 100       259 if ($text eq 'Icon') {
261 10         29 $output .= qq[  
262             } else {
263              
264 122         336 my $link = _directory_listing_link(
265             "$virtual_dir?C=$col_code;O=$order_code", $text);
266 122         386 $output .= qq[
267             $link $sortind
268            
269             ];
270             }
271             }
272              
273 32         103 $output .= "
274              
275 32         65 my $table_element_template = qq[  %s 
276              
277 32         77 foreach my $item (@items) {
278 199 100       514 next if $item->{name} eq '.';
279 167 50 33     386 next if $item->{forbidden} && !$show_forbidden;
280 167         286 $output .= "
281              
282 167 100       471 if ($show_icon) {
283 62         198 my $icon = choose_icon($item);
284 62         265 $output .= sprintf $table_element_template,
285             "icon", "";
286             }
287              
288 167 50       353 if ($item->{forbidden}) {
289             $output .= sprintf $table_element_template,
290 0         0 "forbidden-name", $item->{name};
291             } else {
292 167         281 my $name = $item->{name};
293 167 100       335 $name = 'Parent Directory' if $name eq '..';
294 167         334 my $href = "$virtual_dir/$item->{name}";
295 167         531 $href =~ s{^//}{/};
296 167         375 my $link = _directory_listing_link($href, $name);
297 167         537 $output .= sprintf $table_element_template, "name", $link;
298             }
299              
300              
301 167 100       371 if ($show_file_time) {
302             $output .= sprintf $table_element_template,
303 155         415 "time", _render_modtime($item->{modtime});
304             }
305 167 100       510 if ($show_file_size) {
306 156         344 $output .= sprintf $table_element_template,
307             "size", _render_size($item);
308             }
309 167 100       379 if ($show_file_type) {
310             $output .= sprintf $table_element_template,
311 157         416 "type", $item->{type};
312             }
313 167         441 $output .= "
314             }
315 32         113 $output .= "
\n";
316              
317 32 100       153 if ($self->stash("footer")) {
318 2         23 $output .= "
\n";
319 2         12 my $footer = $self->stash("footer");
320 2         33 $footer =~ s/__DIR__/$virtual_dir/g;
321 2         6 $output .= $footer . "\n";
322             }
323              
324 32         420 $output .= "\n\n";
325 32         144 $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     145 if (defined($stylesheet) && !ref($stylesheet)) {
334 2         11 return qq[\n];
335             }
336              
337 30         76 my $style = "";
338 30 100       99 if (!defined $stylesheet) {
    50          
    50          
    50          
339 29         97 $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   78 return qq~~;
375             }
376              
377             sub _render_size {
378 156     156   238 my $item = shift;
379 156 100       378 if ($item->{is_dir}) {
380 58         227 return "--";
381             }
382 98         162 my $s = $item->{size};
383 98 50       209 if ($s < 100000) {
384 98         340 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   274 my $t = shift;
400 155         3382 my @gt = localtime($t);
401 155         1817 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   212 my $file = shift;
409 106 100       643 if ($file =~ s/.*\.//) {
410 103         855 return $file;
411             }
412 3         20 return "Unknown";
413             }
414              
415             sub _serve_icon {
416 4     4   36193 my $self = shift;
417 4         16 my $icon = $self->param('icon');
418 4         140 my $bytes = MojoX::DirectoryListing::Icons::get_icon( $icon );
419 4         18 $self->render( format => 'gif',
420             data => $bytes );
421             }
422              
423             1;
424              
425             __END__