X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FNary.pm;h=058048249bb723f9a23481098addd389b342615e;hb=04997f51e7b0a73e04ef0c8df41d4ad045fc7584;hp=3a0b00097b305393648f75290be32933e4d13f78;hpb=94abb82a3fbe010a38413500797bbdb4d373e016;p=perl%2Fmodules%2FSub-Nary.git diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index 3a0b000..0580482 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -16,13 +16,13 @@ Sub::Nary - Try to count how many elements a subroutine can return in list conte =head1 VERSION -Version 0.01 +Version 0.02 =cut our $VERSION; BEGIN { - $VERSION = '0.01'; + $VERSION = '0.02'; } =head1 SYNOPSIS @@ -42,7 +42,7 @@ This module uses the L framework to walk into subroutines and try to guess ho The usual constructor. Currently takes no argument. -=head2 C +=head2 C Takes a code reference to a named or anonymous subroutine, and returns a hash reference whose keys are the possible numbers of returning scalars, and the corresponding values the "probability" to get them. The special key C<'list'> is used to denote a possibly infinite number of returned arguments. The return value hence would look at @@ -102,7 +102,11 @@ returns C<3> or C<4> arguments with probability C<1/2> ; and never returns C<1> argument but returns C<2> with probability C<1/2 * 1/2 = 1/4>, C<3> with probability C<1/2 * 1/2 + 1/2 * 1/2 = 1/2> and C<4> with probability C<1/4> too. -=item * The C<'list'> state is absorbant in regard of all the other ones. +=item * If a core function may return different numbers of scalars, each kind is considered equally possible. + +For example, C returns C<13> elements on success and C<0> on error. The according probability will then be C<< { 0 => 0.5, 13 => 0.5 } >>. + +=item * The C state is absorbing in regard of all the other ones. This is just a pedantic way to say that "list + fixed length = list". That's why @@ -112,7 +116,8 @@ That's why } is considered as always returning an unbounded list. -The convolution law also does not behave the same when C elements are involved : in the following example, + +Also, the convolution law does not behave the same when C elements are involved : in the following example, sub oneorlist { if (rand < 0.1) { @@ -189,6 +194,21 @@ sub combine { }} map { (ref) ? $_ : { $_ => 1 } } grep defined, @_; } +sub power { + my ($p, $n, $c) = @_; + my $s = sum values %$p; + return { 0 => $s * $c } unless $n; + if ($n eq 'list') { + my $z = delete $p->{0}; + return { 'list' => $c } unless $z; + return { 0 => $c } if $z == 1; + return { 0 => $c * $z, list => $c * ($s - $z) }; + } + my $r = combine map { { %$p } } 1 .. $n; + $r->{$_} *= $c for keys %$r; + return $r; +} + sub add { reduce { $a->{$_} += $b->{$_} for keys %$b; @@ -197,16 +217,33 @@ sub add { } my %ops; + $ops{$_} = 1 for scalops; $ops{$_} = 0 for qw/stub nextstate/; $ops{$_} = 1 for qw/padsv/; $ops{$_} = 'list' for qw/padav/; $ops{$_} = 'list' for qw/padhv rv2hv/; -$ops{$_} = 'list' for qw/padany flip match/; +$ops{$_} = 'list' for qw/padany/; +$ops{$_} = 'list' for qw/match entereval readline/; + +$ops{each} = { 0 => 0.5, 2 => 0.5 }; +$ops{stat} = { 0 => 0.5, 13 => 0.5 }; + +$ops{caller} = sub { my @a = caller 0; scalar @a }->(); +$ops{localtime} = do { my @a = localtime; scalar @a }; +$ops{gmtime} = do { my @a = gmtime; scalar @a }; + +$ops{$_} = { 0 => 0.5, 10 => 0.5 } for map "gpw$_", qw/nam uid ent/; +$ops{$_} = { 0 => 0.5, 4 => 0.5 } for map "ggr$_", qw/nam gid ent/; +$ops{$_} = 'list' for qw/ghbyname ghbyaddr ghostent/; +$ops{$_} = { 0 => 0.5, 4 => 0.5 } for qw/gnbyname gnbyaddr gnetent/; +$ops{$_} = { 0 => 0.5, 3 => 0.5 } for qw/gpbyname gpbynumber gprotoent/; +$ops{$_} = { 0 => 0.5, 4 => 0.5 } for qw/gsbyname gsbyport gservent/; sub enter { my ($self, $cv) = @_; + return 'list' if class($cv) ne 'CV'; my $op = $cv->ROOT; my $tag = tag($op); @@ -231,7 +268,7 @@ sub enter { sub expect_return { my ($self, $op) = @_; - return ($self->expect_list($op))[0] => 1 if name($op) eq 'return'; + return ($self->expect_kids($op))[0] => 1 if name($op) eq 'return'; if ($op->flags & OPf_KIDS) { for ($op = $op->first; not null $op; $op = $op->sibling) { @@ -240,45 +277,25 @@ sub expect_return { } } - return; + return 0; } -sub expect_list { +sub expect_any { my ($self, $op) = @_; my $n = name($op); + return ($self->expect_kids($op))[0] => 1 if $n eq 'return'; + my $meth = $self->can('pp_' . $n); return $self->$meth($op) if $meth; - return $ops{$n} => 0 if exists $ops{$n}; - if ($op->flags & OPf_KIDS) { - my @res = (0); - my ($p, $r); - for ($op = $op->first; not null $op; $op = $op->sibling) { - my $n = name($op); - next if $n eq 'pushmark'; - if ($n eq 'nextstate' - and not null(($op = $op->sibling)->sibling)) { - ($p, $r) = $self->expect_return($op); - return $p => 1 if $r; - } else { - ($p, $r) = $self->expect_any($op); - return $p => 1 if $r; - push @res, $p; - } - } - return (combine @res) => 0; + if (exists $ops{$n}) { + my $r = $ops{$n}; + $r = { %$r } if ref $r; + return $r => 0; } - return; -} - -sub expect_any { - my ($self, $op) = @_; - - return ($self->expect_list($op))[0] => 1 if name($op) eq 'return'; - - if (class($op) eq 'LOGOP') { + if (class($op) eq 'LOGOP' and not null $op->first) { my @res; my ($p, $r); @@ -301,7 +318,31 @@ sub expect_any { return (add @res) => 0; } - return $self->expect_list($op); + return $self->expect_kids($op); +} + +sub expect_kids { + my ($self, $op) = @_; + + return 0 unless $op->flags & OPf_KIDS; + + my @res = (0); + my ($p, $r); + for ($op = $op->first; not null $op; $op = $op->sibling) { + my $n = name($op); + next if $n eq 'pushmark'; + if ($n eq 'nextstate' + and not null(($op = $op->sibling)->sibling)) { + ($p, $r) = $self->expect_return($op); + return $p => 1 if $r; + } else { + ($p, $r) = $self->expect_any($op); + return $p => 1 if $r; + push @res, $p; + } + } + + return (combine @res) => 0; } # Stolen from B::Deparse @@ -395,13 +436,12 @@ sub pp_goto { sub pp_const { my ($self, $op) = @_; - if (class($op) eq 'SVOP' and (my $sv = $self->const_sv($op))) { - my $c = class($sv); - if ($c eq 'AV') { - return $sv->FILL + 1; - } elsif ($c eq 'HV') { - return 2 * $sv->FILL; - } + my $sv = $self->const_sv($op); + my $c = class($sv); + if ($c eq 'AV') { + return $sv->FILL + 1; + } elsif ($c eq 'HV') { + return 2 * $sv->FILL; } return 1; @@ -421,10 +461,81 @@ sub pp_rv2av { return (name($op) eq 'const') ? $self->expect_any($op) : 'list'; } -sub pp_aassign { $_[0]->expect_any($_[1]->first) } +sub pp_aassign { + my ($self, $op) = @_; + + $op = $op->first; + + # Can't assign to return + my ($p, $r) = $self->expect_any($op->sibling); + return $p => 0 if not exists $p->{list}; + + $self->expect_any($op); +} sub pp_leaveloop { $_[0]->expect_return($_[1]->first->sibling) } +sub pp_flip { + my ($self, $op) = @_; + + $op = $op->first; + return 'list' if name($op) ne 'range'; + + my $begin = $op->first; + if (name($begin) eq 'const') { + my $end = $begin->sibling; + if (name($end) eq 'const') { + $begin = $self->const_sv($begin); + $end = $self->const_sv($end); + no warnings 'numeric'; + return int(${$end->object_2svref}) - int(${$begin->object_2svref}) + 1; + } else { + my ($p, $r) = $self->expect_return($end); + return $p => 1 if $r; + } + } else { + my ($p, $r) = $self->expect_return($begin); + return $p => 1 if $r; + } + + return 'list' +} + +sub pp_grepwhile { + my ($self, $op) = @_; + + $op = $op->first; + return 'list' if name($op) ne 'grepstart'; + + $op = $op->first->sibling; + my ($p, $r) = $self->expect_any($op); + return $p => 1 if $r; + + $op = $op->sibling; + ($p, $r) = $self->expect_any($op); + return $p => 1 if $r; + + return 'list'; +} + +sub pp_mapwhile { + my ($self, $op) = @_; + + $op = $op->first; + return 'list' if name($op) ne 'mapstart'; + + $op = $op->first->sibling; + my ($p1, $r) = $self->expect_any($op); + return $p1 => 1 if $r; + + $op = $op->sibling; + (my $p2, $r) = $self->expect_any($op); + return $p2 => 1 if $r; + $p2 = { $p2 => 1 } unless ref $p2; + + return add map { power $p1, $_, $p2->{$_} } keys %$p2; +} + =head1 EXPORT An object-oriented module shouldn't export any function, and so does this one.