I've got a subroutine that delares a format in an eval expression. If this subroutine gets called more than once, perl warns that a format has been redefined.
This code:
use warnings;
routine();
routine();
sub routine{
my $s = "FAIL";
my $def = "format =\n#<<<<#>>>>\n\$s, \$s\n.";
eval $def;
write;
}
prints
FAIL FAIL
Format STDOUT redefined at (eval 2) line 1.
FAIL FAIL
Is it possible to delete the format declaration at the end of the subroutine?
Here is a simple solution that uses a flag to avoid redefining the format.
use strict;
use warnings;
routine();
routine();
my $format_defined;
sub routine{
my $s = "FAIL";
if (!$format_defined) {
my $def = "format =\n#<<<<#>>>>\n\$s, \$s\n.";
eval $def;
$format_defined = 1;
}
write;
}
Here is a more sophisticated solution that allows for the format to be redefined for each call. It uses a temporary filehandle in place of STDOUT that redirects the output to a scalar, which you can then print to STDOUT.
routine('FAIL');
routine('PASS');
sub routine{
my $s = shift;
format REPORT =
#<<<<#>>>>
$s, $s
.
my $report;
open my $fh, '>', \$report;
select $fh;
$~ = 'REPORT';
write;
close $fh;
select STDOUT;
print $report;
}
Related
I am attempting to create a Perl script that filters data presented on STDIN, changing all occurrences of
one string to another and outputting all input lines, changed and unchanged to STDOUT. FROMSTRING and TOSTRING can be PERL-compatible regular expressions. I am unable to get matching output.
Here is an example of what I am trying to achieve.
echo "Today is Saturday" | f.pl 'a' '#'
Output Tod#y is S#turd#y.
echo io | filter.pl '([aeiou])([aeiou])' '$2$1'
Output oi.
#!/usr/bin/perl
use strict;
use warnings;
if (#ARGV != 2){
print STDERR "Usage: ./filter.pl FROMSTRING TOSTRING\n"
}
exit 1;
my $FROM = $ARGV[0];
my $TO = $ARGV[1];
my $inLine = "";
while (<STDIN>){
$inLine = $_;
$inLine =~ s/$FROM/$TO/;
print $inLine
}
exit 0;
First off, the replacement part of a s/.../.../ operation is not a regex; it works like a double-quoted string.
There are a couple of issues with your code.
Your exit 1; statement appears in the middle of the main code, not in the error block. You probably want:
if (#ARGV != 2) {
print STDERR "Usage: ./filter.pl FROMSTRING TOSTRING\n";
exit 1;
}
You're missing a g flag if you want multiple substitutions to happen in the same line:
$inLine =~ s/$FROM/$TO/g;
There's no need to predeclare $inLine; it's only used in one block.
There's also no need to read a line into $_ just to copy it into $inLine.
It's common to use $names_like_this for variables and functions, not $namesLikeThis.
You can use $0 instead of hardcoding the program name in the error message.
exit 0; is redundant at the end.
The following is closer to how I'd write it:
#!/usr/bin/perl
use strict;
use warnings;
if (#ARGV != 2) {
die "Usage: $0 FROMSTRING TOSTRING\n";
}
my ($from, $to) = #ARGV;
while (my $line = readline STDIN) {
$line =~ s/$from/$to/g;
print $line;
}
That said, none of this addresses your second example with '$2$1' as the replacement. The above code won't do what you want because $to is a plain string. Perl won't scan it to look for things like $1 and replace them.
When you write "foo $bar baz" in your code, it means the same thing as 'foo ' . $bar . ' baz', but this only applies to code, i.e. stuff that literally appears in your source code. The contents of $bar aren't re-scanned at runtime to expand e.g. \n or $quux. This also applies to $1 and friends, which are just normal variables.
So how do you get '$2$1' to work?
One way is to mess around with eval, but I don't like it because, well, it's eval: If you're not very careful, it would allow someone to execute arbitrary code by passing the right replacement "string".
Doing it without eval is possible and even easy with e.g. Data::Munge::replace:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Munge qw(replace);
if (#ARGV != 2) {
die "Usage: $0 FROMSTRING TOSTRING\n";
}
my ($from, $to) = #ARGV;
while (my $line = readline STDIN) {
print replace($line, $from, $to, 'g');
}
replace works like JavaScript's String#replace in that it expands special $ sequences.
Doing it by hand is also possible but slightly annoying because you basically have to treat $to as a template and expand all $ sequences by hand (e.g. by using another regex substitution):
# untested
$line =~ s{$from}{
my #start = #-;
my #stop = #+;
(my $r = $to) =~ s{\$([0-9]+|\$)}{
$1 eq '$'
? '$'
: substr($from, $start[$1], $stop[$1] - $start[$1])
}eg;
$r
}eg;
(This does not implement braced groups such as ${1}, ${2}, etc. Those are left as an exercise for the reader.)
This code is sufficiently annoying to write (and look at) that I much prefer using a module like Data::Munge for this sort of thing.
three errors found:
; after error message
exit 1;
$inLine =~ s/$FROM/$TO/g;
like:
#!/usr/bin/perl
use strict;
use warnings;
if (#ARGV != 2){
print STDERR "Usage: ./filter.pl FROMSTRING TOSTRING\n";
exit 1;
}
my $FROM = $ARGV[0];
my $TO = $ARGV[1];
my $inLine = "";
while (<STDIN>){
$inLine = $_;
$inLine =~ s/$FROM/$TO/g;
print $inLine
}
exit 0;
i am newbie to perl. and this is my second assignment i should create program to parse n files and print m sentences using n-grams model. long story short, i wrote this script that will take n arguments, where the first and second arguments are numeric but the rest are files names, however i am getting this error Wide character in print at ngram.pl line 35, line 1.
steps to reproduce it :
input from command line : perl ngram.pl 5 10 tale-cities.txt bleak-house.txt papers.txt
output : Wide character in print at ngram.pl line 35, line 1.
#!/usr/bin/perl
use strict;
use warnings FATAL => 'all';
use Scalar::Util qw(looks_like_number);
use utf8;
use Encode;
#Charles Dickens
sub checkIfNumberic
{
my ($inp)=#_;
if (looks_like_number($inp)){
return "True";
}
else{
return "False" ;
}
}
sub main
{
my $correctInput=", your input must be something like this 5 10 somefile.txt somefile2.txt ";
my #inputs= #ARGV;
if (checkIfNumberic($inputs[0]) eq "False"){
die "first argument must be numberic $correctInput\n";
}
if (checkIfNumberic($inputs[1]) eq "False"){
die "second argument must be numberic $correctInput\n";
}
for (my $i=2; $i< scalar #inputs ;$i++)
{
if (open(my $fh, '<:encoding(UTF-8)', $inputs[$i])) {
while (my $line = <$fh>) {
chomp $line;
print "$line \n";
}
}
}
}
main();
You decoded your inputs (the script, with use utf8;; and the file, with :encoding(UTF-8)), but you didn't encode your outputs. Add
use open ':std', ':encoding(UTF-8)';
This is equivalent to
BEGIN {
binmode STDIN, ':encoding(UTF-8)';
binmode STDOUT, ':encoding(UTF-8)';
binmode STDERR, ':encoding(UTF-8)';
}
It also sets the default encoding for file handles opened in its lexical scope, you can remove the existing :encoding(UTF-8) if you want.
In the following code if there is space between FILE and ( in the printf statement
like
printf FILE ("Test string inline\n");
Perl will treat FILE as a filehandle otherwise
printf FILE("Test string inline\n");
will be treated as subroutine call(If no subroutine is defined by FILE perl will through an error Undefined subroutine &main::FILE called at ./test.pl line xx ). Isn't there a better way Perl can implement this ? (Maybe this is why bareword filehandles are considered outdated ?)
#!/usr/bin/perl
use warnings;
open(FILE,">test.txt");
printf FILE ("Test string inline\n");
close(FILE);
sub FILE
{
return("Test string subroutine\n");
}
Are you asking how to avoid that error accidentally? You could wrap the handle in curlies
printf({ HANDLE } $pattern, #args);
print({ HANDLE } #args);
say({ HANDLE } #args);
Or since parens are often omitted for say, print and printf,
printf { HANDLE } $pattern, #args;
print { HANDLE } #args;
say { HANDLE } #args;
Or you could use a method call
HANDLE->printf($pattern, #args);
HANDLE->print(#args);
HANDLE->say(#args);
Try:
#!/usr/bin/env perl
use strict;
use warnings;
# --------------------------------------
use charnames qw( :full :short );
use English qw( -no_match_vars ) ; # Avoids regex performance penalty
my $test_file = 'test.txt';
open my $test_fh, '>', $test_file or die "could not open $test_file: $OS_ERROR\n";
printf {$test_fh} "Test string inline" or die "could not print $test_file: $OS_ERROR\n";
close $test_fh or die "could not close $test_file: $OS_ERROR\n";
I already did some research on Perl script debugging but couldn't find what I was looking for.
Let me explain my problem here.
I have a Perl script which is not entering into last while loop it seems cos it is not printing anything inside as instructed.
So, I want to know is there any easier method available to see all lines one by one like we can see in shell script using
set -x
Here is my Perl script code
#!/usr/bin/perl -w
my $ZONEADM = "/usr/sbin/zoneadm list -c";
use strict;
use diagnostics;
use warnings;
system("clear");
print "Enter the app\n";
chomp(my $INS = <>);
print "\nEnter the Symmitrix ID\n";
chomp(my $SYMM = <>);
print "\nEnter the Server\n";
chomp(my $SRV = <>);
print "\nEnter the devices\n";
while (<>) {
if($_ !~ m/(q|quit)/) {
chomp($_);
my $TEMP_FILE = "/export/home/ptiwari/scripts/LOG.11";
open (my $FH, '>>', $TEMP_FILE);
my #arr = split(/:/, $_);
if($arr[3]) {
print $FH "/".$INS."db/".$arr[0]." ".$SYMM." ".$arr[1]." ".$arr[2]." ".$arr[3]."\n";
}
else {
print $FH "/".$INS."db/".$arr[0]." ".$SYMM." ".$arr[1]." ".$arr[2]."\n";
}
undef #arr;
close $FH;
}
else {
exit;
}
}
my $IS_ZONE = qx($ZONEADM|grep -i $SRV|grep -v global);
if($IS_ZONE) {
$IS_ZONE = "yes";
}
else {
$IS_ZONE = "no";
}
open(my $FLH, '<', "/export/home/ptiwari/scripts/LOG.11");
my #lines;
while(<$FLH>) {
my ($GLOBAL_MTPT, $SYM, $SYM_DEV, $SIZE, $NEWFS) = split;
print $GLOBAL_MTPT." ".$SYM." ".$SYM_DEV;
print "\n";
}
I already tried perl -d but it didn't show me anything which can help me to troubleshoot why it didn't enter the while loop.
Your while(<>) loop doesn't have sensible termination conditions. The /q|quit/ regex is buggy.
You exit the whole script if any line contains q or quit. You will also exit, if the device descriptions contains things like quill or acquisition. The effect of typing an accidental q is similar to a CtrlC.
The only way to finish the loop and go on with the script is to send an EOF. This requires the user to punch CtrlD into the keyboard, or a file to simply end. Then your script will continue.
There are some other things wrong/weird with this script.
Main criticism: (a) all-uppercase variables are informally reserved for Perl and pragmatic modules. Lowercase or mixed case variables work too. (b) Your script contains quite some redundant code. Either refactor it into subs, or rewrite your logic
Here is an example rewrite that may be easier to debug / may not contain some of the bugs.
#!/usr/bin/perl
use strict;
use warnings;
use diagnostics;
use constant DEBUG_FLAG => 1; # set to false value for release
my $zoneadm_command = "/usr/sbin/zoneadm list -c";
my $temp_file_name = "/export/home/ptiwari/scripts/LOG.11";
sub prompt { print "\n", $_[0], "\n"; my $answer = <>; chomp $answer; return $answer }
sub DEBUG { print STDERR "DEBUG> ", #_, "\n" if DEBUG_FLAG }
system("clear");
my $app_name = prompt("Enter the app");
my $symm_id = prompt("Enter the Symmitrix ID");
my $server = prompt("Enter the server name");
print "Enter the devices.\n";
print qq(\tTo terminate the script, type "q" or "quit".\n);
print qq(\tTo finish the list of devices, type Ctrl+D.\n);
open my $temp_file, ">>", $temp_file_name
or die "Can't open log file: $!";
while (<>) {
chomp; # remove trailing newline
exit if /^q(?:uit)?$/; # terminate the script if the input line *is* `q` or `quit`.
my #field = split /:/;
# grep: select all true values
#field = grep {$_} ("/${app_name}db/$field[0]", $symm_id, #field[1 .. 3]);
print $temp_file join(" ", #field), "\n";
}
close $temp_file;
DEBUG("finished the reading loop");
# get the zones with only *one* extra process
my #zones =
grep {not /global/}
grep {/\Q$server\E/i}
map {chomp; $_}
qx($zoneadm_command);
my $is_zone = #zones ? "yes" : "no";
DEBUG("Am I in the zone? $is_zone");
open my $device_file, "<", $temp_file_name or die "Can't open $temp_file_name: $!";
while (<$device_file>) {
chomp;
my ($global_mtpt, $sym, $sym_dev) = split;
print join(" ", $global_mtpt, $sym, $sym_dev), "\n";
# or short: print join(" ", (split)[0 .. 2]), "\n";
}
You need something like this for stepping into the script:
http://www.devshed.com/c/a/Perl/Using-The-Perl-Debugger/
You can really use the debugger: http://perldoc.perl.org/perldebug.html
But if your preference is to trace like bash -x, take a look at this discussion:
http://www.perlmonks.org/?node_id=419653
The Devel::Trace Perl module is designed to mimic sh -x tracing for shell programs.
Try to remove the "my $" from the last open statement and the "$" from there in the last while statement. Or better yet, try this:
open(my FLH, '<', "/export/home/ptiwari/scripts/LOG.11");
my #lines = <FLH>;
foreach (#lines) {
my ($GLOBAL_MTPT, $SYM, $SYM_DEV, $SIZE, $NEWFS) = split;
print $GLOBAL_MTPT." ".$SYM." ".$SYM_DEV;
print "\n";
}
Let me know about the results.
I quickly jotted off a Perl script that would average a few files with just columns of numbers. It involves reading from an array of filehandles. Here is the script:
#!/usr/local/bin/perl
use strict;
use warnings;
use Symbol;
die "Usage: $0 file1 [file2 ...]\n" unless scalar(#ARGV);
my #fhs;
foreach(#ARGV){
my $fh = gensym;
open $fh, $_ or die "Unable to open \"$_\"";
push(#fhs, $fh);
}
while (scalar(#fhs)){
my ($result, $n, $a, $i) = (0,0,0,0);
while ($i <= $#fhs){
if ($a = <$fhs[$i]>){
$result += $a;
$n++;
$i++;
}
else{
$fhs[$i]->close;
splice(#fhs,$i,1);
}
}
if ($n){ print $result/$n . "\n"; }
}
This doesn't work. If I debug the script, after I initialize #fhs it looks like this:
DB<1> x #fhs
0 GLOB(0x10443d80)
-> *Symbol::GEN0
FileHandle({*Symbol::GEN0}) => fileno(6)
1 GLOB(0x10443e60)
-> *Symbol::GEN1
FileHandle({*Symbol::GEN1}) => fileno(7)
So far, so good. But it fails at the part where I try to read from the file:
DB<3> x $fhs[$i]
0 GLOB(0x10443d80)
-> *Symbol::GEN0
FileHandle({*Symbol::GEN0}) => fileno(6)
DB<4> x $a
0 'GLOB(0x10443d80)'
$a is filled with this string rather than something read from the glob. What have I done wrong?
You can only use a simple scalar variable inside <> to read from a filehandle. <$foo> works. <$foo[0]> does not read from a filehandle; it's actually equivalent to glob($foo[0]). You'll have to use the readline builtin, a temporary variable, or use IO::File and OO notation.
$text = readline($foo[0]);
# or
my $fh = $foo[0]; $text = <$fh>;
# or
$text = $foo[0]->getline; # If using IO::File
If you weren't deleting elements from the array inside the loop, you could easily use a temporary variable by changing your while loop to a foreach loop.
Personally, I think using gensym to create filehandles is an ugly hack. You should either use IO::File, or pass an undefined variable to open (which requires at least Perl 5.6.0, but that's almost 10 years old now). (Just say my $fh; instead of my $fh = gensym;, and Perl will automatically create a new filehandle and store it in $fh when you call open.)
If you are willing to use a bit of magic, you can do this very simply:
use strict;
use warnings;
die "Usage: $0 file1 [file2 ...]\n" unless #ARGV;
my $sum = 0;
# The current filehandle is aliased to ARGV
while (<>) {
$sum += $_;
}
continue {
# We have finished a file:
if( eof ARGV ) {
# $. is the current line number.
print $sum/$. , "\n" if $.;
$sum = 0;
# Closing ARGV resets $. because ARGV is
# implicitly reopened for the next file.
close ARGV;
}
}
Unless you are using a very old perl, the messing about with gensym is not necessary. IIRC, perl 5.6 and newer are happy with normal lexical handles: open my $fh, '<', 'foo';
I have trouble understanding your logic. Do you want to read several files, which just contains numbers (one number per line) and print its average?
use strict;
use warnings;
my #fh;
foreach my $f (#ARGV) {
open(my $fh, '<', $f) or die "Cannot open $f: $!";
push #fh, $fh;
}
foreach my $fh (#fh) {
my ($sum, $n) = (0, 0);
while (<$fh>) {
$sum += $_;
$n++;
}
print "$sum / $n: ", $sum / $n, "\n" if $n;
}
Seems like a for loop would work better for you, where you could actually use the standard read (iteration) operator.
for my $fh ( #fhs ) {
while ( defined( my $line = <$fh> )) {
# since we're reading integers we test for *defined*
# so we don't close the file on '0'
#...
}
close $fh;
}
It doesn't look like you want to shortcut the loop at all. Therefore, while seems to be the wrong loop idiom.