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;
56 k.pp = scalar_util_reftype;
57 sub_op_register(aTHX_ &k);
60 In your Perl module file :
62 package Scalar::Util::Ops;
69 use Sub::Op; # Before loading our own shared library
74 push @ISA, 'DynaLoader';
75 __PACKAGE__->bootstrap($VERSION);
78 sub import { Sub::Op::enable(reftype => scalar caller) }
80 sub unimport { Sub::Op::disable(reftype => scalar caller) }
84 In your F<Makefile.PL> :
86 use ExtUtils::Depends;
88 my $ed = ExtUtils::Depends->new('Scalar::Util::Ops' => 'Sub::Op');
91 $ed->get_makefile_vars,
97 use B::Hooks::EndOfScope;
98 use Variable::Magic 0.08;
102 $placeholder = sub { require Carp; Carp::croak('PLACEHOLDER') };
103 _placeholder($placeholder);
106 my $sw = Variable::Magic::wizard(
107 data => sub { +{ guard => 0, pkg => $_[1], map => $_[2] } },
109 my ($var, $data, $name) = @_;
111 return if $data->{guard};
112 local $data->{guard} = 1;
114 return unless $data->{map}->{$name};
116 my $pkg = $data->{pkg};
117 my $fqn = join '::', $pkg, $name;
119 _incoming($name, $pkg);
122 *$fqn = $placeholder unless exists &$fqn;
133 Variable::Magic::getdata(%{"${pkg}::"}, $sw);
136 defined $data ? $data->{map} : undef;
140 my ($pkg, $name) = @_;
143 Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 });
150 Variable::Magic::dispell(%{"${pkg}::"}, $sw);
156 my $pkg = @_ > 0 ? $_[0] : caller;
157 my $fqn = "${pkg}::$name";
159 my $map = _map($pkg);
168 $^H{+(__PACKAGE__)} = 1;
170 on_scope_end { disable($name, $pkg) };
178 my $pkg = @_ > 0 ? $_[0] : caller;
179 my $fqn = "${pkg}::$name";
181 my $map = _map($pkg);
184 delete $map->{$name};
185 unless (keys %$map) {
194 my ($pkg, $inject) = @_;
196 my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
198 while (my ($meth, $code) = each %$inject) {
199 next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
201 *{"${pkg}::$meth"} = $code;
208 $injector = Variable::Magic::wizard(
209 data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
211 my ($stash, $data, $key) = @_;
213 return if $data->{guard};
214 local $data->{guard} = 1;
216 _inject($data->{pkg}, $data->{subs});
226 $B_OP_inject{first} = sub {
227 if (defined _custom_name($_[0])) {
228 $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
229 goto $_[0]->can('first') || die 'oops';
232 Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
235 $B_OP_inject{can} = sub {
236 my ($obj, $meth) = @_;
237 if ($meth eq 'first') {
238 return undef unless defined _custom_name($obj);
240 $obj->SUPER::can($meth);
243 if (%B:: and %B::OP:: and *B::OP::type{CODE}) {
244 _inject('B::OP', \%B_OP_inject);
246 Variable::Magic::cast %B::OP::, $injector, 'B::OP', \%B_OP_inject;
249 my $B_Deparse_inject = {
251 my ($self, $op, $cx) = @_;
252 my $name = _custom_name($op);
253 die 'unhandled custom op' unless defined $name;
254 if ($op->flags & B::OPf_STACKED()) {
255 my $kid = $op->first;
256 $kid = $kid->first->sibling; # skip ex-list, pushmark
258 for (; not B::Deparse::null($kid); $kid = $kid->sibling) {
259 push @exprs, $self->deparse($kid, 6);
261 my $args = join(", ", @exprs);
262 return "$name($args)";
269 if (%B:: and %B::Deparse:: and *B::Deparse::pp_entersub{CODE}) {
270 _inject('B::Deparse', $B_Deparse_inject);
272 Variable::Magic::cast %B::Deparse::, $injector, 'B::Deparse', $B_Deparse_inject;
277 BEGIN { _monkeypatch() }
283 L<Variable::Magic>, L<B::Hooks::EndOfScope>.
285 L<ExtUtils::Depends>.
291 L<B::Hooks::OP::Check::EntersubForCV>.
295 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
297 You can contact me by mail or on C<irc.perl.org> (vincent).
301 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>.
302 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
306 You can find documentation for this module with the perldoc command.
310 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Op>.
312 =head1 COPYRIGHT & LICENSE
314 Copyright 2010 Vincent Pit, all rights reserved.
316 This program is free software; you can redistribute it and/or modify it
317 under the same terms as Perl itself.