lib/Class/Accessor/Grouped.pm

   1 package Class::Accessor::Grouped;
   2 use strict;
   3 use warnings;
   4 use Carp ();
   5 use Scalar::Util ();
   6 use MRO::Compat;
   7
   8 our $VERSION = '0.10001';
   9 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
  10
  11 # when changing minimum version don't forget to adjust L</PERFORMANCE> and
  12 # the Makefile.PL as well
  13 our $__minimum_xsa_version;
  14 BEGIN {
  15     $__minimum_xsa_version = '1.06';
  16 }
  17
  18 our $USE_XS;
  19 # the unless defined is here so that we can override the value
  20 # before require/use, *regardless* of the state of $ENV{CAG_USE_XS}
  21 $USE_XS = $ENV{CAG_USE_XS}
  22     unless defined $USE_XS;
  23
  24 # Yes this method is undocumented
  25 # Yes it should be a private coderef like all the rest at the end of this file
  26 # No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
  27 # %$*@!?&!&#*$!!!
  28 sub _mk_group_accessors {
  29     my($self, $maker, $group, @fields) = @_;
  30     my $class = Scalar::Util::blessed $self || $self;
  31
  32     no strict 'refs';
  33     no warnings 'redefine';
  34
  35     # So we don't have to do lots of lookups inside the loop.
  36     $maker = $self->can($maker) unless ref $maker;
  37
  38     foreach (@fields) {
  39         if( $_ eq 'DESTROY' ) {
  40             Carp::carp("Having a data accessor named DESTROY in ".
  41                        "'$class' is unwise.");
  42         }
  43
  44         my ($name, $field) = (ref $_)
  45             ? (@$_)
  46             : ($_, $_)
  47         ;
  48
  49         my $alias = "_${name}_accessor";
  50
  51         for my $meth ($name, $alias) {
  52
  53             # the maker may elect to not return anything, meaning it already
  54             # installed the coderef for us (e.g. lack of Sub::Name)
  55             my $cref = $self->$maker($group, $field, $meth)
  56                 or next;
  57
  58             my $fq_meth = "${class}::${meth}";
  59
  60             *$fq_meth = Sub::Name::subname($fq_meth, $cref);
  61                 #unless defined &{$class."\:\:$field"}
  62         }
  63     }
  64 };
  65
  66 # coderef is setup at the end for clarity
  67 my $gen_accessor;
  68
  69 =head1 NAME
  70
  71 Class::Accessor::Grouped - Lets you build groups of accessors
  72
  73 =head1 SYNOPSIS
  74
  75 =head1 DESCRIPTION
  76
  77 This class lets you build groups of accessors that will call different
  78 getters and setters.
  79
  80 =head1 METHODS
  81
  82 =head2 mk_group_accessors
  83
  84 =over 4
  85
  86 =item Arguments: $group, @fieldspec
  87
  88 Returns: none
  89
  90 =back
  91
  92 Creates a set of accessors in a given group.
  93
  94 $group is the name of the accessor group for the generated accessors; they
  95 will call get_$group($field) on get and set_$group($field, $value) on set.
  96
  97 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
  98 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
  99 methods.
 100
 101 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
 102 this is used as both field and accessor name, if a listref it is expected to
 103 be of the form [ $accessor, $field ].
 104
 105 =cut
 106
 107 sub mk_group_accessors {
 108     my ($self, $group, @fields) = @_;
 109
 110     $self->_mk_group_accessors('make_group_accessor', $group, @fields);
 111     return;
 112 }
 113
 114 =head2 mk_group_ro_accessors
 115
 116 =over 4
 117
 118 =item Arguments: $group, @fieldspec
 119
 120 Returns: none
 121
 122 =back
 123
 124 Creates a set of read only accessors in a given group. Identical to
 125 L</mk_group_accessors> but accessors will throw an error if passed a value
 126 rather than setting the value.
 127
 128 =cut
 129
 130 sub mk_group_ro_accessors {
 131     my($self, $group, @fields) = @_;
 132
 133     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 134 }
 135
 136 =head2 mk_group_wo_accessors
 137
 138 =over 4
 139
 140 =item Arguments: $group, @fieldspec
 141
 142 Returns: none
 143
 144 =back
 145
 146 Creates a set of write only accessors in a given group. Identical to
 147 L</mk_group_accessors> but accessors will throw an error if not passed a
 148 value rather than getting the value.
 149
 150 =cut
 151
 152 sub mk_group_wo_accessors {
 153     my($self, $group, @fields) = @_;
 154
 155     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 156 }
 157
 158 =head2 make_group_accessor
 159
 160 =over 4
 161
 162 =item Arguments: $group, $field, $method
 163
 164 Returns: \&accessor_coderef ?
 165
 166 =back
 167
 168 Called by mk_group_accessors for each entry in @fieldspec. Either returns
 169 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
 170 C<undef> if it elects to install the coderef on its own.
 171
 172 =cut
 173
 174 sub make_group_accessor { $gen_accessor->('rw', @_) }
 175
 176 =head2 make_group_ro_accessor
 177
 178 =over 4
 179
 180 =item Arguments: $group, $field, $method
 181
 182 Returns: \&accessor_coderef ?
 183
 184 =back
 185
 186 Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
 187 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
 188 C<undef> if it elects to install the coderef on its own.
 189
 190 =cut
 191
 192 sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
 193
 194 =head2 make_group_wo_accessor
 195
 196 =over 4
 197
 198 =item Arguments: $group, $field, $method
 199
 200 Returns: \&accessor_coderef ?
 201
 202 =back
 203
 204 Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
 205 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
 206 C<undef> if it elects to install the coderef on its own.
 207
 208 =cut
 209
 210 sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
 211
 212 =head2 get_simple
 213
 214 =over 4
 215
 216 =item Arguments: $field
 217
 218 Returns: $value
 219
 220 =back
 221
 222 Simple getter for hash-based objects which returns the value for the field
 223 name passed as an argument.
 224
 225 =cut
 226
 227 sub get_simple {
 228     return $_[0]->{$_[1]};
 229 }
 230
 231 =head2 set_simple
 232
 233 =over 4
 234
 235 =item Arguments: $field, $new_value
 236
 237 Returns: $new_value
 238
 239 =back
 240
 241 Simple setter for hash-based objects which sets and then returns the value
 242 for the field name passed as an argument.
 243
 244 =cut
 245
 246 sub set_simple {
 247     return $_[0]->{$_[1]} = $_[2];
 248 }
 249
 250
 251 =head2 get_inherited
 252
 253 =over 4
 254
 255 =item Arguments: $field
 256
 257 Returns: $value
 258
 259 =back
 260
 261 Simple getter for Classes and hash-based objects which returns the value for
 262 the field name passed as an argument. This behaves much like
 263 L<Class::Data::Accessor> where the field can be set in a base class,
 264 inherited and changed in subclasses, and inherited and changed for object
 265 instances.
 266
 267 =cut
 268
 269 sub get_inherited {
 270     my $class;
 271
 272     if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
 273         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 274           return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
 275         }
 276         else {
 277           Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 278         }
 279     }
 280     else {
 281         $class = $_[0];
 282     }
 283
 284     no strict 'refs';
 285     no warnings 'uninitialized';
 286
 287     my $cag_slot = '::__cag_'. $_[1];
 288     return ${$class.$cag_slot} if defined(${$class.$cag_slot});
 289
 290     # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
 291     my $cur_gen = mro::get_pkg_gen ($class);
 292     if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
 293         @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
 294         ${$class.'::__cag_pkg_gen__'} = $cur_gen;
 295     }
 296
 297     for (@{$class.'::__cag_supers__'}) {
 298         return ${$_.$cag_slot} if defined(${$_.$cag_slot});
 299     };
 300
 301     return undef;
 302 }
 303
 304 =head2 set_inherited
 305
 306 =over 4
 307
 308 =item Arguments: $field, $new_value
 309
 310 Returns: $new_value
 311
 312 =back
 313
 314 Simple setter for Classes and hash-based objects which sets and then returns
 315 the value for the field name passed as an argument. When called on a hash-based
 316 object it will set the appropriate hash key value. When called on a class, it
 317 will set a class level variable.
 318
 319 B<Note:>: This method will die if you try to set an object variable on a non
 320 hash-based object.
 321
 322 =cut
 323
 324 sub set_inherited {
 325     if (defined Scalar::Util::blessed $_[0]) {
 326         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 327             return $_[0]->{$_[1]} = $_[2];
 328         } else {
 329             Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 330         };
 331     } else {
 332         no strict 'refs';
 333
 334         return ${$_[0].'::__cag_'.$_[1]} = $_[2];
 335     };
 336 }
 337
 338 =head2 get_component_class
 339
 340 =over 4
 341
 342 =item Arguments: $field
 343
 344 Returns: $value
 345
 346 =back
 347
 348 Gets the value of the specified component class.
 349
 350     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 351
 352     $self->result_class->method();
 353
 354     ## same as
 355     $self->get_component_class('result_class')->method();
 356
 357 =cut
 358
 359 sub get_component_class {
 360     return $_[0]->get_inherited($_[1]);
 361 };
 362
 363 =head2 set_component_class
 364
 365 =over 4
 366
 367 =item Arguments: $field, $class
 368
 369 Returns: $new_value
 370
 371 =back
 372
 373 Inherited accessor that automatically loads the specified class before setting
 374 it. This method will die if the specified class could not be loaded.
 375
 376     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 377     __PACKAGE__->result_class('MyClass');
 378
 379     $self->result_class->method();
 380
 381 =cut
 382
 383 sub set_component_class {
 384     if ($_[2]) {
 385         local $^W = 0;
 386         require Class::Inspector;
 387         if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
 388             eval "require $_[2]";
 389
 390             Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
 391         };
 392     };
 393
 394     return $_[0]->set_inherited($_[1], $_[2]);
 395 };
 396
 397 =head2 get_super_paths
 398
 399 Returns a list of 'parent' or 'super' class names that the current class inherited from.
 400
 401 =cut
 402
 403 sub get_super_paths {
 404     return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
 405 };
 406
 407 =head1 PERFORMANCE
 408
 409 To provide total flexibility L<Class::Accessor::Grouped> calls methods
 410 internally while performing get/set actions, which makes it noticeably
 411 slower than similar modules. To compensate, this module will automatically
 412 use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
 413 accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is
 414 available on your system.
 415
 416 =head2 Benchmark
 417
 418 This is the result of a set/get/set loop benchmark on perl 5.12.1 with
 419 thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
 420 L<Moo>, L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>,
 421 L<XSA|Class::XSAccessor>, and L<CAF_XSA|Class::XSAccessor::Compat>:
 422
 423            Rate  CAG moOse  CAF moUse  moo HANDMADE CAF_XS moUse_XS moo_XS CAF_XSA  XSA CAG_XS
 424  CAG      169/s   --  -21% -24%  -32% -32%     -34%   -59%     -63%   -67%    -67% -67%   -67%
 425  moOse    215/s  27%    --  -3%  -13% -13%     -15%   -48%     -53%   -58%    -58% -58%   -58%
 426  CAF      222/s  31%    3%   --  -10% -10%     -13%   -46%     -52%   -57%    -57% -57%   -57%
 427  moUse    248/s  46%   15%  11%    --  -0%      -3%   -40%     -46%   -52%    -52% -52%   -52%
 428  moo      248/s  46%   15%  11%    0%   --      -3%   -40%     -46%   -52%    -52% -52%   -52%
 429  HANDMADE 255/s  50%   18%  14%    3%   3%       --   -38%     -45%   -50%    -51% -51%   -51%
 430  CAF_XS   411/s 143%   91%  85%   66%  66%      61%     --     -11%   -20%    -20% -21%   -21%
 431  moUse_XS 461/s 172%  114% 107%   86%  86%      81%    12%       --   -10%    -11% -11%   -11%
 432  moo_XS   514/s 204%  139% 131%  107% 107%     102%    25%      12%     --     -0%  -1%    -1%
 433  CAF_XSA  516/s 205%  140% 132%  108% 108%     103%    26%      12%     0%      --  -0%    -0%
 434  XSA      519/s 206%  141% 133%  109% 109%     104%    26%      13%     1%      0%   --    -0%
 435  CAG_XS   519/s 206%  141% 133%  109% 109%     104%    26%      13%     1%      0%   0%     --
 436
 437 Benchmark program is available in the root of the
 438 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
 439
 440 =head2 Notes on Class::XSAccessor
 441
 442 You can force (or disable) the use of L<Class::XSAccessor> before creating a
 443 particular C<simple> accessor by either manipulating the global variable
 444 C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
 445 L<localization|perlfunc/local>, or you can do so before runtime via the
 446 C<CAG_USE_XS> environment variable.
 447
 448 Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
 449 L</set_simple> this module does its best to detect if you are overriding
 450 one of these methods and will fall back to using the perl version of the
 451 accessor in order to maintain consistency. However be aware that if you
 452 enable use of C<Class::XSAccessor> (automatically or explicitly), create
 453 an object, invoke a simple accessor on that object, and B<then> manipulate
 454 the symbol table to install a C<get/set_simple> override - you get to keep
 455 all the pieces.
 456
 457 While L<Class::XSAccessor> works surprisingly well for the amount of black
 458 magic it tries to pull off, it's still black magic. At present (Sep 2010)
 459 the module is known to have problems on Windows under heavy thread-stress
 460 (e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
 461 will not be used automatically if you are running under C<MSWin32>.
 462
 463 =head1 AUTHORS
 464
 465 Matt S. Trout <mst@shadowcatsystems.co.uk>
 466
 467 Christopher H. Laco <claco@chrislaco.com>
 468
 469 =head1 CONTRIBUTORS
 470
 471 Caelum: Rafael Kitover <rkitover@cpan.org>
 472
 473 groditi: Guillermo Roditi <groditi@cpan.org>
 474
 475 Jason Plum <jason.plum@bmmsi.com>
 476
 477 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 478
 479
 480 =head1 COPYRIGHT & LICENSE
 481
 482 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
 483
 484 This program is free software; you can redistribute it and/or modify
 485 it under the same terms as perl itself.
 486
 487 =cut
 488
 489 ########################################################################
 490 ########################################################################
 491 ########################################################################
 492 #
 493 # Here be many angry dragons
 494 # (all code is in private coderefs since everything inherits CAG)
 495 #
 496 ########################################################################
 497 ########################################################################
 498
 499 BEGIN {
 500
 501   die "Huh?! No minimum C::XSA version?!\n"
 502     unless $__minimum_xsa_version;
 503
 504   local $@;
 505   my $err;
 506
 507
 508   $err = eval { require Sub::Name; 1; } ? undef : do {
 509     delete $INC{'Sub/Name.pm'};   # because older perls suck
 510     $@;
 511   };
 512   *__CAG_NO_SUBNAME = $err
 513     ? sub () { $err }
 514     : sub () { 0 }
 515   ;
 516
 517
 518   $err = eval {
 519     require Class::XSAccessor;
 520     Class::XSAccessor->VERSION($__minimum_xsa_version);
 521     require Sub::Name;
 522     1;
 523   } ? undef : do {
 524     delete $INC{'Sub/Name.pm'};   # because older perls suck
 525     delete $INC{'Class/XSAccessor.pm'};
 526     $@;
 527   };
 528   *__CAG_NO_CXSA = $err
 529     ? sub () { $err }
 530     : sub () { 0 }
 531   ;
 532
 533
 534   *__CAG_BROKEN_GOTO = ($] < '5.008009')
 535     ? sub () { 1 }
 536     : sub () { 0 }
 537   ;
 538
 539
 540   *__CAG_UNSTABLE_DOLLARAT = ($] < '5.013002')
 541     ? sub () { 1 }
 542     : sub () { 0 }
 543   ;
 544
 545
 546   *__CAG_TRACK_UNDEFER_FAIL = (
 547     $INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}
 548       and
 549     $0 =~ m|^ x?t / .+ \.t $|x
 550   ) ? sub () { 1 }
 551     : sub () { 0 }
 552   ;
 553 }
 554
 555 # Autodetect unless flag supplied
 556 # Class::XSAccessor is segfaulting on win32, in some
 557 # esoteric heavily-threaded scenarios
 558 # Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway
 559 my $xsa_autodetected;
 560 if (! defined $USE_XS) {
 561   $USE_XS = (!__CAG_NO_CXSA and $^O ne 'MSWin32') ? 1 : 0;
 562   $xsa_autodetected++;
 563 }
 564
 565 my $maker_templates = {
 566   rw => {
 567     xs_call => 'accessors',
 568     pp_code => sub {
 569       my $set = "set_$_[0]";
 570       my $get = "get_$_[0]";
 571       my $field = $_[1];
 572       $field =~ s/'/\\'/g;
 573
 574       "
 575         \@_ != 1
 576           ? shift->$set('$field', \@_)
 577           : shift->$get('$field')
 578       "
 579     },
 580   },
 581   ro => {
 582     xs_call => 'getters',
 583     pp_code => sub {
 584       my $get = "get_$_[0]";
 585       my $field = $_[1];
 586       $field =~ s/'/\\'/g;
 587
 588       "
 589         \@_ == 1
 590           ? shift->$get('$field')
 591           : do {
 592             my \$caller = caller;
 593             my \$class = ref \$_[0] || \$_[0];
 594             Carp::croak(\"'\$caller' cannot alter the value of '$field' \".
 595                         \"(read-only attributes of class '\$class')\");
 596           }
 597       "
 598     },
 599   },
 600   wo => {
 601     xs_call => 'setters',
 602     pp_code => sub {
 603       my $set = "set_$_[0]";
 604       my $field = $_[1];
 605       $field =~ s/'/\\'/g;
 606
 607       "
 608         \@_ != 1
 609           ? shift->$set('$field', \@_)
 610           : do {
 611             my \$caller = caller;
 612             my \$class = ref \$_[0] || \$_[0];
 613             Carp::croak(\"'\$caller' cannot access the value of '$field' \".
 614                         \"(write-only attributes of class '\$class')\");
 615           }
 616       "
 617     },
 618   },
 619 };
 620
 621
 622 my ($accessor_maker_cache, $no_xsa_warned_classes);
 623
 624 # can't use pkg_gen to track this stuff, as it doesn't
 625 # detect superclass mucking
 626 my $original_simple_getter = __PACKAGE__->can ('get_simple');
 627 my $original_simple_setter = __PACKAGE__->can ('set_simple');
 628
 629 # Note!!! Unusual signature
 630 $gen_accessor = sub {
 631   my ($type, $class, $group, $field, $methname) = @_;
 632   if (my $c = Scalar::Util::blessed( $class )) {
 633     $class = $c;
 634   }
 635
 636   # When installing an XSA simple accessor, we need to make sure we are not
 637   # short-circuiting a (compile or runtime) get_simple/set_simple override.
 638   # What we do here is install a lazy first-access check, which will decide
 639   # the ultimate coderef being placed in the accessor slot
 640   #
 641   # Also note that the *original* class will always retain this shim, as
 642   # different branches inheriting from it may have different overrides.
 643   # Thus the final method (properly labeled and all) is installed in the
 644   # calling-package's namespace
 645   if ($USE_XS and $group eq 'simple') {
 646     die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA )
 647       if __CAG_NO_CXSA;
 648
 649     return sub {
 650       my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0];
 651
 652       if (__CAG_TRACK_UNDEFER_FAIL) {
 653         my $deferred_calls_seen = do {
 654           no strict 'refs';
 655           \%{"${current_class}::__cag_deferred_xs_shim_invocations"}
 656         };
 657         my @cframe = caller(0);
 658         if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {
 659           Carp::carp (
 660             "Deferred version of method $cframe[3] invoked more than once (originally "
 661           . "invoked at $already_seen). This is a strong indication your code has "
 662           . 'cached the original ->can derived method coderef, and is using it instead '
 663           . 'of the proper method re-lookup, causing performance regressions'
 664           );
 665         }
 666         else {
 667           $deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]";
 668         }
 669       }
 670
 671       if (
 672         $current_class->can('get_simple') == $original_simple_getter
 673           &&
 674         $current_class->can('set_simple') == $original_simple_setter
 675       ) {
 676         # nothing has changed, might as well use the XS crefs
 677         #
 678         # note that by the time this code executes, we already have
 679         # *objects* (since XSA works on 'simple' only by definition).
 680         # If someone is mucking with the symbol table *after* there
 681         # are some objects already - look! many, shiny pieces! :)
 682         Class::XSAccessor->import(
 683           replace => 1,
 684           class => $current_class,
 685           $maker_templates->{$type}{xs_call} => {
 686             $methname => $field,
 687           },
 688         );
 689       }
 690       else {
 691         if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {
 692           # not using Carp since the line where this happens doesn't mean much
 693           warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
 694             . "'$current_class' inheriting from '$class' due to an overriden get_simple and/or "
 695             . "set_simple\n";
 696         }
 697
 698         no strict 'refs';
 699         no warnings 'redefine';
 700
 701         my $fq_name = "${current_class}::${methname}";
 702         *$fq_name = Sub::Name::subname($fq_name, do {
 703           # that's faster than local
 704           $USE_XS = 0;
 705           my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
 706           $USE_XS = 1;
 707           $c;
 708         });
 709       }
 710
 711       # older perls segfault if the cref behind the goto throws
 712       # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
 713       return $current_class->can($methname)->(@_) if __CAG_BROKEN_GOTO;
 714
 715       goto $current_class->can($methname);
 716     };
 717   }
 718
 719   # no Sub::Name - just install the coderefs directly (compiling every time)
 720   elsif (__CAG_NO_SUBNAME) {
 721     my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
 722       $maker_templates->{$type}{pp_code}->($group, $field);
 723
 724     no warnings 'redefine';
 725     local $@ if __CAG_UNSTABLE_DOLLARAT;
 726     eval "sub ${class}::${methname} { $src }";
 727
 728     undef;  # so that no further attempt will be made to install anything
 729   }
 730
 731   # a coderef generator with a variable pad (returns a fresh cref on every invocation)
 732   else {
 733     ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
 734       my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
 735         $maker_templates->{$type}{pp_code}->($group, $field);
 736
 737       local $@ if __CAG_UNSTABLE_DOLLARAT;
 738       eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;
 739     })->()
 740   }
 741 };
 742
 743 1;