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