lib/Perl/Critic/Policy/DynamicMoose.pm

   1 package Perl::Critic::Policy::DynamicMoose;
   2 use Moose;
   3 use MooseX::NonMoose;
   4 extends 'Perl::Critic::DynamicPolicy';
   5
   6 has document => (
   7     is      => 'rw',
   8     isa     => 'PPI::Document',
   9     handles => [qw/ppi_document/],
  10 );
  11
  12 sub applies_to { 'PPI::Document' }
  13 sub applies_to_metaclass { 'Class::MOP::Class', inner() }
  14
  15 around violation => sub {
  16     my $orig    = shift;
  17     my $self    = shift;
  18     my $desc    = shift;
  19     my $expl    = shift;
  20     my $element = shift;
  21
  22     if (!$element) {
  23         my $doc = $self->ppi_document;
  24
  25         # Without this hack, Storable complains of being unable to reconstruct
  26         # overloading for an unknown package (perhaps PPI::Document?). For some
  27         # reason it works for PPI::Element. Anyway, this should hopefully be
  28         # replaced with a more useful location, something like
  29         # ( class:MyClass / attr:foo / builder:build_foo )
  30         $element = $doc->find('PPI::Element')->[0];
  31     }
  32
  33     return $self->$orig($desc, $expl, $element, @_);
  34 };
  35
  36 sub violates_dynamic {
  37     my $self = shift;
  38     my $doc  = shift;
  39
  40     $self->document($doc);
  41
  42     my $old_packages = $self->find_packages;
  43     $self->compile_document;
  44     my @new_packages = $self->new_packages($old_packages);
  45
  46     my @violations;
  47     for my $package (@new_packages) {
  48         my $meta = Class::MOP::class_of($package)
  49             or next;
  50
  51         grep { $meta->isa($_) } $self->applies_to_metaclass
  52             or next;
  53
  54         push @violations, $self->violates_metaclass($meta, $doc);
  55     }
  56
  57     return @violations;
  58 }
  59
  60 sub compile_document {
  61     my $self = shift;
  62     my $doc = $self->document;
  63
  64     my $source_code = $doc->content;
  65
  66     eval $source_code;
  67
  68     die "Unable to execute " . $doc->filename . ": $@" if $@;
  69 }
  70
  71 sub find_packages {
  72     my $self = shift;
  73     return [ Class::MOP::get_all_metaclass_names ];
  74 }
  75
  76 sub new_packages {
  77     my $self = shift;
  78     my $old  = shift;
  79     my @new;
  80     my %seen;
  81
  82     $seen{$_} = 1 for @$old;
  83
  84     for (@{ $self->find_packages }) {
  85         push @new, $_ if !$seen{$_}++;
  86     }
  87
  88     return @new;
  89 }
  90
  91 no Moose;
  92
  93 1;
  94