Merge branch 'dev'

Conflicts:
	Mechanize.pm

.travis.yml

@@ -0,0 +1,18 @@
+language: perl
+perl:
+  - "dev"
+  - "5.24"
+  - "5.22"
+  - "5.20"
+  - "5.18"
+  - "5.16"
+  - "5.14"
+  - "5.12"
+  - "5.10"
+sudo: false
+before_install:
+  - git clone git://github.com/travis-perl/helpers ~/travis-perl-helpers
+  - source ~/travis-perl-helpers/init
+  - build-perl
+  - perl -V
+  - cpanm HTML::Lint || true

Changes

@@ -4,6 +4,25 @@ WWW::Mechanize and Test::WWW::Mechanize do not use rt.cpan.org for
 bug tracking.  They are now being tracked via Google Code at
 http://code.google.com/p/www-mechanize/issues/list
 
+NEXT
+------------------------------------
+[ENHANCEMENTS]
+Added a delete_ok() method.  Thanks, moznion.
+
+Added header_exists() and header_matches() methods.  Thanks, Eric
+A. Zarko.
+
+content_contains() now fails if it's called with a regex.  content_like()
+now fails if it's not called with a regex.
+
+
+[FIXES]
+The test server run during the test suite allowed URLs outside of the
+document tree, which could potentially be a security problem.  This has
+been fixed.  Thanks, Tynovsky.
+https://github.com/petdance/test-www-mechanize/issues/33
+
+
 1.44    Sat Jun 30 20:32:04 CDT 2012
 ------------------------------------
 There is no new functionality in this release.

MANIFEST

@@ -11,6 +11,7 @@ t/badlinks.html
 t/click_ok.t
 t/content_contains.t
 t/content_lacks.t
+t/delete_ok.t
 t/fluffy.html
 t/followable_links.t
 t/follow_link_ok.t
@@ -21,6 +22,7 @@ t/goodlinks.html
 t/has_tag.t
 t/head_ok-parms.t
 t/head_ok.t
+t/headers.t
 t/html/form.html
 t/html_lint_ok.t
 t/html/scratch.html

Mechanize.pm

@@ -9,11 +9,11 @@ Test::WWW::Mechanize - Testing-specific WWW::Mechanize subclass
 
 =head1 VERSION
 
-Version 1.44
+Version 1.45_01
 
 =cut
 
-our $VERSION = '1.44';
+our $VERSION = '1.45_01';
 
 =head1 SYNOPSIS
 
@@ -1155,7 +1155,7 @@ sub _default_links_desc {
     return sprintf( '%d link%s %s', $url_count, $url_count == 1 ? '' : 's', $desc_suffix );
 }
 
-# This actually performs the status check of each url.
+# This actually performs the status check of each URL.
 sub _check_links_status {
     my $self = shift;
     my $urls = shift;
@@ -1186,7 +1186,7 @@ sub _check_links_status {
     return @failures;
 }
 
-# This actually performs the content check of each url.
+# This actually performs the content check of each URL.
 sub _check_links_content {
     my $self = shift;
     my $urls = shift;
@@ -1686,6 +1686,52 @@ sub scraped_id_is {
 }
 
 
+=head2 $mech->header_exists( $field [, $desc ] )
+
+Assures that a given response header exists. The actual value of the response header is not checked, only that the header exists.
+
+=cut
+
+sub header_exists {
+    my $self = shift;
+    my $field = shift;
+    my $desc = shift || qq{Response has $field header};
+
+    my $ok = defined($self->response->header($field));
+
+    $TB->ok( $ok, $desc );
+    if ( !$ok ) {
+        $TB->diag( HTTP::Headers::as_string($self->response) ) if $self->response;
+    }
+
+    return $ok;
+}
+
+=head2 $mech->header_matches( $field, $value [, $desc ] )
+
+Assures that a given response header exists and has the given value.  Value may be a string or a regular expression.
+
+=cut
+
+sub header_matches {
+    my $self = shift;
+    my $field = shift;
+    my $value = shift;
+    my $desc = shift || qq{Response has $field header with value '$value'};
+
+    my $actual_value = scalar $self->response->header($field);
+    my $ok = (ref($value) eq 'Regexp')
+       ? defined($actual_value) && ($actual_value =~ $value)
+       : defined($actual_value) && ($actual_value eq $value);
+
+    $TB->ok( $ok, $desc );
+    if ( !$ok ) {
+        $TB->diag( $self->response->header($field) ) if $self->response;
+    }
+    return $ok;
+}
+
+
 =head1 TODO
 
 Add HTML::Tidy capabilities.
@@ -1732,6 +1778,10 @@ L<http://search.cpan.org/dist/Test-WWW-Mechanize>
 =head1 ACKNOWLEDGEMENTS
 
 Thanks to
+Eric A. Zarko,
+moznion,
+Robert Stone,
+tynovsky,
 Jerry Gay,
 Jonathan "Duke" Leto,
 Philip G. Potter,
@@ -1748,7 +1798,7 @@ and Pete Krawczyk for patches.
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2004-2012 Andy Lester.
+Copyright 2004-2016 Andy Lester.
 
 This library is free software; you can redistribute it and/or modify it
 under the terms of the Artistic License version 2.0.

README.md

@@ -1,5 +1,7 @@
 # Test-WWW-Mechanize
 
+[![Build Status](https://travis-ci.org/petdance/test-www-mechanize.svg?branch=dev)](https://travis-ci.org/petdance/test-www-mechanize)
+
 Test::WWW::Mechanize is a subclass of the Perl module WWW::Mechanize
 that incorporates features for web application testing.  For example:
 
@@ -39,7 +41,7 @@ To install this module, run the following commands:
 
 # COPYRIGHT AND LICENSE
 
-Copyright (C) 2004-2012 Andy Lester
+Copyright (C) 2004-2016 Andy Lester
 
 This library is free software; you can redistribute it and/or modify it
 under the terms of the Artistic License version 2.0.

t/TestServer.pm

@@ -5,6 +5,7 @@ use strict;
 
 use Test::More;
 use HTTP::Server::Simple::CGI;
+use Cwd qw( realpath );
 use base qw( HTTP::Server::Simple::CGI );
 
 my $dispatch_table = {};
@@ -58,21 +59,32 @@ sub handle_request {
             $file .= 'index.html';
         }
         $file =~ s/\s+//g;
-
         my $filename = "t/html/$file";
-        if ( -r $filename ) {
+
+        my ($code, $msg) = (200, 'OK');
+        if ( ! -r $filename ) {
+            ($code, $msg) = (404, 'Not Found');
+        }
+        if (index(realpath($filename), realpath("t/html")) != 0) {
+            # don't expose a file outside server root
+            ($code, $msg) = (403, 'Forbidden');
+        }
+
+        print "HTTP/1.0 $code $msg\r\n";
+
+        if ($code == 200) {
             if (my $response=do { local (@ARGV, $/) = $filename; <> }) {
-                print "HTTP/1.0 200 OK\r\n";
-                print "Content-Type: text/html\r\nContent-Length: ", length($response), "\r\n\r\n", $response;
-                return;
+                print
+                    "Content-Type: text/html\r\n",
+                    "Content-Length: ", length($response), "\r\n\r\n",
+                    $response;
             }
         }
         else {
-            print "HTTP/1.0 404 Not found\r\n";
             print
                 $cgi->header,
-                $cgi->start_html('Not found'),
-                $cgi->h1('Not found'),
+                $cgi->start_html($msg),
+                $cgi->h1($msg),
                 $cgi->end_html;
         }
     }

t/headers.t

@@ -0,0 +1,92 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 19;
+use Test::Builder::Tester;
+
+use lib 't';
+use TestServer;
+
+my $server      = TestServer->new;
+my $pid         = $server->background;
+my $server_root = $server->root;
+
+use Test::WWW::Mechanize ();
+
+my $mech = Test::WWW::Mechanize->new( autocheck => 0 );
+isa_ok($mech,'Test::WWW::Mechanize');
+$mech->get_ok( "$server_root/form.html" );
+
+GOOD_EXISTS: {
+    test_out( 'ok 1 - Has Content-Type' );
+    my $ok = $mech->header_exists('Content-Type', 'Has Content-Type');
+    test_test( 'Gets existing header and reports success' );
+    is( ref($ok), '', 'get_ok() should only return a scalar' );
+    ok( $ok, 'And the result should be true' );
+
+    # default desc
+    test_out( 'ok 1 - Response has Content-Type header' );
+    $mech->header_exists('Content-Type');
+    test_test( 'Gets existing header and reports success - default desc' );
+}
+
+BAD_EXISTS: {
+    test_out( 'not ok 1 - Try to get a bad header' );
+    test_fail( +1 );
+    my $ok = $mech->header_exists('Server', 'Try to get a bad header');
+    test_diag( 'Content-Length: ' );
+    test_diag( 'Content-Type: ' );
+    test_diag( 'client-date: ' );
+    test_diag( 'client-peer: ' );
+    test_diag( 'client-response-num: ' );
+    test_diag( 'title: ' );
+    test_test( 'Fails to get nonexistent header and reports failure' );
+
+    is( ref($ok), '', 'get_ok() should only return a scalar' );
+    ok( !$ok, 'And the result should be false' );
+}
+
+GOOD_MATCHES: {
+    test_out( 'ok 1 - Content-Type is "text/html"' );
+    my $ok = $mech->header_matches('Content-Type', 'text/html', 'Content-Type is "text/html"');
+    test_test( 'Matches existing header and reports success' );
+    is( ref($ok), '', 'get_ok() should only return a scalar' );
+    ok( $ok, 'And the result should be true' );
+
+    # regex
+    test_out( 'ok 1 - Content-Type matches /^text\\/html$/' );
+    $mech->header_matches('Content-Type', qr/^text\/html$/, 'Content-Type matches /^text\\/html$/');
+    test_test( 'Matches existing header and reports success - regex' );
+
+    # default desc
+    test_out( 'ok 1 - Response has Content-Type header with value \'text/html\'' );
+    $mech->header_matches('Content-Type', 'text/html');
+    test_test( 'Matches existing header and reports success - default desc' );
+}
+
+BAD_MATCHES: {
+    test_out( 'not ok 1 - Try to match a bad header' );
+    test_fail( +1 );
+    my $ok = $mech->header_matches('Server', 'GitHub.com', 'Try to match a bad header');
+    test_test( 'Fails to match nonexistent header and reports failure' );
+
+    is( ref($ok), '', 'get_ok() should only return a scalar' );
+    ok( !$ok, 'And the result should be false' );
+
+    test_out( 'not ok 1 - Content-Type is "text/plain"' );
+    test_fail( +1 );
+    $mech->header_matches('Content-Type', 'text/plain', 'Content-Type is "text/plain"');
+    test_diag( 'text/html' );
+    test_test( 'Fails to match header and reports failure' );
+
+    test_out( 'not ok 1 - Content-Type matches /^text\\/plain$/' );
+    test_fail( +1 );
+    $mech->header_matches('Content-Type', qr/^text\/plain$/, 'Content-Type matches /^text\\/plain$/');
+    test_diag( 'text/html' );
+    test_test( 'Fails to match header and reports failure - regex' );
+}
+
+$server->stop;
+
+done_testing();