I'm trying to wrap my head around perl. It's different enough from what I'm used too (.Net mainly, but C/C++/php/javascript) that some things just aren't "grepping" for me.
I'm working through a book that has some exercises. One of the exercises involves practice coercing scalars into Boolean - Undef and Zeros = false, others = true.
Taking the question, some previous code examples and a desire to pull functions out of repeated code... I'm sitting with this function:
# Which of the following evaluates to true?
use strict;
use warnings;
use diagnostics;
sub check1 {
my #args = #_;
if ($args[0]) {
return "true";
} else {
return "false";
}
}
sub check2 {
my #args = #_;
if ($args[0]) {
print "$args[1] = true\n";
} else {
print "$args[1] = false\n";
}
}
# false (zero or undef)
my $def1 = undef; check2($def1, 'def1');
my $def3 = 0.0; check2($def3, 'def3');
my $def5 = 0; check2($def5, 'def5');
# true (not zero and not undef)
my $def2 = ' '; check2($def2, 'def2');
my $def4 = '0.0'; check2($def4, 'def4');
my $def6 = 'false';check2($def6, 'def6');
my $def7 = 1/0; check2($def7, 'def7');
#as suggested by TheSuitIsBlackNot
my $foo = 0.0; print '$foo = ', check1($foo), "\n";
My question is: Is there a way to remove the duplicate parameter? such that the check function can pull the name of the parameter instead of saying $def1, "def1"?
The solution isn't to get the name of the variable; the solution is to eliminate the variable.
sub check {
my ($name, $value, $expected) = #_;
my $got = $value ? 'true' : 'false';
print("$name is $got. Expected $expected.\n");
}
my #tests = (
[ 'def1', undef, 'false' ],
[ 'def3', 0.0, 'false' ],
[ 'def5', 0, 'false' ],
[ 'def2', ' ', 'true' ],
[ 'def4', '0.0', 'true' ],
[ 'def6', 'false', 'true' ],
);
check(#$_) for #tests;
Related
I am writing a script to solve very basic systems of equations. I convert the equations into binary expression trees, isolate the variable that I want the value of, and then do substitutions.
This is where I have a problem, I have a function "substitution" that walks the binary expression tree of the left side of the equation I want substituted. And when I found the variable to be substituted, I replace the node with the expression tree of another equation.
But when I try to return the new tree, my susbstitution is not there.
It is obviously a pass-by-reference / pass-by-value problem but I cannot find the way to solve it.
Here's a side script that shows the part which doesn't work:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
sub inorder {
my $expression = shift;
my $node = $expression;
if ($node->{type} eq "operator") {
print "(";
inorder($node->{left});
print $node->{value};
inorder($node->{right});
print ")";
}
else {
print $node->{value};
}
}
sub substitution {
my ($inserted_equation, $master_equation) = #_;
my $inserted_expression = $inserted_equation->{right_side};
my $insertion_point = $inserted_equation->{left_side}->{value};
my $master_expression = $master_equation->{right_side};
my #stack_tree_walk;
my $node = $master_expression;
push #stack_tree_walk, {$node->%*, left_visited => 0, side=> "left"};
while(#stack_tree_walk) {
if ($node->{type} eq "variable" and $node->{value} eq $insertion_point) {
foreach (#stack_tree_walk) {
}
# print $node->{value};
# print Dumper $inserted_expression;
$node = $inserted_expression; # WORKS
# print Dumper $node; # WORKS
# print Dumper $master_expression; # DOES NOT WORK
pop #stack_tree_walk;
$node = $stack_tree_walk[-1];
}
elsif ($node->{type} eq "operator") {
if (not $stack_tree_walk[-1]->{left_visited}) {
$stack_tree_walk[-1]->{left_visited} = 1;
$node = $node->{left};
push #stack_tree_walk, {$node->%*, left_visited => 0, side=> "left"};
}
elsif ($node->{side} eq "left") {
$node = $node->{right};
$stack_tree_walk[-1]->{side} = "right";
push #stack_tree_walk, {$node->%*, left_visited => 0, side=> "left"};
}
else {
pop #stack_tree_walk;
$node = $stack_tree_walk[-1];
}
}
else {
pop #stack_tree_walk;
$node = $stack_tree_walk[-1];
}
}
return {right_side=>$master_expression, left_side=>$master_equation->{left_side}};
}
my $equation = {left_side => { type=> "variable",
value=> "y"},
right_side=> { type=> "operator",
value=> "*",
left=> {type=> "variable", value=> "a"},
right=> {type=> "variable", value=> "b"} }
};
my $insertion = {left_side => { type=> "variable" ,
value=> "a" },
right_side=> { type=> "operator",
value=> "+",
left=> {type=> "variable", value=> "x"},
right=> {type=> "variable", value=> "y"} }
};
$,="";
$\="";
print "equations before substitution\n";
inorder($equation->{left_side});
print "=";
inorder($equation->{right_side});
print "\n";
inorder($insertion->{left_side});
print "=";
inorder($insertion->{right_side});
print "\n";
print "------------------\n";
$,="\n";
$\="\n\n";
my $final = substitution($insertion, $equation);
$,="";
$\="";
print "------------------\n";
print "equation substituted\n";
inorder($final->{left_side});
print "=";
inorder($final->{right_side});
print "\n";
Here is the OUPUT:
equations before substitution
y=(a*b)
a=(x+y)
equation substituted
y=(a*b) <==== this is the ERROR
y=((x+y)*b) <==== this should be the RIGHT result
I hope someone can show me which part is wrong.
Thank you.
$node is a essentially a pointer into the structure. Your code simply sets $node to a different pointer, i.e. $inserted_expression. You don't change the structure this way, you only change a local variable $node to point to different things. Basically you does this:
$struct = { foo => { bar => 1 } };
$node = $struct->{foo}; # points at { bar => 1 } in $struct
$node = { bar => 2 } # points at { bar => 2 } and not longer into $struct
print(Dumper($struct)); # unchanged
If you want to change the value you in the struct you need to take a reference to the value and not just take the value, i.e.
$struct = { foo => { bar => 1 } };
$node = \$struct->{foo}; # reference to value of { foo => ... }, currently { bar => 1 }
$$node = { bar => 2 } # changes value of { foo => ... } to { bar => 2 }
print(Dumper($struct)); # changed
First timer...so let me know if there is anything that I have not paid attention to whilst posing a question.
The question is how to use a scalar as a condition, as the code below does not work.
my #parameter=('hub');
my %condition;
$condition{'hub'}{'1'}='$degree>=5';
foreach (#parameter) {
if ($condition{$_}{'1'}) {..}
}
I thought that is because the condition is not interpreted correctly, so I also tried the following, which also did not work.
if ("$condition{$parameter}{'1'}") { ..}
Would really appreciate any help. :)
You either want string eval, which evaluates a string as Perl code
if (eval $condition{$_}{'1'}) { ...
or perhaps a more secure approach would be using code references
$condition{'hub'}{'1'} = sub { return $degree>=5 };
if ($condition{$_}{'1'}->()) { ...
In the second example, you are attaching a piece of code to a variable. The $var->() syntax executes the code and evaluates to the return value of the code.
What you are trying to do is to evaluate '$degree>=5' as real code. Rather than trying to evaluate the string as code (which can be done with eval), it's usually safer and often more robust to instead pass a code-reference. You can use a generator subroutine to generate conditional subs on demand, like this:
sub generate_condition {
my ( $test, $bound ) = #_;
return sub { return $test >= $bound; };
}
my %condition;
$condition{'hub'}{'1'} = generate_condition( $degree, 5 );
if( $condition{$parameter}{1}->() ) { ... }
It gets a little more tricky if you want the >= (ie, the relationship itself) to be dynamically created as well. Then you have a couple of choices. One takes you back to stringy eval, with all of its risks (especially if you start letting your user specify the string). The another would be a lookup table within your generate_condition() sub.
generate_condition() returns a subroutine reference that when invoked, will evaluate the condition that was bound in at creation time.
Here's a generalized solution that will accept any of Perl's conditionals and wrap them along with the arguments being tested into a subroutine. The subref can then be invoked to evaluate the conditional:
use strict;
use warnings;
use feature qw/state/;
sub generate_condition {
my ( $test, $relation, $bound ) = #_;
die "Bad relationship\n"
if ! $relation =~ m/^(?:<=?|>=?|==|l[te]|g[te]|cmp)$/;
state $relationships = {
'<' => sub { return $test < $bound },
'<=' => sub { return $test <= $bound },
'==' => sub { return $test == $bound },
'>=' => sub { return $test >= $bound },
'>' => sub { return $test > $bound },
'<=>' => sub { return $test <=> $bound },
'lt' => sub { return $test lt $bound },
'le' => sub { return $test le $bound },
'eq' => sub { return $test eq $bound },
'ge' => sub { return $test ge $bound },
'gt' => sub { return $test gt $bound },
'cmp' => sub { return $test cmp $bound },
};
return $relationships->{$relation};
}
my $true_condition = generate_condition( 10, '>', 5 );
my $false_condition = generate_condition( 'flower', 'eq', 'stamp' );
print '10 is greater than 5: ',
$true_condition->() ? "true\n" : "false\n";
print '"flower" is equal to "stamp": ',
$false_condition->() ? "true\n" : "false\n";
Often when you construct these sorts of things one is interested in leaving one parameter open to bind at call-time rather than at subroutine manufacture-time. Let's say you only want to bind the "$bound" and "$relation" parameters, but leave "$test" open for specification at subroutine call time. You would modify your sub generation like this:
sub generate_condition {
my ( $relation, $bound ) = #_;
die "Bad relationship\n"
if ! $relation =~ m/^(?:<=?|>=?|==|l[te]|g[te]|cmp)$/;
state $relationships = {
'<' => sub { return $_[0] < $bound },
# ......
And then invoke it like this:
my $condition = generate_condition( '<', 5 );
if( $condition->(2) ) {
print "Yes, 2 is less than 5\n";
}
If the goal is to provide late binding of both the lefthand and righthand side in the relational evaluation, this will work:
sub generate_condition {
my $relation = shift;
die "Bad relationship\n"
if ! $relation =~ m/^(?:<=?|>=?|==|l[te]|g[te]|cmp)$/;
state $relationships = {
'<' => sub { return $_[0] < $_[1] },
'<=' => sub { return $_[0] <= $_[1] },
# ...... and so on .....
return $relationship->($relation);
}
my $condition = generate_condition( '<' );
if( $condition->(2,10) ) { print "True.\n"; }
This sort of tool falls into the category of functional programming, and is covered in beautiful detail in Mark Jason Dominus's book Higher Order Perl
What are you expecting? String values are interpreted as true when they are nonempty.
themel#kallisti: ~ $ perl -e 'print "oops\n" if "false" ; '
oops
themel#kallisti: ~ $ perl -e 'print "oops\n" if "" ; '
themel#kallisti: ~ $ perl -e 'print "oops\n" if "\$degree < 5" ;'
oops
If you want to dynamically evaluate code in your conditions, you have to investigate eval. Example:
my #conds=('$foo>42', '$foo>23');
my $foo = 33;
foreach my $cond(#conds) {
print "$cond itself was true\n" if $cond;
print "$cond evaluated to true\n" if eval($cond);
}
prints
$foo>42 itself was true
$foo>23 itself was true
$foo>23 evaluated to true
This is my problem:
I have a file-system like data-structure:
%fs = (
"home" => {
"test.file" => {
type => "file",
owner => 1000,
content => "Hello World!",
},
},
"etc" => {
"passwd" => {
type => "file",
owner => 0,
content => "testuser:testusershash",
},
"conf" => {
"test.file" => {
type => "file",
owner => 1000,
content => "Hello World!",
},
},
},
);
Now, to get the content of /etc/conf/test.file I need $fs{"etc"}{"conf"}{"test.file"}{"content"}, but my input is an array and looks like this: ("etc","conf","test.file").
So, because the length of the input is varied, I don't know how to access the values of the hash. Any ideas?
You can use a loop. In each step, you proceed one level deeper into the structure.
my #path = qw/etc conf test.file/;
my %result = %fs;
while (#path) {
%result = %{ $result{shift #path} };
}
print $result{content};
You can also use Data::Diver.
my #a = ("etc","conf","test.file");
my $h = \%fs;
while (my $v = shift #a) {
$h = $h->{$v};
}
print $h->{type};
Same logic as what others given, but uses foreach
#keys = qw(etc conf test.file content);
$r = \%fs ;
$r = $r->{$_} foreach (#keys);
print $r;
$pname = '/etc/conf/test.file';
#names = split '/', $pname;
$fh = \%fs;
for (#names) {
$fh = $fh->{"$_"} if $_;
}
print $fh->{'content'};
Path::Class accepts an array. It also gives you an object with helper methods and handles cross platform slash issues.
https://metacpan.org/module/Path::Class
You can just build the hash element expression and call eval. This is tidier if it is wrapped in a subroutine
my #path = qw/ etc conf test.file /;
print hash_at(\%fs, \#path)->{content}, "\n";
sub hash_at {
my ($hash, $path) = #_;
$path = sprintf q($hash->{'%s'}), join q('}{'), #$path;
return eval $path;
}
I have a code like this:
use Data::Dumper;
my %hash = (
'chrX' => {
'b' => [
'-51811268 210',
'-51810794 350',
'-51809935 298'
],
'f' => [
'51929018 210',
'51929492 350',
'51930351 298'
]
}
);
foreach my $cnam ( keys %hash ) {
my #lpos_f = ();
my #lpos_b = ();
if ( $hash{$cnam}{"f"} ) {
#lpos_f = #{ $hash{$cnam}{"f"} };
print "+\n";
print Dumper \#lpos_f;
}
elsif ( $hash{$cnam}{"b"} ) {
#lpos_b = #{ $hash{$cnam}{"b"} };
print "-\n";
print Dumper \#lpos_b;
}
}
Why it didn't give print output in each ELSIF condition such
that it gives both these.
+
[
'51929018 210',
'51929492 350',
'51930351 298'
];
-
['-51811268 210',
'-51810794 350',
'-51809935 298'
];
Currently It only gives "+" output
Because %temp is not %hash. use strict would have told you.
Moreover, you cannot get both of if / else. Either the condition is true and you get the first part, or it is not and you get the else part. (With elsif, the second condition might be not true as well and you get nothing).
I am using Perl, and I need to determine if two arithmetic expression trees are "equal". By equal, I mean the shape of the trees are equal, not the particular values held within. So, for instance [ 'internal', '-' [ 'leaf', 5] ['leaf', 4]] is not the same as [ 'internal', 'average', [ 'internal', '+', [ 'leaf', 42], [ 'leaf', 10 ] ], [ 'leaf', 1 ] ], but is the same as [ 'internal', '+' [ 'leaf', 3] ['leaf', 20]]. So, I am simply looking to match the shape. I have a subroutine that I had hoped to be able to do this, but so far, I am unable to make it properly match. Here is the subroutine:
sub isEqualShape {
my ($ex1, $ex2) = #_;
my $node_type = $ex1->[0];
my $node_type2= $ex2->[0];
my $check;
foreach (#$ex1){
if ( $node_type eq 'leaf' && $node_type2 eq 'leaf'){
$check = 1;
}
elsif ($node_type eq 'internal' && $node_type2 eq 'internal'){
$check = 1;
}
else {
$check = 0;
return 0;
last;
}
}
foreach (#$ex2){
if ( $node_type eq 'leaf' && $node_type2 eq 'leaf'){
$check = 1;
}
elsif ($node_type eq 'internal' && $node_type2 eq 'internal'){
$check = 1;
}
else {
$check = 0;
return 0;
last;
}
}
return $check;
}
and here is my test file:
my $ex1 = [ 'leaf', 42];
my $ex2 = [ 'internal', '+', [ 'leaf', 42], [ 'leaf', 10 ] ];
my $ex3 = [ 'internal', 'average', $ex2, [ 'leaf', 1 ] ];
my $tree = isEqualShape($ex2, $ex3);
if ($tree eq '1'){
print "Shapes Are Equal\n";
}
else {
print "Shapes Are Not Equal \n";
}
When comparing between ex1 and either ex2 or ex3, this returns Shapes are Not Equal, as it is supposed to. However, it returns shape is equal when comparing either ex2 or ex3. How can I fix this, and maybe make this more generalizable?
Edit: I've also tried using popping from an array, but this results in a reference error (I'm new to the whole reference thing).
sub isEqualShape {
my #array = #_;
my ($ex1, $ex2) = #array;
my $node_type = $ex1->[0];
my $node_type2= $ex2->[0];
my $check;
foreach (#$ex1){
if ( $node_type eq 'leaf' && $node_type2 eq 'leaf'){
$check = 1;
}
elsif ($node_type eq 'internal' && $node_type2 eq 'internal'){
$check = 1;
}
else {
$check = 0;
return 0;
last;
}
}
for (#$ex2){
if ( $node_type eq 'leaf' && $node_type2 eq 'leaf'){
$check = 1;
}
elsif ($node_type eq 'internal' && $node_type2 eq 'internal'){
$check = 1;
}
else {
$check = 0;
return 0;
last;
}
pop #$ex1;
pop #$ex2, isEqualShape(#$ex1, #$ex2);
}
return $check;
}
The result given to me is: Can't use string ('internal') as an ARRAY while 'strict refs' are in use.
How can I fix this?
To determine if the structures are the same shape, you will need to use a recursive algorithm (or an iterative one with a stack).
You don't have many test cases to work with, but this should do the trick:
sub isEqualShape {
my ($x, $y) = #_;
if (#$x == #$y and $$x[0] eq $$y[0]) { # same length and node type
for (2 .. $#$x) {
isEqualShape($$x[$_], $$y[$_]) or return undef; # same child shape
}
return 1;
}
return undef;
}