perl 'require' in begin block - perl

I have the following code:
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
BEGIN {
my $supported = undef;
*compute_factorial = sub { if (eval { require bignum; bignum->import(); 1;}) {
my $num = shift;
my $factorial = 1;
foreach my $num (1..$num) {
$factorial *= $num;
}
return $factorial;
} else {
undef;
} };
};
my $f = compute_factorial(25);
say $f;
I'm just testing something, not really a production code...
I do have bignum pragma on my machine (perfectly loadable using use), I was wondering why require doesn't work as it should be (I'm getting exponential numbers rather then "big numbers") in this case?
Thanks,

bignum's import needs to be called before compilation of the code it is intended to effect, or it doesn't work. Here, the BEGIN makes it called before your actual compute_factorial call, but not before the critical my $factorial = 1; is compiled.
A better approach for cases like this is just to directly use Math::Big*:
if (eval { require Math::BigInt }) {
my $num = shift;
my $factorial = Math::BigInt->new(1);
foreach my $num (1..$num) {
$factorial *= $num;
}
return $factorial;
} else {
undef;
}

BEGIN {
require bignum;
import bignum;
my $x = 1;
}
and
require bignum;
import bignum;
my $x = 1;
are the same because require and import are executed after my $x = 1; is already compiled, so bignum never has a chance to make my $x = 1; compile into my $x = Math::BigInt->new(1);. Keep in mind that
use bignum;
my $x = 1;
is actually
BEGIN {
require bignum;
import bignum;
}
my $x = 1;
and not
BEGIN {
require bignum;
import bignum;
my $x = 1;
}
The solution would be
BEGIN {
my $sub;
if (eval { require bignum; }) {
$sub = eval(<<'__EOI__') or die $#;
use bignum;
sub {
my ($num) = #_;
my $factorial = 1;
$factorial *= $_ for 2..$num;
return $factorial;
}
__EOI__
} else {
$sub = sub { croak "Unsupported" };
}
*factorial = $sub;
}
Of course, since you can simply eliminate the pragma, that would be best.
BEGIN {
my $sub;
if (eval { require Math::BigInt; }) {
require Math::BigInt;
$sub = sub {
my ($num) = #_;
my $factorial = Math::BigInt->new(1);
$factorial *= $_ for 2..$num;
return $factorial;
};
} else {
$sub = sub { croak "Unsupported" };
}
*factorial = $sub;
}

As many other pragmas, in newer versions of Perl bignum is only active in scope where you imported it. However, unlike many it also does some funky messing up with upgrading scoped numbers that doesn't quite work with just require. You will have to break check for its existence and use in two different files to isolate scope and still let it do its magic.
big.pl
if (eval { require bignum; 1 }) {
require big_loader;
}
print big_loader::big_num_returner();
print "still ok\n";
big_loader.pm
package big_loader;
use bignum;
sub big_num_returner {
return 2**512
}
1;

Related

Perl calling subroutine reference with explicit additional scope as cleanly as possible

I'd like to be able to write something like the following...
call_with_scope({
x => 47,
}, sub {
printf "$x\n";
printf "$y\n";
});
Where $y is bound in the environment containing the expression (either lexically or dynamically depending on the symbol).
I've found a way to do it, but it requires no strict "vars" to be in effect in the expression containing call_with_scope(...) and the implementation of call_with_scope uses eval to create local bindings before transferring control to the callback.
Is there a way to avoid either requiring no strict "vars" at the call site or refer to and change the value of a local variable without resorting to eval?
For completeness, the code snippet below implements call_with_scope and prints 47 and then 48.
#!/usr/bin/env perl
use strict;
use warnings;
sub call_with_scope {
my ($env, $func) = #_;
my %property;
my #preamble;
foreach my $k (keys %$env) {
$property{$k} = $env->{$k};
# deliberately omitted: logic to ensure that ${$k} is a well-formed variable
push #preamble, "local \$$k = \$property{'$k'};";
}
# force scalar context
do {
my $str = join('', 'no strict "vars";', #preamble, '$_[1]->();');
return scalar(eval($str));
};
}
do {
no strict 'vars';
local $x;
my $y = 48;
call_with_scope(
{
x => 47,
},
sub {
printf "$x\n";
printf "$y\n";
}
);
};
I'm trying to write something kind of like Test::LectroTest ... except that instead of using a source filter and comments like in Property { ##[ x <- Int, y <- Int ]## <body> } ... I want to write something like Property({x => gen_int, y => gen_int}, sub { <body> }) where $x and $y inside body get their values when an "instantiation" of a property test is performed.
You can do this by defining $x and $y as globals in the caller's package.
no strict 'refs';
my $caller = caller;
for my $var (keys %$properties) {
*{$caller.'::'.$var} = $properties->{$var};
}
$code->();
But this can't be easily localized. And polluting the caller's namespace with globals potentially leads to mysterious data leaking between tests. In general, use as little magic as possible in a test library; the user will have enough of their own weird magic to debug.
Instead, provide a function which returns the properties. For example, p.
package LectroTest;
use Exporter qw(import);
our #EXPORT = qw(test p);
our $P;
sub test {
my($props, $test) = #_;
local $P = $props;
$test->();
}
sub p {
return $P;
}
And the test looks like:
use LectroTest;
test(
{ x => 42 }, sub { print p->{x} }
);
The problem is that the anon sub is compiled before call_with_scope is called, so there's no chance for call_with_scope to declare variables for that sub.
Any reason you're not using arguments like any other sub?
call_with_scope([ 47 ], sub {
my ($x) = #_;
printf "%s\n", $x;
printf "%s\n", $y;
});
It's not any longer!
Here's an alternative if you're ok in declaring $x outside of the sub.
use strict;
use warnings;
use PadWalker qw( closed_over );
sub call_with_scope {
my ($inits, $cb) = #_;
my $captures = closed_over($cb);
for my $var_name_with_sigil (keys(%$captures)) {
my ($var_name) = $var_name_with_sigil =~ /^\$(.*)/s
or next;
$inits->{$var_name}
or next;
${ $captures->{$var_name_with_sigil} } = $inits->{$var_name};
}
return $cb->();
}
{
my $x;
my $y = 48;
call_with_scope({
x => 47,
}, sub {
printf "%s\n", $x;
printf "%s\n", $y;
});
}
This works because variables are created at compile-time and cleared on scope exit.
It even works if sub was compiled in a different scope and package than the call to call_with_scope.
{
my $sub = do {
my $x;
my $y = 48;
sub {
printf "%s\n", $x;
printf "%s\n", $y;
}
};
call_with_scope({ x => 47 }, $sub);
}
But do you really want that kind of magic in your program?

Why do I get 'use of uninitialized value' warnings even though I return a value from Try::Tiny's finally block?

It is unclear to me why the piece of code below gives me the error:
Use of uninitialized value in addition (+) at combined_op_test.pl line 12.
I expect the value of $success_count to increment by the value returned from the subroutine on each iteration.
Here is the code:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
use Try::Tiny;
my $success_count = 0;
for ( 1..10 ) {
$success_count += error_causing_sub();
}
sub error_causing_sub {
try {
die ("Error.");
} catch {
} finally {
if (#_) {
say "Error occured.";
return 0;
}
else {
say "Error did not occur.";
return 1;
}
};
}
Any help is appreciated.
As explained in the CAVEATS section of the documentation, the return does not return from the sub, it returns from finally:
return returns from the try block, not from the parent sub (note that this is also how eval works, but not how TryCatch works):
sub parent_sub {
try {
die;
}
catch {
return;
};
say "this text WILL be displayed, even though an exception is thrown";
}
As #simbabque notes, the return value of finally is ignored. If the try fails, the return value of catch is relevant, and it's empty:
The return value of the catch block is not ignored, so if testing the result of the expression for truth on success, be sure to return a false value from the catch block: ...
The following code looks more logical to me:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
use Try::Tiny;
my $success_count = 0;
for ( 1..10 ) {
$success_count += error_causing_sub();
}
say $success_count;
sub error_causing_sub {
my $ret;
try {
die ("Error.") if rand(1) < 0.5;
say "Error did not occur.";
$ret = 1;
} catch {
say "Error occured.";
$ret = 0;
};
return $ret;
}
In addition, AFAIK, the issues with eval that made Try::Tiny relevant were fixed in 5.14. So, you may be better off just using it:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
my $success_count = 0;
$success_count += error_causing_sub() for 1 .. 10;
say $success_count;
sub error_causing_sub {
my $ret;
eval {
die ("Error.") if rand(1) < 0.5;
say "Error did not occur.";
$ret = 1;
} or do {
say "Error occured.";
$ret = 0;
};
return $ret;
}

Subroutine error calculating factorial: Useless use of private variable in void context

I just started to learn Perl and have troubles to calculating factorials iteratively.
With this code I get the error:
Useless use of private variable in void context
sub factorial {
my ($input) = #_; #assigning argument
for ( $input; $input > 0; $input -= 1 ) {
my $factorial = $input * ($input -1);
return $factorial;
}
}
Has anybody an idea what went wrong there?
for (A; B; C) { ... }
is basically
A;
while (B) { ... } continue { C }
so you are evaluating the following:
$input;
That has no effect, so Perl warns you that you probably didn't mean to do that!
Your loop makes no sense! You always return the first pass through. Worse, you don't return anything meaningful when $input is zero!
sub factorial {
my ($n) = #_;
my $accumulator = 1;
for (; $n>0; --$n) {
$accumulator *= $n;
}
return $accumulator;
}
There's rarely any reason to a C-style loop in Perl. The following is clearer:
sub factorial {
my ($n) = #_;
my $accumulator = 1;
for my $i (2..$n) {
$accumulator *= $i;
}
return $accumulator;
}
or
sub factorial {
my ($n) = #_;
my $accumulator = 1;
$accumulator *= $_ for 2..$n;
return $accumulator;
}
The variable (statement) $input in for ($input; ...) serves no purpose and does nothing. By adding use diagnostics; to the top of the program you'll get
Useless use of private variable in void context at t.pl line 19 (#1)
(W void) You did something without a side effect in a context that does
nothing with the return value, [...]
You can also see this and directly fix it by
for (my $input = shift; $input > 0; $input -= 1) {
or
my ($input) = #_;
for (; $input > 0; $input -= 1) { ...
but then the rest is incorrect since $factorial is declared anew at every interation, and you return right away. So move the declaration part (my $factorial;) to before the loop and move return to after the loop. Then your code works -- other than for 0, for which factorial need be 1.
There are other ways, for example
sub factorial {
my ($input) = #_;
my $factorial = $input || 1 # 0! == 1
$factorial *= $input while --$input > 1;
return $factorial;
}
or the "standard" recursive way
sub factorial {
my ($input) = #_;
return 1 if $input == 0;
return factorial($input-1) * $input;
}

perl: Can't call method "push" without a package or object reference?

I was given the assignment to implement a linked list in perl without using the built-in push,pop,shift and unshift. This is my first time learning perl, coming from c++ and java, this is what I came up with:
#!/usr/bin/perl
sub node {
my (#value) = #_;
sub get {
$next;
}
sub push {
#my $next = \#_;
if(defined($next))
{
$next->push(#_);
}
else
{
my $next = \#_;
}
}
sub size {
if(defined($next))
{
$next->size($_[0]);
}
else
{
$_[0]+1;
}
}
sub myprint {
print "$_[0]: ";
foreach (#value) {
print "$_, ";
}
print "\n";
if(defined($next)) {
$next->print($_[0]+1);
}
}
}
while(!defined($done))
{
print "what do you want to do?\n";
print "1 -- push\n";
print "2 -- print nodes\n";
print "3 -- pop\n";
print "4 -- quit\n";
my $val = <STDIN>;
if ($val == 1)
{
print "Type something: ";
$input = <STDIN>;
if(defined($top))
{
$top->push(node($input));
}
else
{
$top = node($input);
}
}
elsif ($val == 2)
{
if(defined($top))
{
$top->myprint(1);
}
}
elsif ($val == 3)
{
if(defined($top))
{
if(defined($top->next))
{
$top=$top->next;
}
}
}
elsif ($val == 4)
{
$done=true;
}
else
{
print "Invalid option\n";
}
}
output:
what do you want to do?
1 -- push
2 -- print nodes
3 -- pop
4 -- quit
1
Type something: q
what do you want to do?
1 -- push
2 -- print nodes
3 -- pop
4 -- quit
1
Type something: w
Can't call method "push" without a package or object reference at ./linkedlistattempt1.pl line 76, <STDIN> line 4.
I'm guessing the "->" operator can only be used with a module or package.
I haven't gotten around to testing the other methods, I'm still working on push. I feel like the best way of doing this is to simply have a holder sub like `sub holder { $value = \#_; } but I don't understand how I would (could?) add more variables, like the next node, hence the sub within a sub design. So without the help of perl's built in functions, how would I do this?
Its important to mention I'm interested in methods that can run on the older versions, going down to 5.10. Most if not all of the tutorials are showing stuff for 5.16 or 5.18
A typical Perl implementation using classic Perl OO would look something like this. Read the man pages perlootut and perlobj to learn how it works.
#!/usr/bin/perl
use strict;
use warnings;
package LinkedList::Node;
# Constructor.
sub new {
my ($class, $item) = #_;
my $self = { item => $item };
return bless($self, $class);
}
# Read-only accessor.
sub item {
my $self = shift;
return $self->{item};
}
# Read-write accessor.
sub next {
my $self = shift;
my $next = $self->{next};
if (#_ > 0) {
$self->{next} = shift;
}
return $next;
}
package LinkedList;
# Constructor. Creates an empty linked list.
sub new {
my $class = shift;
return bless({}, $class);
}
# Read-only accessor.
sub head {
my $self = shift;
return $self->{head};
}
# Insert an item at the beginning.
sub push {
my ($self, $item) = #_;
my $node = LinkedList::Node->new($item);
my $head = $self->{head};
if ($head) {
$node->next($head);
}
$self->{head} = $node;
}
package main;
my $list = LinkedList->new;
$list->push(2);
$list->push(5);
$list->push(9);
for (my $node = $list->head; $node; $node = $node->next) {
print($node->item, "\n");
}

Find unused "use'd" Perl modules

I am working on a very large, very old "historically grown" codebase. In the past, there were often people thinking "Oh, I may need this and that module, so I just include it...", and later, people often "cached" Data inside of modules ("use ThisAndThat" needing a few seconds to load some hundred MB from DB to RAM, yeah, its really a stupid Idea, we are working on that too) and so, often, we have a small module use'ing like 20 or 30 modules, from who 90% are totally unused in the source itself, and, because of "caching" in several use'd submodules, modules tend to take up one minute to load or even more, which is, of course, not acceptable.
So, Im trying to get that done better. Right now, my way is looking through all the modules, understanding them as much as possible and I look at all the modules including them and see whether they are needed or not.
Is there any easier way? I mean: There are functions returning all subs a module has like
...
return grep { defined &{"$module\::$_"} } keys %{"$module\::"}
, so, aint there any simple way to see which ones are exported by default and which ones come from where and are used in the other modules?
A simple example is Data::Dumper, which is included in nearly every file, even, when all debug-warns and prints and so on arent in the script anymore. But still the module has to load Data::Dumper.
Is there any simple way to check that?
Thanks!
The following code could be part of your solution - it will show you which symbols are imported for each instance of use:
package traceuse;
use strict;
use warnings;
use Devel::Symdump;
sub import {
my $class = shift;
my $module = shift;
my $caller = caller();
my $before = Devel::Symdump->new($caller);
my $args = \#_;
# more robust way of emulating use?
eval "package $caller; require $module; $module\->import(\#\$args)";
my $after = Devel::Symdump->new($caller);
my #added;
my #after_subs = $after->functions;
my %before_subs = map { ($_,1) } $before->functions;
for my $k (#after_subs) {
push(#added, $k) unless $before_subs{$k};
}
if (#added) {
warn "using module $module added: ".join(' ', #added)."\n";
} else {
warn "no new symbols from using module $module\n";
}
}
1;
Then just replace "use module ..." with "use traceuse module ...", and you'll get a list of the functions that were imported.
Usage example:
package main;
sub foo { print "debug: foo called with: ".Dumper(\#_)."\n"; }
use traceuse Data::Dumper;
This will output:
using module Data::Dumper added: main::Dumper
i.e. you can tell which functions were imported in robust way. And you can easily extend this to report on imported scalar, array and hash variables - check the docs on Devel::Symdump.
Determine which functions are actually used is the other half of the equation. For that you might be able to get away with a simple grep of your source code - i.e. does Dumper appear in the module's source code that's not on a use line. It depends on what you know about your source code.
Notes:
there may be a module which does what traceuse does - I haven't checked
there might be a better way to emulate "use" from another package
I kind of got of got it to work with PPI. It looks like this:
#!/usr/local/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Term::ANSIColor;
use PPI;
use PPI::Dumper;
my %doneAlready = ();
$" = ", ";
our $maxDepth = 2;
my $showStuffOtherThanUsedOrNot = 0;
parse("/modules/Test.pm", undef, undef, 0);
sub parse {
my $file = shift;
my $indent = shift || 0;
my $caller = shift || $file;
my $depth = shift || 0;
if($depth && $depth >= $maxDepth) {
return;
}
return unless -e $file;
if(exists($doneAlready{$file}) == 1) {
return;
}
$doneAlready{$file} = 1;
my $skript = PPI::Document->new($file);
my #included = ();
eval {
foreach my $x (#{$skript->find("PPI::Statement::Include")}) {
foreach my $y (#{$x->{children}}) {
push #included, $y->{content} if (ref $y eq "PPI::Token::Word" && $y->{content} !~ /^(use|vars|constant|strict|warnings|base|Carp|no)$/);
}
}
};
my %double = ();
print "===== $file".($file ne $caller ? " (Aufgerufen von $caller)" : "")."\n" if $showStuffOtherThanUsedOrNot;
if($showStuffOtherThanUsedOrNot) {
foreach my $modul (#included) {
next unless -e createFileName($modul);
my $is_crap = ((exists($double{$modul})) ? 1 : 0);
print "\t" x $indent;
print color("blink red") if($is_crap);
print $modul;
print color("reset") if($is_crap);
print "\n";
$double{$modul} = 1;
}
}
foreach my $modul (#included) {
next unless -e createFileName($modul);
my $anyUsed = 0;
my $modulDoc = parse(createFileName($modul), $indent + 1, $file, $depth + 1);
if($modulDoc) {
my #exported = getExported($modulDoc);
print "Exported: \n" if(scalar #exported && $showStuffOtherThanUsedOrNot);
foreach (#exported) {
print(("\t" x $indent)."\t");
if(callerUsesIt($_, $file)) {
$anyUsed = 1;
print color("green"), "$_, ", color("reset") if $showStuffOtherThanUsedOrNot;
} else {
print color("red"), "$_, ", color("reset") if $showStuffOtherThanUsedOrNot;
}
print "\n" if $showStuffOtherThanUsedOrNot;
}
print(("\t" x $indent)."\t") if $showStuffOtherThanUsedOrNot;
print "Subs: " if $showStuffOtherThanUsedOrNot;
foreach my $s (findAllSubs($modulDoc)) {
my $isExported = grep($s eq $_, #exported) ? 1 : 0;
my $rot = callerUsesIt($s, $caller, $modul, $isExported) ? 0 : 1;
$anyUsed = 1 unless $rot;
if($showStuffOtherThanUsedOrNot) {
print color("red") if $rot;
print color("green") if !$rot;
print "$s, ";
print color("reset");
}
}
print "\n" if $showStuffOtherThanUsedOrNot;
print color("red"), "=========== $modul wahrscheinlich nicht in Benutzung!!!\n", color("reset") unless $anyUsed;
print color("green"), "=========== $modul in Benutzung!!!\n", color("reset") if $anyUsed;
}
}
return $skript;
}
sub createFileName {
my $file = shift;
$file =~ s#::#/#g;
$file .= ".pm";
$file = "/modules/$file";
return $file;
}
sub getExported {
my $doc = shift;
my #exported = ();
eval {
foreach my $x (#{$doc->find("PPI::Statement")}) {
my $worthATry = 0;
my $isMatch = 0;
foreach my $y (#{$x->{children}}) {
$worthATry = 1 if(ref $y eq "PPI::Token::Symbol");
if($y eq '#EXPORT') {
$isMatch = 1;
} elsif($isMatch && ref($y) ne "PPI::Token::Whitespace" && ref($y) ne "PPI::Token::Operator" && $y->{content} ne ";") {
push #exported, $y->{content};
}
}
}
};
my #realExported = ();
foreach (#exported) {
eval "\#realExported = $_";
}
return #realExported;
}
sub callerUsesIt {
my $subname = shift;
my $caller = shift;
my $namespace = shift || undef;
my $isExported = shift || 0;
$caller = `cat $caller`;
unless($namespace) {
return 1 if($caller =~ /\b$subname\b/);
} else {
$namespace = createPackageName($namespace);
my $regex = qr#$namespace(?:::|->)$subname#;
if($caller =~ $regex) {
return 1;
}
}
return 0;
}
sub findAllSubs {
my $doc = shift;
my #subs = ();
eval {
foreach my $x (#{$doc->find("PPI::Statement::Sub")}) {
my $foundName = 0;
foreach my $y (#{$x->{children}}) {
no warnings;
if($y->{content} ne "sub" && ref($y) eq "PPI::Token::Word") {
push #subs, $y;
}
use warnings;
}
}
};
return #subs;
}
sub createPackageName {
my $name = shift;
$name =~ s#/modules/##g;
$name =~ s/\.pm$//g;
$name =~ s/\//::/g;
return $name;
}
Its really ugly and maybe not 100% working, but it seems, with the tests that Ive done now, that its good for a beginning.