File Coverage

blib/lib/HTML/RobotsMETA.pm

Criterion	Covered	Total	%
statement	38	38	100.0
branch	4	4	100.0
condition	4	6	66.6
subroutine	10	10	100.0
pod	4	4	100.0
total	60	62	96.7

# $Id: /mirror/perl/HTML-RobotsMETA/trunk/lib/HTML/RobotsMETA.pm 4223 2007-10-29T06:42:26.630870Z daisuke  $
#
# Copyright (c) 2007 Daisuke Maki
# All rights reserved.

package HTML::RobotsMETA;
use strict;
use warnings;
use HTML::Parser;
use HTML::RobotsMETA::Rules;
our $VERSION = '0.00004';

sub new
{
    my $class = shift;
    my $self  = bless {}, $class;
    return $self;
}

sub parser
{
    my $self = shift;
    return $self->{parser} ||= HTML::Parser->new(
        api_version => 3,
        $self->get_parser_callbacks
    );
}

sub get_parser_callbacks
{
    my $self = shift;
    return (
        start_h => [ sub { $self->_parse_start_h(@_) }, "tagname, attr" ]
    );
}

sub parse_rules
{
    my $self = shift;

    my @rules;
    local $self->{rules} = \@rules;

    my $parser = $self->parser();

    $parser->parse(@_);
    $parser->eof;

    # merge rules that were found in this document
    my %directives = (map { %$_ } @rules);
    return HTML::RobotsMETA::Rules->new(%directives);
}

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

    return unless $tag eq 'meta';

    # the "name" attribute may contain either "robots", or user-specified
    # robot name, which is specific to a particular crawler
    # XXX - Handle the specific agent part later
    return unless defined $attr->{name} && $attr->{name} =~ /^robots$/;

    my %directives;
    # Allowed values
    #   FOLLOW
    #   NOFOLLOW
    #   INDEX
    #   NOINDEX
    #   ARCHIVE
    #   NOARCHIVE
    #   SERVE
    #   NOSERVER
    #   NOIMAGEINDEX
    #   NOIMAGECLICK
    #   ALL
    #   NONE
    my $content = lc $attr->{content};
    while ($content =~ /((?:no)?(follow|index|archive|serve)|(?:noimage(?:index|click))|all|none)/g) {
        $directives{$1}++;
    }

    push @{$self->{rules}}, \%directives;
}

1;

__END__