File Coverage

blib/lib/Test/XHTML/WAI.pm

Criterion	Covered	Total	%
statement	24	213	11.2
branch	0	116	0.0
condition	0	56	0.0
subroutine	8	34	23.5
pod	7	7	100.0
total	39	426	9.1

package Test::XHTML::WAI;

use strict;
use warnings;

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

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

=head1 NAME

Test::XHTML::WAI - Basic WAI compliance checks.

=head1 SYNOPSIS

    my $txw = Test::XHTML::WAI->new();

    $txw->validate($content);       # run compliance checks
    my $results = $txw->results();  # retrieve results

    $txw->clear();                  # clear all current errors and results
    $txw->errors();                 # all current errors reported
    $txw->errstr();                 # basic error message

    $txw->logfile($file);           # logfile for verbose messages
    $txw->logclean(1);              # 1 = overwrite, 0 = append (default)

=head1 DESCRIPTION

This module attempts to check WAI compliance. Currently only basic checks are
implemented, but more comprehensive checks are planned.

=cut

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

use base qw(Class::Accessor::Fast);
use File::Basename;
use File::Path;
use HTML::TokeParser;
use Data::Dumper;

# -------------------------------------
# Variables

my @RESULTS = qw( PASS FAIL );

my $FIXED = $HTML::TokeParser::VERSION >= 3.69 ? 1 : 0;

# For a full list of valid W3C DTD types, please see
# http://www.w3.org/QA/2002/04/valid-dtd-list.html
my %declarations = (
    'xhtml1-strict.dtd'         => 2,
    'xhtml1-transitional.dtd'   => 2,
    'xhtml1-frameset.dtd'       => 2,
    'html401-strict.dtd'        => 1,
    'html401-loose.dtd'         => 1,
    'html401-frameset.dtd'      => 1,
);

my @TAGS = (
    # list taken from http://www.w3schools.com/tags/default.asp
    'a', 'abbr', 'acronym', 'address', 'applet', 'area',
    'b', 'base', 'basefont', 'bdo', 'big', 'blockquote', 'body', 'br', 'button',
    'caption', 'center', 'cite', 'code', 'col', 'colgroup',
    'dd', 'del', 'dfn', 'dir', 'div', 'dl', 'dt',
    'em',
    'fieldset', 'font', 'form', 'frame', 'framset',
    'head', 'h1', 'h2', 'h3', 'h4', 'h5', 'h6', 'hr', 'html',
    'i', 'iframe', 'img', 'input', 'ins',
    'kbd',
    'label', 'legend', 'li', 'link',
    'map', 'menu', 'meta',
    'noframes', 'noscript',
    'object', 'ol', 'optgroup', 'option',
    'p', 'param', 'pre',
    'q',
    's', 'samp', 'script', 'select', 'small', 'span', 'strike', 'strong', 'style', 'sub',
    'table', 'tbody', 'td', 'textarea', 'tfoot', 'th', 'thead', 'title', 'tr', 'tt',
    'u', 'ul',
    'var',

    '/form'
);

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

sub new {
    my $proto = shift; # get the class name
    my $class = ref($proto) || $proto;

    # private data
    my $self  = {level => 1, dtdtype => 0};
    $self->{RESULTS}{$_} = 0    for(@RESULTS);

    bless ($self, $class);
    return $self;
}

sub DESTROY {
    my $self = shift;
}

__PACKAGE__->mk_accessors(qw( logfile logclean ));

sub validate    { _process_checks(@_);  }
sub results     { _process_results(@_); }

sub clear       { my $self = shift; $self->{ERRORS} = undef; $self->_reset_results(); }
sub errors      { my $self = shift; return $self->{ERRORS}; }
sub errstr      { my $self = shift; return $self->_print_errors(); }

sub level       {
    my ($self,$level) = @_;
    $self->{level} = $level if(defined $level && $level =~ /^[123]$/);
    return $self->{level};
}

# -------------------------------------
# Private Methods

sub _process_results {
    my $self = shift;
    my %results = map {$_ => $self->{RESULTS}{$_}} @RESULTS;
    $self->_log( sprintf "%8s%d\n", "$_:", $results{$_} ) for(@RESULTS);
    return \%results;
}

sub _reset_results {
    my $self = shift;
    $self->{RESULTS}{$_} = 0    for(@RESULTS);
}

sub _print_errors {
    my $self = shift;
    my $str = "\nErrors:\n" ;
    my $i = 1;
    for my $error (@{$self->{ERRORS}}) {
        $str .= "$i. $error->{error}: $error->{message}";
        $str .= " [$error->{ref}]"                              if($error->{ref});
        $str .= " [row $error->{row}, column $error->{col}]"    if($error->{row} && $error->{col} && $FIXED);
        $str .= "\n";
        $i++;
    }
    return $str;
}

# -------------------------------------
# Subroutines

# TODO
# (AA) check for absolute rather than relative table cell values
# (A)  label associated with each input id

sub _process_checks {
    my $self = shift;
    my $html = shift;

    # clear data from previous tests.
    $self->{$_} = undef for(qw(input label form links));

    #push @{ $self->{ERRORS} }, {
    #    error => "debug",
    #    message => "VERSION=$HTML::TokeParser::VERSION, FIXED=$FIXED"
    #};

    #use Data::Dumper;
    #print STDERR "#html=".Dumper($html);

    if($html) {
        my $p = $FIXED
                    ? HTML::TokeParser->new( \$html,
                            start => "'S',tagname,attr,attrseq,text,line,column",
                            end   => "'E',tagname,text,line,column"
                      )
                    : HTML::TokeParser->new( \$html );

        #print STDERR "#p=".Dumper($p);

        # determine declaration and the case requirements
        my $token = $p->get_token();
        if($token && $token->[0] eq 'D') {
            my $declaration = $token->[1];
            $declaration =~ s/\s+/ /sg;
            for my $type (keys %declarations) {
                if($declaration =~ /$type/) {
                    $self->{dtdtype} = $declarations{$type};
                    last;
                }
            }
        } else {
            $p->unget_token($token);
        }

        while( my $tag = $p->get_tag( @TAGS ) ) {

            # force lower case
            $tag->[0] = lc $tag->[0];

            if($tag->[0] eq 'form') {
                $self->{form} = { id => ($tag->[1]{id} || $tag->[1]{name}) };
            } elsif($tag->[0] eq '/form') {
                $self->_check_form($tag);
                $self->{form} = undef;

            } elsif($tag->[0] eq 'input') {
                $self->_check_form_submit($tag);
                $self->_check_form_control($tag);
            } elsif($tag->[0] =~ /^(select|textarea)$/) {
                $self->_check_form_control($tag);
            } elsif($tag->[0] eq 'label') {
                $self->_check_label($tag);

            } elsif($tag->[0] eq 'object') {
                $self->_check_object($tag,$p);
            } elsif($tag->[0] eq 'img') {
                $self->_check_image($tag);
            } elsif($tag->[0] eq 'a') {
                $self->_check_link($tag);
            } elsif($tag->[0] =~ /^(i|b)$/) {
                $self->_check_format($tag);

            # need to confirm
            #} elsif($tag->[0] eq 'map') {
            #    $self->_check_title($tag);

            } elsif($tag->[0] eq 'table') {
                $self->_check_title_summary($tag);
                $self->_check_width($tag);
                $self->_check_height($tag);
            } elsif($tag->[0] =~ /^(th|td)$/) {
                $self->_check_width($tag);
                $self->_check_height($tag);
            }
        }

        $self->_check_labelling();

    } else {
        push @{ $self->{ERRORS} }, {
            #ref     => 'Best Practices Recommedation only',
            error   => "missing content",
            message => 'no XHTML content found'
        };
    }

    if($self->{ERRORS}) {
        $self->_log( "FAIL\n" );
        $self->{RESULTS}{FAIL}++;
    } else {
        $self->_log( "PASS\n" );
        $self->{RESULTS}{PASS}++;
    }
}

# -------------------------------------
# Private Methods : Check Routines

sub _check_form {
    my ($self,$tag) = @_;

    if(!$self->{form}{submit}) {
        push @{ $self->{ERRORS} }, {
            ref     => 'WCAG v2 3.2.2 (A)', #E872
            error   => "W001",
            message => 'no submit button in form (' . ( $self->{form}{id} || '' ) . ')',
            row     => $tag->[2],
            col     => $tag->[3]
        };
    }
}

sub _check_form_control {
    my ($self,$tag) = @_;

    if($tag->[1]{id}) {
        if($self->{input}{ $tag->[1]{id} }) {
            push @{ $self->{ERRORS} }, {
                ref     => 'WCAG v2 4.1.1 (A)', #894
                error   => "W002",
                message => "all <$tag->[0]> tags require a unique id ($tag->[1]{id})",
                row     => $tag->[4],
                col     => $tag->[5]
            };
        } else {
            $self->{input}{ $tag->[1]{id} }{type}   = ($tag->[0] =~ /select|textarea/ ? $tag->[0] : $tag->[1]{type});
            $self->{input}{ $tag->[1]{id} }{title}  = $tag->[1]{title};
            $self->{input}{ $tag->[1]{id} }{row}    = $tag->[4];
            $self->{input}{ $tag->[1]{id} }{column} = $tag->[5];
            $self->{input}{ $tag->[1]{id} }{active} = ($tag->[1]{disabled} || $tag->[1]{readonly} ? 0 : 1);
        }

    } elsif($tag->[1]{type} && $tag->[1]{type} =~ /hidden|submit|reset|button/) {
        return;

    #} elsif($tag->[1]{disabled} || $tag->[1]{readonly}) {
    #    return;

    } elsif(!$tag->[1]{title}) {
        push @{ $self->{ERRORS} }, {
            ref     => 'WCAG v2 1.1.1 (A)', #E866
            error   => "W003",
            message => "all <$tag->[0]> tags require a  or a title attribute ($tag->[1]{name})",
            row     => $tag->[4],
            col     => $tag->[5]
        };
    }
}

sub _check_form_submit {
    my ($self,$tag) = @_;

    if($tag->[1]{type} && $tag->[1]{type} eq 'submit') {
        if(%{$self->{form}}) {
            $self->{form}{submit} = 1;
        } else {
            push @{ $self->{ERRORS} }, {
                #ref     => 'Best Practices Recommedation only',
                error   => "CW001",
                message => 'submit button should be associated with a form',
                row     => $tag->[4],
                col     => $tag->[5]
            };
        }
    }
}

sub _check_label {
    my ($self,$tag) = @_;

    if($tag->[1]{for}) {
        if($self->{label}{ $tag->[1]{for} }) {
            push @{ $self->{ERRORS} }, {
                #ref     => 'Best Practices Recommedation only',
                error   => "CW002",
                message => "all <$tag->[0]> tags should reference a unique id ($tag->[1]{for})",
                row     => $tag->[4],
                col     => $tag->[5]
            };
        } else {
            $self->{label}{ $tag->[1]{for} }{type}   = 'label';
            $self->{label}{ $tag->[1]{for} }{row}    = $tag->[4];
            $self->{label}{ $tag->[1]{for} }{column} = $tag->[5];
        }
    } else {
        push @{ $self->{ERRORS} }, {
            ref     => 'WCAG v2 1.3.1 (A)', #885
            error   => "W004",
            message => "all <$tag->[0]> tags must reference an  tag id",
            row     => $tag->[4],
            col     => $tag->[5]
        };
    }
}

sub _check_image {
    my ($self,$tag) = @_;

    return  if(defined $tag->[1]{alt});

    push @{ $self->{ERRORS} }, {
        ref     => 'WCAG v2 1.1.1 (A)', #E860
        error   => "W005",
        message => "no alt attribute in <$tag->[0]> tag ($tag->[1]{src})",
        row     => $tag->[4],
        col     => $tag->[5]
    };
}

sub _check_link {
    my ($self,$tag) = @_;

    return  unless(defined $tag->[1]{href});    # ignore named anchors

    if($tag->[1]{title}) {
        if($self->{links}{ $tag->[1]{href} } && $self->{links}{ $tag->[1]{href} } ne $tag->[1]{title}) {
            push @{ $self->{ERRORS} }, {
                ref     => 'WCAG v2 2.4.4 (A)', #E898
                error   => "W006",
                message => "repeated links should use the same titles ($tag->[1]{href}, '$self->{links}{ $tag->[1]{href} }' => '$tag->[1]{title}')",
                row     => $tag->[4],
                col     => $tag->[5]
            };
        } else {
            $self->{links}{ $tag->[1]{href} } = $tag->[1]{title};
        }
        return;
    }

    push @{ $self->{ERRORS} }, {
        ref     => 'WCAG v2 1.1.1 (A)', #E871
        error   => "W007",
        message => "no title attribute in a tag ($tag->[1]{href}, '$tag->[3]')",
        row     => $tag->[4],
        col     => $tag->[5]
    };
}

sub _check_format {
    my ($self,$tag) = @_;

    my %formats = (
        'i' => 'em',
        'b' => 'strong'
    );

    return  unless($formats{$tag->[0]});

    push @{ $self->{ERRORS} }, {
        ref     => 'WCAG v2 1.3.1 (A)', #E892
        error   => "W008",
        message => "use CSS for presentation effects, or use <$formats{$tag->[0]}> for emphasis not <$tag->[0]> tag",
        row     => $tag->[4],
        col     => $tag->[5]
    };
}

sub _check_title {
    my ($self,$tag) = @_;

    return  if(defined $tag->[1]{title});

    push @{ $self->{ERRORS} }, {
        #ref     => 'WCAG v2 1.1.1 (A)',
        error   => "W009",
        message => "no title attribute in <$tag->[0]> tag",
        row     => $tag->[4],
        col     => $tag->[5]
    };
}

sub _check_title_summary {
    my ($self,$tag) = @_;

    return  if(defined $tag->[1]{title} || defined $tag->[1]{summary});

    push @{ $self->{ERRORS} }, {
        ref     => 'WCAG v2 1.3.1 (A)', #E879
        error   => "W010",
        message => "no title or summary attribute in <$tag->[0]> tag",
        row     => $tag->[4],
        col     => $tag->[5]
    };
}

sub _check_width {
    my ($self,$tag) = @_;

    return  unless($self->{level} > 1);
    return  unless(defined $tag->[1]{width} && $tag->[1]{width} =~ /^\d+$/);

    push @{ $self->{ERRORS} }, {
        ref     => 'WCAG v2 1.4.4 (AA)',    #E910
        error   => "W011",
        message => "use relative (or CSS), rather than absolute units for width attribute in <$tag->[0]> tag",
        row     => $tag->[4],
        col     => $tag->[5]
    };
}

sub _check_height {
    my ($self,$tag) = @_;

    return  unless($self->{level} > 1);
    return  unless(defined $tag->[1]{height} && $tag->[1]{height} =~ /^\d+$/);

    push @{ $self->{ERRORS} }, {
        ref     => 'WCAG v2 1.4.4 (AA)',    #E910
        error   => "W012",
        message => "use relative (or CSS), rather than absolute units for height attribute in <$tag->[0]> tag",
        row     => $tag->[4],
        col     => $tag->[5]
    };
}

sub _check_object {
    my ($self,$tag,$p) = @_;

    # do we have simple text?
    my $x = $p->get_text();
    $x =~ s/\s+//gs;
    return  if($x);

    my @token;
    my $found;
    while( my $t = $p->get_token() ) {
        unshift @token, $t;
        next    unless($t->[0] eq 'S' || $t->[0] eq 'E');

        if($t->[0] eq 'E' && $t->[1] eq 'object') {
            last;
        } elsif($t->[0] eq 'S' && $t->[1] eq 'p') {
            $x = $p->get_text();
            $x =~ s/\s+//gs;
            $found = 1  if($x);
        } elsif($t->[0] eq 'S' && $t->[1] eq 'img') {
            $found = 1  if($t->[2]{alt});
        }

        last    if($found);
    }

    # put back tokens
    $p->unget_token($_) for(@token);

    return  if($found);

    push @{ $self->{ERRORS} }, {
        ref     => 'WCAG v2 1.1.1 (A)', #E865
        error   => "W013",
        message => qq{No alternative text (e.g.  or ) found for  tag},
        row     => $tag->[4],
        col     => $tag->[5]
    };
}

sub _check_labelling {
    my ($self) = @_;

    for my $input (keys %{$self->{input}}) {
        next    if($self->{input}{$input}{type} && $self->{input}{$input}{type} =~ /hidden|submit|reset|button/);
        next    if($self->{label}{$input});
        next    if($self->{input}{$input}{title});
        #next    if($self->{input}{$input}{active} == 0);

        push @{ $self->{ERRORS} }, {
            ref     => 'WCAG v2 1.1.1 (A)', #E866
            error   => "W014",
            message => "all <$self->{input}{$input}{type}> tags require a unique  tag or a title attribute ($input)",
            row     => $self->{input}{$input}{row},
            col     => $self->{input}{$input}{column}
        };
    }

    for my $input (keys %{$self->{label}}) {
        next    if($self->{input}{$input});

        push @{ $self->{ERRORS} }, {
            ref     => 'WCAG v2 1.3.1 (A)', #E895
            error   => "W015",
            message => "all  tags should reference a unique  tag ($input)",
            row     => $self->{label}{$input}{row},
            col     => $self->{label}{$input}{column}
        };
    }
}

# -------------------------------------
# Private Methods : Other

sub _log {
    my $self = shift;
    my $log = $self->logfile or return;
    mkpath(dirname($log))   unless(-f $log);

    my $mode = $self->logclean ? 'w+' : 'a+';
    $self->logclean(0);

    my $fh = IO::File->new($log,$mode) or die "Cannot write to log file [$log]: $!\n";
    print $fh @_;
    $fh->close;
}

1;

__END__