view release on metacpan or  search on metacpan

lib/Any/Daemon/HTTP/Directory.pm  view on Meta::CPAN

# Copyrights 2013-2020 by [Mark Overmeer].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of distribution Any-Daemon-HTTP. Meta-POD processed
# with OODoc into POD and HTML manual-pages.  See README.md
# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.

package Any::Daemon::HTTP::Directory;
use vars '$VERSION';
$VERSION = '0.30';

use parent 'Any::Daemon::HTTP::Source';

use warnings;
use strict;

use Log::Report    'any-daemon-http';

use File::Spec     ();
use File::Basename qw/dirname/;
use POSIX::1003    qw/strftime :fd :fs/;
use HTTP::Status   qw/:constants/;
use HTTP::Response ();
use Encode         qw/encode/;
use MIME::Types    ();

my $mimetypes = MIME::Types->new(only_complete => 1);

sub _filename_trans($$);


sub init($)
{   my ($self, $args) = @_;
    $self->SUPER::init($args);

    my $path = $self->path;
    my $loc  = $args->{location}
        or error __x"directory definition requires location";

    my $trans;
    if(ref $loc eq 'CODE')
    {   $trans = $loc;
        undef $loc;
    }
    else
    {   $loc = File::Spec->rel2abs($loc);
        substr($loc, -1) eq '/' or $loc .= '/';
        $trans = _filename_trans $path, $loc;

        -d $loc
            or error __x"directory location {loc} for {path} does not exist"
                 , loc => $loc, path => $path;
    }

    $self->{ADHD_loc}   = $loc;
    $self->{ADHD_fn}    = $trans;
    $self->{ADHD_dirlist} = $args->{directory_list} || 0;
    $self->{ADHD_charset} = $args->{charset} || 'utf-8';

    my $if = $args->{index_file};
    my @if = ref $if eq 'ARRAY' ? @$if
           : defined $if        ? $if
           : qw/index.html index.htm/;
    $self->{ADHD_indexfns} = \@if;
    $self;
}

#-----------------

sub location() {shift->{ADHD_location}}
sub charset()  {shift->{ADHD_charset}}

#-----------------

#-----------------------

sub filename($) { $_[0]->{ADHD_fn}->($_[1]) }

sub _filename_trans($$)
{   my ($path, $loc) = @_;
    return $loc if ref $loc eq 'CODE';
    sub
      { my $x = shift;
        $x =~ s!^\Q$path!$loc! or panic "path $x not inside $path";
        $x;
      };
}

sub _collect($$$$)
{   my ($self, $vhost, $session, $req, $uri) = @_;

    my $item = $self->filename($uri);

    # soft-fail when the item does not exists