Test::WWW::Mechanize::JSON - Add a JSON and AJAXy methods to the super-class

Test-WWW-Mechanize-JSON documentation Contained in the Test-WWW-Mechanize-JSON distribution.

Index

Code Index:

NAME

Top

Test::WWW::Mechanize::JSON - Add a JSON and AJAXy methods to the super-class

SYNOPSIS

Top

	use Test::More 'no_plan';
	use_ok("Test::WWW::Mechanize::JSON") or BAIL_OUT;
	my $MECH = Test::WWW::Mechanize::JSON->new(
		noproxy => 1,
		etc     => 'other-params-for-Test::WWW::Mechanize',
	);
	$MECH->get('http://example.com/json');
	my $json_as_perl = $MECH->json_ok or BAIL_OUT Dumper $MECH->response;
	$MECH->diag_json;

DESCRIPTION

Top

Extends Test::WWW::Mechanize to test JSON content in response bodies and x-json headers.

It adds a few HTTP verbs to Mechanize, for convenience.

METHODS: HTTP VERBS

$mech->put

An HTTP 'put' request, using HTTP::Request::Common.

At the time of wriring, modules that rely on HTTP::Request::Common treat PUT as a type of GET, when the spec says it is really a type of POST:

	The fundamental difference between the POST and PUT requests is reflected in the different meaning of the Request-URI.
	                           -- HTTP specification

$mech->delete

An HTTP 'delete' request, using HTTP::Request::Common.

$mech->options

An HTTP 'options' request, using HTTP::Request::Common.

$mech->head

An HTTP 'head' request, using HTTP::Request::Common.

METHODS: ASSERTIONS

$mech->json_ok($desc)

Tests that the last received resopnse body is valid JSON.

A default description of "Got JSON from $url" or "Not JSON from $url" is used if none if provided.

Returns the JSON object, that you may perform further tests upon it.

$mech->x_json_ok($desc)

As $mech-json_ok($desc)> but examines the x-json header.

any_json_ok( $desc )

Like the other JSON methods, but passes if the response contained JSON in the content or x-json header.

$mech->diag_json

Like diag, but renders the JSON of body the last request with indentation.

$mech->diag_x_json

Like diag, but renders the JSON from the x-json header of the last request with indentation.

$mech->utf8_ok( $desc )

Passes if the last response contained a charset=utf-8 definition in its content-type header.

AUTHOR AND COPYRIGHT

Top

Copyright (C) Lee Goddard, 2009/2011.

Available under the same terms as Perl itself.

Test-WWW-Mechanize-JSON documentation Contained in the Test-WWW-Mechanize-JSON distribution. 
use strict;
use warnings;

package Test::WWW::Mechanize::JSON;

our $VERSION = 0.72;

use base "Test::WWW::Mechanize";
use JSON::Any;



sub put {
    my ($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    
	require HTTP::Request::Common;
	my $r = HTTP::Request::Common::POST(@parameters);
	$r->{_method} = 'PUT';
    return $self->request( $r, @suff );
}



sub delete {
    require HTTP::Request::Common;
    my ($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff );
}



sub options {
    require HTTP::Request::Common;
    my ($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    return $self->request( HTTP::Request::Common::_simple_req( 'OPTIONS', @parameters ), @suff );
}



sub head {
    require HTTP::Request::Common;
    my ($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    return $self->request( HTTP::Request::Common::_simple_req( 'HEAD', @parameters ), @suff );
}


sub json_ok {
	my ($self, $desc) = @_;
	return $self->_json_ok( $desc, $self->content );
}



sub x_json_ok {
	my ($self, $desc) = @_;
	return $self->_json_ok( 
		$desc, 
		$self->response->headers->{'x-json'}
	);
}

sub json {
	my ($self, $text) = @_;
	$text ||= exists $self->response->headers->{'x-json'}?
		$self->response->headers->{'x-json'}
	:	$self->content;
	my $json = eval {
		JSON::Any->jsonToObj($text);
	};
	return $json;
}


sub any_json_ok {
	my ($self, $desc) = @_;
	return $self->_json_ok( 
		$desc, 
		$self->json
	);
}	


sub _json_ok {
	my ($self, $desc, $text) = @_;
	my $json = $self->json( $text );

	if (not $desc){
		if (defined $json and ref $json eq 'HASH' and not $@){
			$desc = sprintf 'Got JSON from %s', $self->uri;
		}
		else {
			$desc = sprintf 'Not JSON from %s (%s)', $self->uri, $@;
		}
	}
	
	Test::Builder->new->ok( $json, $desc );

	return $json || undef;
}



sub diag_json {
	my $self = shift;
	return _diag_json( $self->content );
}


sub diag_x_json {
	my $self = shift;
	return _diag_json( 
		$self->response->headers->{'x-json'}
	);
}

sub _diag_json {
	my ($self, $text) = @_;
	eval {
		my $json = $self->json( $text );

		if (defined $json and ref $json eq 'HASH' and not $@){
			diag JSON::Any->objToJson;
		} else {
			warn "Er...";
		}
	};
	warn $@ if $@;
}


sub utf8 {
	return $_[0]->response->headers('content-type') =~ m{charset=\s*utf-8}? 1 : 0;
}


sub utf8_ok {
	my $self = shift;
	my $desc = shift || 'Has a utf-8 heaer';
	Test::Builder->new->ok( $self->utf8, $desc );
}


	


1;


1;