File Coverage

blib/lib/WWW/RobotRules/Parser.pm

Criterion	Covered	Total	%
statement	45	55	81.8
branch	24	30	80.0
condition			n/a
subroutine	7	8	87.5
pod	3	3	100.0
total	79	96	82.2

# $Id: /mirror/perl/WWW-RobotRules-Parser/trunk/lib/WWW/RobotRules/Parser.pm 31629 2007-12-01T13:31:37.690053Z daisuke  $
#
# Copyright (c) 2006-2007 Daisuke Maki
# A lot of this code is based on WWW::RobotRules.

package WWW::RobotRules::Parser;
use strict;
use warnings;
use vars qw($VERSION);
use URI;

BEGIN
{
    $VERSION = '0.04001';
}

sub new { bless { }, shift }

sub parse_uri
{
    my $self = shift;
    my $uri  = shift;

    require LWP::UserAgent;
    my $ua   = LWP::UserAgent->new;
    my $res  = $ua->get($uri);

    if (! $res->is_success) {
        require Carp;
        Carp::croak("Failed to retrieve $uri: Got HTTP code " . $res->code);
    }

    $self->parse($uri, $res->content);
}

sub parse
{
    my $self = shift;
    my $robot_txt_uri = shift;
    my $text = shift;

    $robot_txt_uri = URI->new($robot_txt_uri) if ($robot_txt_uri);

    my %result;
    # blank lines are significant, so turn CRLF into LF to avoid generating
    # false ones
    $text =~ s/\015\012/\012/g;

    my $ua_pattern;
    # split at \012 or \015
    for (split(/[\012\015]/, $text)) {
        # Lines containing only a comment are discarded completely, and
        # therefore do not indicate a record boundary
        next if /^\s*\#/;

        s/\s*\#.*//; # Remove comments at end-of-line

        if (/^\s*User-Agent\s*:\s*(.*)/i) {
            $ua_pattern = $1;
            $ua_pattern =~ s/\s+$//;
        } elsif (/^\s*Disallow\s*:\s*(.*)/i) {
            if (! defined $ua_pattern) {
                $ua_pattern = '*';
            }

            my $disallow = $1;
            $disallow =~ s/\s+$//;
            if (length $disallow) {
                if ($robot_txt_uri) {
                    my $ignore;
                    eval {
                        my $u = URI->new_abs($disallow, $robot_txt_uri);
                        $ignore++ if $u->scheme ne $robot_txt_uri->scheme;
                        $ignore++ if lc($u->host) ne lc($robot_txt_uri->host);
                        $ignore++ if $u->port ne $robot_txt_uri->port;
                        $disallow = $u->path_query;
                        $disallow = "/" unless length $disallow;
                    };
                    next if $@;
                    next if $ignore;
                }
                push @{$result{$ua_pattern}}, $disallow;
            }
        }
    }
    return wantarray ? %result : \%result
}

1;

__END__