File Coverage

blib/lib/WWW/DoctypeGrabber.pm

Criterion	Covered	Total	%
statement	63	80	78.7
branch	15	36	41.6
condition	3	7	42.8
subroutine	11	12	91.6
pod	2	2	100.0
total	94	137	68.6

package WWW::DoctypeGrabber;

use warnings;
use strict;

our $VERSION = '0.007';

use Carp;
use LWP::UserAgent;
use base 'Class::Accessor::Grouped';
use overload q|""|, sub { shift->doctype; };
__PACKAGE__->mk_group_accessors( simple => qw(
    ua
    error
    doctype
    result
    raw
));

sub new {
    my $self = bless {}, shift;
    croak "Must have even number of arguments to new()"
        if @_ & 1;

    my %args = @_;
    $args{ +lc } = delete $args{ $_ } for keys %args;
    $args{timeout}  ||= 30;
    $args{max_size} ||= 500;
    $args{ua}       ||= LWP::UserAgent->new(
        timeout  => 30,
        max_size => 500,
        agent    => 'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.8.1.13)'
                   . ' Gecko/20080325 Ubuntu/7.10 (gutsy) Firefox/2.0.0.13',
    );

    $self->ua( $args{ua} );
    $self->raw( $args{raw} );
    return $self;
}

sub grab {
    my ( $self, $uri ) = @_;

    $self->$_(undef) for qw(error  doctype  result);

    $uri = "http://$uri"
        unless $uri =~ m{^https?://};

    my $response = $self->ua->get( $uri );
    if ( $response->is_success ) {
        return $self->result(
            $self->_parse_doctype(
                $response->content,
                $response->header('Content-type'),
            )
        );
    }
    else {
        return $self->_set_error( $response, 'net' );
    }
}

sub _parse_doctype {
    my ( $self, $content, $mime ) = @_;

    my %parse_result = (
        xml_prolog      => 0,
        non_white_space => 0,
        has_doctype     => 0,
        doctype         => '',
        mime            => $mime,
    );

    DOCTYPE_PARSE: {
        if ( my ( $pre_text ) = $content =~ /(.+)(?=
            if ( my $xml_count = $pre_text =~ s/<\?xml[^>]+?\?>//ig ) {
                $parse_result{xml_prolog} = $xml_count;
            }
            $pre_text =~ s/\s+//g;
            $parse_result{non_white_space} = length $pre_text;
        }

        if ( my ( $doctype_string ) = $content =~ m{(]+>)}i ) {
            $parse_result{has_doctype} = 1;
            $doctype_string =~ s/\s+/ /g;
            $doctype_string =~ s/^\s+|\s+$//g;
            $self->raw
                and return $self->doctype($doctype_string);

            if ( $doctype_string
                =~ s{^
            ) {
                my @doctype_bits = ();
                my ( $type ) = $doctype_string =~ m{^[^/]+?(?=//)}g;
                if ( !defined $type ) {
                    $parse_result{doctype} = 'Invalid/Unknown';

                    last DOCTYPE_PARSE;
                }
                $type =~ /^HTML 4.01$/i
                    and $type .= ' Strict';

                push @doctype_bits, $type;
                if ( my ( $dtd_uri ) =
                    $doctype_string =~ m{\s"(\S+)"\s*>$}
                ) {
                    my $dtd_uris = $self->_get_dtd_uri_table;
                    if ( exists $dtd_uris->{ $type } ) {
                        if ( $dtd_uris->{ $type } eq $dtd_uri ) {
                            push @doctype_bits, '+ url';
                        }
                        else {
                            push @doctype_bits, '+ Invalid url';
                        }
                    }
                    else {
                        push @doctype_bits, '+ Unknown url';
                    }
                }
                $parse_result{doctype} = join q| |, @doctype_bits;
            }
            else {
                $parse_result{doctype} = $doctype_string;
            }
        }
        elsif( $self->raw ) {
            return $self->doctype('NO DOCTYPE');
        }
    }

    if ( $parse_result{has_doctype} ) {
        my @bits;
        $parse_result{xml_prolog}
            and push @bits, "+ $parse_result{xml_prolog} XML prolog";

        $parse_result{non_white_space}
            and push @bits, "+ $parse_result{non_white_space} "
                        . "non-whitespace characters";

        $self->doctype( join q| |, $parse_result{doctype}, @bits );
    }
    else {
        $self->doctype('NO DOCTYPE');
    }

    return \%parse_result;
}

sub _get_dtd_uri_table {
    return {
        'HTML 4.01 Strict'                       =>
            'http://www.w3.org/TR/html4/strict.dtd',

        'HTML 4.01 Transitional'                 =>
            'http://www.w3.org/TR/html4/loose.dtd',

        'HTML 4.01 Frameset'                     =>
            'http://www.w3.org/TR/html4/frameset.dtd',

        'XHTML 1.0 Strict'                       =>
            'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd',

        'XHTML 1.0 Transitional'                 =>
            'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd',

        'XHTML 1.0 Frameset'                     =>
            'http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd',

        'XHTML 1.1'                              =>
            'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd',

        'XHTML Basic 1.0'                        =>
            'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd',

        'XHTML Basic 1.1'                        =>
            'http://www.w3.org/TR/xhtml-basic/xhtml-basic11.dtd',

        'XHTML 1.1 plus MathML 2.0 plus SVG 1.1' =>
            'http://www.w3.org/2002/04/xhtml-math-svg/xhtml-math-svg.dtd',
    };
}

sub _set_error {
    my ( $self, $error_or_resp, $is_net ) = @_;
    if ( $is_net ) {
        $self->error( 'Network error: ' . $error_or_resp->status_line );
    }
    else {
        $self->error( $error_or_resp );
    }
    return;
}

1;
__END__