What is the more elegant way to write the next?
sub depend {
my($x,$y) = #_;
die "only one allowed" if( defined($x) && defined($y) );
die "one must be defined" unless ( defined($x) || defined($y) );
if( defined($x) ) {
$y = somefunc($x);
} else {
$x = somefunc($y);
}
return($x,$y);
}
The function should get exactly only one argument. If get defined both = error, if defined none = error. And the undefined arg is calculated based on the defined one.
Use xor, i.e. the "exclusive or":
sub depend {
my ($x, $y) = #_;
die "Exactly one must be defined.\n" unless defined $x xor defined $y;
if (defined $x) {
$y = somefunc($x);
} else {
$x = somefunc($y);
}
return($x, $y);
}
Update: You can shorten the rest of the sub, too. Instead of the if part, just put
return ($x // somefunc($y), $y // somefunc($x));
I might define the subroutine to take two arguments, but treat them as a key-value pair. To use the width/height example from your comment:
sub depend {
my $key = shift;
my $value = shift;
die "One parameter only" if #_;
return ($value, calc_height($value)) if $key eq "width";
return (calc_width($value), $value) if $key eq "height";
die "Must specify either height or width, not $key";
}
my ($w1, $h1) = depend( width => 5 );
my ($w2, $h2) = depend( height => 10 );
my ($w3, $h3) = depend(); # ERROR Must specify either height or width
my ($w4, $h4) = depend( other=>3 ); # ERROR Must specify either height or width, not other
my ($w5, $h5) = depend( foo => bar, 7); # ERROR, One parameter only
Try this:
sub f
{
my ($x, $y) = #_;
die "BOOM" if (defined $x ? 1 : 0) +
(defined $y ? 1 : 0) != 1;
}
Using xor might not be intuitive, and solution below could easily be extended to more input arguments,
sub depend {
my($x,$y) = #_;
die "There should be only one!" if (grep defined, $x,$y) != 1;
if( defined($x) ) {
$y = somefunc($x);
}
else {
$x = somefunc($y);
}
return($x,$y);
}
Related
I'm trying to set default values to some variables. I know how to do it but I would like to do this task using a subroutine and I'm having problems.
I have this three variables: $t, $insize, $libtype.
And this is the simple function to set default values to them if they're undefined:
sub SetUnlessDefined {
my $t = 1 if !( defined $t );
my $insize = 300 if !( defined $insize );
my $libtype = 0 if !( defined $libtype );
return( $t, $insize, $libtype );
}
I execute the function like this:
( $t, $insize, $libtype ) = SetUnlessDefined( $t, $insize, $libtype );
If all my variables are undefined the function runs OK, but if I have a value for any of them its not working.
Anyone can suggest me a solution? Or a correct way to check if a variables are defined and if they not set a value?
Thanks in advance
You don't read the parameters in the subroutine body:
sub defaults {
my ($t, $insize, $libtype) = #_; # <--- HERE
$t = 1 unless defined $t;
$insize = 300 unless defined $insize;
$libtype = 0 unless defined $libtype;
return ($t, $insize, $libtype);
}
There are other ways how to approach the task, though:
sub defaults {
my #defaults = (1, 300, 0);
for my $i (0 .. $#defaults) {
$_[$i] //= $defaults[$i]; # Perl 5.10 needed
}
}
No assignment is needed in the subroutine call anymore, as the arguments are aliased to the members of #_:
defaults($t, $insize, $libtype);
The my $t part of the code is always running, so in the case where global $t is defined, the local $t is instantiated as undefined, and is returned.
A solution is to use something like this
if (! defined $t ) {
my $t = 1 ;
}
Or maybe just
if (! defined $t ) {
$t = 1 ;
}
and don't return anything.
You are also sending parameters to the function, which are being ignored... maybe the whole thing could be redone without the parameters, and without the second assignment, like this
sub SetUnlessDefined {
if (! defined $t ) {
$t = 1 ;
}
if (! defined $insize ) {
$insize = 3000;
}
if (! defined $libtype ) {
$libtype = 0;
}
}
SetUnlessDefined();
I have a module which is giving me the error "Can't locate object method "isSubset" via package "a" (perhaps you forgot to load "a"?) at /path/to/set.pm line 121.
SET.PM:
package set; #we will create set objects, instead of treating arrays as sets
sub new{
my $packagename = shift;
my #elements = #_;
bless { 'elements' => \#elements } => $packagename;
}
sub contains{
my $set = shift;
my ($element) = #_;
foreach ($set->elements){ if( $_ eq $element ){ return 1 } }
return 0
}
sub isElement{
my ($element,$set) = #_;
return $set->contains($element)
}
sub isSubset{
my $setA = shift;
my $setB = shift;
foreach ($setA->elements){ unless( isElement($_,$setB) ){ return 0 } }
return 1
}
*subset = *isContainedIn = *isContained = \&isSubset;
sub isSuperset{
my $setA = shift;
my $setB = shift;
return $setB->isSubset($setA) # this is line 121
}
*superset = *isContaining = *contains = \&isSuperset; # when i get rid of THIS line, it works fine.
When I comment out the last line, it works fine. Can you enlighten me on what is causing the failure? Am I using glob incorrectly?
CALLING PROGRAM:
my $a = set->new('a'..'g');
my $b = set->new('b'..'f');
print $a->isSubset($b);
Turn on warnings. Perl will tell you:
Subroutine set::contains redefined at ./1.pl line 44.
You use contains for testing both an element and a set.
I am vaguely confused a bit on different methods of passing certain arguments to the constructor type. I want to only pass a hash reference \%hash, or a list foo => 1, bar => 1 but not both and croak if anything else is passed i.e ( single elements, array reference ).
For example, I pass my reference or list.. (This works for the way I do this)
my $obj = foo->new;
my $data = $obj->dump( \%hash );
my $data = $obj->dump( foo => 1, bar => 1 );
or
my $obj = foo->dump( \%hash );
my $obj = foo->dump( foo => 1, bar => 1 );
Package module:
package foo;
use strict;
use Carp;
use Scalar::Util qw/reftype/;
sub new { return bless {}, shift }
sub dump {
my $class = shift;
my $self = shift;
unless ( reftype( $self ) eq reftype {} ) {
croak("Constructor method not a hash type!");
}
}
1;
I've also thought about using the conditional operator ? : here, but I can't get it to error properly.
my $self = reftype($_[0]) eq reftype {} ? shift : {#_};
Is there a better preferred way to do this?
We can look at the various ways your dump method can be called.
If we pass a "hash list", the number of elements is even (#_ % 2 == 0). Also, if at least one key-value pair is present, the first argument (a key) is a string, so not defined reftype $_[0] holds.
If we pass a hash reference, then the argument list should only hold this reference, and no other values: #_ == 1. The first argument will be a hash: reftype($_[0]) eq 'HASH'.
So to put the arguments in a hash reference, one could do something like:
sub dump {
my $invocant = shift;
my $hashref;
if (#_ == 1 and reftype $_[0] eq 'HASH') {
$hashref = $_[0];
} elsif (#_ % 2 == 0 and (#_ == 0 or not defined reftype $_[0])) {
$hashref = +{ #_ };
} else {
croak "Unknown argument format: either pass a hashref, or an even-valued list";
}
...; # do something with $hashref
}
To find out if the $invocant is the class name or an object, just ask it if it is blessed:
if (defined Scalar::Util::blessed $invocant) {
say "Yep, it is an object";
} else {
say "Nope, it is a package name";
}
There's no such thing as a "hash list". foo => 1, bar => 1, is just a four element list. Sounds like you want to accept hash refs and even numbers of args.
sub dump {
my $self = shift;
my %args;
if (#_ == 1) {
croak("...") if (ref($_[0]) // '') ne 'HASH';
%args = %{ $_[0] };
} else {
croak("...") if #_ % 2 != 0;
%args = #_;
}
...
}
Hello I'm trying to write a simple subroutine that will compare two numbers to see if one is greater than the other, less than or equal.
So far I have the following code:
sub Value
{ my $num = $_[0];
my ($last) = shift;
my $compare = sub {
if ($last < $last) {print "Less than \n"; } else {print "Greater than \n";};};
my $hashtable;
$hashtable->{"compare"} = $compare;
$hashtable; }
#Execute Statement
my $num1 = Value(57.8);
my $num2 = Value(129.6);
print "Check: ", $num1->{"compare"}->($num2);
Does anyone have suggestion how I can get this to work correctly? Thanks!
You messed up your argument unpacking in Values. You assign the first argument to $num, and then shift the first argument into $last, so $num and $last will always have the same value.
You compare $last with $last, which isn't useful.
You put your closure into $hashtable->{compare}, but execute the contents of the check field, which is undef.
Your closure prints data to the currently selected filehandle, but doesn't return any useful information. Printing the return value doesn't seem sensible.
$num1 and $num2 are closures, and not numbers. Passing an argument to the closure doesn't do anything, as your closure doesn't unpack any arguments.
Here is a implementation that should address your issues:
use strict; use warnings;
use Test::More;
sub create_closure {
my ($x) = #_;
my $operations = {
compare => sub { my ($y) = #_; return $x <=> $y },
add => sub { my ($y) = #_; return $x + $y },
value => $x,
};
return $operations;
}
# some tests
my $ops = create_closure(15);
ok( $ops->{compare}->(15) == 0, "compare to self" );
ok( $ops->{compare}->(20) < 0, "compare to larger");
ok( $ops->{add}->(5) == 20, "add");
ok( $ops->{value} == 15, "value");
my $ops1 = create_closure(150);
ok( $ops1->{compare}->($ops->{value}) > 0, "compare to smaller value");
done_testing;
Edit
You cannot directly compare two $ops, but we can create a field that returns the original value.
However, you might want to use objects and operator overloading if you intend to do such things more often:
use strict; use warnings; use Test::More;
{
package Ops;
sub new {
my ($class, $val) = #_;
if (ref $val eq __PACKAGE__) {
($val, $class) = ($$val, __PACKAGE__);
}
bless \$val => $class;
}
use overload
# overload numeric coercion
'0+' => sub { ${ $_[0] } },
# overload addition. Take care to dereference to avoid infinite loops.
'+' => sub {
my ($self, $other) = #_;
Ops->new($$self + $other);
},
# overload numeric comparision. Take care to swap the args if neccessary.
'<=>' => sub {
my ($self, $other, $swapped) = #_;
(my $val, $other) = $swapped ? ($other, $$self) : ($$self, $other);
Ops->new($val <=> $other);
}
}
my $ops1 = Ops->new( 15);
my $ops2 = Ops->new(150);
# some tests
ok( ($ops1 <=> 15) == 0, "compare to self" );
ok( ($ops1 <=> 20) < 0, "compare to larger");
ok( ($ops1 + (5)) == 20, "add");
ok( $ops1 == 15, "value");
ok( ($ops2 <=> $ops1) > 0, "compare to smaller value");
done_testing;
do it like this:
our $last;
sub compare
{
my ($x, $y) = #_;
if( $x > $y )
{
print("$x is greater than $y\n");
}
elsif( $x == $y )
{
print("$x is equal to $y\n");
}
else
{
print("$x is less than $y\n");
}
$last = ($x, $y);
};
my $lastValues = compare(3, 4); # pass numbers which you want to compare instead of 3 and 4
print("last compared value = $lastValues");
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.