Perl::Critic::Policy::ValuesAndExpressions::ConstantBeforeLt - disallow bareword before <

    use POSIX;
    DBL_MANT_DIG < 32   # bad, perl 5.8 thinks <>

    func <*.c>          # ok, actual glob
    time < 2e9          # ok, builtins parse ok

    use constant FOO => 16;
    FOO < 32            # ok, your own const

    sub BAR () { 64 }
    BAR < 32            # ok, your own prototyped sub

    (DBL_MANT_DIG) < 10  # ok
    DBL_MANT_DIG() < 10  # ok

    [-ValuesAndExpressions::ConstantBeforeLt]

    if (FOO < 123) { ... }   # bad
    ...
    use constant FOO => 456;

# Copyright 2008, 2009, 2010, 2011 Kevin Ryde

# This file is part of Perl-Critic-Pulp.

# Perl-Critic-Pulp 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.
#
# Perl-Critic-Pulp 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 Perl-Critic-Pulp.  If not, see
# <http://www.gnu.org/licenses/>.


package Perl::Critic::Policy::ValuesAndExpressions::ConstantBeforeLt;
use 5.006;
use strict;
use warnings;
use base 'Perl::Critic::Policy';
use Perl::Critic::Utils qw(is_included_module_name
                           is_method_call
                           is_perl_builtin_with_no_arguments
                           split_nodes_on_comma);

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

our $VERSION = 61;

#
# Incidentally "require Foo < 123" is a similar sort of problem in all Perls
# (or at least up to 5.10.0) with "<" being taken to be a "< >".  But since
# it always provokes a warning when run it doesn't really need perlcritic,
# or if it does then leave it to another policy to address.
#

use constant supported_parameters => ();
use constant default_severity     => $Perl::Critic::Utils::SEVERITY_MEDIUM;
use constant default_themes       => qw(pulp bugs);
use constant applies_to           => ('PPI::Document');

sub violates {
  my ($self, $document) = @_;

  my @violations;
  my %constants;
  my $constants = \%constants;
  $document->find
    (sub {
       my ($document, $elem) = @_;
       @constants{ _use_constants($elem) } = 1;  # hash slice
       push @violations, _one_violate ($self, $elem, $constants);
       return 0;  # no-match, and continue
     });
  return @violations;
}

sub _one_violate {
  my ($self, $elem, $constants) = @_;
  if (! $elem->isa ('PPI::Token::Word')) { return; }

  # eg. "use constant FOO => 123; if (FOO < 456) {}" is ok, for a constant
  # defined at the point in question
  if (exists $constants->{$elem->content}) { return; }

  # eg "time < 123" is ok
  if (is_perl_builtin_with_no_arguments ($elem)) { return; }

  # eg. "bar" in "$foo->bar < 123" is ok
  if (is_method_call ($elem)) { return; }

  # eg. "Foo" in "require Foo" is not a constant
  if (is_included_module_name ($elem)) { return; }


  # must be followed by "<" like "MYBAREWORD < 123"
  my $lt = $elem->snext_sibling or return;
  $lt->isa('PPI::Token::Operator') or return;
  $lt->content eq '<' or return;

  # if a ">" somewhere later like "foo <...>" then it's probably a function
  # call on a readline or glob
  #
  my $after = $lt;
  for (;;) {
    $after = $after->snext_sibling or last;
    if ($after->content eq '>') {
      return;
    }
  }

  return $self->violation ('Bareword constant before "<"',
                           '', $elem);
}

# $elem is any element.  If it's a "use constants" or a "sub foo () { ...}"
# then return the name or names of the constants so created.  Otherwise
# return an empty list.
#
# Perl::Critic::StricterSubs::Utils::find_declared_constant_names() does
# some similar stuff, but it crunches the whole document at once, instead of
# just one statement.
#
my %constant_modules = ('constant' => 1, 'constant::defer' => 1);
sub _use_constants {
  my ($elem) = @_;

  if ($elem->isa ('PPI::Statement::Sub')) {
    if ($elem->prototype eq '()') {
      if (my $name = $elem->name) {
        return $name;
      }
    }
    # anonymous sub or without prototype
    return;
  }

  return unless ($elem->isa ('PPI::Statement::Include')
                 && $elem->type eq 'use'
                 && $constant_modules{$elem->module || ''});

  $elem = $elem->schild(2) or return; # could be "use constant" alone
  ### start at: $elem->content

  my $single = 1;
  if ($elem->isa ('PPI::Structure::Constructor')) {
    # multi-constant "use constant { FOO => 1, BAR => 2 }"
    #
    # PPI::Structure::Constructor         { ... }
    #   PPI::Statement
    #     PPI::Token::Word        'foo'
    #
    $single = 0;
    # multiple constants
    $elem = $elem->schild(0)
      or return;  # empty on "use constant {}"
    goto SKIPSTATEMENT;

  } elsif ($elem->isa ('PPI::Structure::List')) {
    # single constant in parens "use constant (FOO => 1,2,3)"
    #
    # PPI::Structure::List        ( ... )
    #   PPI::Statement::Expression
    #     PPI::Token::Word        'Foo'
    #
    $elem = $elem->schild(0)
      or return;  # empty on "use constant {}"

  SKIPSTATEMENT:
    if ($elem->isa ('PPI::Statement')) {
      $elem = $elem->schild(0) or return;
    }
  }

  # split_nodes_on_comma() handles oddities like "use constant qw(FOO 1)"
  #
  my @nodes = _elem_and_ssiblings ($elem);
  my @arefs = split_nodes_on_comma (@nodes);

  ### @arefs

  if ($single) {
    $#arefs = 0;  # first elem only
  }
  my @constants;
  for (my $i = 0; $i < @arefs; $i += 2) {
    my $aref = $arefs[$i];
    if (@$aref == 1) {
      my $name_elem = $aref->[0];
      if (! $name_elem->isa ('PPI::Token::Structure')) {  # not final ";"
        push @constants, ($name_elem->can('string')
                          ? $name_elem->string
                          : $name_elem->content);
        next;
      }
    }
    ### ConstantBeforeLt skip non-name constant: $aref
  }
  return @constants;
}

sub _elem_and_ssiblings {
  my ($elem) = @_;
  my @ret;
  while ($elem) {
    push @ret, $elem;
    $elem = $elem->snext_sibling;
  }
  return @ret;
}

1;
__END__