File Coverage

blib/lib/Pod/MinimumVersion.pm

Criterion	Covered	Total	%
statement	77	81	95.0
branch	34	44	77.2
condition	19	19	100.0
subroutine	20	20	100.0
pod	4	6	66.6
total	154	170	90.5

# Copyright 2009, 2010, 2011 Kevin Ryde

# This file is part of Pod-MinimumVersion.

# Pod-MinimumVersion is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Pod-MinimumVersion is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Pod-MinimumVersion.  If not, see .


package Pod::MinimumVersion;
use 5.004;
use strict;
use List::Util;
use version;
use vars qw($VERSION @CHECKS);

# uncomment this to run the ### lines
#use Smart::Comments;

$VERSION = 50;

sub new {
  my ($class, %self) = @_;
  $self{'want_reports'} ||= 'one_per_version';
  return bless \%self, $class;
}

sub minimum_version {
  my ($self) = @_;
  my $report = $self->minimum_report || return undef;
  return $report->{'version'};
}
sub minimum_report {
  my ($self) = @_;
  if (! exists $self->{'minimum_report'}) {
    $self->{'minimum_report'}
      = List::Util::reduce {$a->{'version'} > $b->{'version'} ? $a : $b}
        $self->reports;
  }
  return $self->{'minimum_report'};
}
sub reports {
  my ($self) = @_;
  $self->analyze;
  return @{$self->{'reports'} || []};
}

sub analyze {
  my ($self) = @_;
  return if $self->{'analyzed'};
  $self->{'analyzed'} = 1;

  ### Pod-MinVer analyze()

  my %checks;
  foreach my $elem (@CHECKS) {
    my ($func, $command, $version) = @$elem;
    next if ($self->{'above_version'} && $version <= $self->{'above_version'});
    push @{$checks{$command}}, $func;
  }
  return if (! %checks);

  require Pod::MinimumVersion::Parser;
  my $parser = Pod::MinimumVersion::Parser->new (pmv    => $self,
                                                 checks => \%checks);
  if (exists $self->{'string'}) {
    $parser->parse_from_string ("$self->{'string'}");
  } elsif (exists $self->{'filehandle'}) {
    $parser->parse_from_filehandle ($self->{'filehandle'});
  } elsif (exists $self->{'filename'}) {
    # stringize to parse_from_file() taking an overloaded object to be a handle
    # ENHANCE-ME: perhaps opening here and parse_from_filehandle() would be
    # a better way to avoid
    $parser->parse_from_file ("$self->{'filename'}");
  }
}

#------------------------------------------------------------------------------
# 5.004
#
# E<> newly documented in 5.004, but is in pod2man right back to 5.002, so
# don't report that

{
  my $v5004 = version->new('5.004');

  # =for, =begin, =end new in 5.004
  #
  push @CHECKS, [ \&_check_for_begin_end, 'command', $v5004 ];
  my %for_begin_end = (for => 1, begin => 1, end => 1);
  sub _check_for_begin_end {
    my ($self, $command, $text, $para_obj) = @_;
    if ($for_begin_end{$command}) {
      $self->report ('for_begin_end', $v5004, $para_obj, "=$command command");
    }
  }
}

#------------------------------------------------------------------------------
# 5.005

{
  my $v5005 = version->new('5.005');

  # L display alternative new in 5.005
  #
  push @CHECKS, [ \&_check_link_display_text, 'interior_sequence', $v5005 ];
  sub _check_link_display_text {
    my ($self, $command, $arg, $seq_obj) = @_;
    if ($command eq 'L' && $arg =~ /\|/) {
      $self->report ('link_display_text', $v5005, $seq_obj,
                     'Display text L link');
    }
  }
}

#------------------------------------------------------------------------------
# 5.006

{
  my $v5006 = version->new('5.006');

  push @CHECKS, [ \&_check_double_angles, 'interior_sequence', $v5006 ];
  sub _check_double_angles {
    my ($self, $command, $arg, $seq_obj) = @_;

    if ($seq_obj->left_delimiter =~ /^<
      $self->report ('double_angles', $v5006, $seq_obj,
                     'Double angle brackets C<< foo >>');
    }
  }
}

#------------------------------------------------------------------------------
# 5.008

{
  my $v5008 = version->new('5.008');

  # =head3 and =head4 new in 5.8.0
  push @CHECKS, [ \&_check_head34, 'command', $v5008 ];
  my %head34 = (head3 => 1, head4 => 1);
  sub _check_head34 {
    my ($self, $command, $text, $para_obj) = @_;
    if ($head34{$command}) {
      $self->report ('head34', $v5008, $para_obj, "=$command command");
    }
  }

  # E and E documented in 5.6.0, but Pod::Man only has them in
  # 5.8.0, so rate them as a 5008 feature
  #
  # E is in Pod::Man of 5.8.0, though not documented explicitly
  #
  push @CHECKS, [ \&_check_E_5008, 'interior_sequence', $v5008 ];
  my %E_5008 = (apos => 1, sol => 1, verbar => 1);
  sub _check_E_5008 {
    my ($self, $command, $arg, $seq_obj) = @_;

    if ($command eq 'E' && $E_5008{$arg}) {
      $self->report ('E_5008', $v5008, $seq_obj, "E<$arg> escape");
    }
  }

  # L urls new in 5.8.0
  #
  # In 5.6 and earlier the "/" is interpreted as a section, so from
  # L you get something bad like
  #
  #    the section on "/foo.com/index.html" in the http: manpage
  #
  # Crib note: a "|" display text part is not allowed with a url, according
  # to perlpodspec of perl 5.10.0 under the "Authors wanting to link to a
  # particular (absolute) URL" bullet point.  So no need to watch for that
  # in applying this test.
  #
  push @CHECKS, [ \&_check_link_url, 'interior_sequence', $v5008 ];
  sub _check_link_url {
    my ($self, $command, $arg, $seq_obj) = @_;
    # this regexp as recommended by perlpodspec of perl 5.10.0
    if ($command eq 'L' && $arg =~ m/\A\w+:[^:\s]\S*\z/) {
      $self->report ('link_url', $v5008, $seq_obj,
                     'L<> link to URL');
    }
  }
}

#------------------------------------------------------------------------------
# 5.010

{
  my $v5010 = version->new('5.010');

  # =encoding documented in 5.8.0, but Pod::Man doesn't recognise it until
  # 5.10.0, so rate it as a 5010 feature
  #
  push @CHECKS, [ \&_check_encoding, 'command', $v5010 ];
  sub _check_encoding {
    my ($self, $command, $text, $para_obj) = @_;
    if ($command eq 'encoding') {
      $self->report ('encoding', $v5010, $para_obj, '=encoding command');
    }
  }
}

#------------------------------------------------------------------------------
# 5.012

{
  my $v5012 = version->new('5.012');

  # L documented in 5.12.0 where previously explicitly prohibited,
  # rate it as a 5012 feature
  #
  push @CHECKS, [ \&_check_link_url_with_text, 'interior_sequence', $v5012 ];
  sub _check_link_url_with_text {
    my ($self, $command, $arg, $seq_obj) = @_;
    # this regexp adapted from recommendation of perlpodspec from perl 5.10.0
    if ($command eq 'L' && $arg =~ m/\A.*\|\w+:[^:\s]\S*\z/) {
      $self->report ('link_url_with_text', $v5012, $seq_obj,
                     'L<> link with URL and text');
    }
  }
}

#------------------------------------------------------------------------------

sub report {
  my ($self, $name, $version, $pod_obj, $why) = @_;

  if ($self->{'want_reports'} eq 'one_per_check') {
    return if ($self->{'seen'}->{$name}++);
  }
  if ($self->{'want_reports'} eq 'one_per_version') {
    return if ($self->{'seen'}->{$version}++);
  }

  my ($filename, $linenum) = $pod_obj->file_line;
  if (defined $self->{'filename'}) {
    $filename = $self->{'filename'};
  }
  require Pod::MinimumVersion::Report;
  push @{$self->{'reports'}},
    Pod::MinimumVersion::Report->new (filename => $filename,
                                      name     => $name,
                                      linenum  => $linenum,
                                      version  => $version,
                                      why      => $why);
}

1;
__END__