my $pkg = $data->{pkg};
my $fqn = join '::', $pkg, $name;
- no strict 'refs';
- *$fqn = $placeholder unless exists &$fqn;
+ {
+ local $SIG{__WARN__} = sub {
+ CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
+ } if _constant_sub(do { no strict 'refs'; \&$fqn });
+ no strict 'refs';
+ no warnings 'redefine';
+ *$fqn = $placeholder;
+ }
return;
},
my $fqn = join '::', $pkg, $name;
return {
+ old => _defined_sub($fqn) ? \&$fqn : undef,
proto => prototype($fqn),
};
}
my $pkg = @_ > 0 ? $_[0] : caller;
my $map = _map($pkg);
+ my $fqn = join '::', $pkg, $name;
+
if (defined $map) {
- my $proto = $map->{$name}->{proto};
+ my $tag = $map->{$name};
+
+ my $old = $tag->{old};
+ if (defined $old) {
+ no strict 'refs';
+ no warnings 'redefine';
+ *$fqn = $old;
+ }
+
+ my $proto = $tag->{proto};
if (defined $proto) {
no strict 'refs';
- Scalar::Util::set_prototype(\&{"${pkg}::$name"}, $proto);
+ Scalar::Util::set_prototype(\&$fqn, $proto);
}
delete $map->{$name};
}
}
+sub _defined_sub {
+ my ($fqn) = @_;
+ my @parts = split /::/, $fqn;
+ my $name = pop @parts;
+ my $pkg = '';
+ for (@parts) {
+ $pkg .= $_ . '::';
+ return 0 unless do { no strict 'refs'; %$pkg };
+ }
+ return do { no strict 'refs'; defined &{"$pkg$name"} };
+}
+
{
my $injector;
BEGIN {
$obj->SUPER::can($meth);
};
- if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
+ if (_defined_sub('B::OP::type')) {
_inject('B::OP', \%B_OP_inject);
} else {
- Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
+ no strict 'refs';
+ Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
}
my $B_Deparse_inject = {
my ($self, $op, $cx) = @_;
my $name = _custom_name($op);
die 'unhandled custom op' unless defined $name;
- if ($op->flags & B::OPf_STACKED()) {
+ if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
my $kid = $op->first;
$kid = $kid->first->sibling; # skip ex-list, pushmark
my @exprs;
- for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
+ while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
push @exprs, $self->deparse($kid, 6);
+ $kid = $kid->sibling;
}
my $args = join(", ", @exprs);
return "$name($args)";
},
};
- if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
+ if (_defined_sub('B::Deparse::pp_entersub')) {
_inject('B::Deparse', $B_Deparse_inject);
} else {
- Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
+ no strict 'refs';
+ Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
}
}
}
L<subs::auto>.
+L<B::Hooks::XSUB::CallAsOp> provides a C API to declare XSUBs that effectively call a specific PP function.
+Thus, it allows you to write XSUBs with the PP stack conventions used for implementing perl core keywords.
+There's no opcode replacement and no parsing hacks.
+
L<B::Hooks::OP::Check::EntersubForCV>.
=head1 AUTHOR