lib/Method/Generate/Accessor.pm

   1 package Method::Generate::Accessor;
   2
   3 use strictures 1;
   4 use Moo::_Utils;
   5 use base qw(Moo::Object);
   6 use Sub::Quote;
   7 use B 'perlstring';
   8 BEGIN {
   9   our $CAN_HAZ_XS =
  10     !$ENV{MOO_XS_DISABLE}
  11       &&
  12     _maybe_load_module('Class::XSAccessor')
  13       &&
  14     (eval { Class::XSAccessor->VERSION('1.07') })
  15   ;
  16 }
  17
  18 sub generate_method {
  19   my ($self, $into, $name, $spec, $quote_opts) = @_;
  20   die "Must have an is" unless my $is = $spec->{is};
  21   if ($is eq 'ro') {
  22     $spec->{reader} = $name unless exists $spec->{reader};
  23   } elsif ($is eq 'rw') {
  24     $spec->{accessor} = $name unless exists $spec->{accessor};
  25   } elsif ($is eq 'lazy') {
  26     $spec->{init_arg} = undef unless exists $spec->{init_arg};
  27     $spec->{reader} = $name unless exists $spec->{reader};
  28     $spec->{lazy} = 1;
  29     $spec->{builder} ||= '_build_'.$name unless $spec->{default};
  30   } elsif ($is ne 'bare') {
  31     die "Unknown is ${is}";
  32   }
  33   my %methods;
  34   if (my $reader = $spec->{reader}) {
  35     if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
  36       $methods{$reader} = $self->_generate_xs(
  37         getters => $into, $reader, $name
  38       );
  39     } else {
  40       $self->{captures} = {};
  41       $methods{$reader} =
  42         quote_sub "${into}::${reader}"
  43           => '    die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
  44              .$self->_generate_get($name, $spec)
  45           => delete $self->{captures}
  46         ;
  47     }
  48   }
  49   if (my $accessor = $spec->{accessor}) {
  50     if (
  51       our $CAN_HAZ_XS
  52       && $self->is_simple_get($name, $spec)
  53       && $self->is_simple_set($name, $spec)
  54     ) {
  55       $methods{$accessor} = $self->_generate_xs(
  56         accessors => $into, $accessor, $name
  57       );
  58     } else {
  59       $self->{captures} = {};
  60       $methods{$accessor} =
  61         quote_sub "${into}::${accessor}"
  62           => $self->_generate_getset($name, $spec)
  63           => delete $self->{captures}
  64         ;
  65     }
  66   }
  67   if (my $writer = $spec->{writer}) {
  68     if (
  69       our $CAN_HAZ_XS
  70       && $self->is_simple_set($name, $spec)
  71     ) {
  72       $methods{$writer} = $self->_generate_xs(
  73         setters => $into, $writer, $name
  74       );
  75     } else {
  76       $self->{captures} = {};
  77       $methods{$writer} =
  78         quote_sub "${into}::${writer}"
  79           => $self->_generate_set($name, $spec)
  80           => delete $self->{captures}
  81         ;
  82     }
  83   }
  84   if (my $pred = $spec->{predicate}) {
  85     $methods{$pred} =
  86       quote_sub "${into}::${pred}" =>
  87         '    '.$self->_generate_simple_has('$_[0]', $name)."\n"
  88       ;
  89   }
  90   if (my $cl = $spec->{clearer}) {
  91     $methods{$cl} =
  92       quote_sub "${into}::${cl}" =>
  93         "    delete \$_[0]->{${\perlstring $name}}\n"
  94       ;
  95   }
  96   if (my $hspec = $spec->{handles}) {
  97     my $asserter = $spec->{asserter} ||= '_assert_'.$name;
  98     my @specs = do {
  99       if (ref($hspec) eq 'ARRAY') {
 100         map [ $_ => $_ ], @$hspec;
 101       } elsif (ref($hspec) eq 'HASH') {
 102         map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
 103           keys %$hspec;
 104       } elsif (!ref($hspec)) {
 105         map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec);
 106       } else {
 107         die "You gave me a handles of ${hspec} and I have no idea why";
 108       }
 109     };
 110     foreach my $spec (@specs) {
 111       my ($proxy, $target, @args) = @$spec;
 112       $self->{captures} = {};
 113       $methods{$proxy} =
 114         quote_sub "${into}::${proxy}" =>
 115           $self->_generate_delegation($asserter, $target, \@args),
 116           delete $self->{captures}
 117         ;
 118     }
 119   }
 120   if (my $asserter = $spec->{asserter}) {
 121     $self->{captures} = {};
 122     $methods{$asserter} =
 123       quote_sub "${into}::${asserter}" =>
 124         'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!,
 125         delete $self->{captures}
 126       ;
 127   }
 128   \%methods;
 129 }
 130
 131 sub is_simple_attribute {
 132   my ($self, $name, $spec) = @_;
 133   # clearer doesn't have to be listed because it doesn't
 134   # affect whether defined/exists makes a difference
 135   !grep $spec->{$_},
 136     qw(lazy default builder coerce isa trigger predicate weak_ref);
 137 }
 138
 139 sub is_simple_get {
 140   my ($self, $name, $spec) = @_;
 141   !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
 142 }
 143
 144 sub is_simple_set {
 145   my ($self, $name, $spec) = @_;
 146   !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
 147 }
 148
 149 sub has_eager_default {
 150   my ($self, $name, $spec) = @_;
 151   (!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
 152 }
 153
 154 sub _generate_get {
 155   my ($self, $name, $spec) = @_;
 156   my $simple = $self->_generate_simple_get('$_[0]', $name);
 157   if ($self->is_simple_get($name, $spec)) {
 158     $simple;
 159   } else {
 160     'do { '.$self->_generate_use_default(
 161       '$_[0]', $name, $spec,
 162       $self->_generate_simple_has('$_[0]', $name),
 163     ).'; '.$simple.' }';
 164   }
 165 }
 166
 167 sub _generate_simple_has {
 168   my ($self, $me, $name) = @_;
 169   "exists ${me}->{${\perlstring $name}}";
 170 }
 171
 172 sub generate_get_default {
 173   my $self = shift;
 174   $self->{captures} = {};
 175   my $code = $self->_generate_get_default(@_);
 176   ($code, delete $self->{captures});
 177 }
 178
 179 sub _generate_use_default {
 180   my ($self, $me, $name, $spec, $test) = @_;
 181   my $get_value = $self->_generate_get_default($me, $name, $spec);
 182   if ($spec->{coerce}) {
 183     $get_value = $self->_generate_coerce(
 184       $name, $get_value,
 185       $spec->{coerce}
 186     )
 187   }
 188   $self->_generate_simple_set(
 189     $me, $name, $spec, $get_value
 190   ).' unless '.$test;
 191 }
 192
 193 sub _generate_get_default {
 194   my ($self, $me, $name, $spec) = @_;
 195   $spec->{default}
 196     ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
 197     : "${me}->${\$spec->{builder}}"
 198 }
 199
 200 sub generate_simple_get {
 201   my ($self, @args) = @_;
 202   $self->_generate_simple_get(@args);
 203 }
 204
 205 sub _generate_simple_get {
 206   my ($self, $me, $name) = @_;
 207   my $name_str = perlstring $name;
 208   "${me}->{${name_str}}";
 209 }
 210
 211 sub _generate_set {
 212   my ($self, $name, $spec) = @_;
 213   if ($self->is_simple_set($name, $spec)) {
 214     $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
 215   } else {
 216     my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
 217     my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
 218     my $code = "do { my (\$self, \$value) = \@_;\n";
 219     if ($coerce) {
 220       $code .=
 221         "        \$value = "
 222         .$self->_generate_coerce($name, '$value', $coerce).";\n";
 223     }
 224     if ($isa_check) {
 225       $code .=
 226         "        ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
 227     }
 228     if ($trigger) {
 229       my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger);
 230       $code .=
 231         "        ".$simple.";\n        ".$fire.";\n"
 232         ."        \$value;\n";
 233     } else {
 234       $code .= "        ".$simple.";\n";
 235     }
 236     $code .= "      }";
 237     $code;
 238   }
 239 }
 240
 241 sub generate_coerce {
 242   my $self = shift;
 243   $self->{captures} = {};
 244   my $code = $self->_generate_coerce(@_);
 245   ($code, delete $self->{captures});
 246 }
 247
 248 sub _generate_coerce {
 249   my ($self, $name, $value, $coerce) = @_;
 250   $self->_generate_call_code($name, 'coerce', "${value}", $coerce);
 251 }
 252
 253 sub generate_trigger {
 254   my $self = shift;
 255   $self->{captures} = {};
 256   my $code = $self->_generate_trigger(@_);
 257   ($code, delete $self->{captures});
 258 }
 259
 260 sub _generate_trigger {
 261   my ($self, $name, $obj, $value, $trigger) = @_;
 262   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
 263 }
 264
 265 sub generate_isa_check {
 266   my ($self, @args) = @_;
 267   $self->{captures} = {};
 268   my $code = $self->_generate_isa_check(@args);
 269   ($code, delete $self->{captures});
 270 }
 271
 272 sub _generate_isa_check {
 273   my ($self, $name, $value, $check) = @_;
 274   $self->_generate_call_code($name, 'isa_check', $value, $check);
 275 }
 276
 277 sub _generate_call_code {
 278   my ($self, $name, $type, $values, $sub) = @_;
 279   if (my $quoted = quoted_from_sub($sub)) {
 280     my $code = $quoted->[1];
 281     my $at_ = '@_ = ('.$values.');';
 282     if (my $captures = $quoted->[2]) {
 283       my $cap_name = qq{\$${type}_captures_for_${name}};
 284       $self->{captures}->{$cap_name} = \$captures;
 285       Sub::Quote::inlinify(
 286         $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6)
 287       );
 288     } else {
 289       Sub::Quote::inlinify($code, $values);
 290     }
 291   } else {
 292     my $cap_name = qq{\$${type}_for_${name}};
 293     $self->{captures}->{$cap_name} = \$sub;
 294     "${cap_name}->(${values})";
 295   }
 296 }
 297
 298 sub generate_populate_set {
 299   my $self = shift;
 300   $self->{captures} = {};
 301   my $code = $self->_generate_populate_set(@_);
 302   ($code, delete $self->{captures});
 303 }
 304
 305 sub _generate_populate_set {
 306   my ($self, $me, $name, $spec, $source, $test) = @_;
 307   if ($self->has_eager_default($name, $spec)) {
 308     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
 309     my $get_default = $self->_generate_get_default(
 310                         '$new', $_, $spec
 311                       );
 312     my $get_value =
 313       defined($spec->{init_arg})
 314         ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
 315             .$get_default
 316             ."\n${get_indent})"
 317         : $get_default;
 318     if ($spec->{coerce}) {
 319       $get_value = $self->_generate_coerce(
 320         $name, $get_value,
 321         $spec->{coerce}
 322       )
 323     }
 324     ($spec->{isa}
 325       ? "    {\n      my \$value = ".$get_value.";\n      "
 326         .$self->_generate_isa_check(
 327           $name, '$value', $spec->{isa}
 328         ).";\n"
 329         .'      '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
 330         ."    }\n"
 331       : '    '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
 332     )
 333     .($spec->{trigger}
 334       ? '    '
 335         .$self->_generate_trigger(
 336           $name, $me, $self->_generate_simple_get($me, $name),
 337           $spec->{trigger}
 338         )." if ${test};\n"
 339       : ''
 340     );
 341   } else {
 342     "    if (${test}) {\n"
 343       .($spec->{coerce}
 344         ? "      $source = "
 345           .$self->_generate_coerce(
 346             $name, $source,
 347             $spec->{coerce}
 348           ).";\n"
 349         : ""
 350       )
 351       .($spec->{isa}
 352         ? "      "
 353           .$self->_generate_isa_check(
 354             $name, $source, $spec->{isa}
 355           ).";\n"
 356         : ""
 357       )
 358       ."      ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
 359       .($spec->{trigger}
 360         ? "      "
 361           .$self->_generate_trigger(
 362             $name, $me, $self->_generate_simple_get($me, $name),
 363             $spec->{trigger}
 364           ).";\n"
 365         : ""
 366       )
 367       ."    }\n";
 368   }
 369 }
 370
 371 sub generate_multi_set {
 372   my ($self, $me, $to_set, $from) = @_;
 373   "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
 374 }
 375
 376 sub _generate_simple_set {
 377   my ($self, $me, $name, $spec, $value) = @_;
 378   my $name_str = perlstring $name;
 379   my $simple = "${me}->{${name_str}} = ${value}";
 380
 381   if ($spec->{weak_ref}) {
 382     require Scalar::Util;
 383
 384     # Perl < 5.8.3 can't weaken refs to readonly vars
 385     # (e.g. string constants). This *can* be solved by:
 386     #
 387     #Internals::SetReadWrite($foo);
 388     #Scalar::Util::weaken ($foo);
 389     #Internals::SetReadOnly($foo);
 390     #
 391     # but requires XS and is just too damn crazy
 392     # so simply throw a better exception
 393     Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})";
 394
 395       eval { Scalar::Util::weaken($simple); 1 } or do {
 396         if( \$@ =~ /Modification of a read-only value attempted/) {
 397           require Carp;
 398           Carp::croak( sprintf (
 399             'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
 400             $name_str,
 401           ) );
 402         } else {
 403           die \$@;
 404         }
 405       };
 406 EOC
 407   } else {
 408     $simple;
 409   }
 410 }
 411
 412 sub _generate_getset {
 413   my ($self, $name, $spec) = @_;
 414   q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
 415     ."\n      : ".$self->_generate_get($name, $spec)."\n    )";
 416 }
 417
 418 sub _generate_delegation {
 419   my ($self, $asserter, $target, $args) = @_;
 420   my $arg_string = do {
 421     if (@$args) {
 422       # I could, I reckon, linearise out non-refs here using perlstring
 423       # plus something to check for numbers but I'm unsure if it's worth it
 424       $self->{captures}{'@curries'} = $args;
 425       '@curries, @_';
 426     } else {
 427       '@_';
 428     }
 429   };
 430   "shift->${asserter}->${target}(${arg_string});";
 431 }
 432
 433 sub _generate_xs {
 434   my ($self, $type, $into, $name, $slot) = @_;
 435   Class::XSAccessor->import(
 436     class => $into,
 437     $type => { $name => $slot }
 438   );
 439   $into->can($name);
 440 }
 441
 442 1;