#!/usr/bin/perl -w use strict; use lib 't/lib', 'extlib', 'lib', '../lib', '../extlib'; use Test::More; BEGIN { plan $ENV{MT_TEST_SPIDER} ? (tests => 4) : (skip_all => 'Enable spider test with MT_TEST_SPIDER environment variable') ; } use LWP::UserAgent::Local; use URI; use MT::Test qw(:db :data); my $username = "Chuck D"; # Melody my $password = "bass"; # Nelson unlink "t/cookie.jar"; use HTTP::Cookies; my $cgipath = MT->config->CGIPath; $cgipath =~ s/\/*$//; my $cookie_jar = HTTP::Cookies->new(file => "t/cookie.jar"); my $ua = new LWP::UserAgent::Local({ ScriptAlias => "$cgipath/", AddHandler => 'cgi-script .cgi', cookie_jar => $cookie_jar, }); my $start_link = "http://localhost" . $cgipath . "/mt.cgi?username=$username&password=$password"; my $start_url = new URI($start_link); my %link_queue; my %links_checked; my $count = 0; my $link_count = 0; my @failures; my @notgoods; my @notgood_pages; my @fetched; my @warnings; my %modes_seen; my $skip_pattern = qr{logout|export|magic_token}; my $must_match = qr{(/cgi-bin/|^\?).*mt\.cgi}; my $warning_pattern = qr{Uninitialized}; my $good_pattern = qr{Copyright .* 2001-\d+ Six Apart\. All Rights Reserved\.}; my $bad_pattern = qr{|time\s+to\s+upgrade!}i; my $verbose = 0; my $debug = 1; my $test_mode = 1; $link_queue{$start_link} = $start_link; while (keys %link_queue && $count < 500) { my ($curr_link, $its_parent) = %link_queue; $link_count++; delete $link_queue{$curr_link}; next unless $curr_link =~ m/$must_match/; next if $skip_pattern && $curr_link =~ m/$skip_pattern/; $curr_link = URI->new_abs($curr_link, $its_parent); next if $curr_link->scheme ne 'http' && $curr_link->scheme ne 'https'; next if $curr_link->host ne $start_url->host(); unless ($links_checked{$curr_link}) { print "REQUESTING $curr_link\n" if $verbose; my $req = new HTTP::Request(GET => $curr_link) or die "a thousand deaths"; my $resp = $ua->request($req) or next; #print STDERR "Response: [" . $resp->content() . "]\n" if $verbose; use Data::Dumper; print STDERR $resp->content() unless $resp->content() =~ m/$good_pattern/; push @failures, $curr_link unless $resp->is_success; my ($mode) = ($curr_link =~ m/__mode=([^&]*)/); if ($mode) { if (exists $modes_seen{$mode}) { $modes_seen{$mode}++; } else { $modes_seen{$mode} = 1; } } $count++; my $content = $resp->content(); push @notgoods, $curr_link unless $content =~ m/$good_pattern/; push @notgoods, $curr_link if $content =~ m/$bad_pattern/; push @warnings, $curr_link if $content =~ m/$warning_pattern/; push @fetched, $curr_link; my @form_actions = $content =~ m|