I have an array that may or may not look like [0, 1] and I want to test for that.
This code (inside a method) works:
sub some_other_method {
my $self = shift;
...
if (scalar #myArray == 2 && #myArray[0] == 0 && #myArray[1] == 1) {
# this will successfully catch arrays that look like [0, 1]
}
}
If I move the contents of the if into a separate method and then call it, it doesn't work.
sub is_warning {
my $self = shift;
my #array = shift;
return scalar #array == 2 && #array[0] == 0 && #array[1] == 1;
}
...
sub some_other_method {
my $self = shift;
...
if ($self->is_warning(#myArray)) {
# this will not catch arrays that look like [0, 1]
}
}
If I add a print #array; to is_warning, it just prints a single number.
What am I doing wrong?
You've missed something crucial about Perl - a subroutine is only ever passed a list of scalar values in #_. So to pass an array, you need to use one of the techniques in subroutines stuff and other below.
#!/usr/bin/env perl
use strict;
use warnings;
use Data::Dumper;
sub stuff {
my ( $arg, #other_args ) = #_;
print Dumper \#other_args;
print "$_\n" for #other_args;
}
sub other {
my ( $arg, $array_ref ) = #_;
print Dumper $array_ref;
print "$_\n" for #$array_ref;
}
my $param = "fish";
my #array = ( "wiggle", "wobble", "boo" );
stuff( $param, #array );
other( $param, \#array );
In stuff the subroutine is handed a list of values to do with what it will. In the other, it's given two values - $param and a reference to #array.
The reason you're only getting 1 in your case, is that shift is only pulling a single value off #_. So any extra arguments are getting left behind. You'll be able to see this with;
print Dumper \#_;
Please remove the my $self = shift; line from is_warning function and test it again.
Please try below script:
#!/usr/bin/perl
use Data::Dumper;
sub is_warning {
my #array = #_;
print Dumper \#_;
return scalar #array == 2 && #array[0] == 0 && #array[1] == 1;
}
sub some_other_method {
my #myArray = (0,1);
if (is_warning(#myArray)) {
print "\nif inside some : #myArray\n";
}
}
some_other_method();
Related
Say I have a number, $x = 0; and I want to increment it with a subroutine, but the subroutine won't be returning its value:
sub increment {
my ($var) = #_;
my #list = (
'a',
'b',
'c',
...
'x',
'y',
'z'
);
return $list[$var++];
}
while ($x < 10) {
print increment($x);
}
As-is, this will print aaaaaaaaaa forever instead of abcdefghij. If I replace increment($x) with increment(\$x), it converts the scalar address to a decimal number and increments that instead. In the above scenario, it ends up throwing an error because 25423331 or whatever isn't a valid array element.
If $x were an element in a hash or an array, I could pass the parent as a reference to have the original modified:
$x = {'val' => 0};
while ($x->{'val'} < 10) {
print increment($x);
}
sub increment {
...
return $list[$var->{$val}++];
}
How can I modify the original value of a scalar reference?
You can pass a reference to the variable to modify.
sub increment {
my ($ref) = #_;
++$$ref;
}
my $i = 0;
say $i; # prints 0
increment(\$i);
say $i; # prints 1
You could also take advantage of the fact that Perl passes by reference.
sub increment {
++$_[0];
}
my $i = 0;
say $i; # prints 0
increment($i);
say $i; # prints 1
But hiding the increment as such is a really bad idea. Either iterate over a list,
for my $x ('a'..'z') {
...
}
Or write an iterator.
sub make_iter {
my #list = #_;
return sub {
return #list ? shift(#list) : ();
};
}
my $iter = make_iter('a'..'z');
while (my ($x) = $iter->()) {
...
}
You need to dereference $var inside the subroutine, like this:
my $x = 0;
say $x; # prints 0
foo(\$x);
say $x; # prints 1
sub foo {
my $y = shift;
$$y++;
}
As an exercise, I'm trying to implement a stack to calculate postfix expressions.
use strict;
use warnings;
use Scalar::Util qw(looks_like_number);
my %operators = (
'+' => \&sum,
'-' => \&subs,
'*' => \&mul,
'/' => \&div,
);
print 'Enter an expression to evaluate : ';
chomp($_ = <STDIN>);
my #lettres=split(//);
my #stack;
for(my $i = 0; $i < #lettres; $i++){
if(looks_like_number($lettres[$i])){
unshift #stack, $lettres[$i];
} else {
my $nb1 = shift #stack;
my $nb2 = shift #stack;
unshift #stack, $operators{$lettres[$i]}->($nb1,$nb2);
}
}
print 'Answer : ' .shift #stack;
sub sum { return $_[0] + $_[1];}
sub mul { return $_[0] * $_[1];}
sub subs { return $_[0] - $_[1];}
sub div { return $_[0] / $_[1];}
When running it, I got:
Can't use an undefined value as a subroutine reference at polonaise.pl line 25,
<STDIN> line 1.
Line 25 is:
unshift #stack, $operators{$lettres[$i]}->($nb1,$nb2);
I suspect that $operators{$lettres[$i]}->($nb1,$nb2); is causing the issue but I don't know why since I begin with Perl.
Why this happens and how can I fix that?
First, only consider as valid tokens sequences of non-space characters. Second, if a token doesn't look like a number, make sure a handler exists in the %operators hash. I find push and pop more natural when dealing with a stack, but that doesn't really matter;
#!/usr/bin/env perl
use strict;
use warnings;
# Turn on autoflush
local $| = 1;
use Scalar::Util qw(looks_like_number);
my %operators = (
'+' => \&add,
'-' => \&subtract,
'*' => \&multiply,
'/' => \÷,
);
print 'Enter an expression to evaluate : ';
my $input = <STDIN>;
my #tokens = split ' ', $input;
my #stack;
for my $token (#tokens) {
if (looks_like_number($token)) {
push #stack, $token;
}
else {
if (exists $operators{$token}) {
my $op = $operators{$token};
my $x = pop #stack;
my $y = pop #stack;
push #stack, $op->($x, $y);
}
else {
warn "Unknown token '$token'\n";
}
}
}
print "Answer: $stack[-1]\n";
sub add { $_[0] + $_[1];}
sub multiply { $_[0] * $_[1];}
sub subtract { $_[0] - $_[1];}
sub divide { $_[0] / $_[1];}
use strict;
sub main {
print shift;
nested(#_);
}
sub nested {
print shift;
deep(#_);
}
sub deep {
print shift;
}
my #list = qw(main nested deep);
main(#list);
How to get this "stair-step" output:
>main
>>nested
>>>deep
Note functions main, nested and deep - required and may be call over and over in different variations
I'd generally pass around an indentation string, along these lines:
use strict;
sub main {
my ($strings, $indent) = #_;
$indent = "" unless defined $indent;
print $indent, shift(#$strings), "\n";
nested($strings, $indent."\t");
}
sub nested {
my ($strings, $indent) = #_;
$indent = "" unless defined $indent;
print $indent, shift(#$strings), "\n";
deep($strings, $indent."\t");
}
sub deep {
my ($strings, $indent) = #_;
$indent = "" unless defined $indent;
print $indent, shift(#$strings), "\n";
}
my #list = qw(main nested deep);
main(\#list);
A similar technique is to pass around an indent level as an integer, incrementing it as needed:
use strict;
sub main {
my ($strings, $indent) = #_;
$indent = 0 unless defined $indent;
print "\t" x $indent, shift(#$strings), "\n";
nested($strings, $indent+1);
}
sub nested {
my ($strings, $indent) = #_;
$indent = 0 unless defined $indent;
print "\t" x $indent, shift(#$strings), "\n";
deep($strings, $indent+1);
}
sub deep {
my ($strings, $indent) = #_;
$indent = 0 unless defined $indent;
print "\t" x $indent, shift(#$strings), "\n";
}
my #list = qw(main nested deep);
main(\#list);
It looks like your array is a list of subroutine names that you want to be called in order. To do that you need to disable strict 'refs' temporarily. This example demonstrates.
Note that the code for all three subroutines is identical. Presumably you will want to put something between the print trace output and the call to the next subroutine in the list the differentiates the three blocks of code.
I have written it so that the number of preceding angle brackets is passed as the second parameter to the subroutines, and defaults to 1 if no value was passed (for the initial call of the sequence).
use strict;
use warnings;
my #list = qw(main nested main deep nested);
main(\#list);
sub main {
my ($list, $indent) = (#_, 1);
my $name = shift #$list;
print '>' x $indent, $name, "\n";
no strict 'refs';
&{$list->[0]}($list, $indent + 1) if #$list;
}
sub nested {
my ($list, $indent) = (#_, 1);
my $name = shift #$list;
print '>' x $indent, $name, "\n";
no strict 'refs';
&{$list->[0]}($list, $indent + 1) if #$list;
}
sub deep {
my ($list, $indent) = (#_, 1);
my $name = shift #$list;
print '>' x $indent, $name, "\n";
no strict 'refs';
&{$list->[0]}($list, $indent + 1) if #$list;
}
output
>main
>>nested
>>>main
>>>>deep
>>>>>nested
Here's a way to maintain the indent level in it's own state:
sub decorator {
my $string = +shift;
my $level = 0;
return sub { $string x ++$level }
}
my $steps = decorator( '>' ); # Each time $steps->() is called
# the indent level increases
print $steps->(), $_, "\n" for qw( main deep nested );
Given a typeglob, how can I find which types are actually defined?
In my application, we user PERL as a simple configuration format.
I'd like to require() the user config file, then be able to see which variables are defined, as well as what types they are.
Code: (questionable quality advisory)
#!/usr/bin/env perl
use strict;
use warnings;
my %before = %main::;
require "/path/to/my.config";
my %after = %main::;
foreach my $key (sort keys %after) {
next if exists $before{$symbol};
local *myglob = $after{$symbol};
#the SCALAR glob is always defined, so we check the value instead
if ( defined ${ *myglob{SCALAR} } ) {
my $val = ${ *myglob{SCALAR} };
print "\$$symbol = '".$val."'\n" ;
}
if ( defined *myglob{ARRAY} ) {
my #val = #{ *myglob{ARRAY} };
print "\#$symbol = ( '". join("', '", #val) . "' )\n" ;
}
if ( defined *myglob{HASH} ) {
my %val = %{ *myglob{HASH} };
print "\%$symbol = ( ";
while( my ($key, $val) = each %val ) {
print "$key=>'$val', ";
}
print ")\n" ;
}
}
my.config:
#A = ( a, b, c );
%B = ( b=>'bee' );
$C = 'see';
output:
#A = ( 'a', 'b', 'c' )
%B = ( b=>'bee', )
$C = 'see'
$_<my.config = 'my.config'
In the fully general case, you can't do what you want thanks to the following excerpt from perlref:
*foo{THING} returns undef if that particular THING hasn't been used yet, except in the case of scalars. *foo{SCALAR} returns a reference to an anonymous scalar if $foo hasn't been used yet. This might change in a future release.
But if you're willing to accept the restriction that any scalar must have a defined value to be detected, then you might use code such as
#! /usr/bin/perl
use strict;
use warnings;
open my $fh, "<", \$_; # get DynaLoader out of the way
my %before = %main::;
require "my.config";
my %after = %main::;
foreach my $name (sort keys %after) {
unless (exists $before{$name}) {
no strict 'refs';
my $glob = $after{$name};
print "\$$name\n" if defined ${ *{$glob}{SCALAR} };
print "\#$name\n" if defined *{$glob}{ARRAY};
print "%$name\n" if defined *{$glob}{HASH};
print "&$name\n" if defined *{$glob}{CODE};
print "$name (format)\n" if defined *{$glob}{FORMAT};
print "$name (filehandle)\n" if defined *{$glob}{IO};
}
}
will get you there.
With my.config of
$JACKPOT = 3_756_788;
$YOU_CANT_SEE_ME = undef;
#OPTIONS = qw/ apple cherries bar orange lemon /;
%CREDITS = (1 => 1, 5 => 6, 10 => 15);
sub is_jackpot {
local $" = ""; # " fix Stack Overflow highlighting
"#_[0,1,2]" eq "barbarbar";
}
open FH, "<", \$JACKPOT;
format WinMessage =
You win!
.
the output is
%CREDITS
FH (filehandle)
$JACKPOT
#OPTIONS
WinMessage (format)
&is_jackpot
Printing the names takes a little work, but we can use the Data::Dumper module to take part of the burden. The front matter is similar:
#! /usr/bin/perl
use warnings;
use strict;
use Data::Dumper;
sub _dump {
my($ref) = #_;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Terse = 1;
scalar Dumper $ref;
}
open my $fh, "<", \$_; # get DynaLoader out of the way
my %before = %main::;
require "my.config";
my %after = %main::;
We need to dump the various slots slightly differently and in each case remove the trappings of references:
my %dump = (
SCALAR => sub {
my($ref,$name) = #_;
return unless defined $$ref;
"\$$name = " . substr _dump($ref), 1;
},
ARRAY => sub {
my($ref,$name) = #_;
return unless defined $ref;
for ("\#$name = " . _dump $ref) {
s/= \[/= (/;
s/\]$/)/;
return $_;
}
},
HASH => sub {
my($ref,$name) = #_;
return unless defined $ref;
for ("%$name = " . _dump $ref) {
s/= \{/= (/;
s/\}$/)/;
return $_;
}
},
);
Finally, we loop over the set-difference between %before and %after:
foreach my $name (sort keys %after) {
unless (exists $before{$name}) {
no strict 'refs';
my $glob = $after{$name};
foreach my $slot (keys %dump) {
my $var = $dump{$slot}(*{$glob}{$slot},$name);
print $var, "\n" if defined $var;
}
}
}
Using the my.config from your question, the output is
$ ./prog.pl
#A = ('a','b','c')
%B = ('b' => 'bee')
$C = 'see'
Working code using a CPAN module that gets some of the hair out of the way, Package::Stash. As noted in my comment to gbacon's answer, this is blind to the config file doing $someval = undef but that seems to be unavoidable, and at least the other cases are caught. It also limits itself to the SCALAR, ARRAY, HASH, CODE, and IO types -- getting GLOB and FORMAT is possible but it makes the code less pretty and also creates noise in the output :)
#!perl
use strict;
use warnings;
use Package::Stash;
sub all_vars_in {
my ($package) = #_;
my #ret;
my $stash = Package::Stash->new($package);
for my $sym ($stash->list_all_package_symbols) {
for my $sigil (qw($ # % &), '') {
my $fullsym = "$sigil$sym";
push #ret, $fullsym if $stash->has_package_symbol($fullsym);
}
}
#ret;
}
my %before;
$before{$_} ++ for all_vars_in('main');
require "my.config";
for my $var (all_vars_in('main')) {
print "$var\n" unless exists $before{$var};
}
Beginning in 5.010, you can distinguish whether a SCALAR exists using the B introspection module; see Detecting declared package variables in perl
Update: example copied from that answer:
# package main;
our $f;
sub f {}
sub g {}
use B;
use 5.010;
if ( ${ B::svref_2object(\*f)->SV } ) {
say "f: Thar be a scalar tharrr!";
}
if ( ${ B::svref_2object(\*g)->SV } ) {
say "g: Thar be a scalar tharrr!";
}
1;
UPDATE:
gbacon is right. *glob{SCALAR} is defined.
Here is the output I get using your code:
Name "main::glob" used only once:
possible typo at
test_glob_foo_thing.pl line 13.
'FOO1' (SCALAR)
'FOO1' (GLOB)
'FOO2' (SCALAR)
'FOO2' (GLOB)
'_<my.config' (SCALAR)
'_<my.config' (GLOB)
This is despite FOO2 being defined as a hash, but not as a scalar.
ORIGINAL ANSWER:
If I understand you correctly, you simply need to use the defined built-in.
#!/usr/bin/env perl
use strict;
use warnings;
my %before = %main::;
require "/path/to/my.config";
my %after = %main::;
foreach my $key (sort keys %after) {
if (not exists $before{$key}) {
if(defined($after{$key}){
my $val = $after{$key};
my $what = ref($val);
print "'$key' ($what)\n";
}
}
}
I hate to ask, but instead of messing around with typeglobs, why not switch to a real configuration format? e.g. check out Config::Simple and YAML.
I wouldn't recommend messing around with typeglobs and symbol tables in normal cases (some CPAN modules do that, but only at the bottom levels of large systems - e.g. Moose in the lowest levels of Class::MOP). Perl gives you a lot of rope to work with, but that rope is also quite happy to self-noosify and self-tie-around-your-neck if you're not careful :)
See also: How do you manage configuration files in Perl?
no strict 'refs';
my $func_name = 'myfunc';
*{$func_name}{CODE}()
use strict 'refs';
If you don't mind parsing Data::Dump output, you could use it to tease out the differences.
use strict;
use warnings;
use Data::Dump qw{ dump };
my %before = %main::;
require "my.config";
my %after = %main::;
foreach my $key ( sort keys %after ) {
if ( not exists $before{$key} ) {
my $glob = $after{$key};
print "'$key' " . dump( $glob) . "\n";
}
}
Using this code with the following config file:
$FOO1 = 3;
$FOO2 = 'my_scalar';
%FOO2 = ( a=>'b', c=>'d' );
#FOO3 = ( 1 .. 5);
$FOO4 = [ 1 .. 5 ];
I believe that this output provides enough information to be able to figure out which parts of each type glob are defined:
'FOO1' do {
my $a = *main::FOO1;
$a = \3;
$a;
}
'FOO2' do {
my $a = *main::FOO2;
$a = \"my_scalar";
$a = { a => "b", c => "d" };
$a;
}
'FOO3' do {
my $a = *main::FOO3;
$a = [1 .. 5];
$a;
}
'FOO4' do {
my $a = *main::FOO4;
$a = \[1 .. 5];
$a;
}
'_<my.config' do {
my $a = *main::_<my.config;
$a = \"my.config";
$a;
}
I have an array #test. What's the best way to check if each element of the array is the same string?
I know I can do it with a foreach loop but is there a better way to do this? I checked out the map function but I'm not sure if that's what I need.
If the string is known, you can use grep in scalar context:
if (#test == grep { $_ eq $string } #test) {
# all equal
}
Otherwise, use a hash:
my %string = map { $_, 1 } #test;
if (keys %string == 1) {
# all equal
}
or a shorter version:
if (keys %{{ map {$_, 1} #test }} == 1) {
# all equal
}
NOTE: The undefined value behaves like the empty string ("") when used as a string in Perl. Therefore, the checks will return true if the array contains only empty strings and undefs.
Here's a solution that takes this into account:
my $is_equal = 0;
my $string = $test[0]; # the first element
for my $i (0..$#test) {
last unless defined $string == defined $test[$i];
last if defined $test[$i] && $test[$i] ne $string;
$is_equal = 1 if $i == $#test;
}
Both methods in the accepted post give you the wrong answer if #test = (undef, ''). That is, they declare an undefined value to be equal to the empty string.
That might be acceptable. In addition, using grep goes through all elements of the array even if a mismatch is found early on and using the hash more than doubles the memory used by elements of array. Neither of these would be a problem if you have small arrays. And, grep is likely to be fast enough for reasonable list sizes.
However, here is an alternative that 1) returns false for (undef, '') and (undef, 0), 2) does not increase the memory footprint of your program and 3) short-circuits as soon as a mismatch is found:
#!/usr/bin/perl
use strict; use warnings;
# Returns true for an empty array as there exist
# no elements of an empty set that are different
# than each other (see
# http://en.wikipedia.org/wiki/Vacuous_truth)
sub all_the_same {
my ($ref) = #_;
return 1 unless #$ref;
my $cmpv = \ $ref->[-1];
for my $i (0 .. $#$ref - 1) {
my $this = \ $ref->[$i];
return unless defined $$cmpv == defined $$this;
return if defined $$this
and ( $$cmpv ne $$this );
}
return 1;
}
However, using List::MoreUtils::first_index is likely to be faster:
use List::MoreUtils qw( first_index );
sub all_the_same {
my ($ref) = #_;
my $first = \ $ref->[0];
return -1 == first_index {
(defined $$first != defined)
or (defined and $_ ne $$first)
} #$ref;
}
TIMTOWTDI, and I've been reading a lot of Mark Jason Dominus lately.
use strict;
use warnings;
sub all_the_same {
my $ref = shift;
return 1 unless #$ref;
my $cmp = $ref->[0];
my $equal = defined $cmp ?
sub { defined($_[0]) and $_[0] eq $cmp } :
sub { not defined $_[0] };
for my $v (#$ref){
return 0 unless $equal->($v);
}
return 1;
}
my #tests = (
[ qw(foo foo foo) ],
[ '', '', ''],
[ undef, undef, undef ],
[ qw(foo foo bar) ],
[ '', undef ],
[ undef, '' ]
);
for my $i (0 .. $#tests){
print "$i. ", all_the_same($tests[$i]) ? 'equal' : '', "\n";
}
You can check how many times the element in the array (#test) is repeated by counting it in a hash (%seen). You can check how many keys ($size) are present in the hash (%seen). If more than 1 key is present, you know that the elements in the array are not identical.
sub all_the_same {
my #test = #_;
my %seen;
foreach my $item (#test){
$seen{$item}++
}
my $size = keys %seen;
if ($size == 1){
return 1;
}
else{
return 0;
}
}
I think, we can use List::MoreUtils qw(uniq)
my #uniq_array = uniq #array;
my $array_length = #uniq_array;
$array_length == 1 ? return 1 : return 0;
I use List::Util::first for all similar purposes.
# try #0: $ok = !first { $_ ne $string } #test;
# try #1: $ok = !first { (defined $_ != defined $string) || !/\A\Q$string\E\z/ } #test;
# final solution
use List::Util 'first';
my $str = shift #test;
my $ok = !first { defined $$_ != defined $str || defined $str && $$_ ne $str } map \$_, #test;
I used map \$_, #test here to avoid problems with values that evaluate to false.
Note. As cjm noted fairly, using map defeats the advantage of first short-circuiting. So I tip my hat to Sinan with his first_index solution.