[Http-webtest-commits] HTTP-WebTest/lib/HTTP/WebTest/Plugin LinksTest.pm,NONE,1.1

[Ilya M. <m_...@us...>]

Update of /cvsroot/http-webtest/HTTP-WebTest/lib/HTTP/WebTest/Plugin
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30168/lib/HTTP/WebTest/Plugin

Added Files:
	LinksTest.pm 
Log Message:
Added LinksTest.pm


--- NEW FILE: LinksTest.pm ---
package HTTP::WebTest::Plugin::LinksTest;

use strict;
use base qw(HTTP::WebTest::Plugin);
use HTML::TokeParser;
use URI;

sub param_types {
    return q(check_links yesno);
}

sub check_response {
    my $self = shift;

    $self->validate_params(qw(check_links));

    return if $self->test_param('check_links') !~ /yes/i;

    my $curr_res = $self->webtest->current_response;
    return unless $curr_res->is_success;

    ## do nothing unless it is HTML
    return unless $curr_res->content_type eq 'text/html';

    my $links = $self->find_links(response => $curr_res);

    return unless $links;

    my $link         = "";
    my $ua           = $self->webtest->user_agent;
    my $failures     = "";
    my $link_count   = scalar @$links;
    my $failed_count = 0;
    foreach $link (@$links) {
       my $req = HTTP::Request->new(HEAD => $link->{url});
       my $res = $ua->request($req);

       unless ($res->is_success) {
          $failed_count++;
          $failures .= " link: ".$link->{'url'}.
                       "(".$res->status_line.")\n";
       }
    }

    my $status  = "$link_count links found. Failed: $failed_count.";
    my $result  = 1;
    my $comment = $status;

    if ($failures)  {
        $result  = 0;
        $comment = $status." Failures: ".$failures;
    }

    return ['CHECK LINKS',$self->test_result($result,$comment)];
}

sub find_base {
    my $self = shift;
    my $response = shift;

    my $base    = $response->base;
    my $content = $response->content;

    ## look for base tag inside of head tag
    my $parser = HTML::TokeParser->new(\$content);
    my $token  = $parser->get_tag('head');
    if (defined $token) {
	$token = $parser->get_tag('base', '/head');

	if ($token->[0] eq 'base') {
	    $base = $token->[1]{href};
	}
    }

    return $base;
}

sub find_links {
    my $self = shift;
    my %param = @_;

    my $response = $param{response};
    my $base     = $self->find_base($response);
    my $content  = $response->content;

    ## look for matching 'link' tags
    my $parser = HTML::TokeParser->new(\$content);
    my @links  = ();
    while (my $token = $parser->get_token) {
        if ($token->[0] eq 'S') {
            ## Process 'start' tags
            my $uri  = "";
            my $type = "";
            if ($token->[1] =~ /^(a|area|link)$/) {
                ## has attr href=URL|URI
                $type = $1;
                $uri  = $token->[2]{href};

                ## Skip mailto and javascript href values
                next if $uri =~ /^(?:mailto|javascript)\:/;

            }
            elsif ($token->[1] =~ /^(img|script|frame|style|embed)$/) {
                ## has attr src=URI
                $type = $1;
                $uri  = $token->[2]{src};

            }
            elsif ($token->[1] eq 'form') {
                ## has attr action=URI
                $type = 'form';
                $uri  = $token->[2]{action};
            }
            elsif ($token->[1] eq 'applet') {
                ## has attr codebase=URL|this.location and code=code.class
                ## will fetch codebase/code.class
                $type = 'applet';
                $uri  = $token->[2]{codebase};
                $uri .= '/' unless $uri =~ /\/$/; ## Append trailing slash
                $uri .= $token->[2]{code};

            }

            next unless $uri;
            push @links,{url  => URI->new_abs($uri,$base),
                         type => $type,
                        };
        }
    }

    return (@links) ? \@links : "";
}

1;

=head1 NAME

HTTP::WebTest::Plugin::LinksTest - Checks links on a webpage

=head1 SYNOPSIS

  ## Example: wt configuration usage

  plugins = ( ::LinksTest )

  test_name = Main page
     url = http://192.168.1.102/
     check_links = yes
  end_test

=head1 DESCRIPTION

This is a plugin module for the HTTP::WebTest test suite. This plugin
checks the links contained with a page (static or dynamic) and reports
back the number of links found and the failure count. The checks consist of
issuing HEAD requests to the URLS used by the following tags:


  * <a    href="..."    ## href="mailto:.. and href="javascript: are skipped
  * <area href="..."
  * <link href="..."

  * <img    src="..."
  * <script src="..."
  * <frame  src="..."
  * <sytle  src="..."
  * <embed  src="..."

  * <form action="..."

  * <applet codebase="URL" code="java.class"

A good chunk of the code was I<gleaned> from the
B<HTTP::WebTest::Plugin::(Click|StatusTest)> modules. Thanks Ilya.

=head1 TEST PARAMETERS

=for pod_merge copy opt_params

=head2 check_links

If set to C<yes> checks links in HTML pages.

=head3 Allowed values

C<yes>, C<no>

=head3 Default value

C<no>

=cut

=head1 SEE ALSO

L<HTTP::WebTest>

=head1 AUTHOR

Carlos  Ramirez, E<lt>ca...@qu...E<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2004 by Carlos  Ramirez

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.3 or,
at your option, any later version of Perl 5 you may have available.

=cut