From: Vincent Pit <perl@profvince.com>
Date: Wed, 4 Nov 2015 17:41:16 +0000 (-0200)
Subject: Enable free callbcks
X-Git-Tag: v0.11~6
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=d4db715e455063f957068da7ac3bc548935f9ff5;p=perl%2Fmodules%2Fre-engine-Plugin.git

Enable free callbcks
---

diff --git a/MANIFEST b/MANIFEST
index 4fc5bf7..b0837a3 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -16,7 +16,6 @@ t/10-usage/import.t
 t/10-usage/integrate.t
 t/10-usage/scope.t
 t/20-methods/base.t
-t/20-methods/free.t
 t/20-methods/minlen/bytes.t
 t/20-methods/minlen/get.t
 t/20-methods/minlen/set.t
@@ -28,6 +27,7 @@ t/20-methods/str/modify.t
 t/20-methods/str/types.t
 t/20-methods/str/undef.t
 t/30-callbacks/exec.t
+t/30-callbacks/free.t
 t/40-ctl/eval-comp.t
 t/40-ctl/eval-exec.t
 t/50-num_buff/FETCH.t
diff --git a/Plugin.pm b/Plugin.pm
index 93ac7e6..ad5e219 100644
--- a/Plugin.pm
+++ b/Plugin.pm
@@ -20,7 +20,7 @@ sub import
     my ($pkg, %sub) = @_;
 
     # Valid callbacks
-    my @callback = qw<comp exec>;
+    my @callback = qw<comp exec free>;
 
     for (@callback) {
         next unless exists $sub{$_};
@@ -55,7 +55,7 @@ sub callbacks
 {
     my ($re, %callback) = @_;
 
-    my %map = map { $_ => "_$_" } qw<exec>;
+    my %map = map { $_ => "_$_" } qw<exec free>;
 
     for my $key (keys %callback) {
         my $name = $map{$key};
diff --git a/Plugin.pod b/Plugin.pod
index 1c98ce5..e69c8f4 100644
--- a/Plugin.pod
+++ b/Plugin.pod
@@ -45,6 +45,7 @@ key-value pairs of names and subroutine references:
     use re::engine::Plugin (
         comp => sub {},
         exec => sub {},
+        free => sub {},
     );
 
 To write a custom engine which imports your functions into the
@@ -59,6 +60,7 @@ caller's scope use use the following snippet:
         re::engine::Plugin->import(
             comp => \&comp,
             exec => \&exec,
+            free => \&free,
         );
     }
 
@@ -67,6 +69,7 @@ caller's scope use use the following snippet:
     # Implementation of the engine
     sub comp { ... }
     sub exec { ... }
+    sub free { ... }
 
     1;
 
@@ -110,15 +113,21 @@ invalid pattern such as C</(/>.
 
 =head2 exec
 
-    exec => sub {
-        my ($rx, $str) = @_;
+    my $ponies;
+    use re::engine::Plugin(
+        exec => sub {
+            my ($rx, $str) = @_;
 
-        # We always like ponies!
-        return 1 if $str ~~ /pony/;
+            # We always like ponies!
+            if ($str ~~ /pony/) {
+                $ponies++;
+                return 1;
+            }
 
-        # Failed to match
-        return;
-    }
+            # Failed to match
+            return;
+        }
+    );
 
 Called when a regex is being executed, i.e. when it's being matched
 against something. The scalar being matched against the pattern is
@@ -129,6 +138,28 @@ successful, and a false one if it wasn't.
 This callback can also be specified on an individual basis with the
 L</callbacks> method.
 
+=head2 free
+
+    use re::engine::Plugin(
+        free => sub {
+            my ($rx) = @_;
+
+            say 'matched ' ($ponies // 'no')
+                . ' pon' . ($ponies > 1 ? 'ies' : 'y');
+
+            return;
+        }
+    );
+
+Called when the regexp structure is freed by the perl interpreter.
+Note that this happens pretty late in the destruction process, but
+still before global destruction kicks in. The only argument this
+callback receives is the C<re::engine::Plugin> object associated
+with the regexp, and its return value is ignored.
+
+This callback can also be specified on an individual basis with the
+L</callbacks> method.
+
 =head1 METHODS
 
 =head2 str
@@ -213,8 +244,8 @@ Takes a list of key-value pairs of names and subroutines, and replace the
 callback currently attached to the regular expression for the type given as
 the key by the code reference passed as the corresponding value.
 
-The only valid key is currently C<exec>. See L</exec> for more details about
-this callback.
+The only valid keys are currently C<exec> and C<free>. See L</exec> and
+L</free> for more details about these callbacks.
 
 =head2 num_captures
 
diff --git a/Plugin.xs b/Plugin.xs
index da33ce2..c16dfba 100644
--- a/Plugin.xs
+++ b/Plugin.xs
@@ -18,6 +18,7 @@
 typedef struct {
  SV *comp;
  SV *exec;
+ SV *free;
 } xsh_hints_user_t;
 
 static SV *rep_validate_callback(SV *code) {
@@ -34,6 +35,7 @@ static SV *rep_validate_callback(SV *code) {
 static void xsh_hints_user_init(pTHX_ xsh_hints_user_t *hv, xsh_hints_user_t *v) {
  hv->comp = rep_validate_callback(v->comp);
  hv->exec = rep_validate_callback(v->exec);
+ hv->free = rep_validate_callback(v->free);
 
  return;
 }
@@ -43,6 +45,7 @@ static void xsh_hints_user_init(pTHX_ xsh_hints_user_t *hv, xsh_hints_user_t *v)
 static void xsh_hints_user_clone(pTHX_ xsh_hints_user_t *nv, xsh_hints_user_t *ov, CLONE_PARAMS *params) {
  nv->comp = xsh_dup_inc(ov->comp, params);
  nv->exec = xsh_dup_inc(ov->exec, params);
+ nv->free = xsh_dup_inc(ov->free, params);
 
  return;
 }
@@ -52,6 +55,7 @@ static void xsh_hints_user_clone(pTHX_ xsh_hints_user_t *nv, xsh_hints_user_t *o
 static void xsh_hints_user_deinit(pTHX_ xsh_hints_user_t *hv) {
  SvREFCNT_dec(hv->comp);
  SvREFCNT_dec(hv->exec);
+ SvREFCNT_dec(hv->free);
 
  return;
 }
@@ -248,6 +252,12 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
   SvREFCNT_inc_simple_void_NN(h->exec);
  }
 
+ /* Same goes for the free callback, if there's one. */
+ if (h->free) {
+  re->cb_free = h->free;
+  SvREFCNT_inc_simple_void_NN(h->free);
+ }
+
  re->cb_num_capture_buff_FETCH  = NULL;
  re->cb_num_capture_buff_STORE  = NULL;
  re->cb_num_capture_buff_LENGTH = NULL;
@@ -359,6 +369,8 @@ Plugin_free(pTHX_ REGEXP * const RX)
 {
  struct regexp *rx;
  re__engine__Plugin self;
+ SV *callback;
+ dSP;
 
  if (PL_dirty)
   return;
@@ -366,26 +378,6 @@ Plugin_free(pTHX_ REGEXP * const RX)
  rx = rxREGEXP(RX);
  SELF_FROM_PPRIVATE(self, rx->pprivate);
 
- SvREFCNT_dec(self->pattern);
- SvREFCNT_dec(self->str);
- SvREFCNT_dec(self->stash);
-
- SvREFCNT_dec(self->cb_exec);
-
- SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
- SvREFCNT_dec(self->cb_num_capture_buff_STORE);
- SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
-
- self->rx = NULL;
-
- Safefree(self);
-
- SvREFCNT_dec(rx->pprivate);
-
-/*
- dSP;
- SV *callback;
-
  callback = self->cb_free;
 
  if (callback) {
@@ -402,8 +394,24 @@ Plugin_free(pTHX_ REGEXP * const RX)
   FREETMPS;
   LEAVE;
  }
+
+ SvREFCNT_dec(self->pattern);
+ SvREFCNT_dec(self->str);
+ SvREFCNT_dec(self->stash);
+
+ SvREFCNT_dec(self->cb_exec);
+
+ SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
+ SvREFCNT_dec(self->cb_num_capture_buff_STORE);
+ SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
+
+ self->rx = NULL;
+
+ Safefree(self);
+
+ SvREFCNT_dec(rx->pprivate);
+
  return;
-*/
 }
 
 void *
@@ -695,6 +703,16 @@ PPCODE:
  }
  XSRETURN(0);
 
+void
+_free(re::engine::Plugin self, ...)
+PPCODE:
+ if (items > 1) {
+  SvREFCNT_dec(self->cb_free);
+  self->cb_free = ST(1);
+  SvREFCNT_inc_simple_void(self->cb_free);
+ }
+ XSRETURN(0);
+
 void
 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
 PPCODE:
@@ -726,12 +744,13 @@ PPCODE:
  XSRETURN(0);
 
 SV *
-_tag(SV *comp, SV *exec)
+_tag(SV *comp, SV *exec, SV *free)
 PREINIT:
  xsh_hints_user_t arg;
 CODE:
  arg.comp = comp;
  arg.exec = exec;
+ arg.free = free;
  RETVAL = xsh_hints_tag(&arg);
 OUTPUT:
  RETVAL
diff --git a/t/20-methods/free.t b/t/20-methods/free.t
deleted file mode 100644
index 61c5dff..0000000
--- a/t/20-methods/free.t
+++ /dev/null
@@ -1,18 +0,0 @@
-=pod
-
-Test the C<free> method
-
-=cut
-
-use strict;
-use Test::More skip_all => "Doesn't work currently (where did my scope go?!)";
-
-use re::engine::Plugin (
-    comp => sub {
-        my ($re) = @_;
-
-        $re->free( sub { pass "ran free" } );
-    }
-);
-
-"str" ~~ /pattern/;
diff --git a/t/30-callbacks/free.t b/t/30-callbacks/free.t
new file mode 100644
index 0000000..b3f1660
--- /dev/null
+++ b/t/30-callbacks/free.t
@@ -0,0 +1,42 @@
+=pod
+
+Test the C<free> callback
+
+=cut
+
+use strict;
+use Test::More tests => 2;
+
+my $pat = 'pattern';
+
+{
+    use re::engine::Plugin (
+        free => sub {
+            pass 'default free callback';
+        },
+    );
+
+    # Regexp destruction happens too late for Test::More, so do it in an eval.
+    eval q[
+        "str" =~ /$pat/;
+    ];
+    die $@ if $@;
+}
+
+{
+    use re::engine::Plugin (
+        comp => sub {
+            my ($re) = @_;
+
+            $re->callbacks(
+                free => sub { pass 'free callback set in the comp callback' },
+            );
+        }
+    );
+
+    # Ditto.
+    eval q[
+        "str" =~ /$pat/;
+    ];
+    die $@ if $@;
+}