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 dynamicmoose), 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 AUTHOR
 115
 116 Shawn M Moore, C<sartak@bestpractical.com>
 117
 118 =cut
 119