File Coverage

blib/lib/WebServer/DirIndex.pm
Criterion Covered Total %
statement 33 33 100.0
branch n/a
condition n/a
subroutine 11 11 100.0
pod n/a
total 44 44 100.0


line stmt bran cond sub pod time code
1             package WebServer::DirIndex; # For cpanm :-(
2              
3 1     1   168340 use strict;
  1         3  
  1         66  
4 1     1   6 use warnings;
  1         2  
  1         66  
5 1     1   751 use Feature::Compat::Class;
  1         535  
  1         5  
6              
7             our $VERSION = '0.1.4';
8              
9             class WebServer::DirIndex {
10              
11 1     1   1746 use Path::Tiny;
  1         20881  
  1         91  
12 1     1   743 use HTTP::Date;
  1         6456  
  1         91  
13 1     1   701 use HTML::Escape qw(escape_html);
  1         966  
  1         80  
14 1     1   739 use MIME::Types;
  1         6621  
  1         69  
15 1     1   646 use URI::Escape;
  1         2429  
  1         83  
16 1     1   655 use WebServer::DirIndex::CSS;
  1         3  
  1         46  
17 1     1   648 use WebServer::DirIndex::File;
  1         3  
  1         46  
18 1     1   7 use WebServer::DirIndex::HTML;
  1         2  
  1         946  
19              
20             my $mime_types = MIME::Types->new;
21              
22             field $dir :param;
23             field $dir_url :param;
24             field $icons :param = undef;
25             field $pretty :param = 0;
26             field $html_class :param = 'WebServer::DirIndex::HTML';
27             field $css_class :param = 'WebServer::DirIndex::CSS';
28             field $_html_obj;
29             field $_css_obj;
30             field @files;
31              
32             ADJUST {
33             $icons = 1 if !defined($icons) && $pretty; # pretty implies icons when unset
34             $icons //= 1; # default to enabled otherwise
35             $_html_obj = $html_class->new(icons => $icons);
36             $_css_obj = $css_class->new(pretty => $pretty);
37             @files = ( WebServer::DirIndex::File->parent_dir(
38             html_class => $html_class,
39             icons => $icons,
40             ) );
41              
42             my @children = map { $_->basename } path($dir)->children;
43              
44             for my $basename (sort { $a cmp $b } @children) {
45             my $file = "$dir/$basename";
46             my $url = $dir_url . $basename;
47              
48             my $is_dir = -d $file;
49             my @stat = stat $file;
50              
51             $url = join '/', map { uri_escape($_) } split m{/}, $url;
52              
53             if ($is_dir) {
54             $basename .= '/';
55             $url .= '/';
56             }
57              
58             my $type_obj = $is_dir ? undef : $mime_types->mimeTypeOf($file);
59             my $mime_type = $is_dir
60             ? 'directory'
61             : ($type_obj ? $type_obj->type : 'text/plain');
62              
63             push @files, WebServer::DirIndex::File->new(
64             url => $url,
65             name => $basename,
66             size => $stat[7],
67             mime_type => $mime_type,
68             mtime => HTTP::Date::time2str($stat[9]),
69             html_class => $html_class,
70             icons => $icons,
71             );
72             }
73             }
74              
75             method files { return @files }
76              
77             method to_html ($path_info) {
78             my $path = escape_html("Index of $path_info");
79             my $files_html = join "\n", map { $_->to_html } @files;
80             my $css = $_css_obj->css;
81             return sprintf $_html_obj->dir_html, $path, $css, $path, $files_html;
82             }
83             }
84              
85             1;
86              
87             __END__