X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FNary.pm;h=2b9b6719ebbf6c79fef5f7370e0da270166a2a43;hb=efc5762598689b6ee22dfc8ad29f4e8a22457c0a;hp=8af7cd6671c8662ca7e09e3ea02fb6933ab9a814;hpb=a1d67c5f3a8c72b0d81d6e6c2aaee64921930491;p=perl%2Fmodules%2FSub-Nary.git

diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm
index 8af7cd6..2b9b671 100644
--- a/lib/Sub/Nary.pm
+++ b/lib/Sub/Nary.pm
@@ -9,25 +9,21 @@ use Carp qw/croak/;
 
 use B qw/class ppname svref_2object OPf_KIDS/;
 
-use Test::More; use Data::Dumper;
-
 =head1 NAME
 
 Sub::Nary - Try to count how many elements a subroutine can return in list context.
 
 =head1 VERSION
 
-Version 0.02
+Version 0.03
 
 =cut
 
 our $VERSION;
 BEGIN {
- $VERSION  = '0.02';
+ $VERSION  = '0.03';
 }
 
-our $DEBUG = 0;
-
 =head1 SYNOPSIS
 
     use Sub::Nary;
@@ -243,7 +239,6 @@ sub inspect {
  my ($self, $op) = @_;
 
  my $n = name($op);
- diag "@ $n" if $DEBUG;
  return add($self->inspect_kids($op)), undef if $n eq 'return';
 
  my $meth = $self->can('pp_' . $n);
@@ -258,11 +253,9 @@ sub inspect {
  if (class($op) eq 'LOGOP' and not null $op->first) {
   my @res;
 
-  diag "? logop\n" if $DEBUG;
-
   my $op = $op->first;
   my ($r1, $l1) = $self->inspect($op);
-  return $r1, $l1 if $r1 and zero $l1;
+  return $r1, $l1 if defined $r1 and zero $l1;
   my $c = count $l1;
 
   $op = $op->sibling;
@@ -311,10 +304,8 @@ sub inspect_kids {
    $op = $op->first;
    redo;
   }
-  diag "> $n" if $DEBUG;
   my ($rc, $lc) = $self->inspect($op);
   $c = 1 - count $r;
-  diag Dumper [ $c, $r, \@l, $rc, $lc ] if $DEBUG;
   $r = add $r, scale $c, $rc if defined $rc;
   if (not defined $lc) {
    @l = ();
@@ -323,7 +314,6 @@ sub inspect_kids {
   push @l, scale $c, $lc;
  }
 
-# diag Dumper \@l if $DEBUG;
  my $l = scale +(1 - count $r), normalize combine @l;
 
  return $r, $l;
@@ -363,15 +353,9 @@ sub pp_entersub {
  my $r;
  my $c = 1;
  for (; not null $op->sibling; $op = $op->sibling) {
-  my $n = name($op);
-  next if $n eq 'nextstate';
-  diag "* $n" if $DEBUG;
   my ($rc, $lc) = $self->inspect($op);
-  $r = add $r, scale $c, $rc if defined $rc;
-  if (zero $lc) {
-   $c = 1 - count $r;
-   return $r, $c ? { 0 => $c } : undef
-  }
+  return $rc, $lc if defined $rc and not defined $lc;
+  $r = add $r, scale $c, $rc;
   $c *= count $lc;
  }
 
@@ -457,12 +441,20 @@ sub pp_rv2av {
  my ($self, $op) = @_;
  $op = $op->first;
 
- my ($r, $l) = $self->inspect($op);
- if (name($op) ne 'const') {
-  my $c = 1 - count $r;
-  $l = $c ? { list => $c } : 0;
+ if (name($op) eq 'gv') {
+  return undef, { list => 1 };
  }
- return $r, $l; 
+
+ $self->inspect($op);
+}
+
+sub pp_sassign {
+ my ($self, $op) = @_;
+
+ my $r = ($self->inspect($op->first))[0];
+
+ my $c = 1 - count $r;
+ return $r, $c ? { 1 => $c } : undef
 }
 
 sub pp_aassign {
@@ -480,27 +472,33 @@ sub pp_aassign {
 sub pp_leaveloop {
  my ($self, $op) = @_;
 
- diag "* leaveloop" if $DEBUG;
-
  $op = $op->first;
  my ($r1, $l1);
- if (name($op) eq 'enteriter') {
+ my $for;
+ if (name($op) eq 'enteriter') { # for loop ?
+  $for = 1;
   ($r1, $l1) = $self->inspect($op);
-  return $r1, $l1 if $r1 and zero $l1;
+  return $r1, $l1 if defined $r1 and zero $l1;
  }
 
  $op = $op->sibling;
- my $r;
+ my ($r2, $l2);
  if (name($op->first) eq 'and') {
-  ($r, my $l) = ($self->inspect($op->first->first))[0];
-  return $r, $l if $r and zero $l;
-  $r = ($self->inspect($op->first->first->sibling))[0];
+  ($r2, $l2) = $self->inspect($op->first->first);
+  return $r2, $l2 if defined $r2 and zero $l2;
+  my $c = count $l2;
+  return { list => 1 }, undef if !$for and defined $r2;
+  my ($r3, $l3) = $self->inspect($op->first->first->sibling);
+  return { list => 1 }, undef if defined $r3 and defined $l3;
+  $r2 = add $r2, scale $c, $r3;
  } else {
-  $r = ($self->inspect($op))[0];
+  ($r2, $l2) = $self->inspect($op);
+  return { list => 1 }, undef if defined $r2 and defined $l2;
  }
 
+ my $r = (defined $r1) ? add $r1, scale +(1 - count $r1), $r2
+                       : $r2;
  my $c = 1 - count $r;
- diag "& leaveloop $c" if $DEBUG;
  return $r, $c ? { 0 => $c } : undef;
 }
 
@@ -542,12 +540,12 @@ sub pp_grepwhile {
  $op = $op->first->sibling;
 
  my ($r2, $l2) = $self->inspect($op->sibling);
- return $r2, $l2 if $r2 and zero $l2;
+ return $r2, $l2 if defined $r2 and zero $l2;
  my $c2 = count $l2; # First one to happen
 
  my ($r1, $l1) = $self->inspect($op);
- return (add $r2, scale $c2, $r1), undef if $r1 and zero $l1 and not zero $l2;
- diag Dumper [ [ $r1, $l1 ], [ $r2, $l2 ] ] if $DEBUG;
+ return (add $r2, scale $c2, $r1), undef if defined $r1 and zero $l1
+                                                        and not zero $l2;
  my $c1 = count $l1;
 
  $l2 = { $l2 => 1 } unless ref $l2;
@@ -566,12 +564,12 @@ sub pp_mapwhile {
  $op = $op->first->sibling;
 
  my ($r2, $l2) = $self->inspect($op->sibling);
- return $r2, $l2 if $r2 and zero $l2;
+ return $r2, $l2 if defined $r2 and zero $l2;
  my $c2 = count $l2; # First one to happen
 
  my ($r1, $l1) = $self->inspect($op);
- return (add $r2, scale $c2, $r1), undef if $r1 and zero $l1 and not zero $l2;
- diag Dumper [ [ $r1, $l1 ], [ $r2, $l2 ] ] if $DEBUG;
+ return (add $r2, scale $c2, $r1), undef if defined $r1 and zero $l1
+                                                        and not zero $l2;
  my $c1 = count $l1;
 
  $l2 = { $l2 => 1 } unless ref $l2;