File Coverage

blib/lib/Test/WWW/Simple.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Test::WWW::Simple;

use strict;
use warnings;

our $VERSION = '0.34';

use Test::Builder;
use Test::LongString;
use Test::More;
use WWW::Mechanize::Pluggable;

my $Test = Test::Builder->new;  # The Test:: singleton
my $Mech = WWW::Mechanize::Pluggable->new(autocheck => 0);
                                # The Mech user agent and support methods
my $cache_results = 0;          # default to not caching Mech fetches
our $last_url;                  # last URL fetched successfully by Mech
my %page_cache;                 # saves pages for %%cache; we probably
                                # will want to change this over to a
                                # tied hash later to allow for disk caching
                                # instead of just memory caching.
my %status_cache;               # ditto

$Test::WWW::display_length = 40; # length for display in error messages

sub import {
    my ($class, %args) = @_;
    my $caller = caller;
    no strict 'refs';
    *{$caller.'::page_like_full'}   = \&page_like_full;
    *{$caller.'::page_unlike_full'} = \&page_unlike_full;
    *{$caller.'::text_like'}        = \&text_like;
    *{$caller.'::text_unlike'}      = \&text_unlike;
    *{$caller.'::page_like'}        = \&page_like;
    *{$caller.'::page_unlike'}      = \&page_unlike;
    *{$caller.'::user_agent'}       = \&user_agent;
    *{$caller.'::cache'}            = \&cache;
    *{$caller.'::no_cache'}         = \&no_cache;
    *{$caller.'::mech'}             = \&mech;
    *{$caller.'::last_test'}        = \&last_test;

    $Test->exported_to($caller);

    # Check the 'use' arguments to see if we have either
    # 'agent', 'agent_string', or 'no_agent'.
    #
    # If we have none of these, assume 'Windows IE 6'.
    if (defined $args{agent}) {
      # This is a string suitable for passing to agent_alias.
      my $alias = $args{agent};
      if (grep { /^$alias\z/ } $Mech->known_agent_aliases()) {
         $Mech->agent_alias($alias);
      }
      else {
        die "'$alias' is not a valid WWW::Mechanize user agent alias\n";
      }
    }
    elsif (defined $args{agent_string}) {
      $Mech->agent('agent_string');
    }
    elsif(!defined $args{no_agent}) {
      $Mech->agent_alias('Windows IE 6');
    }
    else {
      # No action; no_agent was defined,
      # so leave the user agent as "WWW::Mechanize/version".
    }

    if (defined $args{tests}) {
      plan tests => $args{tests};
    }
}

sub _clean_text {
  my $page = $Mech->content(format=>'text');
  $page =~ s/\xa0/ /g;
  return $page;
}

sub text_like($$;$) {
    my($url, $regex, $comment) = @_;
    my ($state, $content, $status_line) = _fetch($url);
    $state
      ? like_string(_clean_text(), $regex, $comment)
      : fail "Fetch of $url failed: ".$status_line;
}

sub text_unlike($$;$) {
    my($url, $regex, $comment) = @_;
    my ($state, $content, $status_line) = _fetch($url);
    $state
      ? unlike_string(_clean_text(), $regex, $comment)
      : fail "Fetch of $url failed: ".$status_line;
}

sub page_like($$;$) {
    my($url, $regex, $comment) = @_;
    my ($state, $content, $status_line) = _fetch($url);
    $state
      ? like_string($content, $regex, $comment)
      : fail "Fetch of $url failed: ".$status_line;
}

sub page_unlike($$;$) {
    my($url, $regex, $comment) = @_;
    my ($state, $content, $status_line) = _fetch($url);
    $state
      ? unlike_string($content, $regex, $comment)
      : fail "Fetch of $url failed: ".$status_line;
}

sub page_like_full($$;$) {
    my($url, $regex, $comment) = @_;
    my ($state, $content, $status_line) = _fetch($url);
    $state
      ? like($content, $regex, $comment)
      : fail "Fetch of $url failed: ".$status_line;
}

sub page_unlike_full($$;$) {
    my($url, $regex, $comment) = @_;
    my ($state, $content, $status_line) = _fetch($url);
    $state
      ? unlike($content, $regex, $comment)
      : fail "Fetch of $url failed: ".$status_line;
}

sub _fetch {
  my ($url, $comment) = @_;
  local $Test::Builder::Level = 2;
  my @results;

  if ($cache_results) {
    if (defined $page_cache{$url}) {
      # in cache: return it.
      @results = (1, $page_cache{$url}, $status_cache{$url});
    }
    elsif ($last_url eq $url) {
      # "cached" in Mech object
      @results = (1,
              $page_cache{$url}   = $Mech->content,
              $status_cache{$url} = $Mech->response->status_line);
    }
    else {
      # not in cache - load and save the page (if any)
      $Mech->get($url);
      @results = ($Mech->success,
              $page_cache{$url}   = $Mech->content,
              $status_cache{$url} = $Mech->response->status_line);
    }
  }
  else {
   # not caching. Just grab it.
   $Mech->get($url);
   @results = ($Mech->success, $Mech->content, $Mech->response->status_line);
  }
  $last_url = $_[0];
  $page_cache{$url}   = $results[1];
  $status_cache{$url} = $results[2];
  @results;
}

sub _trimmed_url {
    my $url = shift;
    length($url) > $Test::WWW::display_length
       ? substr($url,0,$Test::WWW::display_length) . "..."
       : $url;
}

sub user_agent {
   my $agent = shift || "Windows IE 6";
   $Mech->agent_alias($agent);
}

sub mech {
  my ($self) = @_;
  return $Mech;
}

sub last_test {
  my($self) = @_;
  return ($Test->details)[-1];
}

sub cache (;$) {
  my $comment = shift;
  $Test->diag($comment) if defined $comment;
  $last_url = "";
  $cache_results = 1;
  1;
}

sub no_cache (;$) {
  my $comment = shift;
  $Test->diag($comment) if defined $comment;
  $last_url = "";
  $cache_results = 0;
  1;
}


1;

__END__