File Coverage

blib/lib/Dancer2/Plugin/Path/Class.pm

Criterion	Covered	Total	%
statement	80	85	94.1
branch	14	22	63.6
condition			n/a
subroutine	11	11	100.0
pod			n/a
total	105	118	88.9

package Dancer2::Plugin::Path::Class;

# ABSTRACT: list a directory using Path::Class

use strict;
use warnings;

our $VERSION = 0.05;

use Dancer2::Plugin;
use MIME::Types;
use Path::Class;
use Fcntl "S_IRUSR";
use Format::Human::Bytes;

sub _decorate_dirs {
    my ($dir, $dirs) = @_;
    my @ls_dirs = ();
    for my $basename (@{$dirs}) {
        my $subdir = $dir->subdir($basename);
        my @subdirs = (); # the subdirs of this subdir
        my $file_count = 0; # the number of files in this subdir
        while (my $ent = $subdir->next) {
            my $subsubname = $ent->basename;
            next if $subsubname =~ /^\./; # hidden
            next if $subsubname =~ /~$/; # ignore
            next unless -r $ent; # can read
            if ($ent->is_dir) {
                push @subdirs, $subsubname;
            } else {
                $file_count++;
            }
        }
        @subdirs = sort {$a cmp $b} @subdirs;
        push @ls_dirs, {
            name => $basename,
            subdirs => \@subdirs,
            file_count => $file_count,
        };
    }
    return \@ls_dirs;
}

sub _ymd {
    my $stamp = shift;
    my ($mday, $mon, $year) = (localtime($stamp))[3..5];
    my $date = sprintf("%4d-%02d-%02d", $year + 1900, $mon + 1, $mday);
    return $date;
}

sub _decorate_files {
    my ($dir, $files) = @_;
    my @ls_files = ();
    my $mt = MIME::Types->new;
    for my $basename (@{$files}) {
        my $st = $dir->file($basename)->stat;
        next unless $st;
        next unless $st->cando(S_IRUSR, 1); # can read
        my $type = $mt->mimeTypeOf($basename);
        push @ls_files, {
            name => $basename,
            type => "$type",
            size => Format::Human::Bytes::base2($st->size),
            date => _ymd($st->mtime),
        };
    }
    return \@ls_files;
}

register ls => sub {
    my ($dsl, @args) = plugin_args(@_);
    my $dir = dir(@args);
    my $ls_name = $dir->basename;
    my @dirs = ();
    my @files = ();
    my $ls_dirs;
    my $ls_files;

    if (-d $dir) {
        while (my $ent = $dir->next) {
            my $basename = $ent->basename;
            next if $basename =~ /^\./; # hidden
            next if $basename =~ /~$/; # ignore
            if ($ent->is_dir) {
                next unless -r $ent; # can read
                push @dirs, $basename;
            } else {
                push @files, $basename;
            }
        }
        @dirs = sort {$a cmp $b} @dirs;
        $ls_dirs = _decorate_dirs($dir, \@dirs);
        @files = sort {$a cmp $b} @files;
        $ls_files = _decorate_files($dir, \@files);
    } else {
        push @files, $dir->basename;
        $ls_files = _decorate_files($dir->parent, \@files);
    }

    my $ls_cdup = $dsl->request->path;
    $ls_cdup =~ s{/[^/]*$}{};

    $dsl->var( ls_name  => $ls_name );
    $dsl->var( ls_cdup  => $ls_cdup );
    $dsl->var( ls_dirs  => $ls_dirs );
    $dsl->var( ls_files => $ls_files );

    return $dir;

};

register_plugin;
1;
__END__