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