File Coverage

blib/lib/Test/Varnish.pm

Criterion	Covered	Total	%
statement	42	108	38.8
branch	4	32	12.5
condition	5	32	15.6
subroutine	12	19	63.1
pod	8	8	100.0
total	71	199	35.6

package Test::Varnish;

our $VERSION = '0.03';

use warnings;
use strict;

use Carp;
use Getopt::Long;
use HTTP::Cookies;
use HTTP::Request;
use LWP::UserAgent;
use Test::More;
use URI;

sub analyze_response {
    my ($self, $res) = @_;
    my $cached = 0;

    if ($self->verbose) {

        my $hdr_obj = $res->headers;
        my @hdr_names = $hdr_obj->header_field_names;

        # Only "X-Varnish" is the standard, but some people use
        # custom and/or debugging headers
        for my $name (@hdr_names) {
            next unless $name =~ m{^X\-Varnish};
            my $value = $res->header($name) || q{};
            diag("$name: $value");
        }

    }

    my $main_header = $res->header("X-Varnish");
    #my $status = $res->header("X-Varnish-Status");
    #my $cacheable = $res->header("X-Varnish-Cacheable");

    # "X-Varnish: 2131920313 1299858343" means cached
    # "X-Varnish: 2039442137" means not cached
    if (defined $main_header && $main_header =~ m{^ \s* \d+ \s+ \d+ \s* $}mx) {
        $cached = 1;
    }

    return $cached;
}

sub new {
    my ($class, $opt) = @_;

    $class = ref $class || $class;
    $opt ||= {};

    my $self = {
        _verbose => $opt->{verbose},
    };

    bless $self, $class;
}

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

    my $is_cached = $self->_is_cached($args);
    my $url = $args->{url};

    if (! defined $is_cached) {
        $message ||= qq{Request to url '$url' failed};
        return ok(0 => $message);
    }

    $message ||= qq{Request to url '$url' should be cached by Varnish};

    return ok($is_cached, $message);
}

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

    my $is_cached = $self->_is_cached($args);
    my $url = $args->{url};

    if (! defined $is_cached) {
        $message ||= qq{Request to url '$url' failed};
        return ok(0 => $message);
    }

    $message ||= qq{Request to $url should not be cached by Varnish};

    return ok(! $is_cached, $message);
}

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

    if (! $args || ref $args ne 'HASH') {
        croak q{is_cached() requires a hashref};
    }

    # 'headers' is optional, 'url' is mandatory
    if (! $args->{url}) {
        croak q{is_cached() requires a 'url'};
    }

    my $res = $self->request($args);

    # Request failed, assert a test failure
    if (! $res) {
        return;
    }

    # Request successful, check if varnish has cached it
    return $self->analyze_response($res);

}

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

    my $method = $args->{method} || q(GET);
    my $headers = $args->{headers} || {};
    my $url = $args->{url};

    if (! $url) {
        croak(q(No 'url' argument?));
    }

    #if (! exists $headers->{Host} || ! $headers->{Host}) {
    #   croak(q(No 'host' header?));
    #}

    # Init user agent object
    my $ua = $self->user_agent();

    # Avoid the '//' or varnish rules don't fire properly
    my $host = $headers->{Host};
    if (! $host) {
        my $url_obj = URI->new($url);
        if (! $url_obj) {
            croak(qq(URI failed parsing url '$url'. Can't continue without a "Host" header.));
        }
        $host = $url_obj->host();
    }

    my $req = HTTP::Request->new($method => $url);

    # We need to set HTTP/1.1 Host: header or the varnish
    # rules based on hostname won't kick in (my.cn. vs my.)
    $req->header(Host => $host);

    if ($headers) {
        while (my ($name, $value) = each %{ $headers }) {
            if ($name eq 'Cookie') {
                ($name, $value) = split '=', $value, 2;
                #diag ("Setting cookie [$name] => [$value]");
                $ua->cookie_jar->set_cookie(undef, $name, $value, '/', $host);
                #$req->header(Cookie => "$name=$value");
            }
            else {
                $req->header($name => $value);
            }
        }
    }

    my $res = $ua->request($req);

    #if ($headers && exists $headers->{Cookie}) {
    #    $ua->cookie_jar->clear_temporary_cookies();
    #}

    return $res;
}

sub _response_sets_cookies {
    my ($res) = @_;

    my $cookie_header = $res->header("Set-Cookie");
    #diag("cookie_header: " . ($cookie_header || ""));

    return defined $cookie_header && $cookie_header ne q{}
        ? 1
        : 0;
}

sub user_agent {
    my ($self) = @_;

    my $ua = LWP::UserAgent->new( max_redirect => 0 );
    my $jar = HTTP::Cookies->new();

    $ua->agent($self->user_agent_string());
    $ua->cookie_jar($jar);

    return $ua;
}

sub user_agent_string {

    return qq{Test-Varnish/$VERSION};

}

sub verbose {
    my $self = shift;

    if (@_) {
        $self->{_verbose} = shift(@_) ? 1 : 0;
    }

    return $self->{_verbose};
}

1; # End of Test::Varnish

__END__