From: Vincent Pit <vince@profvince.com>
Date: Thu, 21 Aug 2008 10:16:11 +0000 (+0200)
Subject: Add support for die()
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Nary.git;a=commitdiff_plain;h=3a7f23b3ef06db23f3bd2f2707e70b61c6a15b4f

Add support for die()
---

diff --git a/MANIFEST b/MANIFEST
index cb97b5c..e818157 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -18,6 +18,7 @@ t/23-branch.t
 t/24-ops.t
 t/25-grepmap.t
 t/26-exit.t
+t/27-die.t
 t/90-boilerplate.t
 t/91-pod.t
 t/92-pod-coverage.t
diff --git a/Nary.xs b/Nary.xs
index 0329eea..66eced6 100644
--- a/Nary.xs
+++ b/Nary.xs
@@ -31,6 +31,7 @@ STATIC void sn_store_ent(pTHX_ HV *tb, SV *key, SV *val, U32 hash) {
 
 STATIC U32 sn_hash_list = 0;
 STATIC U32 sn_hash_exit = 0;
+STATIC U32 sn_hash_die  = 0;
 
 /* --- XS ------------------------------------------------------------------ */
 
@@ -42,6 +43,7 @@ BOOT:
 {
  PERL_HASH(sn_hash_list, "list", 4);
  PERL_HASH(sn_hash_exit, "exit", 4);
+ PERL_HASH(sn_hash_die,  "die",  3);
 }
 
 void
@@ -248,13 +250,13 @@ PROTOTYPE: @
 PREINIT:
  HV *res[3];
  SV *val;
- SV *exit1, *list1;
+ SV *kexit, *klist, *kdie;
  SV *temp;
  HE *key, *old;
  I32 i;
  I32 n = 0, o;
  I32 j, n1, n2;
- NV pl = 0, pe = 0;
+ NV pe = 0, pd = 0, pl = 0;
  sn_combcache *cache = NULL;
  I32 cachelen = 1;
 CODE:
@@ -268,7 +270,7 @@ CODE:
  temp = sv_2mortal(newSViv(0));
  for (i = 0; i < items; ++i) {
   SV *cur = ST(i);
-  NV pe1 = 0, pl1 = 0;
+  NV pe1 = 0, pd1 = 0, pd2, pl1 = 0;
   if (!SvOK(cur))
    continue;
   if (!SvROK(cur)) {
@@ -285,29 +287,42 @@ CODE:
    res[o] = newHV();
   else
    hv_clear(res[o]);
-  exit1 = hv_delete((HV *) cur, "exit", 4, 0);
+  kexit = hv_delete((HV *) cur, "exit", 4, 0);
   n1    = hv_iterinit((HV *) cur);
-  if (exit1) {
+  if (kexit) {
    if (!n1) {
-    pe = 1;
+    pe = 1 - pd;
     pl = 0;
     n  = o;
     break;
    }
-   pe1 = SvNV(exit1);
+   pe1 = SvNV(kexit);
   }
-  list1 = hv_delete((HV *) cur, "list", 4, 0);
-  if (list1) {
+  kdie  = hv_delete((HV *) cur, "die", 3, 0);
+  if (kdie) {
    if (n1 == 1) {
-    pl = 1 - pe;
+    pd = 1 - pe;
+    pl = 0;
+    n  = o;
+    break;
+   }
+   --n1;
+   pd1 = SvNV(kdie);
+  }
+  klist = hv_delete((HV *) cur, "list", 4, 0);
+  if (klist) {
+   if (n1 == 1) {
+    pl = 1 - (pe + pd);
     n  = o;
     break;
    }
-   pl1 = SvNV(list1);
+   pl1 = SvNV(klist);
   }
-  pl = pl1 * (1 - pe) + pl * (1 - pe1) - pl * pl1;
-  pe = pe + (1 - pe) * pe1;
-  n2 = hv_iterinit(res[n]);
+  pl  = pl1 * (1 - (pd + pe)) + pl * (1 - (pd1 + pe1)) - pl * pl1;
+  pd2 = pd1 * (1 - pe)        + pd                     - pd * pd1;
+  pe  = pe1 * (1 - pd)        + pe                     - pe * pe1;
+  pd  = pd2;
+  n2  = hv_iterinit(res[n]);
   if (!n2) {
    cache[0].k = 0;
    cache[0].v = 1;
@@ -343,6 +358,8 @@ CODE:
  SvREFCNT_dec(res[2]);
  if (pe)
   sn_store(res[n], "exit", 4, newSVnv(pe), sn_hash_exit);
+ if (pd)
+  sn_store(res[n], "die",  3, newSVnv(pd), sn_hash_die);
  if (pl)
   sn_store(res[n], "list", 4, newSVnv(pl), sn_hash_list);
  if (n == 1)
diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm
index f789e69..159dd8e 100644
--- a/lib/Sub/Nary.pm
+++ b/lib/Sub/Nary.pm
@@ -426,6 +426,20 @@ sub pp_exit {
  return $r, undef;
 }
 
+sub pp_die {
+ my ($self, $op) = @_;
+
+ my ($r, undef) = $self->inspect_kids($op);
+ if (defined $r) {
+  my $c = 1 - count $r;
+  $r->{die} = $c if $c;
+ } else {
+  $r = { die => 1 };
+ }
+
+ return $r, undef;
+}
+
 sub pp_goto {
  my ($self, $op) = @_;
 
@@ -503,6 +517,18 @@ sub pp_aassign {
  $self->inspect($op);
 }
 
+sub pp_leavetry {
+ my ($self, $op) = @_;
+
+ my ($r, $l) = $self->inspect_kids($op);
+ if (defined $r) {
+  my $d = delete $r->{die};
+  $r->{0} += $d if defined $d;
+ }
+
+ return $r, $l;
+}
+
 sub pp_leaveloop {
  my ($self, $op) = @_;
 
diff --git a/t/16-combine.t b/t/16-combine.t
index 7f0b459..bfd9d4e 100644
--- a/t/16-combine.t
+++ b/t/16-combine.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 41;
+use Test::More tests => 60;
 
 use Sub::Nary;
 
@@ -12,7 +12,11 @@ use Sub::Nary;
 my $h12 = { 1 => 0.5, 2 => 0.5 };
 my $h1l = { 1 => 0.5, list => 0.5 };
 my $h1e = { 1 => 0.5, exit => 0.5 };
+my $h1d = { 1 => 0.5, die  => 0.5 };
 my $h1le = { 1 => 0.25, list => 0.25, exit => 0.5 };
+my $h12e = { 1 => 0.25, 2    => 0.25, exit => 0.5 };
+my $h1ld = { 1 => 0.25, list => 0.25, die  => 0.5 };
+my $h12d = { 1 => 0.25, 2    => 0.25, die  => 0.5 };
 
 my @tests = (
  [ [ ],          undef ],
@@ -57,11 +61,44 @@ my @tests = (
  [ [ 'exit', 1 ],             'exit' ],
  [ [ { %$h1e }, 1 ],          { exit => 0.5, 2 => 0.5 } ],
  [ [ { %$h1e }, { %$h1e } ],  { exit => 0.75, 2 => 0.25 } ],
+
  [ [ { %$h1e }, { %$h1l } ],  { exit => 0.5, list => 0.25, 2 => 0.25 } ],
  [ [ { %$h1l }, { %$h1e } ],  { exit => 0.5, list => 0.25, 2 => 0.25 } ],
  [ [ { %$h1l }, { %$h1le } ], { exit => 0.5, list => 0.375, 2 => 0.125 } ],
  [ [ { %$h1e }, { %$h1le } ], { exit => 0.75, list => 0.125, 2 => 0.125 } ],
 
+ [ [ 'die' ],                 'die' ],
+ [ [ 'die', 2 ],              'die' ],
+ [ [ { %$h1d }, 2 ],          { die => 0.5, 3 => 0.5 } ],
+ [ [ { %$h1d }, 1 ],          { die => 0.5, 2 => 0.5 } ],
+ [ [ { %$h1d }, { %$h1d } ],  { die => 0.75, 2 => 0.25 } ],
+
+ [ [ { %$h1d }, { %$h1l } ],  { die => 0.5, list => 0.25, 2 => 0.25 } ],
+ [ [ { %$h1l }, { %$h1d } ],  { die => 0.5, list => 0.25, 2 => 0.25 } ],
+ [ [ { %$h1l }, { %$h1ld } ], { die => 0.5, list => 0.375, 2 => 0.125 } ],
+ [ [ { %$h1d }, { %$h1ld } ], { die => 0.75, list => 0.125, 2 => 0.125 } ],
+
+ [ [ { %$h1e }, { %$h1d } ],  { exit => 0.5,   die => 0.25, 2 => 0.25 } ],
+ [ [ { %$h1d }, { %$h1e } ],  { exit => 0.25,  die => 0.5,  2 => 0.25 } ],
+ [ [ { %$h1e }, { %$h1ld } ], { exit => 0.5,   die => 0.25,
+                                list => 0.125, 2 => 0.125 } ],
+ [ [ { %$h1d }, { %$h1le } ], { exit => 0.25,  die => 0.5,
+                                list => 0.125, 2 => 0.125 } ],
+
+ [ [ { %$h12d }, { %$h1le } ], { exit => 0.25,  die => 0.5,
+                                 list => 0.125, 2 => 0.0625, 3 => 0.0625 } ],
+ [ [ { %$h12e }, { %$h1ld } ], { exit => 0.5,    die => 0.25,
+                                 list => 0.125, 2 => 0.0625, 3 => 0.0625 } ],
+ [ [ { %$h1ld }, { %$h12e } ], { exit => 0.25,  die => 0.5,
+                                 list => 0.125, 2 => 0.0625, 3 => 0.0625 } ],
+ [ [ { %$h1le }, { %$h12d } ], { exit => 0.5,    die => 0.25,
+                                 list => 0.125, 2 => 0.0625, 3 => 0.0625 } ],
+
+ [ [ { %$h1ld }, { %$h1le } ], { exit => 0.25,   die => 0.5,
+                                 list => 0.1875, 2 => 0.0625  } ],
+ [ [ { %$h1le }, { %$h1ld } ], { exit => 0.5,    die => 0.25,
+                                 list => 0.1875, 2 => 0.0625  } ],
+
  [ [ $h1l, $h1l ],              { 2 => 0.25, list => 0.5 } ], # Side effects
 );
 
diff --git a/t/27-die.t b/t/27-die.t
new file mode 100644
index 0000000..3880282
--- /dev/null
+++ b/t/27-die.t
@@ -0,0 +1,47 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+
+use Sub::Nary;
+
+my $sn = Sub::Nary->new();
+
+my ($x, $y);
+
+sub dies {
+ if ($x) {
+  die do { return 3, 4 if $y }
+ }
+ @_[0 .. 2];
+}
+
+my @tests = (
+ [ sub { die },                        { die => 1 } ],
+ [ sub { die 1 },                      { die => 1 } ],
+ [ sub { if ($x) { die } },            { die => 0.5, 1 => 0.5 } ],
+ [ sub { if (die) { return 1, 2 } },   { die => 1 } ],
+ [ sub { die do { return 3, 4 } },     { 2 => 1 } ],
+ [ sub { $x ? die($y ? die : return(2, 3)) : 4 },
+                                       { die => 0.25, 2 => 0.25, 1 => 0.5 } ],
+
+ [ \&dies,                             { die => 0.25, 2 => 0.25, 3 => 0.5 } ],
+ [ sub { dies(), do { $x ? @_ : 1 } }, { die => 0.25, 3 => 0.125, 4 => 0.25,
+                                          list => (0.25 + 0.5) * 0.5 } ],
+ [ sub { dies(), 1, do { $x ? @_ : 1 } },
+          { die => 0.25, 4 => 0.125, 5 => 0.25, list => (0.25 + 0.5) * 0.5 } ],
+
+ [ sub { eval "1, do { die }, 3" },    'list' ],
+ [ sub { eval { die } },               { 0 => 1 } ],
+ [ sub { eval { $x ? die : (4, 5) } }, { 0 => 0.5, 2 => 0.5 } ],
+);
+
+my $i = 1;
+for (@tests) {
+ my $r = $sn->nary($_->[0]);
+ my $exp = ref $_->[1] ? $_->[1] : { $_->[1] => 1 };
+ is_deeply($r, $exp, 'die test ' . $i);
+ ++$i;
+}