t/immutable/inline_close_over.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5
   6 use Test::Requires 'Data::Visitor';
   7 use Test::Requires 'PadWalker';
   8 use Try::Tiny;
   9 my $can_partialdump = try {
  10     Class::MOP::load_class('Devel::PartialDump', { -version => 0.14 }); 1;
  11 };
  12
  13 {
  14     package Test::Visitor;
  15     use Moose;
  16     use Moose::Util::TypeConstraints;
  17     extends 'Data::Visitor';
  18
  19     has closed_over => (
  20         traits  => ['Array'],
  21         isa     => 'ArrayRef',
  22         default => sub { [] },
  23         handles => {
  24             add_closed_over => 'push',
  25             closed_over     => 'elements',
  26             pass            => 'is_empty',
  27         },
  28     );
  29
  30     before visit_code => sub {
  31         my $self = shift;
  32         my ($code) = @_;
  33         my $closed_over = PadWalker::closed_over($code);
  34         $self->visit_ref($closed_over);
  35     };
  36
  37     after visit => sub {
  38         my $self = shift;
  39         my ($thing) = @_;
  40
  41         $self->add_closed_over($thing)
  42             unless $self->_is_okay_to_close_over($thing);
  43     };
  44
  45     sub _is_okay_to_close_over {
  46         my $self = shift;
  47         my ($thing) = @_;
  48
  49         match_on_type $thing => (
  50             'RegexpRef'  => sub { 1 },
  51             'Object'     => sub { 0 },
  52             'GlobRef'    => sub { 0 },
  53             'FileHandle' => sub { 0 },
  54             'Any'        => sub { 1 },
  55         );
  56     }
  57 }
  58
  59 sub close_over_ok {
  60     local $Test::Builder::Level = $Test::Builder::Level + 1;
  61     my ($package, $method) = @_;
  62     my $visitor = Test::Visitor->new;
  63     my $code = $package->meta->find_method_by_name($method)->body;
  64     $visitor->visit($code);
  65     if ($visitor->pass) {
  66         pass("${package}::${method} didn't close over anything complicated");
  67     }
  68     else {
  69         fail("${package}::${method} closed over some stuff:");
  70         my @closed_over = $visitor->closed_over;
  71         for my $i (1..10) {
  72             last unless @closed_over;
  73             my $closed_over = shift @closed_over;
  74             if ($can_partialdump) {
  75                 $closed_over = Devel::PartialDump->new->dump($closed_over);
  76             }
  77             diag($closed_over);
  78         }
  79         diag("... and " . scalar(@closed_over) . " more")
  80             if @closed_over;
  81     }
  82 }
  83
  84 {
  85     package Foo;
  86     use Moose;
  87     use Moose::Util::TypeConstraints;
  88
  89     has foo => (
  90         is  => 'ro',
  91         isa => 'Str',
  92     );
  93
  94     has bar => (
  95         is      => 'ro',
  96         isa     => 'Int',
  97         default => 1,
  98     );
  99
 100     has baz => (
 101         is      => 'rw',
 102         isa     => 'ArrayRef[Num]',
 103         default => sub { [ 1.2 ] },
 104         trigger => sub { warn "blah" },
 105     );
 106
 107     subtype 'Thing',
 108          as 'Int',
 109          where { $_ < 5 },
 110          message { "must be less than 5" };
 111     has quux => (
 112         is        => 'rw',
 113         isa       => 'Thing',
 114         predicate => 'has_quux',
 115         clearer   => 'clear_quux',
 116     );
 117
 118     __PACKAGE__->meta->make_immutable;
 119 }
 120
 121 close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux);
 122
 123 {
 124     package Foo::Sub;
 125     use Moose;
 126     extends 'Foo';
 127
 128     around foo => sub {
 129         my $orig = shift;
 130         my $self = shift;
 131         $self->$orig(@_);
 132     };
 133
 134     after bar => sub { };
 135     before baz => sub { };
 136     override quux => sub { super };
 137
 138     sub blah { inner }
 139
 140     __PACKAGE__->meta->make_immutable;
 141 }
 142
 143 close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah);
 144
 145 {
 146     package Foo::Sub::Sub;
 147     use Moose;
 148     extends 'Foo::Sub';
 149
 150     augment blah => { inner };
 151
 152     __PACKAGE__->meta->make_immutable;
 153 }
 154
 155 close_over_ok('Foo::Sub::Sub', $_) for qw(new blah);
 156
 157 {
 158     my %handles = (
 159         Array   => {
 160             count                 => 'count',
 161             elements              => 'elements',
 162             is_empty              => 'is_empty',
 163             push                  => 'push',
 164             push_curried          => [ push => 42, 84 ],
 165             unshift               => 'unshift',
 166             unshift_curried       => [ unshift => 42, 84 ],
 167             pop                   => 'pop',
 168             shift                 => 'shift',
 169             get                   => 'get',
 170             get_curried           => [ get => 1 ],
 171             set                   => 'set',
 172             set_curried_1         => [ set => 1 ],
 173             set_curried_2         => [ set => ( 1, 98 ) ],
 174             accessor              => 'accessor',
 175             accessor_curried_1    => [ accessor => 1 ],
 176             accessor_curried_2    => [ accessor => ( 1, 90 ) ],
 177             clear                 => 'clear',
 178             delete                => 'delete',
 179             delete_curried        => [ delete => 1 ],
 180             insert                => 'insert',
 181             insert_curried        => [ insert => ( 1, 101 ) ],
 182             splice                => 'splice',
 183             splice_curried_1      => [ splice => 1 ],
 184             splice_curried_2      => [ splice => 1, 2 ],
 185             splice_curried_all    => [ splice => 1, 2, ( 3, 4, 5 ) ],
 186             sort                  => 'sort',
 187             sort_curried          => [ sort => ( sub { $_[1] <=> $_[0] } ) ],
 188             sort_in_place         => 'sort_in_place',
 189             sort_in_place_curried =>
 190                 [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
 191             map                   => 'map',
 192             map_curried           => [ map => ( sub { $_ + 1 } ) ],
 193             grep                  => 'grep',
 194             grep_curried          => [ grep => ( sub { $_ < 5 } ) ],
 195             first                 => 'first',
 196             first_curried         => [ first => ( sub { $_ % 2 } ) ],
 197             join                  => 'join',
 198             join_curried          => [ join => '-' ],
 199             shuffle               => 'shuffle',
 200             uniq                  => 'uniq',
 201             reduce                => 'reduce',
 202             reduce_curried        => [ reduce => ( sub { $_[0] * $_[1] } ) ],
 203             natatime              => 'natatime',
 204             natatime_curried      => [ natatime => 2 ],
 205         },
 206         Hash    => {
 207             option_accessor  => 'accessor',
 208             quantity         => [ accessor => 'quantity' ],
 209             clear_options    => 'clear',
 210             num_options      => 'count',
 211             delete_option    => 'delete',
 212             is_defined       => 'defined',
 213             options_elements => 'elements',
 214             has_option       => 'exists',
 215             get_option       => 'get',
 216             has_no_options   => 'is_empty',
 217             keys             => 'keys',
 218             values           => 'values',
 219             key_value        => 'kv',
 220             set_option       => 'set',
 221         },
 222         Counter => {
 223             inc_counter    => 'inc',
 224             inc_counter_2  => [ inc => 2 ],
 225             dec_counter    => 'dec',
 226             dec_counter_2  => [ dec => 2 ],
 227             reset_counter  => 'reset',
 228             set_counter    => 'set',
 229             set_counter_42 => [ set => 42 ],
 230         },
 231         Number  => {
 232             abs         => 'abs',
 233             add         => 'add',
 234             inc         => [ add => 1 ],
 235             div         => 'div',
 236             cut_in_half => [ div => 2 ],
 237             mod         => 'mod',
 238             odd         => [ mod => 2 ],
 239             mul         => 'mul',
 240             set         => 'set',
 241             sub         => 'sub',
 242             dec         => [ sub => 1 ],
 243         },
 244         Bool    => {
 245             illuminate  => 'set',
 246             darken      => 'unset',
 247             flip_switch => 'toggle',
 248             is_dark     => 'not',
 249         },
 250         String  => {
 251             inc              => 'inc',
 252             append           => 'append',
 253             append_curried   => [ append => '!' ],
 254             prepend          => 'prepend',
 255             prepend_curried  => [ prepend => '-' ],
 256             replace          => 'replace',
 257             replace_curried  => [ replace => qr/(.)$/, sub { uc $1 } ],
 258             chop             => 'chop',
 259             chomp            => 'chomp',
 260             clear            => 'clear',
 261             match            => 'match',
 262             match_curried    => [ match  => qr/\D/ ],
 263             length           => 'length',
 264             substr           => 'substr',
 265             substr_curried_1 => [ substr => (1) ],
 266             substr_curried_2 => [ substr => ( 1, 3 ) ],
 267             substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
 268         },
 269         Code    => {
 270             execute        => 'execute',
 271             execute_method => 'execute_method',
 272         },
 273     );
 274
 275     my %isa = (
 276         Array   => 'ArrayRef[Str]',
 277         Hash    => 'HashRef[Int]',
 278         Counter => 'Int',
 279         Number  => 'Num',
 280         Bool    => 'Bool',
 281         String  => 'Str',
 282         Code    => 'CodeRef',
 283     );
 284
 285     my %default = (
 286         Array   => [],
 287         Hash    => {},
 288         Counter => 0,
 289         Number  => 0.0,
 290         Bool    => 1,
 291         String  => '',
 292         Code    => sub { },
 293     );
 294
 295     for my $trait (keys %default) {
 296         my $class_name = "Native::$trait";
 297         my $handles = $handles{$trait};
 298         my $attr_class = Moose::Util::with_traits(
 299             'Moose::Meta::Attribute',
 300             "Moose::Meta::Attribute::Native::Trait::$trait",
 301         );
 302         Moose::Meta::Class->create(
 303             $class_name,
 304             superclasses => ['Moose::Object'],
 305             attributes   => [
 306                 $attr_class->new(
 307                     'nonlazy',
 308                     is      => 'ro',
 309                     isa     => $isa{$trait},
 310                     default => sub { $default{$trait} },
 311                     handles => {
 312                         map {; "nonlazy_$_" => $handles->{$_} } keys %$handles
 313                     },
 314                 ),
 315                 $attr_class->new(
 316                     'lazy',
 317                     is      => 'ro',
 318                     isa     => $isa{$trait},
 319                     lazy    => 1,
 320                     default => sub { $default{$trait} },
 321                     handles => {
 322                         map {; "lazy_$_" => $handles->{$_} } keys %$handles
 323                     },
 324                 ),
 325             ],
 326         );
 327         close_over_ok($class_name, $_) for (
 328             'new',
 329             map {; "nonlazy_$_", "lazy_$_" } keys %$handles
 330         );
 331     }
 332 }
 333
 334 {
 335     package WithInitializer;
 336     use Moose;
 337
 338     has foo => (
 339         is          => 'ro',
 340         isa         => 'Str',
 341         initializer => sub { },
 342     );
 343
 344     has bar => (
 345         is          => 'ro',
 346         isa         => 'Str',
 347         lazy        => 1,
 348         default     => sub { 'a' },
 349         initializer => sub { },
 350     );
 351
 352     __PACKAGE__->meta->make_immutable;
 353 }
 354
 355 close_over_ok('WithInitializer', 'foo');
 356 { local $TODO = "initializer still closes over things";
 357 close_over_ok('WithInitializer', $_) for qw(new bar);
 358 }
 359
 360 BEGIN {
 361     package CustomErrorClass;
 362     use Moose;
 363     extends 'Moose::Error::Default';
 364 }
 365
 366 {
 367     package WithCustomErrorClass;
 368     use metaclass (
 369         metaclass => 'Moose::Meta::Class',
 370         error_class => 'CustomErrorClass',
 371     );
 372     use Moose;
 373
 374     has foo => (
 375         is  => 'ro',
 376         isa => 'Str',
 377     );
 378
 379     __PACKAGE__->meta->make_immutable;
 380 }
 381
 382 { local $TODO = "custom error classes still close over things";
 383 close_over_ok('WithCustomErrorClass', $_) for qw(new foo);
 384 }
 385
 386 done_testing;