Perl::Critic::Policy::Documentation::ProhibitUnbalancedParens - don't leave an open bracket or paren

    Blah blah (and something.    # bad

    Blah blah ( [ ).             # bad

    Blah blah brace }.           # bad

    [1,2)             # bad

    (This is some     # bad

    thing.)           # bad

    =for ProhibitUnbalancedParens allow next

    Something ( deliberately unclosed.

    =for ProhibitUnbalancedParens allow next 2

    First deliberate [ unclosed.

    Second (.

    ## no critic (ProhibitUnbalancedParens)

    [-Documentation::ProhibitUnbalancedParens]

# Copyright 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/>.


# perlcritic -s ProhibitUnbalancedParens ProhibitUnbalancedParens.pm

# unclosed:
#  perlcritic -s ProhibitUnbalancedParens /usr/share/perl/5.12/CGI.pm

# smiley close:
#  perlcritic -s ProhibitUnbalancedParens /usr/share/perl5/accessors.pm


package Perl::Critic::Policy::Documentation::ProhibitUnbalancedParens;
use 5.006;
use strict;
use warnings;
use base 'Perl::Critic::Policy';
use Perl::Critic::Utils;

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

our $VERSION = 61;

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

sub violates {
  my ($self, $elem, $document) = @_;
  ### ProhibitUnbalancedParens on: $elem->content

  my $parser = Perl::Critic::Pulp::PodParser::ProhibitUnbalancedParens->new
    (policy => $self);
  $parser->parse_from_elem ($elem);
  return $parser->violations;
}

package Perl::Critic::Pulp::PodParser::ProhibitUnbalancedParens;
use strict;
use warnings;
use Pod::ParseLink;
use base 'Perl::Critic::Pulp::PodParser';

sub command {
  my ($self, $command, $text, $linenum, $paraobj) = @_;
  if ($command eq 'for'
      && $text =~ /^ProhibitUnbalancedParens\b\s*(.*)/) {
    my $directive = $1;
    ### $directive
    if ($directive =~ /^allow next( (\d+))?/) {
      # numbered "allow next 5" means up to that many following
      # unnumbered "allow next" means one following
      $self->{'allow_next'} = (defined $2 ? $2 : 1);
    }
  }
  return command_as_textblock(@_);
}

my %command_non_text = (for   => 1,
                        begin => 1,
                        end   => 1,
                        cut   => 1);
sub command_as_textblock {
  my ($self, $command, $text, $linenum, $paraobj) = @_;
  ### command: $command
  unless ($command_non_text{$command}) {
    # padded to make the column number right, the leading spaces do no harm
    # for this policy
    $self->textblock ((' ' x (length($command)+1)) . $text,
                      $linenum,
                      $paraobj);
  }
  return '';
}

my %open_to_close = ('(' => ')',
                     '[' => ']',
                     '{' => '}');
my %close_to_open = reverse %open_to_close;

sub textblock {
  my ($self, $text, $linenum, $pod_para) = @_;
  ### textblock: "linenum=$linenum"

  if (($self->{'allow_next'}||0) > 0) {
    $self->{'allow_next'}--;
    return '';
  }

  my $interpolated = $self->interpolate($text, $linenum);
  ### $text
  ### $interpolated

  my @parens;
  while ($interpolated
         =~ m/
                              ([][({})])       # $1 open or close
                          |([:;]-?\)         # $2 smiley face optional close
                              |\b[a-zA-Z1-9]\) #    "middle a) or 1) item"
                              |(?<!\$)\$\)     #    perlvar $), and not $$
                              )
                          |(["'])[][(){}]+\3 # $3 "(" quoted
                          |[:;]-?[(]         # smiley face not an open
                          |(?<!\$)\$\$       # perlvar $$ consumed
                          |\$\(\w*\)         # makefile var $(abc)
                          |\$\[\w*\]         # perhaps template $[abc]
                          |(?<!\$)\$[][(]    # perlvars $[, $(, $], and not $$
                          |^\s*(\d+|[A-Za-z])\.?\)   # initial "1.5) something"
                          /xg) {
    ### match: $&
    ### $1
    ### $2
    ### $3
    if (defined $1) {
      push @parens, { char => $1,
                      pos  => pos($interpolated)-1,
                    };

    } elsif (defined $2) {
      push @parens, { char => ')',
                      pos => pos($interpolated)-1,
                      optional => 1,
                    };
    }
  }
  ### @parens

  # sort optional closes to after hard closes
  {
    my @optional;
    my @new;
    foreach my $p (@parens) {
      if (@optional && $optional[0]->{'char'} ne $p->{'char'}) {
        push @new, splice @optional;
      }
      if ($p->{'optional'}) {
        push @optional, $p;
      } else {
        push @new, $p;
      }
    }
    @parens = (@new, @optional);
  }
  ### sorted: @parens

  my @opens;
  foreach my $p (@parens) {
    ### $p
    my $char = $p->{'char'};
    if (my $want_openchar = $close_to_open{$char}) {
      # a close
      if (my $o = pop @opens) {
        my $openchar = $o->{'char'};
        if ($openchar ne $want_openchar) {
          if ($p->{'optional'}) {
            ### mismatched optional close, skip
            push @opens, $o;
            next;
          }
          $self->violation_at_linenum_and_textpos
            ("Mismatched closing paren \"$char\" expected \"$open_to_close{$openchar}\"",
             $linenum, $interpolated, $p->{'pos'});
        }

      } else {
        if ($p->{'optional'}) {
          ### unopened optional close, skip
          next;
        }
        $self->violation_at_linenum_and_textpos
          ("Unopened close paren \"$char\"",
           $linenum, $interpolated, $p->{'pos'});
      }

    } else {
      # an open
      push @opens, $p;
    }
  }
  foreach my $p (@opens) {
    $self->violation_at_linenum_and_textpos
      ("Unclosed paren \"$p->{'char'}\"",
       $linenum, $interpolated, $p->{'pos'});
  }
  return '';
}

*interior_sequence = \&interior_sequence_as_displayed_noncode_text;

sub interior_sequence_as_displayed_noncode_text {
  my ($self, $cmd, $text, $pod_seq) = @_;

  if ($cmd eq 'X' || $cmd eq 'C') {
    # keep only the newlines
    $text =~ tr/\n//cd;

  } elsif ($cmd eq 'L') {
    my ($display, $inferred, $name, $section, $type)
      = Pod::ParseLink::parselink ($text);
    ### $display
    ### $inferred
    ### $name
    return $inferred;  # the display part, or the name part if no display
  }
  return $text;
}

1;
__END__