File Coverage

blib/lib/HTML/Meta/Robots.pm

Criterion	Covered	Total	%
statement	62	67	92.5
branch	12	14	85.7
condition	1	2	50.0
subroutine	14	15	93.3
pod	4	4	100.0
total	93	102	91.1

package HTML::Meta::Robots;
############################################################################
# A simple HTML meta tag "robots" generator.
# @copyright © 2013, BURNERSK. Some rights reserved.
# @license http://www.perlfoundation.org/artistic_license_2_0 Artistic License 2.0
# @author BURNERSK
############################################################################
# Perl pragmas.
use strict;
use warnings FATAL => 'all';
use utf8;
use version 0.77; our $VERSION = version->new('v0.3.3');

############################################################################
# Register accessor methods.
BEGIN {
  no strict 'refs';  ## no critic (ProhibitNoStrict ProhibitProlongedStrictureOverride)
  use Carp qw( carp );

  my @simple_accessors     = qw( follow archive odp ydir snippet );
  my %deprecated_accessors = (
    open_directory_project => 'odp',
    yahoo                  => 'ydir',
  );

  # Register simple accessors which only can get/set boolean values.
  foreach my $accessor (@simple_accessors) {
    *{"HTML::Meta::Robots::$accessor"} = sub {
      my ( $self, @params ) = @_;
      $self->_accessor( $accessor, @params );
    };
  }

  # Register index accessor which also sets simple accessors.
  *{'HTML::Meta::Robots::index'} = sub {
    my ( $self, @params ) = @_;
    if ( scalar @params ) {
      $self->_accessor( $_, @params ) for @simple_accessors;
    }
    $self->_accessor( 'index', @params );
  };

  # Register DEPRECATED accessors.
  foreach my $accessor ( keys %deprecated_accessors ) {
    *{"HTML::Meta::Robots::$accessor"} = sub {
      my ( $self, @params ) = @_;
      carp sprintf
        q{Usage of %s->%s is DEPRECATED and will be removed in future! Use %s->%s instead},
        __PACKAGE__, $accessor,
        __PACKAGE__, $deprecated_accessors{$accessor};
      $self->_accessor( $deprecated_accessors{$accessor}, @params );
    };
  }
}

############################################################################
# Class constructor.
sub new {
  my ( $class, %params ) = @_;
  my $self = bless {}, $class;

  # Setup property order.
  $self->{order} = [qw( index follow archive odp ydir snippet )];

  # Allow all properties by default.
  $self->{props}->{$_} = 1 for @{ $self->{order} };

  # Set properties configured by init parameters.
  $self->$_( $params{$_} ) for grep { exists $self->{props}->{$_} } keys %params;

  return $self;
}

############################################################################
# INTERNAL - Simple getter/setter for internal fields.
sub _accessor {
  my ( $self, $field, @params ) = @_;
  if ( scalar @params ) {
    $self->{props}->{$field} = $params[0] ? 1 : 0;
    return $self;
  }
  return $self->{props}->{$field};
}

############################################################################
# Return robots meta tag's content.
sub content {
  my ($self) = @_;
  return join q{,}, map { $self->{props}->{$_} ? $_ : "no$_" } @{ $self->{order} };
}

############################################################################
# Return robots meta tag.
sub meta {
  my ( $self, $no_xhtml ) = @_;
  if ( !$no_xhtml ) {
    return sprintf '', $self->content;
  }
  else {
    return sprintf '', $self->content;
  }
}

############################################################################
# Parses external robot meta tag content.
sub parse {
  my ( $self, $content ) = @_;
  my %props = map { $_ =~ m/^(no)?(.+)$/s; $2 => $1 ? 0 : 1 } split /\s*,\s*/s, lc $content;
  $self->index( delete( $props{index} ) // 1 );
  $self->$_( delete $props{$_} ) for grep { exists $self->{props}->{$_} } keys %props;
  $self->{unknown_props} = \%props if scalar keys %props;
  return $self;
}

############################################################################
1;
__END__