# Copyright 2008, 2009, 2010 Kevin Ryde

# 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::Compatibility::TestMoreLikeModifiers;
use strict;
use warnings;
use base 'Perl::Critic::Policy';
use Perl::Critic::Utils qw(:severities parse_arg_list);
use Perl::Critic::Utils::PPIRegexp qw(:all);
use version;

our $VERSION = 0;

use constant DEBUG => 0;


sub supported_parameters { return; }
sub default_severity { return $SEVERITY_MEDIUM;   }
sub default_themes   { return qw(pulp bugs);      }
sub applies_to       { return 'PPI::Token::Word'; }

my $perl_ok_version = version->new('5.10.0');

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

  my $word = $elem->content;
  $word eq 'Test::More::like'
    || ($word eq 'like' && _document_uses_Test_More($document))
      || return;
  if (DEBUG) { print "word $word\n"; }

  if (my $version = $document->highest_explicit_perl_version) {
    if ($version >= $perl_ok_version) {
      return;  # $document is demanding new enough perl
    }
  }

  my @args_arefs = parse_arg_list ($elem);
  my @re_elems = @{$args_arefs[1]};
  @re_elems = grep {$_->significant} @re_elems;

  @re_elems == 1 || return;
  my $re_elem = $re_elems[0];
  if (DEBUG) { print "re_elem ",ref($re_elem),": $re_elem\n"; }
  my ($subdoc, $ext_elem) = _string_elem_to_regexp ($re_elem);

  $ext_elem->isa('PPI::Token::QuoteLike::Regexp')
    || $ext_elem->isa('PPI::Token::Regexp')
      || return;  # not a regexp (maybe a variable containing a regexp ...)

  my $mhash = $ext_elem->{'modifiers'}
    || return;  # no modifiers
  if (DEBUG) {
    require Data::Dumper;
    print "mhash ",Data::Dumper::Dumper($mhash),"\n";
  }
  my %modifiers = %$mhash;    # copy;
  delete $modifiers{'x'};     # /x is ok
  if (%modifiers) { return; } # no other modifiers is good

  my $modifiers = join ('', sort keys %modifiers);
  return $self->violation
    ("Modifiers /$modifiers don't work with like() until Perl $perl_ok_version",
     '',
     $re_elem);
}

sub _string_elem_to_regexp {
  my ($elem) = @_;

  if ($elem->isa('PPI::Token::Quote')) {
    # literal() from Single, string() from Double
    # the latter is only really an approximation, but is often good enough
    my $str = ($elem->can('literal')
               ? $elem->literal : $elem->string);
    if (DEBUG) { print "sub-parse: $str\n"; }

    # Eg. parses to
    #     PPI::Document
    #         PPI::Statement
    #             PPI::Token::Regexp::Match   '/pattern/i'
    #
    if (my $subdoc = PPI::Document->new (\$str)) {
      my $subelem = $subdoc->schild(0);
      if ($subelem && $subelem->isa('PPI::Statement')) {
        $subelem = $subelem->schild(0);
        if ($subelem->isa('PPI::Token::Regexp::Match')) {
          if (DEBUG) { print " got: ",ref($subelem),": $subelem\n"; }
          return ($subdoc, $subelem);
        }
      }
    }
  }
  # otherwise given elem
  return (undef, $elem);
}


sub _document_uses_Test_More {
  my ($document) = @_;
  my $key = __PACKAGE__ . '--using-Test::More';
  if (exists $document->{$key}) { return $document->{$key}; }

  my $ret = $document->find_any
    (sub {
       my ($document, $elem) = @_;
       return ($elem->isa ('PPI::Statement::Include')
               && $elem ne 'no'
               && (($elem->module || '') eq 'Test::More'));
     });
  if (DEBUG) { print "using Test::More -- ", ($ret?"yes":"no"), "\n"; }
  return ($document->{$key} = $ret);
}

1;
__END__

=head1 NAME

Perl::Critic::Policy::Compatibility::TestMoreLikeModifiers - don't use regexp modifiers with like() tests

=head1 DESCRIPTION

This policy is part of the Perl::Critic::Pulp addon.  It warns about regexp
modifiers like C</i> and C</m> passed to C<like> tests with C<Test::More>,
because such modifiers don't end up propagated to the test until Perl 5.10.
For example,

    use Test::More tests => 1;
    like ('My String', qr/str/i);     # bad
    like ("abc\ndef\n", '/^abc$/m');  # bad

If you've got an explicit C<use 5.010> or similar then you'll only be
running and this check is not applied.

As always if you don't care about C<__END__> you can always disable
C<TestMoreLikeModifiers> from your F<.perlcriticrc> in the usual way,

    [-Compatibility::TestMoreLikeModifiers]

=head1 SEE ALSO

L<Perl::Critic::Pulp>, L<Perl::Critic>

=head1 HOME PAGE

L<http://user42.tuxfamily.org/perl-critic-pulp/index.html>

=head1 COPYRIGHT

Copyright 2008, 2009, 2010 Kevin Ryde

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 L<http://www.gnu.org/licenses>.

=cut