Enable free callbcks

diff --git a/MANIFEST b/MANIFEST
index 4fc5bf759f84526d63ff3cdf8a112491b9a537db..b0837a353b504286579caa95f5e113163726321d 100644 (file)
--- 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 93ac7e68a116a1bd097726f43930760de6a084d6..ad5e21949986b2847c1f0704325ce897fa9ba7f2 100644 (file)
--- 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 1c98ce574a92f857f2e59dd3b4c6e2d7441be407..e69c8f4b45c4299972b6abdec8ba4f51aa43b9a1 100644 (file)
--- 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 da33ce2ff9050a130fe6f6d79d58d8b3b6262814..c16dfba3ed652bc61b82192036b858183fc49692 100644 (file)
--- 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 (file)
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 (file)
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 $@;
+}