Unable to print after while loop in perl - perl

BEGIN {
use FindBin;
$scriptsDir = $FindBin::RealBin;
}
sub print_log {
($log, $msg) = ($_[0], $_[1]);
print $log $msg;
}
$opt_rh_gsr = "path_to_file";
open(FO, "$opt_rh_gsr") || die "-F-: Can not open file \n";
while(<FO>) {
if(/vdd_nets/) {
$vdd_net = 1;
$vdd_string = "VDD_NETS \{ \n";
}
if(/gnd_nets/) {
$gnd_net = 1;
}
if(($gnd_net == 1)) {
chomp();
$new_line = $_;
#split_new_line = split(":", $new_line);
}
if(($gnd_net == 1) && /\}/) {
$gnd_net = 0;
$gnd_string .= "\} \n";
exit;
}
if($vdd_net) {
if(/^\s*\S+\s+\S+\s+{/) {
$paren++;
}
if (0 != $paren && /^\s*(\w+)\s*$/) {
$vdd_nets{$1} = $parenvolt;
next;
}
if(/^\s*}\s*$/ || /^\s+$/) {
if (0 == $paren) {
$vdd_net = 0; next;
}
else {
$paren--; next;
}
}
chomp();
if(/\s*\}\s*$/ && ($vdd_net == 1)){
s/\'//g;
$vdd_net = 0;
#_ = split(":");
$vdd_string .= "$_[0] $_[1] \n";
$vdd_string .= "\} \n";
next;
}
if($gnd_net) {
if(/^\s*\}\s+$/ || /^\s+$/) {
$gnd_net = 0;
next;
}
#chomp();
if(/\s*\}\s*$/ && ($gnd_net == 1)){
s/\'//g;
$gnd_net = 0;
}
#_ = split();
$GNDNET = $_[0];
if ($_[0] =~ /^\w+$/) {
$groundnets{$_[0]} = 1;
}
}
}
}
print " done reading \n";
close(FO);
print "closed file \n";
The above is not printing the last 2 print statement (before and after the close of file handle). I tried print STDOUT, that didn't work. I also tried to flush, that didn't work either.
The script is exiting after executing, so it is not stuck in a infinite loop anywhere. I tries using perl5.6 and 5.8, but both of them have the same problem.

To exit a loop, you should use the keyword last instead of exit (which exits the whole program). This if:
if(($gnd_net == 1) && /\}/) {
$gnd_net = 0;
$gnd_string .= "\} \n";
print "exiting loop $gnd_string \n";
exit;
}
Should thus be:
if(($gnd_net == 1) && /\}/) {
$gnd_net = 0;
$gnd_string .= "\} \n";
print "exiting loop $gnd_string \n";
last;
}
(unless you actually wanted to exit the program, in which case the print should rather have been print "exiting program...")
A few tips:
Always add use strict and use warnings at the beginning of your scripts. It will catch many mistakes and save you a lot of time.
Use 3-operand open to open files (ie, open FILEHANDLE,MODE,EXPR instead of open FILEHANDLE,EXPR), and lexical filehandles (ie, $FO instead of FO). Your open should thus have been: open my $FO, '<', $opt_rh_gsr instead of open(FO, "$opt_rh_gsr").
Adding || die "-F-: Can not open file \n" after open is a good idea, but 1) you should do or die instead of || die (in this specific case it doesn't matter, but with or rather than ||, you can omit the parenthesis around open's arguments), and 2) you should add the name of the file you were trying to open (in that case, you'd print die "-F-: Can not open file '$opt_rh_gsr'). 3) add $! to the die to have the error message (die "-F-: Can not open file '$opt_rh_gsr': $!). And 4), as suggested by TLP, don't add a newline at the end of a die string.
sub print_log { ($log, $msg) = ($_[0], $_[1]); ... could have been sub print_log { ($log, $msg) = #_;; it's a bit more idiomatic and concise.
Indent properly your code. It's possible that indentation was lost in the copy-paste, but, if it's not the case, then you should indent better your code. This will save you a lot of time when writing/reading your code, and will save other people even more time when they'll read your code. Most IDEs have indentation features that can help you indent the code.

Related

How do I add variables to be set based on a numeric input in perl?

I am making a score-keeping script in Perl, and would like to have it ask how many players there are, and ask for a name, then score, for each player. I have a good bit of this script done, but only for 3 players. the current script can be found on github here: skore
(from link:)
#!/usr/bin/env perl
use strict;
my $version = "1.0";
my $arg = shift(#ARGV);
my $subname = $arg;
if (!defined($arg)){
cmd_go();
}
$subname =~ s/-/_/g;
my $sub = main->can("cmd_$subname") || main->can("dev_$subname") || main->can("hid_$subname");
if (!defined($sub))
{
print STDERR "Invalid command given.\nUse \e[1;32m./skore help\e[0m for a list of commands.\n";
exit 1;
}
else
{
$sub->(#ARGV);
exit 0;
}
# Main command
sub cmd_go()
{
print "\e[2J\e[0G\e[0d"; # J = Erase in Display, 2 = Entire Screen, (G, d) = Move cursor to (..,..)
print "••••••••••••••••••••\n";
print "• Welcome to \e[1;32mskore\e[0m •\n";
print "••••••••••••••••••••\n\n";
my #game = prompt("What game are we scoring?\n");
print "••• Game name locked: #game\n\n";
my #p1name = prompt("Player 1 name?\n");
my #p2name = prompt("Player 2 name?\n");
my #p3name = prompt("Player 3 name?\n");
print "\n";
print "••• Player names locked: #p1name #p2name #p3name\n\n";
my #p1score = prompt_num("score for #p1name?\n");
my #p2score = prompt_num("score for #p2name?\n");
my #p3score = prompt_num("score for #p3name?\n");
print "\n";
print "••• Game: #game\n";
print "••• #p1name\n";
print "••••• \e[1;32m#p1score\e[0m\n";
print "••• #p2name\n";
print "••••• \e[1;32m#p2score\e[0m\n";
print "••• #p3name\n";
print "••••• \e[1;32m#p3score\e[0m\n";
exit 1;
}
sub cmd_help()
{
print "To get right into using skore, simply type ./skore\n";
print "For details about skore, such as version, use ./skore pkg\n";
}
sub cmd_pkg()
{
print "skore version: $version\n";
print "Detected OS: ";
exec "uname -r";
}
sub prompt {
my ($query) = #_; # take a prompt string as argument
local $| = 1; # activate autoflush to immediately show the prompt
print $query;
chomp(my $answer = <STDIN>); return $answer;
}
sub prompt_num {
NSTART:
my ($querynum) = #_;
print $querynum;
chomp(my $pnum = <STDIN>);
if ($pnum eq $pnum+0) { return $pnum; }
else { print "Error: That is not a number. Try again.\n"; goto NSTART; }
}
sub prompt_yn {
my ($queryyn) = #_;
my $answer = prompt("$queryyn (y/N): ");
return lc($answer) eq 'y';
}
I'd like to also point out that I'm new to perl.
OK, wow. Stop for a moment, step back and put the code down. Think about what you're trying to accomplish here.
There's a bunch of things you're doing in your code that's really going to benefit from taking a step back, and understanding what's going on, before proceeding.
First off:
my $arg = shift(#ARGV);
my $subname = $arg;
if (!defined($arg)){
cmd_go();
}
What is this intended to do? You only use $arg 3 times here, and one of those is to copy it to $subname.
This could be quite simplified by:
my $subname = shift;
cmd_go() unless defined $subname;
Now this:
my $sub = main->can("cmd_$subname") || main->can("dev_$subname") || main->can("hid_$subname");
Where did that come from? Because I'm pretty sure that - as a beginner to perl - you didn't write that yourself, not least because you don't have any subroutines prefixed with dev_ or hid. And this sort of redirect is serious overkill for a program that basically does just one thing.
(And normally, you'd use flags like getopt rather than a command that you leave blank in a default state).
You are also massively overusing arrays - which suggests you're not really sure the difference between #game and $game.
E.g. this:
my #game = prompt("What game are we scoring?\n");
prompt does this though:
chomp(my $answer = <STDIN>); return $answer;
It returns a scalar (a single line) and you're putting it into an array for - as far as I can tell - no particular reason.
Likewise this:
my #p1score = prompt_num("score for #p1name?\n");
my #p2score = prompt_num("score for #p2name?\n");
my #p3score = prompt_num("score for #p3name?\n");
First off - you're using a bunch of single element arrays. But then you're numbering them. When ... actually, the whole point of arrays is to have numbered values.
So how about instead:
print "Num players?:\n";
chomp ( my $num = <STDIN> );
my #players;
my %scores;
for ( 1..$num ) {
print "Player name\n";
chomp ( my $name = <STDIN> );
push ( #players, $name );
}
foreach my $person ( #players ) {
print "Score for $person:\n";
chomp ( my $score = <STDIN> );
while ( $score =~ /\D/ ) {
print "Invalid - please enter numeric value\n";
chomp ( $score = <STDIN> );
}
$scores{$person} = $score;
}
foreach my $person ( #players ) {
print "$person => $score{$person}\n";
}
There are a bunch of other things that you're doing that is more complicated than it needs to be.
What I would suggest you do:
go re-read the perl basics. perldata in particular.
have a look at getopt which is a good (and standard) way to take program 'flag' style input. (e.g. showing version, if that's what you really want.
it looks a lot like you've cargo-culted the code here. I would suggest you re-write from the ground up, and when you hit a problem - ask about it on Stack Overflow, if you can't figure it out from the perl docs.
Try this. Hope this is what you wanted.
#!/usr/bin/env perl
use strict;
my $version = "1.0";
my $arg = shift(#ARGV);
my $subname = $arg;
if (!defined($arg)){
cmd_go();
}
$subname =~ s/-/_/g;
my $sub = main->can("cmd_$subname") || main->can("dev_$subname") || main->can("hid_$subname");
if (!defined($sub))
{
print STDERR "Invalid command given.\nUse \e[1;32m./skore help\e[0m for a list of commands.\n";
exit 1;
}
else
{
$sub->(#ARGV);
exit 0;
}
# Main command
sub cmd_go()
{
print "\e[2J\e[0G\e[0d"; # J = Erase in Display, 2 = Entire Screen, (G, d) = Move cursor to (..,..)
print "••••••••••••••••••••\n";
print "• Welcome to \e[1;32mskore\e[0m •\n";
print "••••••••••••••••••••\n\n";
my #game = prompt("What game are we scoring?\n");
print "••• Game name locked: #game\n\n";
my $players= prompt("Enter total number of players:\n");
my #players_list;
for(my $i=0;$i<$players;$i++){
push(#players_list , prompt("Enter Player ".($i+1)." name\n"));
}
print "\n";
print "••• Player names locked: ";
for(my $i=0;$i<$players;$i++){
print $players_list[$i]."\t";
}
print "\n\n";
my #players_score;
for(my $i=0;$i<$players;$i++){
push(#players_score, prompt("score for $players_list[$i]?\n"));
}
print "\n";
print "••• Game: #game\n";
for(my $i=0;$i<$players;$i++){
print "$players_list[$i]\n";
print "••••• \e[1;32m$players_score[$i]\e[0m\n";
}
exit 1;
}
sub cmd_help()
{
print "To get right into using skore, simply type ./skore\n";
print "For details about skore, such as version, use ./skore pkg\n";
}
sub cmd_pkg()
{
print "skore version: $version\n";
print "Detected OS: ";
exec "uname -r";
}
sub prompt {
my ($query) = #_; # take a prompt string as argument
local $| = 1; # activate autoflush to immediately show the prompt
print $query;
chomp(my $answer = <STDIN>); return $answer;
}
sub prompt_num {
NSTART:
my ($querynum) = #_;
print $querynum;
chomp(my $pnum = <STDIN>);
if ($pnum eq $pnum+0) { return $pnum; }
else { print "Error: That is not a number. Try again.\n"; goto NSTART; }
}
sub prompt_yn {
my ($queryyn) = #_;
my $answer = prompt("$queryyn (y/N): ");
return lc($answer) eq 'y';
}

equivalent of the default variable doesn't work

I have a simple server application written in Perl. Here's the working version of it.
my $client;
while ($client = $local->accept() ) {
print "Connected: ", $client->peerhost(), ":", $client->peerport(), "\n";
while (<$client>) {
if ($mod_ctr == -1) {
$num_count = $_;
init();
}
elsif ($mod_sayaci % 2 == 0) {
$plus_count = $_;
}
elsif ($mod_sayaci % 2 == 1) {
$minus_count = $_;
eval();
}
last if m/^q/gi;
$mod_sayaci++;
}
print "Server awaits..\n";
}
I'm positive this works perfectly. Now, When I change my code to take a starting char from the client to determine the operation instead of using mod:
my $client;
while ($client = $local->accept() ) {
print "Connected: ", $client->peerhost(), ":", $client->peerport(), "\n";
$input;
$operation;
$value;
while ($input = <$client>) {
$operation = substr($input, 0, 1);
$value = substr($input, 1, 1);
print "input: $input \n";
print "operation: $operation \n";
print "value: $value \n";
if ($operation == "r") {
print "entered r \n";
$num_count = $value;
init();
}
elsif ($operation == "a") {
print "entered a \n";
$plus_count = $value;
}
elsif ($operation == "e") {
print "entered e \n";
$minus_count = $value;
eval();
}
elsif ($operation == "q") {
# will quit here
}
}
print "Server awaits..\n";
}
At the client side, I make the user start with the request which sends r as operation. Everything works fine until now. After the first input, input, operation and value prints work fine, but it always enters the first if and prints entered r. What am I missing here?
You have changed from using numbers to using strings to dictate which of the branches should be executed. You need to use eq instead of == to do string comparisons.
Like this
if ($operation eq "r") {
print "entered r\n";
$num_count = $value;
init();
}
etc.
Also, you would be doing yourself and anyone who helps you a big favour if you added
use strict;
use warnings;
to the top of every Perl program you write. The "declarations"
$input;
$operation;
$value;
don't do anything useful except as a comment to say which variables are used within the block. Write this
my ($input, $operation, $value);
and you have done something much more useful.

Searching string in a multiline file using perl

I'm trying to find a match in a multi-line string using this script.
It works only when there's one row in the destination file.
I would like to know if there's any substitution for $_ in order to search a multi-line text?
#!/usr/bin/perl
my $time=`date +%D_%H:%M`;
chomp($time);
my $last_location=`cat /file.txt`;
chomp($last_location);
open (ERRORLOG, ">>/errors.log") || die "failed to open errorlog file \n$!\n\a";
open (MESSAGES, "</logfile") || die "failed to open alarms file \n$!\n\a";
seek(MESSAGES, 0, 2) || die "Couldn't seek to pos: 0 at end of file $!\n";
$end_position = tell(MESSAGES);
if ($end_position < $last_location) {
$last_location=0;
}
if ($end_position > $last_location) {
seek(MESSAGES, $last_location, 0) || die "Couldn't seek to pos: $last_location $! \n";
$num_of_messages_sent=0;
while (<MESSAGES>) {
chomp;
$line_to_check $_;
if ($line_to_check =~ /some text/ ) {
print ERRORLOG "$time: $line_to_check \n";
if ($num_of_messages_sent < 4) {
do something;
}
if ($num_of_messages_sent == 4) {
do something;
}
#increase counter
$num_of_messages_sent = $num_of_messages_sent + 1;
}
}
$last_location = tell(MESSAGES);
# print "last: $last_location , end: $end_position \n";
`echo $last_location >/file_last_location.txt`;
}
close (ERRORLOG);
close (MESSAGES);
Looks better this way:
while (my $line = <MESSAGES>) {
chomp($line);
print "line : $line\n";
if ($line =~ m!your_regexp_here!i){
print ERRORLOG "$time: $line_to_check \n";
$num_of_messages_sent++;
print "\tMATCH\tline: $line\n";
if ($num_of_messages_sent < 4){
print "Found $num_of_messages_sent matches\n";
}
}
}

How can I replace a specific word when it occurs only once in a given subset of data?

Consider the dataset below. Each chunk begining with a number is a 'case'. In the real dataset I have hundreds of thousands of cases. I'd like to replace the word "Exclusion" with "0" when there's only one word Exclusion in a case (e.g. case 10001).
If I loop through lines, I can count how many "Exclusions" I have in each case. But, if there's only one line with the word "Exclusion", I don't know how to get back to that line and replace the word.
How can I do that?
10001
M1|F1|SP1;12;12;12;11;13;10;Exclusion;D16S539
M1|F1|SP1;12;10;12;9;11;9;3.60;D16S
M1|F1|SP1;12;10;10;7;11;7;20.00;D7S
M1|F1|SP1;13;12;12;12;12;12;3.91;D13S
M1|F1|SP1;11;11;13;11;13;11;3.27;D5S
M1|F1|SP1;14;12;14;10;12;10;1.99;CSF
10002
M1|F1|SP1;8;13;13;8;8;12;2.91;D16S
M1|F1|SP1;13;11;13;10;10;10;4.13;D7S
M1|F1|SP1;12;9;12;10;11;16;Exclusion;D13S
M1|F1|SP1;12;10;12;10;14;15;Exclusion;D5S
M1|F1|SP1;13;10;10;10;17;18;Exclusion;CSF
sub process_block {
my ($block) = #_;
$block =~ s/\bExclusion\b/0/
if $block !~ /\bExclusion\b.*\bExclusion\b/s;
print($block);
}
my $buf;
while (<>) {
if (/^\d/) {
process_block($buf) if $buf;
$buf = '';
}
$buf .= $_;
}
process_block($buf) if $buf;
As you read the file, buffer up all lines in a case, and count exclusions,
my ($case,$buf,$count) = (undef,"",0);
while(my $ln = <>) {
Use a regex to detect a case,
if( $ln =~ /^\d+$/ ) {
#new case, process/print old case
$buf =~ s/;Exclusion;/;0;/ if($count==1);
print $buf;
($case,$buf,$count) = ($ln,"",0);
}
use a regex to detect 'Exclusion' now?
elsif( $ln =~ /;Exclusion;/ ) { $count++; }
$buf .= $l;
}
And when you are done, you may have a case left to process,
if( length($buf)>0 ) {
$buf =~ s/;Exclusion;/;0;/ if($count==1);
print $buffer;
}
This is the best I could think of. Assume you read your file into #lines
# separate into blocks
foreach my $line (#lines) {
chomp($line);
if ($line =~ m/^(\d+)/) {
$key = $1;
}
else {
push (#{$block{$key}}, $line);
}
}
# go through each block
foreach my $key (keys %block) {
print "$key\n";
my #matched = grep ($_ =~ m/exclusion/i, #{$block{$key}});
if (scalar (1 == #matched)){
foreach my $line (#{$block{$key}}) {
$line =~ s/Exclusion/0/i;
print "$line\n";
}
}
else {
foreach my $line (#{$block{$key}}) {
print "$line\n";
}
}
}
There're already many correct answers here, which use buffers to store the content of a "case".
Here's another solution using tell and seek to rewind the file, so buffers are not necessary. This could be useful when your "case" is very large and you're sensitive to the performance or memory usage.
use strict;
use warnings;
open FILE, "text.txt";
open REPLACE, ">replace.txt";
my $count = 0; # count of 'Exclusion' in the current case
my $position = 0;
my $prev_position = 0;
my $first_occur_position = 0; # first occurence of 'Exclusion' in the current case
my $visited = 0; # whether the current line is visited before
while (<FILE>) {
# keep track of the position before reading
# the current line
$prev_position = $position;
$position = tell FILE;
if ($visited == 0) {
if (/^\d+/) {
# new case
if ($count == 1) {
# rewind to the first occurence
# of 'Exclusion' in the previous case
seek FILE, $first_occur_position, 0;
$visited = 1;
}
else {
print REPLACE $_;
}
}
elsif (/Exclusion/) {
$count++;
if ($count > 1) {
seek FILE, $first_occur_position, 0;
$visited = 1;
}
elsif ($count == 1) {
$first_occur_position = $prev_position;
}
}
else {
print REPLACE $_ if ($count == 0);
}
if (eof FILE && $count == 1) {
seek FILE, $first_occur_position, 0;
$visited = 1;
}
}
else {
if ($count == 1) {
s/Exclusion/0/;
}
if (/^\d+/) {
$position = tell FILE;
$visited = 0;
$count = 0;
}
print REPLACE $_;
}
}
close REPLACE;
close FILE;

perl: persist set of strings with commit support

I have a set of strings that is modified inside a loop of 25k iterations. It's empty at the beginning, but 0-200 strings are randomly added or removed from it in each cycle. At the end, the set contains about 80k strings.
I want to make it resumable. The set should be saved to disk after each cycle and be loaded on resume.
What library can I use? The amount of raw data is ~16M, but the changes are usually small. I don't want it to rewrite the whole store on each iteration.
Since the strings are paths, I'm thinking of storing them in a log file like this:
+a
+b
commit
-b
+d
commit
In the beginning the file is loaded into a hash and then compacted. If there's no commit line in the end, the last block is not taken into account.
The Storable package brings persistence to your Perl data structures (SCALAR, ARRAY, HASH or REF objects), i.e. anything that can be conveniently stored to disk and retrieved at a later time.
I've decided to put away the heavy artillery and write something simple:
package LoL::IMadeADb;
sub new {
my $self;
( my $class, $self->{dbname} ) = #_;
# open for read, then write. create if not exist
#msg "open $self->{dbname}";
open(my $fd, "+>>", $self->{dbname}) or die "cannot open < $self->{dbname}: $!";
seek($fd, 0, 0);
$self->{fd} = $fd;
#msg "opened";
$self->{paths} = {};
my $href = $self->{paths};
$self->{nlines} = 0;
my $lastcommit = 0;
my ( $c, $rest );
while(defined($c = getc($fd)) && substr(($rest = <$fd>), -1) eq "\n") {
$self->{nlines}++;
chomp($rest);
if ($c eq "c") {
$lastcommit = tell($fd);
#msg "lastcommit: " . $lastcommit;
} elsif ($c eq "+") {
$href->{$rest} = undef;
} elsif ($c eq "-") {
delete $href->{$rest};
}
#msg "line: '" . $c . $rest . "'";
}
if ($lastcommit < tell($fd)) {
print STDERR "rolling back incomplete file: " . $self->{dbname} . "\n";
seek($fd, $lastcommit, 0);
while(defined($c = getc($fd)) && substr(($rest = <$fd>), -1) eq "\n") {
$self->{nlines}--;
chomp($rest);
if ($c eq "+") {
delete $href->{$rest};
} else {
$href->{$rest} = undef;
}
}
truncate($fd, $lastcommit) or die "cannot truncate $self->{dbname}: $!";
print STDERR "rolling back incomplete file; done\n";
}
#msg "entries = " . (keys( %{ $href })+0) . ", nlines = " . $self->{nlines} . "\n";
bless $self, $class
}
sub add {
my ( $self , $path ) = #_;
if (!exists $self->{paths}{$path}) {
$self->{paths}{$path} = undef;
print { $self->{fd} } "+" . $path . "\n";
$self->{nlines}++;
$self->{changed} = 1;
}
undef
}
sub remove {
my ( $self , $path ) = #_;
if (exists $self->{paths}{$path}) {
delete $self->{paths}{$path};
print { $self->{fd} } "-" . $path . "\n";
$self->{nlines}++;
$self->{changed} = 1;
}
undef
}
sub save {
my ( $self ) = #_;
return undef unless $self->{changed};
my $fd = $self->{fd};
my #keys = keys %{$self->{paths}};
if ( $self->{nlines} - #keys > 5000 ) {
#msg "compacting";
close($fd);
my $bkpdir = dirname($self->{dbname});
($fd, my $bkpname) = tempfile(DIR => $bkpdir , SUFFIX => ".tmp" ) or die "cannot create backup file in: $bkpdir: $!";
$self->{nlines} = 1;
for (#keys) {
print { $fd } "+" . $_ . "\n" or die "cannot write backup file: $!";
$self->{nlines}++;
}
print { $fd } "c\n";
close($fd);
move($bkpname, $self->{dbname})
or die "cannot rename " . $bkpname . " => " . $self->{dbname} . ": $!";
open($self->{fd}, ">>", $self->{dbname}) or die "cannot open < $self->{dbname}: $!";
} else {
print { $fd } "c\n";
$self->{nlines}++;
# flush:
my $previous_default = select($fd);
$| ++;
$| --;
select($previous_default);
}
$self->{changed} = 0;
#print "entries = " . (#keys+0) . ", nlines = " . $self->{nlines} . "\n";
undef
}
1;