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 sub default_themes { qw(moose dynamic), inner() }
  15
  16 around violation => sub {
  17     my $orig    = shift;
  18     my $self    = shift;
  19     my $desc    = shift;
  20     my $expl    = shift;
  21     my $element = shift;
  22
  23     if (!$element) {
  24         my $doc = $self->ppi_document;
  25
  26         # Without this hack, Storable complains of being unable to reconstruct
  27         # overloading for an unknown package (perhaps PPI::Document?). For some
  28         # reason it works for PPI::Element. Anyway, this should hopefully be
  29         # replaced with a more useful location, something like
  30         # ( class:MyClass / attr:foo / builder:build_foo )
  31         $element = $doc->find('PPI::Element')->[0];
  32     }
  33
  34     return $self->$orig($desc, $expl, $element, @_);
  35 };
  36
  37 sub violates_dynamic {
  38     my $self = shift;
  39     my $doc  = shift;
  40
  41     $self->document($doc);
  42
  43     my $old_packages = $self->find_packages;
  44     $self->compile_document;
  45     my @new_packages = $self->new_packages($old_packages);
  46
  47     my @violations;
  48     for my $package (@new_packages) {
  49         my $meta = Class::MOP::class_of($package)
  50             or next;
  51
  52         grep { $meta->isa($_) } $self->applies_to_metaclass
  53             or next;
  54
  55         push @violations, $self->violates_metaclass($meta, $doc);
  56     }
  57
  58     return @violations;
  59 }
  60
  61 sub compile_document {
  62     my $self = shift;
  63     my $doc = $self->document;
  64
  65     my $source_code = $doc->content;
  66
  67     eval $source_code;
  68
  69     die "Unable to execute " . $doc->filename . ": $@" if $@;
  70 }
  71
  72 sub find_packages {
  73     my $self = shift;
  74     return [ Class::MOP::get_all_metaclass_names ];
  75 }
  76
  77 sub new_packages {
  78     my $self = shift;
  79     my $old  = shift;
  80     my @new;
  81     my %seen;
  82
  83     $seen{$_} = 1 for @$old;
  84
  85     for (@{ $self->find_packages }) {
  86         push @new, $_ if !$seen{$_}++;
  87     }
  88
  89     return @new;
  90 }
  91
  92 no Moose;
  93
  94 1;
  95
  96 __END__
  97
  98 =head1 NAME
  99
 100 Perl::Critic::Policy::DynamicMoose
 101
 102 =head1 DESCRIPTION
 103
 104 The included policies are:
 105
 106 =over 4
 107
 108 =item L<Perl::Critic::Policy::DynamicMoose::ProhibitPublicBuilders>
 109
 110 Prohibit public builder methods for attributes. [Severity: 3]
 111
 112 =back
 113
 114 =head1 WARNING
 115
 116 B<VERY IMPORTANT:> Most L<Perl::Critic> Policies (including all the ones that
 117 ship with Perl::Critic> use pure static analysis -- they never compile nor
 118 execute any of the code that they analyze.  However, this policy is very
 119 different.  It actually attempts to compile your code and then compares the
 120 subroutines mentioned in your code to those found in the symbol table.
 121 Therefore you should B<not> use this Policy on any code that you do not trust,
 122 or may have undesirable side-effects at compile-time (such as connecting to the
 123 network or mutating files).
 124
 125 For this Policy to work, all the modules included in your code must be
 126 installed locally, and must compile without error.
 127
 128 =head1 AUTHOR
 129
 130 Shawn M Moore, C<sartak@bestpractical.com>
 131
 132 =cut
 133