view release on metacpan or  search on metacpan

lib/App/HTTP_Proxy_IMP/IMP/FakeResponse.pm  view on Meta::CPAN

use strict;
use warnings;
package App::HTTP_Proxy_IMP::IMP::FakeResponse;
use base 'Net::IMP::HTTP::Request';
use fields qw(root file response);
no warnings 'experimental'; # smartmatch

use Net::IMP;
use Net::IMP::Debug;
use Carp;
use Digest::MD5;

sub RTYPES { ( IMP_PASS,IMP_REPLACE,IMP_DENY,IMP_ACCTFIELD ) }

sub new_factory {
    my ($class,%args) = @_;
    my $dir = $args{root} or croak("no root directory given");
    -d $dir && -r _ && -x _ or croak("cannot use base dir $dir: $!");
    my $obj = $class->SUPER::new_factory(%args);
    $obj->{root} = $dir;
    return $obj;
}

sub validate_cfg {
    my ($class,%args) = @_;
    my $dir = delete $args{root};
    delete $args{ignore_parameters};
    my @err = $class->SUPER::validate_cfg(%args);
    if ( ! $dir ) {
	push @err, "no 'root' given";
    } elsif ( ! -d $dir || ! -r _ || ! -x _ ) {
	push @err, "cannot access root dir $dir";
    }
    return @err;
}

sub request_hdr {
    my ($self,$hdr) = @_;

    my ($method,$proto,$host,$path) = $hdr =~m{\A([A-Z]+) +(?:(\w+)://([^/]+))?(\S+)};
    $host = $1 if $hdr =~m{\nHost: *(\S+)}i;
    if ( ! $host ) {
	$self->run_callback([IMP_DENY,0,'cannot determine host']);
	return;
    }
    $proto ||= 'http';
    $host = lc($host);
    my $port =
        $host=~s{^(?:\[(\w._\-:)+\]|(\w._\-))(?::(\d+))?$}{ $1 || $2 }e ?
        $3:80;

    my $dir = $self->{factory_args}{root}."/$host:$port";
    goto IGNORE if ! -d $dir;

    my $uri = "$proto://$host:$port$path";
    my $qstring = $path =~s{\?(.+)}{} ? $1 : undef;
    # collect information to determine filename
    my %file = (
	uri => $uri,
        dir => $dir,
        method => $method,
        md5path => Digest::MD5->new->add($path)->hexdigest,
        md5data => undef,
    );