Any-Daemon-HTTP
view release on metacpan or search on metacpan
lib/Any/Daemon/HTTP/Directory.pm view on Meta::CPAN
<td>$d->{user}</td>
<td>$d->{group}</td>
<td align="right">$d->{size_nice}</td>
<td>$d->{mtime_nice}</td>
<td><a href="$d->{name}">$d->{name}</a>$symdest</td></tr>
__ROW
}
local $" = "\n";
my $content = encode 'utf8', <<__PAGE;
<html><head><title>$dir</title></head>
<style>TD { padding: 0 10px; }</style>
<body>
<h1>Directory $dir</h1>
<table>
@rows
</table>
<p><i>Generated $now</i></p>
</body></html>
__PAGE
HTTP::Response->new(HTTP_OK, undef
, ['Content-Type' => 'text/html; charset='.$self->charset]
, $content
);
}
my %filetype =
( &S_IFSOCK => 's', &S_IFLNK => 'l', &S_IFREG => '-', &S_IFBLK => 'b'
, &S_IFDIR => 'd', &S_IFCHR => 'c', &S_IFIFO => 'p');
my @flags = ('---', '--x', '-w-', '-wx', 'r--', 'r-x', 'rw-', 'rwx');
my @stat_fields =
qw/dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks/;
sub list($@)
{ my ($self, $dirname, %opts) = @_;
opendir my $from_dir, $dirname
or return;
my $names = $opts{names} || qr/^[^.]/;
my $prefilter
= ref $names eq 'Regexp' ? sub { $_[0] =~ $names }
: ref $names eq 'CODE' ? $names
: panic "::Directory::list(names) must be regexp or code, not $names";
my $postfilter = $opts{filter} || sub {1};
ref $postfilter eq 'CODE'
or panic "::Directory::list(filter) must be code, not $postfilter";
my $hide_symlinks = $opts{hide_symlinks};
my (%dirlist, %users, %groups);
foreach my $name (grep $prefilter->($_), readdir $from_dir)
{ my $path = $dirname.$name;
my %d = (name => $name, path => $path);
@d{@stat_fields}
= $hide_symlinks ? stat($path) : lstat($path);
if(!$hide_symlinks && -l _)
{ @d{qw/kind is_symlink /} = ('SYMLINK', 1)}
elsif(-d _) { @d{qw/kind is_directory/} = ('DIRECTORY',1)}
elsif(-f _) { @d{qw/kind is_file /} = ('FILE', 1)}
else { @d{qw/kind is_other /} = ('OTHER', 1)}
$postfilter->(\%d)
or next;
if($d{is_symlink})
{ my $sl = $d{symlink_dest} = readlink $path;
$d{symlink_dest_exists} = -e $sl;
}
elsif($d{is_file})
{ my ($s, $l) = ($d{size}, ' ');
($s,$l) = ($s/1024, 'kB') if $s > 1024;
($s,$l) = ($s/1024, 'MB') if $s > 1024;
($s,$l) = ($s/1024, 'GB') if $s > 1024;
$d{size_nice} = sprintf +($s>=100?"%.0f%s":"%.1f%s"), $s,$l;
}
elsif($d{is_directory})
{ $d{name} .= '/';
}
$d{user} = $users{$d{uid}} ||= getpwuid $d{uid};
$d{group} = $users{$d{gid}} ||= getgrgid $d{gid};
my $mode = $d{mode};
my $b = $filetype{$mode & S_IFMT} || '?';
$b .= $flags[ ($mode & S_IRWXU) >> 6 ];
substr($b, -1, -1) = 's' if $mode & S_ISUID;
$b .= $flags[ ($mode & S_IRWXG) >> 3 ];
substr($b, -1, -1) = 's' if $mode & S_ISGID;
$b .= $flags[ $mode & S_IRWXO ];
substr($b, -1, -1) = 't' if $mode & S_ISVTX;
$d{flags} = $b;
$d{mtime_nice} = strftime "%F %T", localtime $d{mtime};
$dirlist{$name} = \%d;
}
\%dirlist;
}
#-----------------------
1;
( run in 1.490 second using v1.01-cache-2.11-cpan-39bf76dae61 )