t/immutable/inline_close_over.t

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