File Coverage

blib/lib/HTML/T5.pm

Criterion	Covered	Total	%
statement	116	116	100.0
branch	45	48	93.7
condition	8	8	100.0
subroutine	18	18	100.0
pod	7	7	100.0
total	194	197	98.4

package HTML::T5;

use 5.010001;
use strict;
use warnings;
use Carp ();

use HTML::T5::Message;

=head1 NAME

HTML::T5 - HTML validation in a Perl object

=head1 VERSION

Version 0.012

=cut

our $VERSION = '0.012';

=head1 SYNOPSIS

    use HTML::T5;

    my $tidy = HTML::T5->new( {config_file => 'path/to/config'} );
    $tidy->ignore( type => TIDY_WARNING, type => TIDY_INFO );
    $tidy->parse( "foo.html", $contents_of_foo );

    for my $message ( $tidy->messages ) {
        print $message->as_string;
    }

=head1 DESCRIPTION

C is an HTML checker in a handy dandy object.  It's meant
as a replacement for L.  If you're currently
an L user looking to migrate, see the section
L.

C was forked from L by Andy Lester (PETDANCE), thanks.

=head1 EXPORTS

Message types C, C and C.

Everything else is an object method.

=cut

use base 'Exporter';

use constant TIDY_ERROR   => 3;
use constant TIDY_WARNING => 2;
use constant TIDY_INFO    => 1;

our @EXPORT = qw( TIDY_ERROR TIDY_WARNING TIDY_INFO );

=head1 METHODS

=head2 new()

Create an HTML::T5 object.

    my $tidy = HTML::T5->new();

Optionally you can give a hashref of configuration parms.

    my $tidy = HTML::T5->new( {config_file => 'path/to/tidy.cfg'} );

This configuration file will be read and used when you clean or parse an HTML file.

You can also pass options directly to tidy.

    my $tidy = HTML::T5->new( {
                                    output_xhtml => 1,
                                    tidy_mark => 0,
                                } );

See C for the list of options supported by tidy.

The following options are not supported by C:

=over 4

=item * quiet

=back

=cut

sub new {
    my $class = shift;
    my $args = shift || {};
    my @unsupported_options = qw(
        force-output
        gnu-emacs-file
        gnu-emacs
        keep-time
        quiet
        slide-style
        write-back
    ); # REVIEW perhaps a list of supported options would be better

    my $self = bless {
        messages     => [],
        ignore_type  => [],
        ignore_text  => [],
        config_file  => '',
        tidy_options => {},
    }, $class;

    for my $key (keys %{$args} ) {
        if ($key eq 'config_file') {
            $self->{config_file} = $args->{$key};
            next;
        }

        my $newkey = $key;
        $newkey =~ tr/_/-/;

        if ( grep {$newkey eq $_} @unsupported_options ) {
            Carp::croak( "Unsupported option: $newkey" );
        }

        $self->{tidy_options}->{$newkey} = $args->{$key};
    }

    return $self;
}

=head2 messages()

Returns the messages accumulated.

=cut

sub messages {
    my $self = shift;

    return @{$self->{messages}};
}

=head2 clear_messages()

Clears the list of messages, in case you want to print and clear, print
and clear.  If you don't clear the messages, then each time you call
L you'll be accumulating more in the list.

=cut

sub clear_messages {
    my $self = shift;

    $self->{messages} = [];

    return;
}

=head2 ignore( parm => value [, parm => value ] )

Specify types of messages to ignore.  Note that the ignore flags must be
set B calling C.  You can call C as many times
as necessary to set up all your restrictions; the options will stack up.

=over 4

=item * type => TIDY_INFO|TIDY_WARNING|TIDY_ERROR

Specifies the type of messages you want to ignore, either info or warnings
or errors.  If you wanted, you could call ignore on all three and get
no messages at all.

    $tidy->ignore( type => TIDY_WARNING );

=item * text => qr/regex/

=item * text => [ qr/regex1/, qr/regex2/, ... ]

Checks the text of the message against the specified regex or regexes,
and ignores the message if there's a match.  The value for the I
parm may be either a regex, or a reference to a list of regexes.

    $tidy->ignore( text => qr/DOCTYPE/ );
    $tidy->ignore( text => [ qr/unsupported/, qr/proprietary/i ] );

=back

=cut

sub ignore {
    my $self = shift;
    my @parms = @_;

    while ( @parms ) {
        my $parm = shift @parms;
        my $value = shift @parms;
        my @values = ref($value) eq 'ARRAY' ? @{$value} : ($value);

        Carp::croak( qq{Invalid ignore type of "$parm"} )
            unless ($parm eq 'text') or ($parm eq 'type');

        push( @{$self->{"ignore_$parm"}}, @values );
    } # while

    return;
} # ignore

=head2 parse( $filename, $str [, $str...] )

Parses a string, or list of strings, that make up a single HTML file.

The I<$filename> parm is only used as an identifier for your use.
The file is not actually read and opened.

Returns true if all went OK, or false if there was some problem calling
tidy, or parsing tidy's output.

=cut

sub parse {
    my $self = shift;
    my $filename = shift;
    if (@_ == 0) {
        Carp::croak('Usage: parse($filename,$str [, $str...])');
    }
    my $html = join( '', @_ );

    utf8::encode($html) if utf8::is_utf8($html);
    my ($errorblock,$newline) = _tidy_messages( $html, $self->{config_file}, $self->{tidy_options} );
    return 1 unless defined $errorblock;

    utf8::decode($errorblock);

    return !$self->_parse_errors($filename, $errorblock, $newline);
}

sub _parse_errors {
    my $self = shift;
    my $filename = shift;
    my $errs = shift;
    my $newline = shift;

    my $parse_errors;

    my @lines = split( /$newline/, $errs );

    for my $line ( @lines ) {
        chomp $line;

        my $message;
        if ( $line =~ /^line (\d+) column (\d+) - (Warning|Error|Info): (.+)$/ ) {  ## no critic ( ControlStructures::ProhibitCascadingIfElse )
            my ($line, $col, $type, $text) = ($1, $2, $3, $4);
            $type =
                ($type eq 'Warning') ? TIDY_WARNING :
                ($type eq 'Info')    ? TIDY_INFO :
                                       TIDY_ERROR;
            $message = HTML::T5::Message->new( $filename, $type, $line, $col, $text );

        }
        elsif ( $line =~ m/^Info: (.+)$/  ) {
            # Info line we don't want

            my $text = $1;
            $message = HTML::T5::Message->new( $filename, TIDY_INFO, undef, undef, $text );
        }
        elsif ( $line =~ /^Tidy found \d+ warnings? and \d+ errors?!/ ) {
            # Summary line we don't want
            # We should take these counts from the summary and make sure they match what we parsed.
        }
        elsif ( $line eq 'No warnings or errors were found.' ) {
            # Summary line we don't want

        }
        elsif ( $line eq 'This document has errors that must be fixed before' ) {
            # Summary line we don't want

        }
        elsif ( $line eq 'using HTML Tidy to generate a tidied up version.' ) {
            # Summary line we don't want

        }
        elsif ( $line =~ m/^\s*$/  ) {
            # Blank line we don't want
        }
        else {
            Carp::carp "HTML::T5: Unknown error type: $line";
            ++$parse_errors;
        }
        push( @{$self->{messages}}, $message )
            if $message && $self->_is_keeper( $message );
    } # for
    return $parse_errors;
}

=head2 clean( $str [, $str...] )

Cleans a string, or list of strings, that make up a single HTML file.

Returns the cleaned string as a single string.

=cut

sub clean {
    my $self = shift;

    if (@_ == 0) {
        Carp::croak('Usage: clean($str [, $str...])');
    }
    my $text = join( '', @_ );

    utf8::encode($text) if utf8::is_utf8($text);
    if ( defined $text ) {
        $text .= "\n";
    }

    my ($cleaned, $errbuf, $newline) = _tidy_clean( $text,
                                          $self->{config_file},
                                          $self->{tidy_options});
    utf8::decode($cleaned);
    utf8::decode($errbuf);

    $self->_parse_errors('', $errbuf, $newline);
    return $cleaned;
}

# Tells whether a given message object is one that we should keep.

sub _is_keeper {
    my $self = shift;

    my $message = shift;

    my @ignore_types = @{$self->{ignore_type}};
    if ( @ignore_types ) {
        return 0 if grep { $message->type == $_ } @ignore_types;
    }

    my @ignore_texts = @{$self->{ignore_text}};
    if ( @ignore_texts ) {
        return 0 if grep { $message->text =~ $_ } @ignore_texts;
    }

    return 1;
}

=head2 tidy_library_version()

Returns the version of the underling tidy library.

=cut

sub tidy_library_version {
    my $version_str = _tidy_library_version();

    return $version_str;
}

require XSLoader;
XSLoader::load('HTML::T5', $VERSION);

1;

__END__