I am a newbie in newbies for perl. I am trying to create a function which returns the value of the hash. The following piece of code simply returns the last index of the hash. I googled around and couldnt find what i need. Appreciate if anyone can tell me where I am going wrong.
I am expecting, if I pass "he_1", I should get a return back value of 1, etc.. but all I see is 9.
#!/usr/bin/perl
my %IndexMap = ();
my $MAX_V = 5;
my $MAX_T = 10;
sub InitIndexMap {
foreach my $i (0..$MAX_V-1) {
$IndexMap["he_".$i] = $i;
print "he_".$i;
print $IndexMap["he_".$i];
}
foreach my $i ($MAX_V..$MAX_T-1) {
$IndexMap["un".$i] = $i;
print "un".$i;
print $IndexMap["un".$i];
}
}
sub GetVal {
my ($name) = #_;
return $IndexMap[$name];
}
&InitIndexMap();
my ($index) = &Getval("he_4");
print $index;
To read a hash, use curly braces, not brackets. Try this:
sub InitIndexMap {
foreach my $i (0..$MAX_V-1) {
$IndexMap{ "he_" . $i } = $i;
print "he_".$i;
print $IndexMap{ "he_" . $i };
}
foreach my $i ($MAX_V..$MAX_T-1) {
$IndexMap{ "un" . $i } = $i;
print "un".$i;
print $IndexMap{ "un" . $i };
}
}
sub GetVal {
my ( $name ) = #_;
return $IndexMap{ $name };
}
You should add this to the top of the script:
use strict;
use warnings;
The general rule to always turn those pragmas. They warnings and errors that that cause would have probably led you to the answer to your question.
You should access hashes with curly brackets like { and }.
$hash_name{$key} = $value;
In your example.
$IndexMap{"he_".$i} = $i;
You should consider doing some tutorials.
This is VERY BASIC knowledge in Perl.
Related
I'm trying to read a FORTRAN program using Perl, and remove an INCLUDE command and replace it with a USE.
This is working great, except when printing out the contents of the hash storing the existing USE statements, I get an extra entry.
my #lines = ( );
my %uses = { };
foreach $f1line (<>) {
$f1line =~ s/\r[\n]*//g;
if ($f1line =~ /^\s*INCLUDE 'FILE1.CMN'/ ||
$f1line =~ /^\s*INCLUDE 'FILE2.CMN'/ ||
$f1line =~ /^\s*INCLUDE 'FILE3.CMN'/) {
$f1line = " USE My_Mod";
}
if ($f1line =~ /^\s*USE /) {
$uses{$f1line} = 1;
}
push #lines, $f1line . $/;
}
$found = 0;
foreach $line (#lines) {
if ($found == 0 && $line =~ /^\s*USE /) {
foreach my $x (sort(keys(%uses))) {
print $x . $/; # (1)
}
$found = 1;
} elsif ($found == 1 && $line =~ /^\s*USE /) {
next;
} else {
print $line;
}
}
The output is this:
C Include parameters here
USE My_Mod
USE MyOther_Mod
USE EvenAnother_Mod
HASH(0x7f9dc3805ce8)
Where is the HASH(0x...) reference coming from? The only place I'm printing the contents of the hash is on line (1). It almost looks like iterating over the keys of the hash is somehow including the hash itself.
How can I get rid of this?
You are not really having a big problem, the big deal here is that you are not able to see the errors you are doing.
That's why you should always strict and warnings
In your code you start with:
my %uses = { };
When it should be:
my %uses = ();
or
my %uses; #it's fine also
And then it will works.
By using {} in a "hash" context you could create a hashref which is not the case.
A reference to an anonymous hash can be created using curly brackets:
$hashref = {
'Adam' => 'Eve',
'Clyde' => 'Bonnie',
};
Also is a good practice declare your variables in foreach loop like:
foreach my $line (#lines) {
And in the rest of your code.
I am attempting to write a code that will encrypt letters with a basic cyclic shift cipher while leaving any character that is not a letter alone. I am trying to do this through the use of a sub that finds the new value for each of the letters. When I run the code now,it formats the result so there is a single space between every encrypted letter instead of keeping the original formatting. I also cannot get the result to be only in lowercase letters.
sub encrypter {
my $letter = shift #_;
if ($letter =~ m/^[a-zA-Z]/) {
$letter =~ y/N-ZA-Mn-za-m/A-Za-z/;
return $letter;
}
else {
return lc($letter);
}
}
print "Input string to be encrypted: ";
my $input = <STDIN>;
chomp $input;
print "$input # USER INPUT\n";
my #inputArray = split (//, $input);
my $i = 0;
my #encryptedArray;
for ($i = 0; $i <= $#inputArray; $i++) {
$encryptedArray[$i] = encrypter($inputArray[$i]);
}
print "#encryptedArray # OUTPUT\n";
You might try changing this line:
if ($letter = m/[^a-zA-Z]/ ) {
To something more like this:
if ($letter =~ m/^[a-zA-Z]/) {
In the original line you are doing an assignment to the variable $letter, and the ^ will need to be before the [a-zA-Z] for the comparison.
You're attempting to do a rot13 translation on your characters. This can be done a little easier using tr:
use strict;
use warnings;
sub rot13 {
my $string = shift;
$string =~ tr/a-zA-Z/n-zA-Za-m/;
return $string;
}
print "Input string to be encrypted: ";
chomp(my $input = <STDIN>);
print "$input # USER INPUT\n";
print "Cycle of 4:\n";
for (1..4) {
$input = rot13($input);
print " $input\n";
}
Outputs
Input string to be encrypted: asdf
asdf # USER INPUT
Cycle of 4:
nFqs
ASDF
NfQS
asdf
Here is a some kind of more general implementation of it, it is easier to adapt it to something like, for example, using different rotation places for different letter:
#!/usr/bin/perl
use strict;
use warnings;
use feature qw(switch say);
sub rotateBy {
my ($letter, $rotate_places) = #_;
$rotate_places = $rotate_places ? $rotate_places : 13;
my $width = (ord 'z') - (ord 'a') + 1;
sub rotate {
my ($let, $base, $places, $width) = #_;
my $i = (ord $let) - (ord $base);
return chr((ord $base) + ($i + $places) % $width);
}
given ($letter) {
when (m/[a-z]/) {
return rotate ($letter, 'a', $rotate_places, $width);
}
when (m/A-Z/) {
return rotate ($letter, 'A', $rotate_places, $width);
}
default {
return $letter;
}
}
}
while (<>) {
chomp;
print "PLAINTEXT : $_\n";
print "CIPHERTEXT: ";
foreach my $let (split //) {
print rotateBy($let);
}
print "\n";
}
By the way, the above code looks too verbose to me, maybe there is a better way to do it.
Bon,
I have this code which is a simple loop, which works… to call it you need to send it a reference to an array of numbers.
#blah = (0b0010,0b010,0b0111);
$ans = &logical_loop(\#blah);
sub logical_loop()
{
my $codes = $_[0];
my $ans = 0;
foreach (#$codes) {
printf "%b\n",$_;
$ans = ($ans | $_)
}
return($ans);
}
I wanted to make it recursive, so I wrote this code which doesn't work…. please can somebody tell me what I have missed? something to do with variables scopes perhaps?
sub recursive_loop
{
my $codes = $_[0];
my $el = shift #$codes;
if (#$codes == ()) {
return ($el | $answer);
} else {
$answer = (&recursive_loop(\#$codes) | $el);
}
}
sub recursive_loop {
return 0 unless #_;
my $head = shift;
return $head | recursive_loop(#_);
}
#blah = (0b0010,0b010,0b0111);
recursive_loop(#blah);
More efficient tail recursive:
sub or_it_up {
unshift #_, 0;
goto &recursive_loop;
}
sub recursive_loop {
my $ans = shift;
return $ans unless #_;
unshift #_, $ans | shift;
goto &recursive_loop;
}
#blah = (0b0010,0b010,0b0111);
or_it_up(#blah);
You can use calling recursive_loop as function but in this way it will not make stack frame.
You can also write it simply without or_it_up which serves just educational purpose. Calling recursive_loop directly will make result caused by nature of binary or.
I see a few problems with your subroutine.
its name contains a spacing mark
it doesn't call itself therefore no recursion is possible
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.
I'm new to Perl and I understand you can call functions by name, like this:
&$functionName();. However, I'd like to use an array by name. Is this possible?
Long code:
sub print_species_names {
my $species = shift(#_);
my #cats = ("Jeffry", "Owen");
my #dogs = ("Duke", "Lassie");
switch ($species) {
case "cats" {
foreach (#cats) {
print $_ . "\n";
}
}
case "dogs" {
foreach (#dogs) {
print $_ . "\n";
}
}
}
}
Seeking shorter code similar to this:
sub print_species_names {
my $species = shift(#_);
my #cats = ("Jeffry", "Owen");
my #dogs = ("Duke", "Lassie");
foreach (#<$species>) {
print $_ . "\n";
}
}
Possible? Yes. Recommended? No. In general, using symbolic references is bad practice. Instead, use a hash to hold your arrays. That way you can look them up by name:
sub print_species_names {
my $species = shift;
my %animals = (
cats => [qw(Jeffry Owen)],
dogs => [qw(Duke Lassie)],
);
if (my $array = $animals{$species}) {
print "$_\n" for #$array
}
else {
die "species '$species' not found"
}
}
If you want to reduce that even more, you could replace the if/else block with:
print "$_\n" for #{ $animals{$species}
or die "species $species not found" };
You can achieve something close by using a hash of array references:
%hash = ( 'cats' => [ "Jeffry", "Owen"],
'dogs' => [ "Duke", "Lassie" ] );
$arrayRef = $hash{cats};
You could also use eval here:
foreach (eval("#$species")) {
print $_ . "\n";
}
I should have made it clear that you need to turn off strict refs for this to work. So surrounding the code with use "nostrict" and use "strict" works.
This is whats known as a soft reference in perl.