Test::WWW::Mechanize::Object - run mech tests by making

  use Test::WWW::Mechanize::Object;
  my $mech = Test::WWW::Mechanize::Object->new(handler => $obj);
  $mech->get_ok('/foo');
  # use $mech as usual, omitting scheme/host if you want to

  $obj->request($request);

  http://localhost.localdomain (the default default)
  http://myserver.com/myurl

  $obj->prepare_request($request, $mech);

  $obj->before_request($request, $mech);

  $obj->after_request($request, $response, $mech);

  $obj->on_redirect($request, $response, $mech);

  $mech->get('/foo', ...);

    perldoc Test::WWW::Mechanize::Object

package Test::WWW::Mechanize::Object;

use v5.6.1;
use Carp ();
use warnings;
use strict;
use base qw(Test::WWW::Mechanize);

our $VERSION = '0.020';

sub new {
  my ($class, %arg) = @_;
  my $handler = delete $arg{handler}
    or Carp::croak("the 'handler' argument is required for $class->new()");
  my $self = $class->SUPER::new(%arg);
  $self->{handler} = $handler;
  return $self;
}

sub __hook {
  my ($self, $hookname, $args) = @_;
  return unless my $meth = $self->{handler}->can($hookname);
  $self->{handler}->$meth(@$args);
}

sub _make_request {
  my ($self, $request, @rest) = @_;
  $self->__hook(prepare_request => [ $request, $self ]);
  $self->SUPER::_make_request($request, @rest);
}

sub __add_url_base {
  my $self = shift;
  my $url  = shift;
  if ($url =~ m!^/!) {
    #warn "prepending url_base to $url\n";
    $url = $self->__url_base . $url;
    $url =~ s{(?<!:)/+}{/}g;
  }
  return ($url, @_);
}

# replaces "$old" with "$new" in $uri
sub __rebase_uri {
  my ($uri, $old, $new) = @_;
  return $uri if $old->eq($new);
  my $clone = $uri->clone;
  for my $part (qw(host scheme)) {
    return $uri unless $clone->$part eq $old->$part;
  }
  my %path = (
    clone => [ grep { length } $clone->path_segments ],
    old   => [ grep { length } $old->path_segments ],
  );
  while (@{$path{clone}} and @{$path{old}}
           and $path{clone}->[0] eq $path{old}->[0]
         ) {
    shift @{$path{$_}} for qw(clone old);
  }
  if (@{$path{old}}) {
    # unmatched path parts remaining
    return $uri;
  }
  for my $part (qw(host scheme)) {
    $clone->$part($new->$part);
  }
  my $path = join "/", $new->path_segments, @{$path{clone}};
  $path =~ s{/+}{/}g;
  $clone->path($path);
  return $clone->canonical;
}

sub __rebase_request_uri {
  my $req = shift;
  $req->uri( __rebase_uri( $req->uri, @_ ) );
}

sub __url_base {
  my $self = shift;
  return $self->{__url_base} ||= (
    $self->{handler}->can('url_base') ?
      URI->new($self->{handler}->url_base)->canonical :
        $self->__default_url_base
      );
}

sub __default_url_base {
  my $self = shift;
  return $self->{__default_url_base} ||= (
    URI->new(
      $self->{handler}->can('default_url_base') ?
        $self->{handler}->default_url_base :
          'http://localhost.localdomain'
        )
  );
}

BEGIN {
  for my $sub (qw(get head post)) {
    no strict 'refs';
    *$sub = sub {
      my $self = shift;
      my $meth = "SUPER::$sub";
      $self->$meth($self->__add_url_base(@_));
    }
  }
}

sub send_request {
  my ($self, $request, $arg, $size) = @_;
  $self->__hook(before_request => [ $request, $self ]);
  # url_base will have already been added, so we change it to the default here
  __rebase_request_uri(
    $request,
    $self->__url_base,
    $self->__default_url_base,
  );
  my $response = $self->{handler}->request($request);
  $response->request($request);

  # change the default back to the real current url_base for cookie extraction
  __rebase_request_uri(
    $request,
    $self->__default_url_base,
    $self->__url_base,
  );
  # change cookie and location headers
  unless ($self->__url_base->eq($self->__default_url_base)) {
    for my $header (qw(Set-Cookie Set-Cookie2 Set-Cookie3)) {
      my @values = $response->header($header);
      $response->header($header => [ map {
        #warn "$header: was: $_\n";
        my $domain = $self->__default_url_base->host;
        my $path   = $self->__default_url_base->path || '/';
        if (m{  \b domain = \Q$domain\E ([;\s]|$) }x and
              m{\b path   = \Q$path\E ([;\s]|$) }x) {
          s{    \b domain = \Q$domain\E ([;\s]|$) }
                        {domain=@{[ $self->__url_base->host ]}$1}x;
          s{    \b path   = \Q$path\E ([;\s]|$)}
                        {path=@{[ $self->__url_base->path ]}$1}x;
        }
        #warn "$header: now: $_\n";
        $_
      } @values ]);
    }
  }

  $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;

  $self->__hook(after_request => [ $request, $response, $self ]);

  if ($response->is_redirect) {
    $self->__hook(on_redirect => [ $request, $response, $self ]);
    unless ($self->__url_base->eq($self->__default_url_base)) {
      $response->header(
        Location => __rebase_uri(
          URI->new($response->header('Location')),
          $self->__default_url_base,
          $self->__url_base,
        ),
      );
    }
  }

  return $response;
}

1; # End of Test::WWW::Mechanize::Object