view release on metacpan or  search on metacpan

lib/Class/Accessor/Grouped.pm  view on Meta::CPAN

          do {
            # that's faster than local
            $USE_XS = 0;
            my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
            $USE_XS = 1;
            $c;
          };
        }
      };

      # if after this shim was created someone wrapped it with an 'around',
      # we can not blindly reinstall the method slot - we will destroy the
      # wrapper. Silently chain execution further...
      if ( ! $cag_produced_crefs->{ $current_class->can($methname) || 0 } ) {

        # older perls segfault if the cref behind the goto throws
        # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
        return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;

        goto $resolved_implementation;
      }


      if (__CAG_ENV__::TRACK_UNDEFER_FAIL) {
        my $deferred_calls_seen = do {
          no strict 'refs';
          \%{"${current_class}::__cag_deferred_xs_shim_invocations"}
        };
        my @cframe = caller(0);

        if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {
          Carp::carp (
            "Deferred version of method $cframe[3] invoked more than once (originally "
          . "invoked at $already_seen). This is a strong indication your code has "
          . 'cached the original ->can derived method coderef, and is using it instead '
          . 'of the proper method re-lookup, causing minor performance regressions'
          );
        }
        else {
          $deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]";
        }
      }

      # install the resolved implementation into the code slot so we do not
      # come here anymore (hopefully)
      # since XSAccessor was available - so is Sub::Name
      {
        no strict 'refs';
        no warnings 'redefine';

        my $fq_name = "${current_class}::${methname}";
        *$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);
      }

      # now things are installed - one ref less to carry
      delete $resolved_methods->{$current_class}{$methname};

      # but need to record it in the expectation registry *in case* it
      # was cached via ->can for some moronic reason
      Scalar::Util::weaken( $cag_produced_crefs->{$resolved_implementation} = $resolved_implementation );


      # older perls segfault if the cref behind the goto throws
      # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
      return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;

      goto $resolved_implementation;
    };

    Scalar::Util::weaken($cag_produced_crefs->{$ret} = $ret);

    $ret; # returning shim
  }

  # no Sub::Name - just install the coderefs directly (compiling every time)
  elsif (__CAG_ENV__::NO_SUBNAME) {
    my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
      $maker_templates->{$type}{pp_generator}->($group, $field);

    $cag_eval->(
      "no warnings 'redefine'; sub ${class}::${methname} { $src }; 1",
    );

    undef;  # so that no further attempt will be made to install anything
  }

  # a coderef generator with a variable pad (returns a fresh cref on every invocation)
  else {
    ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
      my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
        $maker_templates->{$type}{pp_generator}->($group, $field);

      $cag_eval->( "sub { my \$dummy; sub { \$dummy if 0; $src } }" );
    })->()
  }
};

1;