File Coverage

lib/HTTP/Server/Directory.pm

Criterion	Covered	Total	%
statement	18	61	29.5
branch	0	40	0.0
condition	0	2	0.0
subroutine	6	20	30.0
pod	0	6	0.0
total	24	129	18.6

# Copyrights 2008 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 1.05.
package HTTP::Server::Directory;
use vars '$VERSION';
$VERSION = '0.11';

use warnings;
use strict;

use Log::Report 'httpd-multiplex', syntax => 'SHORT';

use Net::CIDR    qw/cidrlookup/;
use File::Spec   ();

sub _allow_cleanup($);
sub _allow_match($$$$);
sub _filename_trans($$);


sub new(@)
{   my $class = shift;
    my $args  = @_==1 ? shift : {@_};
    (bless {}, $class)->init($args);
}

sub init($)
{   my ($self, $args) = @_;

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

    if(ref $loc eq 'CODE') {;}
    else
    {   File::Spec->file_name_is_absolute($loc)
           or error __x"directory location {loc} for path {path} not absolute"
                , loc => $loc, path => $path;
        -d $loc
           or error __x"directory location {loc} for path {path} does not exist"
                , loc => $loc, path => $path;

        substr($loc,-1) eq '/' or $loc .= '/';
    }
    $self->{HSD_loc}   = $loc;
    $self->{HSD_fn}    = _filename_trans $path, $loc;

    $self->{HSD_allow} = _allow_cleanup $args->{allow};
    $self->{HSD_deny}  = _allow_cleanup $args->{deny};

    $self;
}

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

sub path()     {shift->{HSD_path}}
sub location() {shift->{HSD_location}}

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

sub allow($$$$)
{   my ($self, $client, $session, $req, $uri) = @_;
    if(my $allow = $self->{HSD_allow})
    {   $self->_allow_match($client, $session, $uri, $allow) or return 0;
    }
    if(my $deny = $self->{HSD_deny})
    {    $self->_allow_match($client, $session, $uri, $deny) and return 0;
    }
    1;
}

sub _allow_match($$$$)
{   my ($self, $client, $session, $uri, $rules) = @_;
    my ($ip, $host) = @$client{'ip', 'host'};
    first { $_->($ip, $host, $session, $uri) } @$rules ? 1 : 0;
}

sub _allow_cleanup($)
{   my $p = shift or return;
    my @p;
    foreach my $r (ref $p eq 'ARRAY' ? @$p : $p)
    {   push @p
          , ref $r eq 'CODE'    ? $r
          : index($r, ':') >= 0 ? sub {cidrlookup $_[0], $r}    # IPv6
          : $r !~ m/[a-zA-Z]/   ? sub {cidrlookup $_[0], $r}    # IPv4
          : $r =~ s/^\.//       ? sub {$_[1] =~ qr/(^|\.)\Q$r\E$/i} # Domain
          :                       sub {lc($_[1]) eq lc($r)}     # hostname
    }
    @p ? \@p : undef;
}


sub filename($) { $_[0]->{HSD_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 within $path";
        $x;
      };
}


1;