From: Vincent Pit Date: Mon, 4 Aug 2008 21:06:35 +0000 (+0200) Subject: Importing Sub-Nary-0.01.tar.gz X-Git-Tag: v0.01 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=2ff703e1e6a01caeed0b04cc50c00ad835d4302f;p=perl%2Fmodules%2FSub-Nary.git Importing Sub-Nary-0.01.tar.gz --- 4b846088d0ffe4f979b145ec2af821922bd5c7af diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..849fef3 --- /dev/null +++ b/.gitignore @@ -0,0 +1,23 @@ +blib* +pm_to_blib* + +Makefile +Makefile.old +Build +_build* + +*.tar.gz +Sub-Nary-* + +core.* +*.[co] +*.so +*.bs +*.out +*.def +*.exp + +cover_db +*.gcda +*.gcov +*.gcno diff --git a/Changes b/Changes new file mode 100644 index 0000000..09b3976 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Sub-Nary + +0.01 2008-08-04 16:35 UTC + First version, released on an unsuspecting world. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..d09cac0 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,22 @@ +Changes +MANIFEST +Makefile.PL +Nary.xs +README +lib/Sub/Nary.pm +samples/cx.pl +t/00-load.t +t/02-can.t +t/10-obj.t +t/11-cache.t +t/15-scalops.t +t/20-return.t +t/21-list.t +t/22-call.t +t/23-branch.t +t/90-boilerplate.t +t/91-pod.t +t/92-pod-coverage.t +t/95-portability-files.t +t/99-kwalitee.t +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..34705a9 --- /dev/null +++ b/META.yml @@ -0,0 +1,20 @@ +--- #YAML:1.0 +name: Sub-Nary +version: 0.01 +abstract: Try to count how many elements a subroutine can return in list context. +license: perl +author: + - Vincent Pit +generated_by: ExtUtils::MakeMaker version 6.42 +distribution_type: module +requires: + B: 0 + Carp: 0 + List::Util: 0 + XSLoader: 0 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 +build_requires: + ExtUtils::MakeMaker: 0 + Test::More: 0 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..9e010ce --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,54 @@ +use 5.008001; + +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $BUILD_REQUIRES = { + 'ExtUtils::MakeMaker' => 0, + 'Test::More' => 0, +}; + +sub build_req { + my $tometa = ' >> $(DISTVNAME)/META.yml;'; + my $build_req = 'echo "build_requires:" ' . $tometa; + foreach my $mod ( sort { lc $a cmp lc $b } keys %$BUILD_REQUIRES ) { + my $ver = $BUILD_REQUIRES->{$mod}; + $build_req .= sprintf 'echo " %-30s %s" %s', "$mod:", $ver, $tometa; + } + return $build_req; +} + +WriteMakefile( + NAME => 'Sub::Nary', + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => 'lib/Sub/Nary.pm', + ABSTRACT_FROM => 'lib/Sub/Nary.pm', + PL_FILES => {}, + PREREQ_PM => { + 'B' => 0, + 'Carp' => 0, + 'List::Util' => 0, + 'XSLoader' => 0 + }, + dist => { + PREOP => 'pod2text lib/Sub/Nary.pm > $(DISTVNAME)/README; ' + . build_req, + COMPRESS => 'gzip -9f', SUFFIX => 'gz' + }, + clean => { FILES => 'Sub-Nary-* *.gcov *.gcda *.gcno cover_db' } +); + +1; + +package MY; + +sub postamble { + my $cv = join ' -coverage ', 'cover', + qw/statement branch condition path subroutine time/; + <new(); + my $r = $sn->nary(\&hlagh); + +DESCRIPTION + This module uses the B framework to walk into subroutines and try to + guess how many scalars are likely to be returned in list context. It's + not always possible to give a definitive answer to this question at + compile time, so the results are given in terms of "probability of + return" (to be understood in a sense described below). + +METHODS + "new" + The usual constructor. Currently takes no argument. + + "nary $coderf" + 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 'list' is used to denote a possibly infinite number of returned + arguments. The return value hence would look at + + { 1 => 0.2, 2 => 0.4, 4 => 0.3, list => 0.1 } + + that is, we should get 1 scalar 1 time over 5 and so on. The sum of all + values is 1. The returned result, and all the results obtained from + intermediate subs, are cached into the object. + + "flush" + Flushes the Sub::Nary object cache. Returns the object itself. + +PROBABILITY OF RETURN + The probability is computed as such : + + * All the returning points in the same subroutine (i.e. all the explicit + "return" and the last computed value) are considered equally possible. + For example, the subroutine + + sub simple { + if (rand < 0.1) { + return 1; + } else { + return 2, 3; + } + } + + is seen returning one or two arguments each with probability "1/2". + As for + + sub hlagh { + my $x = rand; + if ($x < 0.1) { + return 1, 2, 3; + } elsif ($x > 0.9) { + return 4, 5; + } + } + + it is considered to return 1 (when the two tests fail, the last + computed value is returned, which here is "$x > 0.9" evaluated in + the scalar context of the test), 2 or 3 arguments each with + probability "1/3". + + * The total probability law for a given returning point is the + convolution product of the probabilities of its list elements. + As such, + + sub notsosimple { + return 1, simple(), 2 + } + + returns 3 or 4 arguments with probability "1/2" ; and + + sub double { + return simple(), simple() + } + + never returns 1 argument but returns 2 with probability "1/2 * 1/2 = + 1/4", 3 with probability "1/2 * 1/2 + 1/2 * 1/2 = 1/2" and 4 with + probability "1/4" too. + + * The 'list' state is absorbant in regard of all the other ones. + This is just a pedantic way to say that "list + fixed length = + list". That's why + + sub listy { + return 1, simple(), @_ + } + + is considered as always returning an unbounded list. The convolution + law also does not behave the same when "list" elements are involved + : in the following example, + + sub oneorlist { + if (rand < 0.1) { + return 1 + } else { + return @_ + } + } + + sub composed { + return oneorlist(), oneorlist() + } + + "composed" returns 2 scalars with probability "1/2 * 1/2 = 1/4" and + a "list" with probability "3/4". + +EXPORT + An object-oriented module shouldn't export any function, and so does + this one. + +CAVEATS + The algorithm may be pessimistic (things seen as "list" while they are + of fixed length) but not optimistic (the opposite, duh). + + "wantarray" isn't specialized when encountered in the optree. + +DEPENDENCIES + perl 5.8.1. + + Carp (standard since perl 5), B (since perl 5.005), XSLoader (since perl + 5.006) and List::Util (since perl 5.007003). + +AUTHOR + Vincent Pit, "", . + + You can contact me by mail or on #perl @ FreeNode (vincent or + Prof_Vince). + +BUGS + Please report any bugs or feature requests to "bug-b-nary at + rt.cpan.org", or through the web interface at + . I will be + notified, and then you'll automatically be notified of progress on your + bug as I make changes. + +SUPPORT + You can find documentation for this module with the perldoc command. + + perldoc Sub::Nary + + Tests code coverage report is available at + . + +ACKNOWLEDGEMENTS + Thanks to Sebastien Aperghis-Tramoni for helping to name this module. + +COPYRIGHT & LICENSE + Copyright 2008 Vincent Pit, all rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm new file mode 100644 index 0000000..18d4223 --- /dev/null +++ b/lib/Sub/Nary.pm @@ -0,0 +1,474 @@ +package Sub::Nary; + +use 5.008001; + +use strict; +use warnings; + +use Carp qw/croak/; +use List::Util qw/reduce sum/; + +use B qw/class ppname svref_2object OPf_KIDS/; + +=head1 NAME + +Sub::Nary - Try to count how many elements a subroutine can return in list context. + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION; +BEGIN { + $VERSION = '0.01'; +} + +=head1 SYNOPSIS + + use Sub::Nary; + + my $sn = Sub::Nary->new(); + my $r = $sn->nary(\&hlagh); + +=head1 DESCRIPTION + +This module uses the L framework to walk into subroutines and try to guess how many scalars are likely to be returned in list context. It's not always possible to give a definitive answer to this question at compile time, so the results are given in terms of "probability of return" (to be understood in a sense described below). + +=head1 METHODS + +=head2 C + +The usual constructor. Currently takes no argument. + +=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 + + { 1 => 0.2, 2 => 0.4, 4 => 0.3, list => 0.1 } + +that is, we should get C<1> scalar C<1> time over C<5> and so on. The sum of all values is C<1>. The returned result, and all the results obtained from intermediate subs, are cached into the object. + +=head2 C + +Flushes the L object cache. Returns the object itself. + +=head1 PROBABILITY OF RETURN + +The probability is computed as such : + +=over 4 + +=item * All the returning points in the same subroutine (i.e. all the explicit C and the last computed value) are considered equally possible. + +For example, the subroutine + + sub simple { + if (rand < 0.1) { + return 1; + } else { + return 2, 3; + } + } + +is seen returning one or two arguments each with probability C<1/2>. +As for + + sub hlagh { + my $x = rand; + if ($x < 0.1) { + return 1, 2, 3; + } elsif ($x > 0.9) { + return 4, 5; + } + } + +it is considered to return C<1> (when the two tests fail, the last computed value is returned, which here is C<< $x > 0.9 >> evaluated in the scalar context of the test), C<2> or C<3> arguments each with probability C<1/3>. + +=item * The total probability law for a given returning point is the convolution product of the probabilities of its list elements. + +As such, + + sub notsosimple { + return 1, simple(), 2 + } + +returns C<3> or C<4> arguments with probability C<1/2> ; and + + sub double { + return simple(), simple() + } + +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. + +This is just a pedantic way to say that "list + fixed length = list". +That's why + + sub listy { + return 1, simple(), @_ + } + +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, + + sub oneorlist { + if (rand < 0.1) { + return 1 + } else { + return @_ + } + } + + sub composed { + return oneorlist(), oneorlist() + } + +C returns C<2> scalars with probability C<1/2 * 1/2 = 1/4> and a C with probability C<3/4>. + +=back + +=cut + +BEGIN { + require XSLoader; + XSLoader::load(__PACKAGE__, $VERSION); +} + +sub _check_self { + croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object' + unless ref $_[0] and $_[0]->isa(__PACKAGE__); +} + +sub new { + my $class = shift; + $class = ref($class) || $class || __PACKAGE__; + bless { cache => { } }, $class; +} + +sub flush { + my $self = shift; + _check_self($self); + $self->{cache} = { }; + $self; +} + +sub nary { + my $self = shift; + my $sub = shift; + + $self->{cv} = [ ]; + return $self->enter(svref_2object($sub)); +} + +sub name ($) { + my $n = $_[0]->name; + $n eq 'null' ? substr(ppname($_[0]->targ), 3) : $n +} + +sub combine { + reduce {{ + my %res; + my $la = delete $a->{list}; + my $lb = delete $b->{list}; + if (defined $la || defined $lb) { + $la ||= 0; + $lb ||= 0; + $res{list} = $la + $lb - $la * $lb; + } + while (my ($ka, $va) = each %$a) { + $ka = int $ka; + while (my ($kb, $vb) = each %$b) { + my $key = $ka + int $kb; + $res{$key} += $va * $vb; + } + } + \%res + }} map { (ref) ? $_ : { $_ => 1 } } grep defined, @_; +} + +sub add { + reduce { + $a->{$_} += $b->{$_} for keys %$b; + $a + } map { (ref) ? $_ : { $_ => 1 } } grep defined, @_; +} + +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/; + +sub enter { + my ($self, $cv) = @_; + + my $op = $cv->ROOT; + my $tag = tag($op); + + return { %{$self->{cache}->{$tag}} } if exists $self->{cache}->{$tag}; + + # Anything can happen with recursion + for (@{$self->{cv}}) { + return 'list' if $tag == tag($_->ROOT); + } + + unshift @{$self->{cv}}, $cv; + (my $r, undef) = $self->expect_any($op->first); + shift @{$self->{cv}}; + + $r = { $r => 1} unless ref $r; + my $total = sum values %$r; + $r = { map { $_ => $r->{$_} / $total } keys %$r }; + $self->{cache}->{$tag} = { %$r }; + return $r; +} + +sub expect_return { + my ($self, $op) = @_; + + return ($self->expect_list($op))[0] => 1 if name($op) eq 'return'; + + if ($op->flags & OPf_KIDS) { + for ($op = $op->first; not null $op; $op = $op->sibling) { + my ($p, $r) = $self->expect_return($op); + return $p => 1 if $r; + } + } + + return; +} + +sub expect_list { + my ($self, $op) = @_; + + my $n = name($op); + 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; + } + + return; +} + +sub expect_any { + my ($self, $op) = @_; + + return ($self->expect_list($op))[0] => 1 if name($op) eq 'return'; + + if (class($op) eq 'LOGOP') { + my @res; + my ($p, $r); + + my $op = $op->first; + ($p, $r) = $self->expect_return($op); + return $p => 1 if $r; + + $op = $op->sibling; + push @res, ($self->expect_any($op))[0]; + + # If the logop has no else branch, it can also return the *scalar* result of + # the conditional + $op = $op->sibling; + if (null $op) { + push @res, 1; + } else { + push @res, ($self->expect_any($op))[0]; + } + + return (add @res) => 0; + } + + return $self->expect_list($op); +} + +# Stolen from Sub::Deparse + +sub padval { $_[0]->{cv}->[0]->PADLIST->ARRAYelt(1)->ARRAYelt($_[1]) } + +sub gv_or_padgv { + my ($self, $op) = @_; + if (class($op) eq 'PADOP') { + return $self->padval($op->padix) + } else { # class($op) eq "SVOP" + return $op->gv; + } +} + +sub const_sv { + my ($self, $op) = @_; + my $sv = $op->sv; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->targ) unless $$sv; + return $sv; +} + +sub pp_entersub { + my ($self, $op, $exp) = @_; + + my $next = $op; + while ($next->flags & OPf_KIDS) { + $next = $next->first; + } + while (not null $next) { + $op = $next; + my ($p, $r) = $self->expect_return($op, $exp); + return $p => 1 if $r; + $next = $op->sibling; + } + + if (name($op) eq 'rv2cv') { + my $n; + do { + $op = $op->first; + my $next = $op->sibling; + while (not null $next) { + $op = $next; + $next = $next->sibling; + } + $n = name($op) + } while ($op->flags & OPf_KIDS and { map { $_ => 1 } qw/null leave/ }->{$n}); + return 'list' unless { map { $_ => 1 } qw/gv refgen/ }->{$n}; + local $self->{sub} = 1; + return $self->expect_any($op, $exp); + } else { + # Method call ? + return 'list'; + } +} + +sub pp_gv { + my ($self, $op) = @_; + + return $self->{sub} ? $self->enter($self->gv_or_padgv($op)->CV) : 1 +} + +sub pp_anoncode { + my ($self, $op) = @_; + + return $self->{sub} ? $self->enter($self->const_sv($op)) : 1 +} + +sub pp_goto { + my ($self, $op) = @_; + + my $n = name($op); + while ($op->flags & OPf_KIDS) { + my $nop = $op->first; + my $nn = name($nop); + if ($nn eq 'pushmark') { + $nop = $nop->sibling; + $nn = name($nop); + } + if ($n eq 'rv2cv' and $nn eq 'gv') { + return $self->enter($self->gv_or_padgv($nop)->CV); + } + $op = $nop; + $n = $nn; + } + + return 'list'; +} + +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; + } + } + + return 1; +} + +sub pp_aslice { $_[0]->expect_any($_[1]->first->sibling) } + +sub pp_hslice; +*pp_hslice = *pp_aslice{CODE}; + +sub pp_lslice { $_[0]->expect_any($_[1]->first) } + +sub pp_rv2av { + my ($self, $op) = @_; + $op = $op->first; + + return (name($op) eq 'const') ? $self->expect_any($op) : 'list'; +} + +sub pp_aassign { $_[0]->expect_any($_[1]->first) } + +sub pp_leaveloop { $_[0]->expect_return($_[1]->first->sibling) } + +=head1 EXPORT + +An object-oriented module shouldn't export any function, and so does this one. + +=head1 CAVEATS + +The algorithm may be pessimistic (things seen as C while they are of fixed length) but not optimistic (the opposite, duh). + +C isn't specialized when encountered in the optree. + +=head1 DEPENDENCIES + +L 5.8.1. + +L (standard since perl 5), L (since perl 5.005), L (since perl 5.006) and L (since perl 5.007003). + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +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. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Sub::Nary + +Tests code coverage report is available at L. + +=head1 ACKNOWLEDGEMENTS + +Thanks to Sebastien Aperghis-Tramoni for helping to name this module. + +=head1 COPYRIGHT & LICENSE + +Copyright 2008 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; # End of Sub::Nary diff --git a/samples/cx.pl b/samples/cx.pl new file mode 100755 index 0000000..0b51a13 --- /dev/null +++ b/samples/cx.pl @@ -0,0 +1,75 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use lib qw{blib/lib blib/arch}; +use B::Deparse; +use B::Concise; +use Sub::Nary; + +my ($x, $y, @z, %h); + +sub wat { + wantarray ? (1, 2) : 1; +} + +sub wut { + my $u = wat 3; + if ($x) { + return wat(1), wat(1), wat(1), wat(1); + } elsif ($y) { + sub { qr/wat/ }, %h; + } elsif (@z) { + { wat => 1 } + } elsif (@_) { + return $x, $y; + } else { + 1, $x, 4; + } +} + +sub foo { + if ($x) { + return 1; + } else { + return 2, 3; + } +} + +sub wut2 { + if ($x) { + } elsif ($y) { + sub { qr/wat/ }, %h; + } elsif (@z) { + return [ ] + } +} + +sub rr { + return return; +} + +sub forr { + return 1, 2 for 1 .. 4; +} + +sub ifr { + if (return 1, 2) { + return 1, 2, 3 + } + return @_[0 .. 3] +} + +my $code = \&wut; + +my $bd = B::Deparse->new(); +print STDERR $bd->coderef2text($code), "\n"; + +B::Concise::walk_output(\*STDERR); +B::Concise::concise_subref('basic', $code, 'cx_test'); + +my $sn = Sub::Nary->new(); +my $cx = $sn->nary($code); +use Data::Dumper; +print STDERR Dumper($cx); diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..2146920 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,11 @@ +#!perl -T + +use strict; +use warnings; +use Test::More tests => 1; + +BEGIN { + use_ok( 'Sub::Nary' ); +} + +diag( "Testing Sub::Nary $Sub::Nary::VERSION, Perl $], $^X" ); diff --git a/t/02-can.t b/t/02-can.t new file mode 100644 index 0000000..5479691 --- /dev/null +++ b/t/02-can.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 3; + +require Sub::Nary; + +for (qw/new nary flush/) { + ok(Sub::Nary->can($_), 'SN can ' . $_); +} diff --git a/t/10-obj.t b/t/10-obj.t new file mode 100644 index 0000000..feaecc9 --- /dev/null +++ b/t/10-obj.t @@ -0,0 +1,29 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 6 + 1 * 2; + +use Sub::Nary; + +my $sn = new Sub::Nary; +ok(defined $sn, 'SN object is defined'); +is(ref $sn, 'Sub::Nary', 'SN object is valid'); + +my $sn2 = $sn->new; +ok(defined $sn2, 'SN::new called as an object method works' ); +is(ref $sn2, 'Sub::Nary', 'SN::new called as an object method works is valid'); + +my $sn3 = Sub::Nary::new(); +ok(defined $sn3, 'SN::new called as a function works '); +is(ref $sn3, 'Sub::Nary', 'SN::new called as a functions returns a Sub::Nary object'); + +my $fake = { }; +bless $fake, 'Sub::Nary::Hlagh'; +for (qw/flush/) { + eval "Sub::Nary::$_('Sub::Nary')"; + like($@, qr/^First\s+argument/, "SN::$_ isn't a class method"); + eval "Sub::Nary::$_(\$fake)"; + like($@, qr/^First\s+argument/, "SN::$_ only applies to SN objects"); +} diff --git a/t/11-cache.t b/t/11-cache.t new file mode 100644 index 0000000..bd1eaf6 --- /dev/null +++ b/t/11-cache.t @@ -0,0 +1,30 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 10; + +use Sub::Nary; + +sub wat { + wantarray ? (1, 2) : 1; +} + +my $sn = Sub::Nary->new(); + +my $r = { 1 => 0.5, 2 => 0.5 }; + +is_deeply($sn->nary(\&wat), $r, 'first run, without cache'); +isnt(keys %{$sn->{cache}}, 0, 'cache isn\'t empty'); +is_deeply($sn->nary(\&wat), $r, 'second run, cached'); +isnt(keys %{$sn->{cache}}, 0, 'cache isn\'t empty'); + +my $sn2 = $sn->flush(); +is_deeply( [ defined $sn2, $sn2->isa('Sub::Nary') ], [ 1, 1 ], 'flush '); +is(keys %{$sn->{cache}}, 0, 'cache is empty'); + +is_deeply($sn->nary(\&wat), $r, 'third run, without cache'); +isnt(keys %{$sn->{cache}}, 0, 'cache isn\'t empty'); +is_deeply($sn->nary(\&wat), $r, 'fourth run, cached'); +isnt(keys %{$sn->{cache}}, 0, 'cache isn\'t empty'); diff --git a/t/15-scalops.t b/t/15-scalops.t new file mode 100644 index 0000000..0efd039 --- /dev/null +++ b/t/15-scalops.t @@ -0,0 +1,13 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 1; + +use Sub::Nary; + +my @scalops = Sub::Nary::scalops(); +my $nbr = Sub::Nary::scalops(); + +is($nbr, scalar @scalops, 'Sub::Nary::scalops return values in list/scalar context are consistent'); diff --git a/t/20-return.t b/t/20-return.t new file mode 100644 index 0000000..ac62ce5 --- /dev/null +++ b/t/20-return.t @@ -0,0 +1,70 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 40; + +use Sub::Nary; + +my $sn = Sub::Nary->new(); + +my ($x, $y, @a, %h); + +my @tests = ( + [ sub { return }, 0 ], + [ sub { return () }, 0 ], + [ sub { return return }, 0 ], + [ sub { return do { return } }, 0 ], + + [ sub { return 1 }, 1 ], + [ sub { return 1, 2 }, 2 ], + [ sub { my $x = 1; $x = 2; return 3, 4, 5; }, 3 ], + [ sub { do { 1; return 2, 3 } }, 2 ], + [ sub { do { 1; return 2, 3; 4 } }, 2 ], + [ sub { do { 1; return 2, return 3 } }, 1 ], + + [ sub { return $x }, 1 ], + [ sub { return $x, $y }, 2 ], + + [ sub { return @a }, 'list' ], + [ sub { return $a[0] }, 1 ], + [ sub { return @a[1, 2] }, 2 ], + [ sub { return @a[2 .. 4] }, 3 ], + [ sub { return @a[do{ 1 .. 5 }] }, 5 ], + [ sub { return @a[do{ 1 .. $x }] }, 'list' ], + + [ sub { return %h }, 'list' ], + [ sub { return $h{a} }, 1 ], + [ sub { return @h{qw/a b/} }, 2 ], + [ sub { return @h{@a[1 .. 3]} }, 3 ], + [ sub { return @h{@a[$y .. 3]} }, 'list' ], + + [ sub { return $x, $a[3], $h{c} }, 3 ], + [ sub { return $x, @a }, 'list' ], + [ sub { return %h, $y }, 'list' ], + + [ sub { return 1 .. 3 }, 'list' ], + + [ sub { for (1, 2, 3) { return } }, 0 ], + [ sub { for (1, 2, 3) { } return 1, 2; }, 2 ], + [ sub { for ($x, 1, $y) { return 1, 2 } }, 2 ], + [ sub { for (@a) { return 1, do { $x } } }, 2 ], + [ sub { for (keys %h) { return do { 1 }, do { return @a[0, 2] } } }, 2 ], + [ sub { for my $i (1 .. 4) { return @h{qw/a b/} } }, 2 ], + [ sub { for (my $i; $i < 10; ++$i) { return 1, @a[do{return 2, 3}] } }, 2 ], + [ sub { return 1, 2 for 1 .. 4 }, 2 ], + + [ sub { while (1) { return } }, 0 ], + [ sub { while (1) { } return 1, 2 }, 2 ], + [ sub { while (1) { return 1, 2 } }, 2 ], + [ sub { while (1) { last; return 1, 2 } }, 2 ], + [ sub { return 1, 2 while 1 }, 2 ], +); + +my $i = 1; +for (@tests) { + my $r = $sn->nary($_->[0]); + is_deeply($r, { $_->[1] => 1 }, 'return test ' . $i); + ++$i; +} diff --git a/t/21-list.t b/t/21-list.t new file mode 100644 index 0000000..cb1dd1a --- /dev/null +++ b/t/21-list.t @@ -0,0 +1,58 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 27; + +use Sub::Nary; + +my $sn = Sub::Nary->new(); + +my ($x, $y, @a, %h); + +my @tests = ( + [ sub { }, 0 ], + [ sub { () }, 0 ], + [ sub { (1, 2, 3)[2 .. 1] }, 0 ], + + [ sub { 1 }, 1 ], + [ sub { 1, 2 }, 2 ], + [ sub { my $x = 1; $x = 2; 3, 4, 5; }, 3 ], + [ sub { do { 1; 2, 3 } }, 2 ], + [ sub { do { 1; 2, do { 3, do { 4 } } } }, 3 ], + + [ sub { $x }, 1 ], + [ sub { $x, $y }, 2 ], + + [ sub { @a }, 'list' ], + [ sub { $a[0] }, 1 ], + [ sub { @a[1, 2] }, 2 ], + [ sub { @a[2 .. 4] }, 3 ], + + [ sub { %h }, 'list' ], + [ sub { $h{a} }, 1 ], + [ sub { @h{qw/a b/} }, 2 ], + + [ sub { $x, $a[3], $h{c} }, 3 ], + [ sub { $x, @a }, 'list' ], + [ sub { %h, $y }, 'list' ], + + [ sub { 1 .. 3 }, 'list' ], + [ sub { my @a = (1 .. 4) }, 4 ], + + [ sub { (localtime)[0, 1, 2] }, 3 ], + + [ sub { for (1, 2, 3) { } }, 0 ], + [ sub { for (1, 2, 3) { 1; } 1, 2 }, 2 ], + + [ sub { while (1) { } }, 0 ], + [ sub { while (1) { 1; } 1, 2 }, 2 ], +); + +my $i = 1; +for (@tests) { + my $r = $sn->nary($_->[0]); + is_deeply($r, { $_->[1] => 1 }, 'list test ' . $i); + ++$i; +} diff --git a/t/22-call.t b/t/22-call.t new file mode 100644 index 0000000..f7bb741 --- /dev/null +++ b/t/22-call.t @@ -0,0 +1,78 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 39; + +use Sub::Nary; + +my $sn = Sub::Nary->new(); + +sub zero { } +sub one { 1 } +sub two { 1, 2 } +sub lots { @_ } + +sub rec { rec(); } + +sub rec1 { rec2(); } +sub rec2 { rec1(); } + +my @tests = ( + [ sub { zero }, 0 ], + [ sub { one }, 1 ], + [ sub { two }, 2 ], + [ sub { lots }, 'list' ], + + [ sub { one, zero, two }, 3 ], + [ sub { one, lots }, 'list' ], + [ sub { lots, two }, 'list' ], + + [ sub { do { one, do { two } } }, 3 ], + [ sub { do { lots, do { one } } }, 'list' ], + + [ sub { 1, return two, do { 4 } }, 3 ], + [ sub { two 1, return 2 }, 1 ], + + [ sub { 1, one(), 2 }, 3 ], + [ sub { 1, one(), @_ }, 'list' ], + [ sub { $_[0], two() }, 3 ], + [ sub { my $x = two() }, 1 ], + [ sub { my @a = two() }, 2 ], + + [ sub { 1, do { two, 1 }, do { one }, @_[0, 1] }, 7 ], + [ sub { 1, do { two, 1, do { one, @_[0, 1] } } }, 7 ], + + [ sub { $_[0]->what }, 'list' ], + [ sub { my $m = $_[1]; $_[0]->$m() }, 'list' ], + [ sub { $_[0]->() }, 'list' ], + [ sub { &two }, 2 ], + [ sub { goto &two }, 2 ], + [ sub { my $x = $_[0]; goto &$x }, 'list' ], + [ sub { FOO: goto FOO, 1 }, 'list' ], + + [ sub { rec() }, 'list' ], + [ sub { rec1() }, 'list' ], + + [ sub { sub { 1, 2 }, 2, 3 }, 3 ], + [ sub { sub { 1, 2 }->() }, 2 ], + [ sub { sub { 1, 2 }->(), 1, 2 }, 4 ], + [ sub { do { sub { 1, 2 } }->(), 3 }, 3 ], + [ sub { do { my $x = sub { }; sub { 1, 2 } }->(), 3 }, 3 ], + [ sub { do { my $x = \&zero; sub { 1, 2 } }->(), 3 }, 3 ], + [ sub { do { my $x = 1; do { my $y = 2; sub { 1, 2 } } }->(), 3 }, 3 ], + [ sub { sub { sub { 1, 2 } }->()->() }, 'list' ], + [ sub { sub { sub { 1, 2 }->(), 3 }->(), 4 }, 4 ], + + [ sub { \&zero }, 1 ], + [ sub { *zero }, 1 ], + [ sub { *zero{CODE}->() }, 'list' ], +); + +my $i = 1; +for (@tests) { + my $r = $sn->nary($_->[0]); + is_deeply($r, { $_->[1] => 1 }, 'call test ' . $i); + ++$i; +} diff --git a/t/23-branch.t b/t/23-branch.t new file mode 100644 index 0000000..f806089 --- /dev/null +++ b/t/23-branch.t @@ -0,0 +1,70 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 14; + +use Sub::Nary; + +my $sn = Sub::Nary->new(); + +my ($x, $y, @a, %h); + +sub ret12 { + if ($x) { + return 1 + } else { + return 1, 2 + } +} + +sub ret1l { $x ? 1 : @_ } + +sub ret1234 { + if ($x) { + return 1, 2 + } elsif ($h{foo}) { + return 3, @a[4, 5]; + } elsif (@a) { + return @h{qw/a b c/}, $y + } +} + +sub retinif { + if (return 1, 2) { + return 1, 2, 3 + } else { + return @_[0 .. 3] + } +} + +my @tests = ( + [ \&ret12, { 1 => 0.5, 2 => 0.5 } ], + [ sub { 1, ret12 }, { 2 => 0.5, 3 => 0.5 } ], + [ sub { 1, do { ret12, 3 } }, { 3 => 0.5, 4 => 0.5 } ], + [ sub { @_[ret12()] }, { 1 => 0.5, 2 => 0.5 } ], + + [ sub { ret12, ret12 }, { 2 => 0.25, 3 => 0.5, 4 => 0.25 } ], + [ sub { ret12, 0, ret12 }, { 3 => 0.25, 4 => 0.5, 5 => 0.25 } ], + [ sub { ret12, @a }, { list => 1 } ], + [ sub { %h, ret12 }, { list => 1 } ], + + [ sub { if ($y) { ret12 } else { ret12 } }, { 1 => 0.5, 2 => 0.5 } ], + + [ \&ret1l, { 1 => 0.5, list => 0.5 } ], + [ sub { $_[0], ret1l }, { 2 => 0.5, list => 0.5 } ], + [ sub { ret1l, ret1l, ret1l }, { 3 => 0.125, list => 0.875 } ], + + [ \&ret1234, { map { $_ => 0.25 } 1 .. 4 } ], + + [ \&retinif, { 2 => 1 } ], +); + +my $i = 1; +for (@tests) { + my $r = $sn->nary($_->[0]); + is_deeply($r, $_->[1], 'branch test ' . $i); + ++$i; +} + diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t new file mode 100644 index 0000000..664f38f --- /dev/null +++ b/t/90-boilerplate.t @@ -0,0 +1,49 @@ +#!perl -T + +use strict; +use warnings; +use Test::More tests => 3; + +sub not_in_file_ok { + my ($filename, %regex) = @_; + open( my $fh, '<', $filename ) + or die "couldn't open $filename for reading: $!"; + + my %violated; + + while (my $line = <$fh>) { + while (my ($desc, $regex) = each %regex) { + if ($line =~ $regex) { + push @{$violated{$desc}||=[]}, $.; + } + } + } + + if (%violated) { + fail("$filename contains boilerplate text"); + diag "$_ appears on lines @{$violated{$_}}" for keys %violated; + } else { + pass("$filename contains no boilerplate text"); + } +} + +sub module_boilerplate_ok { + my ($module) = @_; + not_in_file_ok($module => + 'the great new $MODULENAME' => qr/ - The great new /, + 'boilerplate description' => qr/Quick summary of what the module/, + 'stub function definition' => qr/function[12]/, + ); +} + +not_in_file_ok(README => + "The README is used..." => qr/The README is used/, + "'version information here'" => qr/to provide version information/, +); + +not_in_file_ok(Changes => + "placeholder date/time" => qr(Date/time) +); + +module_boilerplate_ok('lib/Sub/Nary.pm'); + diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..6c79b70 --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,18 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.18; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; + +all_pod_coverage_ok({ also_private => [ qr/^pp_/, qr/^expect_/, qw/add combine const_sv enter gv_or_padgv name null padval scalops tag/ ] }); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..ab541f3 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Portability::Files"; +plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@; +run_tests(); diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t new file mode 100644 index 0000000..7775e60 --- /dev/null +++ b/t/99-kwalitee.t @@ -0,0 +1,9 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +eval { require Test::Kwalitee; Test::Kwalitee->import() }; +plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;