=head1 VERSION
-Version 0.01
+Version 0.02
=cut
sub dl_load_flags { 0x01 }
BEGIN {
- $VERSION = '0.01';
+ $VERSION = '0.02';
require DynaLoader;
push @ISA, 'DynaLoader';
__PACKAGE__->bootstrap($VERSION);
BOOT:
{
sub_op_config_t c;
- c.name = "reftype";
- c.len = sizeof("reftype")-1;
- c.pp = scalar_util_reftype;
- c.check = 0;
- c.ud = NULL;
- sub_op_register(aTHX_ &c);
+ sub_op_init(&c);
+ c.name = "reftype";
+ c.namelen = sizeof("reftype")-1;
+ c.proto = "$";
+ c.protolen = sizeof("$")-1;
+ c.pp = scalar_util_reftype;
+ c.check = 0;
+ c.ud = NULL;
+ sub_op_register(aTHX_ &c, 0);
}
In your Perl module file :
CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
} if _constant_sub(do { no strict 'refs'; \&$fqn });
no strict 'refs';
- no warnings 'redefine';
+ no warnings qw/prototype redefine/;
*$fqn = $placeholder;
}
+ {
+ my $proto = _get_prototype($name);
+ no strict 'refs';
+ Scalar::Util::set_prototype(\&$fqn, $proto);
+ }
+
return;
},
);
+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"} };
+}
+
sub _tag {
my ($pkg, $name) = @_;
=item *
-C<STRLEN len>
+C<STRLEN namelen>
C<name>'s length, in bytes.
=item *
+C<const char *proto>
+
+The prototype you want to apply to the subroutine, or C<NULL> if none.
+Allowed to be static.
+
+=item *
+
+C<STRLEN protolen>
+
+C<proto>'s length, in bytes.
+
+=item *
+
C<Perl_ppaddr_t pp>
The pp function that will be called instead of the subroutine.
=back
-=head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c)>
+=head2 C<void sub_op_init(sub_op_config_t *c)>
+
+Initializes the fields of the C<sub_op_config_t> object.
+For future compatibility, it is required to call this function with your config object before storing your actual values.
+It will store safe defaults for members you won't set.
+
+=head2 C<void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags)>
Registers a name and its configuration into L<Sub::Op>.
The caller is responsible for allocating and freeing the C<sub_op_config_t> object.
-No pointer to it or to its members is kept.
+No pointer to it or to its members is kept, except if you pass the flag C<SUB_OP_REGISTER_STEAL> in which case the configuration object will be stolen to be stored into L<Sub::Op>'s internal datastructure.
+
+=head2 C<sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig)>
+
+Deeply clones the specified C<sub_op_config_t> object.
+
+=head2 C<void sub_op_free(pTHX_ sub_op_config_t *c)>
+
+Free the memory associated with the specified C<sub_op_config_t> object.
=head1 PERL API
return;
}
-sub _inject {
- my ($pkg, $inject) = @_;
-
- my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
-
- while (my ($meth, $code) = each %$inject) {
- next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
- no strict 'refs';
- *{"${pkg}::$meth"} = $code;
- }
-}
-
-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 {
- $injector = Variable::Magic::wizard(
- data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
- store => sub {
- my ($stash, $data, $key) = @_;
-
- return if $data->{guard};
- local $data->{guard} = 1;
-
- _inject($data->{pkg}, $data->{subs});
-
- return;
- },
- );
- }
-
- sub _monkeypatch {
- my %B_OP_inject;
-
- $B_OP_inject{first} = sub {
- if (defined _custom_name($_[0])) {
- $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
- goto $_[0]->can('first') || die 'oops';
- }
- require Carp;
- Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
- };
-
- $B_OP_inject{can} = sub {
- my ($obj, $meth) = @_;
- if ($meth eq 'first') {
- return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
- }
- $obj->SUPER::can($meth);
- };
-
- if (_defined_sub('B::OP::type')) {
- _inject('B::OP', \%B_OP_inject);
- } else {
- no strict 'refs';
- Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
- }
-
- my $B_Deparse_inject = {
- pp_custom => sub {
- my ($self, $op, $cx) = @_;
- my $name = _custom_name($op);
- die 'unhandled custom op' unless defined $name;
- if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
- my $kid = $op->first;
- $kid = $kid->first->sibling; # skip ex-list, pushmark
- my @exprs;
- 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)";
- } else {
- return $name;
- }
- },
- };
+=head1 EXAMPLES
- if (_defined_sub('B::Deparse::pp_entersub')) {
- _inject('B::Deparse', $B_Deparse_inject);
- } else {
- no strict 'refs';
- Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
- }
- }
-}
+See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
-BEGIN { _monkeypatch() }
+=head1 CAVEATS
-=head1 EXAMPLES
+Preexistent definitions of a sub whose name is handled by L<Sub::Op> are restored at the end of the lexical scope in which the module is used.
+But if you define a sub in the scope of action of L<Sub::Op> with a name that is currently being replaced, the new declaration will be obliterated at the scope end.
-See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
+Function calls without parenthesis inside an C<eval STRING> in the scope of the pragma won't be replaced.
+I know a few ways of fixing this, but I've not yet decided on which.
=head1 DEPENDENCIES
projects / perl / modules / Sub-Op.git / blobdiff