--- /dev/null
+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
--- /dev/null
+Revision history for Sub-Nary
+
+0.01 2008-08-04 16:35 UTC
+ First version, released on an unsuspecting world.
+
--- /dev/null
+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)
--- /dev/null
+--- #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 <perl@profvince.com>
+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
--- /dev/null
+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 <perl@profvince.com>',
+ 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/;
+ <<POSTAMBLE;
+cover test_cover:
+ $cv -test
+POSTAMBLE
+}
--- /dev/null
+/* This file is part of the Sub::Nary Perl module.
+ * See http://search.cpan.org/dist/Sub::Nary/ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifndef mPUSHi
+# define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
+#endif /* !mPUSHi */
+
+/* --- XS ------------------------------------------------------------------ */
+
+MODULE = Sub::Nary PACKAGE = Sub::Nary
+
+PROTOTYPES: ENABLE
+
+void
+tag(SV *op)
+PROTOTYPE: $
+CODE:
+ ST(0) = sv_2mortal(newSVuv(SvIV(SvRV(op))));
+ XSRETURN(1);
+
+void
+null(SV *op)
+PROTOTYPE: $
+PREINIT:
+ OP *o;
+CODE:
+ o = INT2PTR(OP *, SvIV(SvRV(op)));
+ ST(0) = sv_2mortal(newSVuv(o == NULL));
+ XSRETURN(1);
+
+void
+scalops()
+PROTOTYPE:
+PREINIT:
+ U32 cxt;
+ int i, count = 0;
+CODE:
+ cxt = GIMME_V;
+ if (cxt == G_SCALAR) {
+ for (i = 0; i < OP_max; ++i) {
+ count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
+ }
+ EXTEND(SP, 1);
+ mPUSHi(count);
+ XSRETURN(1);
+ } else if (cxt == G_ARRAY) {
+ for (i = 0; i < OP_max; ++i) {
+ if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
+ const char *name = PL_op_name[i];
+ XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
+ ++count;
+ }
+ }
+ XSRETURN(count);
+ }
+
--- /dev/null
+NAME
+ Sub::Nary - Try to count how many elements a subroutine can return in
+ list context.
+
+VERSION
+ Version 0.01
+
+SYNOPSIS
+ use Sub::Nary;
+
+ my $sn = Sub::Nary->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, "<perl at profvince.com>", <http://www.profvince.com>.
+
+ 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
+ <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sub-Nary>. 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
+ <http://www.profvince.com/perl/cover/Sub-Nary>.
+
+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.
+
--- /dev/null
+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<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).
+
+=head1 METHODS
+
+=head2 C<new>
+
+The usual constructor. Currently takes no argument.
+
+=head2 C<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 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<flush>
+
+Flushes the L<Sub::Nary> 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<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 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<list> elements are involved : in the following example,
+
+ sub oneorlist {
+ if (rand < 0.1) {
+ return 1
+ } else {
+ return @_
+ }
+ }
+
+ sub composed {
+ return oneorlist(), oneorlist()
+ }
+
+C<composed> returns C<2> scalars with probability C<1/2 * 1/2 = 1/4> and a C<list> 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<list> while they are of fixed length) but not optimistic (the opposite, duh).
+
+C<wantarray> isn't specialized when encountered in the optree.
+
+=head1 DEPENDENCIES
+
+L<perl> 5.8.1.
+
+L<Carp> (standard since perl 5), L<B> (since perl 5.005), L<XSLoader> (since perl 5.006) and L<List::Util> (since perl 5.007003).
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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<bug-b-nary at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sub-Nary>. 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<http://www.profvince.com/perl/cover/Sub-Nary>.
+
+=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
--- /dev/null
+#!/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);
--- /dev/null
+#!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" );
--- /dev/null
+#!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 ' . $_);
+}
--- /dev/null
+#!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");
+}
--- /dev/null
+#!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');
--- /dev/null
+#!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');
--- /dev/null
+#!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;
+}
--- /dev/null
+#!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;
+}
--- /dev/null
+#!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;
+}
--- /dev/null
+#!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;
+}
+
--- /dev/null
+#!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');
+
--- /dev/null
+#!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();
--- /dev/null
+#!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/ ] });
--- /dev/null
+#!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();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
projects / perl / modules / Sub-Nary.git / commitdiff