Permalink
Browse files

Import SVN version (history isn't worth keeping)

  • Loading branch information...
0 parents commit 1d49375425dc9e0e20601db488a38295412459bf @ashb ashb committed Feb 15, 2009
Showing with 285 additions and 0 deletions.
  1. +20 −0 Changes
  2. +37 −0 MANIFEST.SKIP
  3. +16 −0 Makefile.PL
  4. +121 −0 lib/WWW/Mechanize/TreeBuilder.pm
  5. +49 −0 t/01-basic.t
  6. +42 −0 t/lib/MockMechanize.pm
20 Changes
@@ -0,0 +1,20 @@
+Changelog for WWW::Mechanize::TreeBuilder
+
+1.00004 - 2009 Feb 14
+ - Fix delegation with latest Mooses (something seems to have changed along
+ the way) and add tests to it
+ - Bump Moose dep to 0.69 to be on the safe side
+
+1.00003 - 2008 Jan 14
+ - Fix delegation of 'clone' and other methods that already exist on Mechanize
+
+1.00002 - 2007 Sep 6
+ - Fix Makefile.PL so that HTML::TreeBuilder is a dependancy, not just
+ recomended - oops.
+
+1.00001 - 2007 Sep 5
+ - I can't count - fix test count.
+
+1.00000 - 2007 Sep 4
+ - Initial Release
+
@@ -0,0 +1,37 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+,v$
+\B\.svn\b
+
+# Avoid Makemaker generated and utility files.
+\bMakefile$
+\bblib
+\bMakeMaker-\d
+\bpm_to_blib$
+\bblibdirs$
+^MANIFEST\.SKIP$
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build
+
+# Avoid temp and backup files.
+~$
+\.tmp$
+\.old$
+\.bak$
+\#$
+\b\.#
+^\.DS_Store$
+\..*?\.swp$
+
+# Avoid Apache::Test files
+t/conf/apache_test_config.pm
+t/conf/extra.conf$
+t/conf/httpd.conf
+t/conf/mime.types
+t/htdocs
+t/logs
+t/var
+t/store
@@ -0,0 +1,16 @@
+use inc::Module::Install;
+
+perl_version '5.008001';
+name 'WWW-Mechanize-TreeBuilder';
+all_from 'lib/WWW/Mechanize/TreeBuilder.pm';
+license 'perl';
+
+requires 'Moose' => '0.69';
+requires 'HTML::TreeBuilder';
+
+build_requires 'Test::More';
+build:requires 'Test::WWW::Mechanize';
+
+no_index directory => 't/lib';
+
+WriteAll;
@@ -0,0 +1,121 @@
+package WWW::Mechanize::TreeBuilder;
+
+=head1 NAME
+
+WWW::Mechanize::TreeBuilder
+
+=head1 SYNOPSIS
+
+ use Test::More tests => 2;
+ use Test::WWW::Mechanize;
+ # or
+ # use WWW::Mechanize;
+ # or
+ # use Test::WWW::Mechanize::Catalyst 'MyApp';
+
+ my $mech = WWW::Mechanize->new;
+ # or
+ #my $mech = Test::WWW::Mechanize::Catalyst->new;
+ # etc. etc.
+ WWW::Mechanize::TreeBuilder->meta->apply($mech);
+
+ $mech->get_ok('/');
+ ok( $mech->look_down(_tag => 'p')->as_trimmed_text, 'Some text', 'It worked' );
+
+=head1 DESCRIPTION
+
+This module combines WWW::Mechanize and HTML::TreeBuilder. Why? Because I've
+seen too much code like the following:
+
+ like($mech->content, qr{<p>some text</p>}, "Found the right tag");
+
+Which is just all flavours of wrong - its akin to processing XML with regexps.
+Instead, do it like the following:
+
+ ok($mech->look_down(_tag => 'p', sub { $_[0]->as_trimmed_text eq 'some text' })
+
+The anon-sub there is a bit icky, but this means that if the p tag should
+happen to add attributes to the C<< <p> >> tag (such as an id or a class) it
+will still work and find the right tag.
+
+All of the methods avaiable on L<HTML::Element> (that aren't 'private' - i.e.
+everything that doesn't begin with an underscore) such as C<look_down> or
+C<find> are automatically delegated to C<< $mech->tree >> through the magic of
+Moose.
+
+=head1 METHODS
+
+Everything in L<WWW::Mechanize> (or which ever sub class you apply it to) and
+all public methods from L<HTML::Element> except those which WWW::Mechanize
+and HTML::Element give this method. In the case where WWW::Mechanize and
+HTML::TreeBuilder boht define a method, the one from WWW::Mechanize will be
+used (so that the behaviour of Mechanize wont get broken.)
+
+=cut
+
+use Moose::Role;
+use HTML::TreeBuilder;
+
+our $VERSION = '1.00003';
+
+requires '_make_request';
+
+has 'tree' => (
+ is => 'ro',
+ isa => 'HTML::Element',
+ writer => '_set_tree',
+ predicate => 'has_tree',
+ clearer => 'clear_tree',
+ default => undef,
+
+ # Since HTML::Element isn't a moose object, i have to 'list' everything I
+ # want it to handle myself here. how annoying. But since I'm lazy, I'll just
+ # take all subs from the symbol table that dont start with a _
+ handles => sub {
+ my ($attr, $delegate_class) = @_;
+
+ $DB::single = 1;
+ my %methods = map { $_->name => 1
+ } $attr->associated_class->get_all_methods,
+ $attr->associated_class->get_all_attributes;
+
+ return
+ map { $_->name => $_->name }
+ grep { my $n = $_->name; $n !~ /^_/ && !$methods{$n} } $delegate_class->get_all_methods;
+ }
+);
+
+around '_make_request' => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $ret = $self->$orig(@_);
+
+ # Someone needs to learn about weak refs
+ if ($self->has_tree) {
+ $self->tree->delete;
+ $self->clear_tree;
+ }
+
+ if ($ret->content_type =~ m[^(text/html|application/(?:.*?\+)xml)]) {
+ $self->_set_tree( HTML::TreeBuilder->new_from_content($ret->decoded_content)->elementify );
+ }
+
+ return $ret;
+};
+
+sub DEMOLISH {
+ my $self = shift;
+ $self->tree->delete if $self->has_tree;
+}
+
+=head1 AUTHOR
+
+Ash Berlin C<< <ash@cpan.org> >>
+
+=head1 LICENSE
+
+Same as Perl 5.8, or at your option any later version of Perl.
+
+=cut
+
+1;
@@ -0,0 +1,49 @@
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../t/lib";
+
+use Test::More tests => 14;
+
+BEGIN {
+ use_ok 'WWW::Mechanize::TreeBuilder';
+ use_ok 'MockMechanize';
+};
+
+my $mech = MockMechanize->new;
+
+WWW::Mechanize::TreeBuilder->meta->apply($mech);
+
+# Check that the clone come from WWW::Mech, not HTML::TreeBuilder
+my @meths = $mech->meta->find_all_methods_by_name('clone');
+
+is(
+ grep( { $_->{code}{delegate_to_method} } $mech->meta->find_all_methods_by_name('clone')),
+ 0,
+ "clone not delegated to tree"
+);
+
+$mech->get_ok('/', 'Request ok');
+
+# Check we can use normal TWMC methods
+$mech->content_contains('A para');
+
+ok($mech->has_tree, 'We have a HTML tree');
+
+
+
+isa_ok($mech->tree, 'HTML::Element');
+
+is($mech->look_down(_tag => 'p')->as_trimmed_text, 'A para', "Got the right <p> out");
+
+isa_ok($mech->find('h1'), 'HTML::Element', 'Can find an H1 tag');
+like($mech->find('title')->as_trimmed_text, qr/\x{2603}/, 'Copes properly with utf8 encoded data'); # Snowman utf8 test
+
+$mech->get_ok('/image', "Get image okay");
+ok(!$mech->has_tree, "No tree for an image request");
+
+$mech->get_ok('/plain', "Request plain text resource");
+
+ok( !$mech->has_tree, "Plain text content-type has no tree");
+
@@ -0,0 +1,42 @@
+package # Hide from pause
+ MockMechanize;
+
+use strict;
+use warnings;
+
+use base 'Test::WWW::Mechanize';
+
+sub _make_request {
+ my ($self, $req) = @_;
+
+ my ($res);
+
+ if ($req->uri eq '/') {
+ $res = HTTP::Response->new(200, 'OK', ['Content-Type' => 'text/html; charset=utf-8'], <<"EOF");
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html>
+<head>
+ <title>Hurrah \342\230\203!</title>
+</head>
+<body>
+ <h1>It works</h1>
+ <p>A para</p>
+</body>
+</html>
+EOF
+ } elsif ($req->uri eq '/plain') {
+ $res = HTTP::Response->new(200, 'OK', ['Content-Type' => 'text/plain'], "I'm plain text");
+ } elsif ($req->uri eq '/image') {
+ $res = HTTP::Response->new(200, 'OK', ['Content-Type' => 'image/gif'], "I should be an image");
+ }
+
+ $res->request($req);
+ $res->header( 'Content-Base' => $req->uri,
+ 'Content-Length' => length $res->content,
+ Status => 200,
+ Date => 'Tue, 04 Sep 2007 16:57:36 GMT' );
+ return $res;
+}
+
+1;

0 comments on commit 1d49375

Please sign in to comment.