git.maemo.org Git - pkg-perl/blob - deb-src/libwww-mechanize-perl/libwww-mechanize-perl-1.34/t/local/overload.t

   1 #!/usr/bin/perl -w
   2
   3 use Test::More skip_all => "Mysteriously stopped passing, and I don't know why.";
   4 use warnings;
   5 use strict;
   6 use lib 't/local';
   7 use LocalServer;
   8 use Test::More tests => 11;
   9
  10 =head1 NAME
  11
  12 overload.t
  13
  14 =head1 SYNOPSIS
  15
  16 This tests for various ways, advertised in L<WWW::Mechanize>, to
  17 create a subclass of the mech to alter it's behavior in a useful
  18 manner. (Of course free-style overloading is discouraged, as it breaks
  19 encapsulation big time.)
  20
  21 This test first feeds some bad HTML to Mech to make sure that it throws
  22 an error.  Then, it overloads update_html() to fix the HTML before
  23 processing it, and then we should not have an error.
  24
  25 =head2 Overloading update_html()
  26
  27 This is the recommended way to tidy up the received HTML in a generic
  28 way, and/or to install supplemental "surface tests" on the HTML
  29 (e.g. link checker).
  30
  31 =cut
  32
  33 BEGIN {
  34     delete @ENV{ grep { lc eq 'http_proxy' } keys %ENV };
  35     delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };
  36     use_ok( 'WWW::Mechanize' );
  37 }
  38
  39 my $server = LocalServer->spawn(html => <<'BROKEN_HTML');
  40 <html>
  41 <head><title>Broken document</head>
  42 <form>
  43 <table>
  44 <tr><select name="foo">
  45 <option value="bar">Bar</option></td></tr>
  46 </form>
  47 </html>
  48 BROKEN_HTML
  49 isa_ok( $server, 'LocalServer' );
  50
  51 do {
  52     package MyMech;
  53     use base 'WWW::Mechanize';
  54
  55     sub update_html {
  56         my $self = shift;
  57         my $html = shift;
  58
  59         $html =~ s[Broken][Fixed]isg or die "Couldn't fix the HTML for the test (#1)";
  60         $html =~ s[</option>.{0,3}</td>][</option></select></td>]isg or die "Couldn't fix the HTML for the test (#2)";
  61
  62         $self->WWW::Mechanize::update_html( $html );
  63     }
  64 };
  65
  66 my $carpmsg;
  67 local $^W = 1;
  68 no warnings 'redefine';
  69 local *Carp::carp = sub {$carpmsg = shift};
  70
  71 my $mech = WWW::Mechanize->new();
  72 isa_ok( $mech, 'WWW::Mechanize' );
  73
  74 $mech->get( $server->url );
  75 like($carpmsg, qr/bad.*select/i, 'Standard mech chokes on bogus HTML');
  76
  77 # If at first you don't succeed, try with a shorter bungee...
  78 undef $carpmsg;
  79 $mech = MyMech->new();
  80 isa_ok( $mech, 'WWW::Mechanize', 'Derived object' );
  81
  82 my $response = $mech->get( $server->url );
  83 isa_ok( $response, 'HTTP::Response', 'Response I got back' );
  84 ok( $response->is_success, 'Got URL' ) or die 'Can\'t even fetch local url';
  85 ok( $mech->is_html, 'Local page is HTML' );
  86 ok( !$carpmsg, 'No warnings this time' );
  87
  88 my @forms = $mech->forms;
  89 is( scalar @forms, 1, 'One form' );
  90
  91 like($mech->content(), qr[/select], 'alteration visible in ->content() too');