File Coverage

lib/Qmail/Deliverable/Client.pm

Criterion	Covered	Total	%
statement	17	47	36.1
branch	0	22	0.0
condition	0	3	0.0
subroutine	6	9	66.6
pod	2	2	100.0
total	25	83	30.1

package Qmail::Deliverable::Client;

use strict;
use 5.006;
use Carp qw(carp);
use base 'Exporter';
use LWP::Simple qw($ua);
use URI::Escape qw(uri_escape);

our @EXPORT_OK = qw/qmail_local deliverable/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);

our $SERVER = "127.0.0.1:8998";
our $ERROR;

# rfc2822's "atext"
my $atext = "[A-Za-z0-9!#\$%&\'*+\/=?^_\`{|}~-]";
my $valid = qr/^(?!.*\@.*\@)($atext+(?:[\@.]$atext+)*)\.?\z/;

sub _remote {
    my ($command, $arg) = @_;

    my $server = ref($SERVER) eq 'CODE'
        ? $SERVER->()
        : $SERVER;

    if (not defined $server) {
        $ERROR = "No SERVER defined; connection not attempted";
        return "\0";
    }

    my $response = $ua->get(
        "http://$server/qd1/$command?" . uri_escape($arg)
    );

    my $code = $response->code;
    return undef if $code == 204;  # rpc undef

    my $sl = $response->status_line;
    if ($code == 200) {
        return $response->content;
    }

    carp $ERROR = "Server $server unreachable or broken! ($sl)";
    return "\0";
}

sub qmail_local {
    my ($in) = @_;
    my ($address) = lc($in) =~ /$valid/ or
        do { carp "Invalid address: $in"; return; };

    # This we can do locally. Let's not waste HTTP requests :)
    return $address if $address !~ /\@/;

    my $rv = _remote 'qmail_local', $address;
    return "" if defined $rv and $rv eq "\0";
    return $rv;
}

sub deliverable {
    my ($in) = @_;
    my ($address) = lc($in) =~ /$valid/
        or do { carp "Invalid address: $in"; return; };

    my $rv = _remote 'deliverable', $address;
    return 0x2f if not defined $rv;  # shouldn't happen
    return 0x2f if not length $rv;   # shouldn't happen
    return 0x2f if $rv eq "\0";

    return $rv;
}

1;

__END__