File Coverage

blib/lib/Test/XHTML.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package Test::XHTML;

use strict;
use warnings;

use vars qw($VERSION);
$VERSION = '0.13';

#----------------------------------------------------------------------------

=head1 NAME

Test::XHTML - Test web page code validation.

=head1 SYNOPSIS

    use Test::XHTML;

    my $tests = "t/102-internal-level7.csv";
    Test::XHTML::runtests($tests);

=head1 DESCRIPTION

Test the validation of a list of URLs. This includes DTD Validation, WAI WCAG
v2.0 compliance and basic Best Practices.

=cut

# -------------------------------------
# Library Modules

use IO::File;
use Data::Dumper;
use Test::Builder;
use Test::XHTML::Valid;
use Test::XHTML::WAI;
use Test::XHTML::Critic;
use WWW::Mechanize;

# -------------------------------------
# Singletons

my $mech    = WWW::Mechanize->new();
my $txv     = Test::XHTML::Valid->new(mech => $mech);
my $txw     = Test::XHTML::WAI->new();
my $txc     = Test::XHTML::Critic->new();
my $Test    = Test::Builder->new();

sub import {
    my $self    = shift;
    my $caller  = caller;
    no strict 'refs';
    *{$caller.'::runtests'} = \&runtests;
    *{$caller.'::setlog'}   = \&setlog;

    my @args = @_;

    $Test->exported_to($caller);
    $Test->plan(@args)  if(@args);
}

# -------------------------------------
# Public Methods

sub runtests {
    my $tests = shift;
    my ($link,$type,$content,%config,@all);

    my $fh = IO::File->new($tests,'r') or die "Cannot open file [$tests]: $!\n";
    while(<$fh>) {
        s/\s*$//;
        s/^[#,].*$//;
        next    if(/^\s*$/);

        my ($cmd,$text,$label) = split(',',$_,3);
        #$cmd =~ s/\s*$//;
        #$Test->diag("cmd=[$cmd], text=[$text], label=[$label]");

        if($cmd eq 'config') {
            my ($key,$value) = split('=',$text,2);
            $config{lc $key} = $value;
            $txw->level($value) if($key =~ /wai/i);
        } elsif($cmd eq 'all body') {
            push @all, {type => 'like', text => $text, label => $label};
        } elsif($cmd eq 'all body not') {
            push @all, {type => 'unlike', text => $text, label => $label};
        } elsif($cmd eq 'except') {
            push @{ $all[-1]->{except} }, $text;

        } elsif($cmd eq 'body') {
            $label ||= ".. embedded text ('$text') found for '$link'";
            $Test->like($content,qr!$text!s, $label);
            $Test->diag($content)  if($content !~ m!$text!s && $config{'dump'});

        } elsif($cmd eq 'body not') {
            $label ||= ".. embedded text ('$text') not found for '$link'";
            $Test->unlike($content,qr!$text!s, $label);
            $Test->diag($content)  if($content =~ m!$text!s && $config{'dump'});

        } elsif($cmd eq 'form' && $type eq 'url') {
            my ($fname,$ftype) = split('=',$text,2);
            $ftype = undef  unless($ftype =~ /^(num|name|id)$/);
            my $ok = 0;
            my $rs;

            if($fname =~ /^\d+$/ && (!$ftype || $ftype eq 'num')) {
                eval { $rs = $mech->form_number($fname) };
                #$Test->diag("form_number: rs=$rs, [$@]");
                if(!$@ && $rs) { $ok = 1; }
            }
            if(!$ok && (!$ftype || $ftype eq 'name')) {
                eval { $rs = $mech->form_name($fname) };
                #$Test->diag("form_name: rs=$rs, [$@]");
                if(!$@ && $rs) { $ok = 1; }
            }
            if(!$ok && (!$ftype || $ftype eq 'id')) {
                eval { $rs = $mech->form_id($fname) };
                #$Test->diag("form_id: rs=$rs, [$@]");
                if(!$@ && $rs) { $ok = 1; }
            }

            $Test->ok($ok,".. form '$fname' found");

        } elsif($cmd eq 'input' && $type eq 'url') {
            my ($key,$value) = split('=',$text,2);
            if($text eq 'submit' || $key eq 'submit') {
                $mech->submit();
                if($mech->success()) {
                    $content = $mech->content();
                    $link = $mech->base();

                    if(my $result = _check_xhtml(\%config,'xml',$content)) {
                        $Test->is_num($result->{PASS},1,"XHTML validity check for '$link'");
                        if($result->{PASS} != 1) {
                            $Test->diag($txv->errstr());
                            $Test->diag(Dumper($txv->errors())) if($config{ 'dump'});
                            $Test->diag(Dumper($result))        if($config{ 'dump'});
                        }
                    }

                    if(my $result = _check_wai(\%config,$content)) {
                        $Test->is_num($result->{PASS},1,"Content passes basic WAI compliance checks for '$link'");
                        if($result->{PASS} != 1) {
                            $Test->diag($txw->errstr());
                            $Test->diag(Dumper($txw->errors()))     if($config{ 'dump'});
                            $Test->diag(Dumper($result))            if($config{ 'dump'});
                            $Test->diag(Dumper($content))           if($config{ 'dump'} && $config{ 'dump'} == 2);
                        }
                    }

                    if(my $result = _check_critic(\%config,$content)) {
                        $Test->is_num($result->{PASS},1,"Content passes basic page critique checks for '$link'");
                        if($result->{PASS} != 1) {
                            $Test->diag($txc->errstr());
                            $Test->diag(Dumper($txc->errors()))     if($config{ 'dump'});
                            $Test->diag(Dumper($result))            if($config{ 'dump'});
                            $Test->diag(Dumper($content))           if($config{ 'dump'} && $config{ 'dump'} == 2);
                        }
                    }

                } else {
                    $content = '';
                }
            } else {
                $mech->field($key,$value);
            }

        } elsif($cmd eq 'file') {
            $type = $cmd;
            $link = $text;

            if(my $result = _check_xhtml(\%config,$type,$link)) {
                $Test->is_num($result->{PASS},1,"XHTML validity check for '$link'");
                if($result->{PASS} != 1) {
                    $Test->diag($txv->errstr());
                    $Test->diag(Dumper($txv->errors())) if($config{ 'dump'});
                    $Test->diag(Dumper($result))        if($config{ 'dump'});
                }
            }


            $content = $txv->content();
            $label ||= "Got FILE '$link'";
            $Test->ok($content,$label);

            if(my $result = _check_wai(\%config,$content)) {
                $Test->is_num($result->{PASS},1,"Content passes basic WAI compliance checks for '$link'");
                if($result->{PASS} != 1) {
                    $Test->diag($txw->errstr());
                    $Test->diag(Dumper($txw->errors()))     if($config{ 'dump'});
                    $Test->diag(Dumper($result))            if($config{ 'dump'});
                    $Test->diag(Dumper($content))           if($config{ 'dump'} && $config{ 'dump'} == 2);
                }
            }

            if(my $result = _check_critic(\%config,$content)) {
                $Test->is_num($result->{PASS},1,"Content passes basic page critique checks for '$link'");
                if($result->{PASS} != 1) {
                    $Test->diag($txc->errstr());
                    $Test->diag(Dumper($txc->errors()))     if($config{ 'dump'});
                    $Test->diag(Dumper($result))            if($config{ 'dump'});
                    $Test->diag(Dumper($content))           if($config{ 'dump'} && $config{ 'dump'} == 2);
                }
            }

            for my $all (@all) {
                my $ignore = 0;
                for my $except (@{ $all->{except} }) {
                    next    unless($link =~ /$except/);
                    $ignore = 1;
                }

                if($all->{type} eq 'like') {
                    $label = $all->{label} || ".. embedded text ('$all->{text}') found for '$link'";
                    next    if($ignore);
                    $Test->like($content,qr!$all->{text}!, $label);
                    $Test->diag($content)  if($content !~ m!$all->{text}! && $config{'dump'});
                } else {
                    $label = $all->{label} || ".. embedded text ('$all->{text}') not found for '$link'";
                    next    if($ignore);
                    $Test->unlike($content,qr!$all->{text}!, $label);
                    $Test->diag($content)  if($content =~ m!$all->{text}! && $config{'dump'});
                }
           }

        } elsif($cmd eq 'url') {
            $type = $cmd;
            $link = $text;

            if(my $result = _check_xhtml(\%config,$type,$link)) {
                $Test->is_num($result->{PASS},1,"XHTML validity check for '$link'");
                if($result->{PASS} != 1) {
                    $Test->diag($txv->errstr());
                    $Test->diag(Dumper($txv->errors())) if($config{ 'dump'});
                    $Test->diag(Dumper($result))        if($config{ 'dump'});
                }
            }

            $content = $txv->content();
            $label ||= "Got URL '$link'";
            $Test->ok($content,$label);

            if(my $result = _check_wai(\%config,$content)) {
                $Test->is_num($result->{PASS},1,"Content passes basic WAI compliance checks for '$link'");
                if($result->{PASS} != 1) {
                    $Test->diag($txw->errstr());
                    $Test->diag(Dumper($txw->errors()))     if($config{ 'dump'});
                    $Test->diag(Dumper($result))            if($config{ 'dump'});
                    $Test->diag(Dumper($content))           if($config{ 'dump'} && $config{ 'dump'} == 2);
                }
            }

            if(my $result = _check_critic(\%config,$content)) {
                $Test->is_num($result->{PASS},1,"Content passes basic page critique checks for '$link'");
                if($result->{PASS} != 1) {
                    $Test->diag($txc->errstr());
                    $Test->diag(Dumper($txc->errors()))     if($config{ 'dump'});
                    $Test->diag(Dumper($result))            if($config{ 'dump'});
                    $Test->diag(Dumper($content))           if($config{ 'dump'} && $config{ 'dump'} == 2);
                }
            }

            for my $all (@all) {
                my $ignore = 0;
                for my $except (@{ $all->{except} }) {
                    next    unless($link =~ /$except/);
                    $ignore = 1;
                }

                if($all->{type} eq 'like') {
                    $label = $all->{label} || ".. embedded text ('$all->{text}') found for '$link'";
                    next    if($ignore);
                    $Test->like($content,qr!$all->{text}!, $label);
                    $Test->diag($content)  if($content !~ m!$all->{text}! && $config{'dump'});
                } else {
                    $label = $all->{label} || ".. embedded text ('$all->{text}') not found for '$link'";
                    next    if($ignore);
                    $Test->unlike($content,qr!$all->{text}!, $label);
                    $Test->diag($content)  if($content =~ m!$all->{text}! && $config{'dump'});
                }
           }

        }
    }
    $fh->close;
}

sub _check_xhtml {
    my ($config,$type,$link) = @_;

    if($config->{xhtml}) {
        $txv->clear();

           if($type eq 'file')  { $txv->process_file($link); }
        elsif($type eq 'url')   { $txv->process_link($link); }
        elsif($type eq 'xml')   { $txv->process_xml($link); }

        return $txv->process_results();

    } else {
           if($type eq 'file')  { $txv->retrieve_file($link); }
        elsif($type eq 'url')   { $txv->retrieve_url($link); }
    }

    return;
}

sub _check_wai {
    my ($config,$content) = @_;

    return  unless($config->{wai});

    $txw->clear();
    $txw->validate($content);
    return $txw->results();
}

sub _check_critic {
    my ($config,$content) = @_;

    return  unless($config->{critic});

    $txc->clear();
    $txc->validate($content);
    return $txc->results();
}

sub setlog {
    my %hash = @_;

    $txv->logfile($hash{logfile})    if($hash{logfile});
    $txv->logclean($hash{logclean})  if(defined $hash{logclean});

    $txw->logfile($hash{logfile})    if($hash{logfile});
    $txw->logclean($hash{logclean})  if(defined $hash{logclean});
}

1;

__END__