package HTTP::WebTest::Plugin::TagAttTest; use vars qw($VERSION); $VERSION = '0.05'; =head1 NAME HTTP::WebTest::Plugin::TagAttTest - Test by tag and attribute existenc +e =head1 SYNOPSIS Not Applicable =head1 DESCRIPTION This plugin allows to forbid or require tags and/or attributes in a we +b page. =cut use strict; use base qw(HTTP::WebTest::Plugin); #use HTTP::Status; =head1 TEST PARAMETERS =for pod_merge copy params =head2 ignore_case Determines if case is important. =head3 Allowed values C<yes>,C<no> =head3 Default value C<no> =head2 tag_require A required tag. This is an array of hashs such as C<< require_tag => [ +{tag=>"script", tag_text=>"spam", attr=>"language",attr_text=>"javasc +ript"}] >> See also the L</TAG HASH> for a more detailed explaination. =head3 Allowed values list of hashes =head3 Default value None (will generate a failed test) =head2 forbid_tag A forbidden tag. This is an array of hashs such as C<< forbid_tag = +> [{tag=>"script",attr=>"language",attr_text=>"javascript"}] >> See also the L</TAG HASH> for a more detailed explaination. =head3 Allowed values list of hashes =head3 Default value None (will generate a failed test) =head1 TAG HASH =head2 tag tag to forbid =head2 attr attribute to forbid =head2 attr_text regular expression or text. If text, will do a substring search. =head2 tag_text regular expression or text. If text, will do a substring search. Note that if an element is missing, it will not be considered. So some +thing like C<require_tag => [{tag=>"title"}]> will assure that a page has a title + tag, but the title tag could be blank. =cut sub param_types { return q(use_case yesno tag_forbid list tag_require list); } sub get_tag($ $) { my ($page, $tag_name) = @_; if (!defined($tag_name)) { return ($page->get_tag) ; } else { my $res = $page->get_tag($tag_name); return ($res); } } sub search_tag($ $ %) { my $ok = 1; my ($page,$case_re, %tag_search_struct) = @_; chomp (%tag_search_struct); my $tag_search = $tag_search_struct{"tag"}; undef $tag_search if ($tag_search eq ''); my $tag_text_search = $tag_search_struct{"tag_text"}; my $attr_search = $tag_search_struct{"attr"}; undef $attr_search if ($attr_search eq ''); my $attr_text_search = $tag_search_struct{"attr_text"}; my @results=(); if (!defined ($tag_search) && !defined ($attr_search)) { $ok = 0; return($ok, "No values for tag searched"); } TAGLOOP: while ( my $tagstruct = get_tag($page,$tag_search) ) { #print @{$tag}[0] . "\n"; my $tag = @{$tagstruct}[0]; if ($tag =~ m!/!) { #print "endtag"; next; } my %attrhash= %{@{$tagstruct}[1]}; my @attrarr = @{@{$tagstruct}[2]}; #the tag exists so we want to see if the contents match if (defined ($tag_text_search) ) { my $tag_content = $page->get_text; if ($tag_content =~ /$case_re\Q$tag_text_search\E/) { $ok = 0; } } elsif (defined ($tag_search)) #if we didn't search a tag, we s +hould continue with the sucess assumption { $ok = 0; #tag found, but no text was searched } if ( (defined ($tag_text_search) || defined ($tag_search)) & +& $ok) { last; #something is already missing, so we can quit. } if ( (!defined ($attr_search) && !defined ($attr_text_search +)) && !($ok)) { last; #no sense in looking further if we're not looking fo +r attrs or attrs text } for my $attribute (@attrarr) { if (!defined($attr_search)) { #print "stop"; my $attr_content = $attrhash{$attribute}; if ($attr_content =~ /$case_re\Q$attr_text_search\E/) { $ok = 0; last TAGLOOP;#don't need to look more } } if (($attribute eq $attr_search)) { if (!(defined ($attr_text_search))) { $ok = 0; last TAGLOOP; #failure } else { my $attr_content = $attrhash{$attribute}; if ($attr_content =~ /$case_re\Q$attr_text_search\ +E/) { $ok = 0; last TAGLOOP;#don't need to look more } } } } } return ($ok, "tag: " . $tag_search . ", tag text: " . $tag_text_s +earch . ", attribute: " . $attr_search . ", attribute text: " . $attr +_text_search); } sub check_response { my $self = shift; # response content my $content = $self->webtest->current_response->content; $self->validate_params(qw(ignore_case tag_forbid tag_require)); # ignore case or not? my $ignore_case = $self->yesno_test_param('ignore_case'); my $case_re = $ignore_case ? '(?i)' : ''; # test results my @results = (); my @ret = (); # check for forbidden tag and attribute for my $tag_forbid_struct (@{$self->test_param('tag_forbid', [])}) { use HTML::TokeParser; my $page = HTML::TokeParser->new(\$content); my %tags_to_forbid = %{$tag_forbid_struct}; my ($ok, $result_string) = search_tag( $page, $case_re, %tags +_to_forbid); push @results, $self->test_result($ok,"Forbidden tag: " . $res +ult_string); } push @ret, ['Forbidden tag and attribute', @results] if @results; @results = (); #nice effect is that requiring a tag is the opposite of forbidding + it. for my $tag_require_struct (@{$self->test_param('tag_require', []) +}) { use HTML::TokeParser; my $page = HTML::TokeParser->new(\$content); my %tags_to_require = %{$tag_require_struct}; my ($ok, $result_string) = search_tag( $page, $case_re, %tags +_to_require); push @results, $self->test_result(!$ok,"Required tag: " . $res +ult_string); } push @ret, ['Required tag and attribute', @results] if @results; @results = (); return @ret; } =head1 COPYRIGHT Copyright (c) 2003-2004 Edward Fancher. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<HTTP::WebTest|HTTP::WebTest> L<HTTP::WebTest::API|HTTP::WebTest::API> L<HTTP::WebTest::Plugin|HTTP::WebTest::Plugin> L<HTTP::WebTest::Plugins|HTTP::WebTest::Plugins> L<HTTP::WebTest::Plugins|HTTP::WebTest::Plugins::TextMatchTest> =cut 1;
In reply to code review for a WebTest Plugin module. by efanche
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |