File Coverage

blib/lib/HTTP/RobotsTag.pm

Criterion	Covered	Total	%
statement	36	38	94.7
branch	3	6	50.0
condition	0	2	0.0
subroutine	8	8	100.0
pod	2	2	100.0
total	49	56	87.5

# $Id: /mirror/perl/HTTP-RobotsTag/trunk/lib/HTTP/RobotsTag.pm 31676 2007-12-10T00:06:35.669605Z daisuke  $
#
# Copyright (c) 2007 Daisuke Maki
# All rights reserved.

package HTTP::RobotsTag;
use strict;
use warnings;
use Carp qw(croak);
use DateTime::Format::Strptime;
use HTTP::Headers;
use HTTP::RobotsTag::Rules;
our $VERSION = '0.00001';

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

my $re = qr{
    (
        (?:no)?
        (?:
            index   |
            archive |
            snippet |
            follow  |
            unavailable_after:.+
        )
    )
    (?:
        \s*,\s*
        |
        $
    )
}x;

sub parse_headers
{
    my ($self, $headers) = @_;

    if (! eval { $headers->can('header') }) {
        croak "argument does not implement a header() function";
    }

    my $fmt = DateTime::Format::Strptime->new(
        pattern => '%d %b %Y %H:%M:%S %Z'
    );

    my %directives;
    my @tags = $headers->header( 'x-robots-tag' );
    foreach my $tag (@tags) {
        while ($tag =~ /$re/g) {
            my($key, $val) = split(/:/, $tag, 2);
            $key = lc $key;
            if ($key eq 'unavailable_after') {
                $val =~ s/^\s+//;
                $val =~ s/\s+$//;
                $directives{ $key } = $fmt->parse_datetime($val) or die;
            } else {
                $directives{ $key } = $val || 1;
            }
        }
    }

    return HTTP::RobotsTag::Rules->new(%directives);
}

1;

__END__