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 violates_metaclass { die "Your policy (" . blessed($_[0]) . ") needs to implement violates_metaclass" }
  62
  63 sub _compile_document {
  64     my $self = shift;
  65     my $doc = $self->document;
  66
  67     my $source_code = $doc->content;
  68
  69     eval $source_code;
  70
  71     die "Unable to execute " . $doc->filename . ": $@" if $@;
  72 }
  73
  74 sub _find_packages {
  75     my $self = shift;
  76     return [ Class::MOP::get_all_metaclass_names ];
  77 }
  78
  79 sub _new_packages {
  80     my $self = shift;
  81     my $old  = shift;
  82     my @new;
  83     my %seen;
  84
  85     $seen{$_} = 1 for @$old;
  86
  87     for (@{ $self->_find_packages }) {
  88         push @new, $_ if !$seen{$_}++;
  89     }
  90
  91     return @new;
  92 }
  93
  94 no Moose;
  95
  96 1;
  97
  98 __END__
  99
 100 =head1 NAME
 101
 102 Perl::Critic::Policy::DynamicMoose
 103
 104 =head1 DESCRIPTION
 105
 106 The included policies are:
 107
 108 =over 4
 109
 110 =item L<Perl::Critic::Policy::DynamicMoose::ProhibitPublicBuilders>
 111
 112 Prohibit public builder methods for attributes. [Severity: 3]
 113
 114 =back
 115
 116 =head1 WARNING
 117
 118 B<VERY IMPORTANT:> Most L<Perl::Critic> Policies (including all the ones that
 119 ship with Perl::Critic> use pure static analysis -- they never compile nor
 120 execute any of the code that they analyze.  However, this policy is very
 121 different.  It actually attempts to compile your code and then compares the
 122 subroutines mentioned in your code to those found in the symbol table.
 123 Therefore you should B<not> use this Policy on any code that you do not trust,
 124 or may have undesirable side-effects at compile-time (such as connecting to the
 125 network or mutating files).
 126
 127 For this Policy to work, all the modules included in your code must be
 128 installed locally, and must compile without error.
 129
 130 =head1 AUTHOR
 131
 132 Shawn M Moore, C<sartak@bestpractical.com>
 133
 134 =cut
 135