X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FNary.pm;h=eaa378e1aead72279fdf2231aff9c5584a2e18e1;hb=c2cd664de815b04c82497a649abd06b3dd9e8711;hp=611f780d617ad220649149b56ab64094db53cb59;hpb=fd35681c6f0a1e84d407dbe4fcc7a3c25e4d8851;p=perl%2Fmodules%2FSub-Nary.git diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index 611f780..eaa378e 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; @@ -273,7 +266,7 @@ sub inspect { if (null $op) { # If the logop has no else branch, it can also return the *scalar* result of # the conditional - $l3 = { 1 => $c }; + $l3 = { 1 => 1 }; } else { ($r3, $l3) = $self->inspect($op); } @@ -311,18 +304,17 @@ sub inspect_kids { $op = $op->first; redo; } - diag "> $n ($c)" if $DEBUG; my ($rc, $lc) = $self->inspect($op); + $c = 1 - count $r; $r = add $r, scale $c, $rc if defined $rc; - if ($rc and not defined $lc) { + if (not defined $lc) { @l = (); last; } push @l, scale $c, $lc; - $c *= count $lc if defined $lc; } - my $l = combine @l; + my $l = scale +(1 - count $r), normalize combine @l; return $r, $l; } @@ -361,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; } @@ -438,7 +424,7 @@ sub pp_const { if ($c eq 'AV') { $n = $sv->FILL + 1 } elsif ($c eq 'HV') { - $n = 2 * $sv->FILL + $n = 2 * $sv->KEYS } return undef, $n @@ -455,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 { @@ -478,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; } @@ -540,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; @@ -564,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; @@ -605,7 +605,7 @@ You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince). =head1 BUGS -Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. +Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT