t/050_metaclasses/070_close_over_meta.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Moose;
   6
   7 use Class::MOP;
   8 use List::MoreUtils 'any';
   9 use Package::Stash;
  10 use Scalar::Util 'blessed';
  11 use Test::Requires 'PadWalker';
  12
  13 sub doesnt_close_over_meta {
  14     local $Test::Builder::Level = $Test::Builder::Level + 1;
  15     my $code = shift;
  16     my ($pkg, $name) = Class::MOP::get_code_info($code);
  17     my $closed_over = PadWalker::closed_over($code);
  18     ok(!(any { ref eq 'REF' && blessed($$_) && $$_->isa('Class::MOP::Object') }
  19              values %$closed_over),
  20        "${pkg}::${name} doesn't close over any metaobjects");
  21 }
  22
  23 sub class_doesnt_close_over_meta {
  24     local $Test::Builder::Level = $Test::Builder::Level + 1;
  25     my $class = shift;
  26     my $stash = Package::Stash->new($class);
  27     with_immutable {
  28         doesnt_close_over_meta($_)
  29             for map { $stash->get_package_symbol('&' . $_) }
  30                     grep { $_ ne 'meta' }
  31                          $stash->list_all_package_symbols('CODE');
  32     } $class;
  33 }
  34
  35 {
  36     package BasicAccessors;
  37     use Moose;
  38
  39     has foo => (
  40         is        => 'ro',
  41         clearer   => 'clear_foo',
  42         predicate => 'has_foo',
  43     );
  44
  45     has bar => (
  46         is => 'rw',
  47     );
  48
  49     has baz => (
  50         reader => 'get_baz',
  51         writer => 'set_baz',
  52     );
  53
  54     no Moose;
  55 }
  56
  57 {
  58     package MethodModifiers::Base;
  59     use Moose;
  60
  61     sub foo_base { }
  62     sub bar_base { }
  63     sub baz_base { }
  64     sub quux_base { }
  65     sub quuux_base { inner() };
  66
  67     no Moose;
  68 }
  69
  70 {
  71     package MethodModifiers;
  72     use Moose;
  73     extends 'MethodModifiers::Base';
  74
  75     sub foo { }
  76     sub bar { }
  77     sub baz { }
  78
  79     before foo => sub { };
  80     after  bar => sub { };
  81     around baz => sub { };
  82
  83     before foo_base => sub { };
  84     after  bar_base => sub { };
  85     around baz_base => sub { };
  86     override quux_base => sub { super() };
  87     augment quuux_base => sub { inner() };
  88
  89     no Moose;
  90 }
  91
  92 {
  93     package ConstructorDestructor;
  94     use Moose;
  95
  96     has def => (
  97         is      => 'ro',
  98         default => '',
  99     );
 100
 101     has def_ref => (
 102         is      => 'ro',
 103         default => sub { [] },
 104     );
 105
 106     has build => (
 107         is      => 'ro',
 108         builder => '_build_build',
 109     );
 110
 111     has def_lazy => (
 112         is      => 'ro',
 113         default => '',
 114         lazy    => 1,
 115     );
 116
 117     has def_ref_lazy => (
 118         is      => 'ro',
 119         default => sub { [] },
 120         lazy    => 1,
 121     );
 122
 123     has build_lazy => (
 124         is      => 'ro',
 125         builder => '_build_build_lazy',
 126         lazy    => 1,
 127     );
 128
 129     sub _build_build { '' }
 130     sub _build_build_lazy { '' }
 131
 132     sub BUILD { }
 133     sub BUILDARGS { shift->SUPER::BUILDARGS(@_) }
 134     sub DEMOLISH { }
 135
 136     no Moose;
 137 }
 138
 139 {
 140     package FancyAccessors;
 141     use Moose;
 142     use Moose::Util::TypeConstraints;
 143
 144     subtype 'Coerced', as 'Str', where { /a-z/ };
 145     coerce 'Coerced', from 'Str', via { lc };
 146
 147     has foo => (
 148         is          => 'rw',
 149         isa         => 'FancyAccessors',
 150         weak_ref    => 1,
 151         initializer => sub { $_[2]->($_[1]) },
 152     );
 153
 154     has bar => (
 155         is       => 'rw',
 156         isa      => 'Coerced',
 157         coerce   => 1,
 158         trigger  => sub { 'foo' },
 159         init_arg => 'rab',
 160     );
 161
 162     has baz => (
 163         is            => 'ro',
 164         isa           => 'ArrayRef[Int]',
 165         auto_deref    => 1,
 166         required      => 1,
 167         documentation => "it's a baz",
 168     );
 169
 170     no Moose;
 171     no Moose::Util::TypeConstraints;
 172 }
 173
 174 {
 175     package NativeTraits;
 176     use Moose;
 177
 178     has array => (
 179         traits  => ['Array'],
 180         isa     => 'ArrayRef',
 181         default => sub { [] },
 182         handles => {
 183             array_count              => 'count',
 184             array_elements           => 'elements',
 185             array_is_empty           => 'is_empty',
 186             array_push               => 'push',
 187             array_push_curried       => [ push => 42, 84 ],
 188             array_unshift            => 'unshift',
 189             array_unshift_curried    => [ unshift => 42, 84 ],
 190             array_pop                => 'pop',
 191             array_shift              => 'shift',
 192             array_get                => 'get',
 193             array_get_curried        => [ get => 1 ],
 194             array_set                => 'set',
 195             array_set_curried_1      => [ set => 1 ],
 196             array_set_curried_2      => [ set => ( 1, 98 ) ],
 197             array_accessor           => 'accessor',
 198             array_accessor_curried_1 => [ accessor => 1 ],
 199             array_accessor_curried_2 => [ accessor => ( 1, 90 ) ],
 200             array_clear              => 'clear',
 201             array_delete             => 'delete',
 202             array_delete_curried     => [ delete => 1 ],
 203             array_insert             => 'insert',
 204             array_insert_curried     => [ insert => ( 1, 101 ) ],
 205             array_splice             => 'splice',
 206             array_splice_curried_1   => [ splice => 1 ],
 207             array_splice_curried_2   => [ splice => 1, 2 ],
 208             array_splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
 209             array_sort               => 'sort',
 210             array_sort_curried       =>
 211                 [ sort => ( sub { $_[1] <=> $_[0] } ) ],
 212             array_sort_in_place      => 'sort_in_place',
 213             array_sort_in_place_curried =>
 214                 [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
 215             array_map                => 'map',
 216             array_map_curried        => [ map => ( sub { $_ + 1 } ) ],
 217             array_grep               => 'grep',
 218             array_grep_curried       => [ grep => ( sub { $_ < 5 } ) ],
 219             array_first              => 'first',
 220             array_first_curried      => [ first => ( sub { $_ % 2 } ) ],
 221             array_join               => 'join',
 222             array_join_curried       => [ join => '-' ],
 223             array_shuffle            => 'shuffle',
 224             array_uniq               => 'uniq',
 225             array_reduce             => 'reduce',
 226             array_reduce_curried     =>
 227                 [ reduce => ( sub { $_[0] * $_[1] } ) ],
 228             array_natatime           => 'natatime',
 229             array_natatime_curried   => [ natatime => 2 ],
 230         },
 231     );
 232
 233     has bool => (
 234         traits  => ['Bool'],
 235         isa     => 'Bool',
 236         default => 0,
 237         handles => {
 238             bool_illuminate  => 'set',
 239             bool_darken      => 'unset',
 240             bool_flip_switch => 'toggle',
 241             bool_is_dark     => 'not',
 242         },
 243     );
 244
 245     has code => (
 246         traits  => ['Code'],
 247         isa     => 'CodeRef',
 248         default => sub { sub { } },
 249         handles => {
 250             code_execute        => 'execute',
 251             code_execute_method => 'execute_method',
 252         },
 253     );
 254
 255     has counter => (
 256         traits  => ['Counter'],
 257         isa     => 'Int',
 258         default => 0,
 259         handles => {
 260             inc_counter    => 'inc',
 261             inc_counter_2  => [ inc => 2 ],
 262             dec_counter    => 'dec',
 263             dec_counter_2  => [ dec => 2 ],
 264             reset_counter  => 'reset',
 265             set_counter    => 'set',
 266             set_counter_42 => [ set => 42 ],
 267         },
 268     );
 269
 270     has hash => (
 271         traits  => ['Hash'],
 272         isa     => 'HashRef',
 273         default => sub { {} },
 274         handles => {
 275             hash_option_accessor  => 'accessor',
 276             hash_quantity         => [ accessor => 'quantity' ],
 277             hash_clear_options    => 'clear',
 278             hash_num_options      => 'count',
 279             hash_delete_option    => 'delete',
 280             hash_is_defined       => 'defined',
 281             hash_options_elements => 'elements',
 282             hash_has_option       => 'exists',
 283             hash_get_option       => 'get',
 284             hash_has_no_options   => 'is_empty',
 285             hash_key_value        => 'kv',
 286             hash_set_option       => 'set',
 287         },
 288     );
 289
 290     has number => (
 291         traits  => ['Number'],
 292         isa     => 'Num',
 293         default => 0,
 294         handles => {
 295             num_abs         => 'abs',
 296             num_add         => 'add',
 297             num_inc         => [ add => 1 ],
 298             num_div         => 'div',
 299             num_cut_in_half => [ div => 2 ],
 300             num_mod         => 'mod',
 301             num_odd         => [ mod => 2 ],
 302             num_mul         => 'mul',
 303             num_set         => 'set',
 304             num_sub         => 'sub',
 305             num_dec         => [ sub => 1 ],
 306         },
 307     );
 308
 309     has string => (
 310         traits  => ['String'],
 311         isa     => 'Str',
 312         default => '',
 313         handles => {
 314             string_inc             => 'inc',
 315             string_append          => 'append',
 316             string_append_curried  => [ append => '!' ],
 317             string_prepend         => 'prepend',
 318             string_prepend_curried => [ prepend => '-' ],
 319             string_replace         => 'replace',
 320             string_replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
 321             string_chop            => 'chop',
 322             string_chomp           => 'chomp',
 323             string_clear           => 'clear',
 324             string_match           => 'match',
 325             string_match_curried    => [ match  => qr/\D/ ],
 326             string_length           => 'length',
 327             string_substr           => 'substr',
 328             string_substr_curried_1 => [ substr => (1) ],
 329             string_substr_curried_2 => [ substr => ( 1, 3 ) ],
 330             string_substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
 331         },
 332     );
 333
 334     no Moose;
 335 }
 336
 337 { local $TODO = "we close over all kinds of stuff";
 338 class_doesnt_close_over_meta('BasicAccessors');
 339 class_doesnt_close_over_meta('MethodModifiers');
 340 class_doesnt_close_over_meta('ConstructorDestructor');
 341 class_doesnt_close_over_meta('FancyAccessors');
 342 class_doesnt_close_over_meta('NativeTraits');
 343 }
 344
 345 done_testing;