Rename the "check" member to "call"

[perl/modules/Sub-Op.git] / lib / Sub / Op.pm

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index cf67eac9e5317a8f7f984798d8fb3cbb134ca3e6..d8a6b738c7461f856af60f1137ac4ac725f9b9b2 100644 (file)
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -51,12 +51,14 @@ In your XS file :
     {
      sub_op_config_t c;
      sub_op_init(&c);
     {
      sub_op_config_t c;
      sub_op_init(&c);

-     c.name    = "reftype";
-     c.namelen = sizeof("reftype")-1;
-     c.pp      = scalar_util_reftype;
-     c.check   = 0;
-     c.ud      = NULL;
-     sub_op_register(aTHX_ &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 :
     }
 
 In your Perl module file :


@@ -148,14 +150,32 @@ my $sw = Variable::Magic::wizard(
     CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/;
    } if _constant_sub(do { no strict 'refs'; \&$fqn });
    no strict 'refs';
     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;
   }
 
    *$fqn = $placeholder;
   }
 

+  {
+   my $proto = _get_prototype($name);
+   no strict 'refs';
+   Scalar::Util::set_prototype(\&$fqn, $proto);
+  }
+

   return;
  },
 );
 
   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) = @_;
 
 sub _tag {
  my ($pkg, $name) = @_;
 


@@ -222,6 +242,19 @@ C<name>'s length, in bytes.
 
 =item *
 
 
 =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.
 C<Perl_ppaddr_t pp>
 
 The pp function that will be called instead of the subroutine.


@@ -253,11 +286,11 @@ 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.
 
 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)>
+=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.
 
 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)>
 
 
 =head2 C<sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig)>
 


@@ -345,107 +378,6 @@ sub disable {
  return;
 }
 
  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;
-    }
-   },
-  };
-
-  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;
-  }
- }
-}
-
-BEGIN { _monkeypatch() }
-

 =head1 EXAMPLES
 
 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
 =head1 EXAMPLES
 
 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.