10 Sub::Op - Install subroutines as opcodes.
20 sub dl_load_flags { 0x01 }
25 push @ISA, 'DynaLoader';
26 __PACKAGE__->bootstrap($VERSION);
35 STATIC OP *scalar_util_reftype(pTHX) {
42 PUSHs(sv_reftype(SvRV(sv), 0));
48 MODULE = Scalar::Util::Ops PACKAGE = Scalar::Util::Ops
54 k.len = sizeof("reftype")-1;
55 k.pp = scalar_util_reftype;
58 sub_op_register(aTHX_ &k);
61 In your Perl module file :
63 package Scalar::Util::Ops;
70 use Sub::Op; # Before loading our own shared library
75 push @ISA, 'DynaLoader';
76 __PACKAGE__->bootstrap($VERSION);
79 sub import { Sub::Op::enable(reftype => scalar caller) }
81 sub unimport { Sub::Op::disable(reftype => scalar caller) }
85 In your F<Makefile.PL> :
87 use ExtUtils::Depends;
89 my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
92 $ed->get_makefile_vars,
98 use B::Hooks::EndOfScope;
99 use Variable::Magic 0.08;
103 $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
104 _placeholder($placeholder);
107 my $sw = Variable::Magic::wizard(
108 data => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
110 my ($var, $data, $name) = @_;
112 return if $data->{guard};
113 local $data->{guard} = 1;
115 return unless $data->{map}->{$name};
117 my $pkg = $data->{pkg};
118 my $fqn = join '::', $pkg, $name;
121 *$fqn = $placeholder unless exists &$fqn;
132 Variable::Magic::getdata(%{"${pkg}::"}, $sw);
135 defined $data ? $data->{map} : undef;
139 my ($pkg, $name) = @_;
142 Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 });
149 Variable::Magic::dispell(%{"${pkg}::"}, $sw);
155 my $pkg = @_ > 0 ? $_[0] : caller;
156 my $fqn = "${pkg}::$name";
158 my $map = _map($pkg);
167 $^H{+(__PACKAGE__)} = 1;
169 on_scope_end { disable($name, $pkg) };
177 my $pkg = @_ > 0 ? $_[0] : caller;
178 my $fqn = "${pkg}::$name";
180 my $map = _map($pkg);
183 delete $map->{$name};
184 unless (keys %$map) {
193 my ($pkg, $inject) = @_;
195 my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
197 while (my ($meth, $code) = each %$inject) {
198 next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
200 *{"${pkg}::$meth"} = $code;
207 $injector = Variable::Magic::wizard(
208 data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
210 my ($stash, $data, $key) = @_;
212 return if $data->{guard};
213 local $data->{guard} = 1;
215 _inject($data->{pkg}, $data->{subs});
225 $B_OP_inject{first} = sub {
226 if (defined _custom_name($_[0])) {
227 $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
228 goto $_[0]->can('first') || die 'oops';
231 Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
234 $B_OP_inject{can} = sub {
235 my ($obj, $meth) = @_;
236 if ($meth eq 'first') {
237 return undef unless defined _custom_name($obj);
239 $obj->SUPER::can($meth);
242 if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
243 _inject('B::OP', \%B_OP_inject);
245 Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
248 my $B_Deparse_inject = {
250 my ($self, $op, $cx) = @_;
251 my $name = _custom_name($op);
252 die 'unhandled custom op' unless defined $name;
253 if ($op->flags & B::OPf_STACKED()) {
254 my $kid = $op->first;
255 $kid = $kid->first->sibling; # skip ex-list, pushmark
257 for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
258 push @exprs, $self->deparse($kid, 6);
260 my $args = join(", ", @exprs);
261 return "$name($args)";
268 if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
269 _inject('B::Deparse', $B_Deparse_inject);
271 Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
276 BEGIN { _monkeypatch() }
282 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
284 L<ExtUtils::Depends>.
290 L<B::Hooks::OP::Check::EntersubForCV>.
294 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
296 You can contact me by mail or on C<irc.perl.org> (vincent).
300 Please report any bugs or feature requests to C<bug-sub-op at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sub-Op>.
301 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
305 You can find documentation for this module with the perldoc command.
309 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
311 =head1 COPYRIGHT & LICENSE
313 Copyright 2010 Vincent Pit, all rights reserved.
315 This program is free software; you can redistribute it and/or modify it
316 under the same terms as Perl itself.