I want to make a configuration file which hold some objects, like this (where of course none of the paramaters can be considered as a primary key)
param1=abc
param2=ghj
param1=bcd
param2=hjk
; always the sames parameters
This file could be read, lets say with Config::IniFiles, because it has a direct transcription into ini file, like this
[0]
param1=abc
param2=ghj
[1]
param1=bcd
param2=hjk
with, for example, something like
perl -pe 'if (m/^\s*$/ || !$section ) print "[", ($section++ || 0) , "]"'
And finish with
open my $fh, '<', "/path/to/config_file.ini" or die $!;
$cfg = Config::IniFiles->new( -file => $fh );
(...parse here the sections starting with 0.)
But, I here ask me some question about the thing becoming quite complex....
(A) Is There a way to transform the $fh, so that it is not required to execute the perl one-liner BEFORE reading the file sequentially? So, to transform the file during perl is actually reading it.
or
(B) Is there a module to read my wonderfull flat database? Or something approching? I let myslef said, that Gnu coreutils does this kind of flat file reading, but I cannot remember how.
You can create a simple subclass of Config::INI::Reader:
package MyReader;
use strict;
use warnings;
use base 'Config::INI::Reader';
sub new {
my $class = shift;
my $self = $class->SUPER::new( #_ );
$self->{section} = 0;
return $self;
}
sub starting_section { 0 };
sub can_ignore { 0 };
sub parse_section_header {
my ( $self, $line ) = #_;
return $line =~ /^\s*$/ ? ++$self->{section} : undef ;
}
1;
With your input this gives:
% perl -MMyReader -MData::Dumper -e 'print Dumper( MyReader->read_file("cfg") )'
$VAR1 = {
'1' => {
'param2' => 'hjk',
'param1' => 'bcd'
},
'0' => {
'param2' => 'ghj',
'param1' => 'abc'
}
};
You can use a variable reference instead of a file name to create a filehandle that reads from it:
use strict;
use warnings;
use autodie;
my $config = "/path/to/config_file.ini";
my $content = do {
local $/;
open my $fh, "<", $config;
"\n". <$fh>;
};
# one liner replacement
my $section = 0;
$content =~ s/^\s*$/ "\n[". $section++ ."]" /mge;
open my $fh, '<', \$content;
my $cfg = Config::IniFiles->new( -file => $fh );
# ...
You can store the modified data in a real file or a string variable, but I suggest that you use paragraph mode by setting the input record separator $/ to the empty string. Like this
use strict;
use warnings;
{
local $/ = ''; # Read file in "paragraphs"
my $section = 0;
while (<DATA>) {
printf "[%d]\n", $section++;
print;
}
}
__DATA__
param1=abc
param2=ghj
param1=bcd
param2=hjk
output
[0]
param1=abc
param2=ghj
[1]
param1=bcd
param2=hjk
Update
If you read the file into a string, adding section identifiers as above, then you can read the result directly into a Config::IniFiles object using a string reference, for instance
my $config = Config::IniFiles->new(-file => \$modified_contents)
This example shows the tie interface, which results in a Perl hash that contains the configuration information. I have used Data::Dump only to show the structure of the resultant hash.
use strict;
use warnings;
use Config::IniFiles;
my $config;
{
open my $fh, '<', 'config_file.ini' or die "Couldn't open config file: $!";
my $section = 0;
local $/ = '';
while (<$fh>) {
$config .= sprintf "[%d]\n", $section++;
$config .= $_;
}
};
tie my %config, 'Config::IniFiles', -file => \$config;
use Data::Dump;
dd \%config;
output
{
# tied Config::IniFiles
"0" => {
# tied Config::IniFiles::_section
param1 => "abc",
param2 => "ghj",
},
"1" => {
# tied Config::IniFiles::_section
param1 => "bcd",
param2 => "hjk",
},
}
You may want to perform operations on a flux of objects (as Powershell) instead of a flux of text, so
use strict;
use warnings;
use English;
sub operation {
# do something with objects
...
}
{
local $INPUT_RECORD_SEPARATOR = '';
# object are separated with empty lines
while (<STDIN>) {
# key value
my %object = ( m/^ ([^=]+) = ([[:print:]]*) $ /xmsg );
# key cannot have = included, which is the delimiter
# value are printable characters (one line only)
operation ( \%object )
}
A like also other answers.
Related
I need to check a list of domain names and get the list of domains with no NS (probably unregistered). I've already found a nice solution with ADNS and adnshost. The command "adnshost -a -tns domain.com" does what I need (The 4th column in the output will contain the result) but I want to achieve the same with Perl and Net::DNS::Async.
My code:
#!/usr/bin/perl -w
use strict;
use utf8;
use Net::DNS::Async;
my $c = new Net::DNS::Async(QueueSize => 1000, Retries => 3);
my $filename = 'domain_list.txt';
open(FH, '<', $filename);
while(<FH>){
chomp($url);
$c->add(\&callback, "$url");
}
$c->await();
sub callback {
my $response = shift;
print $response->string;
}
So, how do I get the needed info with Perl and Net::DNS::Async ?
You can add NS to the add arguments.
while (<FH>) {
chomp;
$c->add(\&callback, $_, 'NS');
}
$c->await();
sub callback {
my $response = shift;
unless ($response->answer) {
my $host = join '.', #{$response->{question}[0]{qname}{label}};
print "$host\n";
}
}
$response->answer will be "empty" if there are no replies.
I am writing a Perl script which enables the addition and modification of parameters maintained in a particular file.
The script takes the following arguments; Parameter name($paraName), Parameter value($paraVal) and the file ($profile).
The script checks if the parameter($paraName) exists already. if it does, it just changes the value($paraVal) else adds both the parameter($paraName) and the value($paraVal) to the file($profile).
Following is the block of code for the same:
print " checking if parameter is already avaialable";
my $response = system("egrep -qs \"$paraName =\" $profile");
$rc = 1;
if ($response == 0) {
print " Parameter is already available, changing the value now! ";
$rc = system("sed -i 's:.*$paraName.*:$paraName = $paraVal \# Parameter changed by $script:' $profile");
print " Parameter $paraName has been updated with the value $paraVal in the Profile successfully \n\n";
}
else{
print " Parameter is not available, Adding the Paremeter now! ";
$rc = system("echo \"$paraName = $paraVal \# Parameter added by $script\" >> $profile");
print " Parameter $paraName has been added with the value $paraVal in the Profile successfully \n\n";
}
The script works fine for most cases, except when I have arguments with double quotes to be added as a new parameter. It works file for hash(#), slashes (), etc, when passes within a single quote(' ').
This is working in case of changing the value($paraVal) when the parameter($paraName) already exists. But while a new parameter has to be added, this fails to add double quotes in the parameter name.
Would appreciate some help here.
Here is an example of how you could write it as pure Perl:
use feature qw(say);
use strict;
use warnings;
my ( $paraName, $paraVal, $profile ) = #ARGV;
my $script = $0;
open ( my $fh, '<', $profile ) or die "Could not open file '$profile': $!";
my $found = 0;
while( my $line = <$fh> ) {
chomp $line;
if ( my ($key) = $line =~ /^(\Q$paraName\E)\s*=\s*/) {
say "$key = $paraVal \# Parameter changed by $script";
$found = 1;
}
else {
say $line;
}
}
close $fh;
if ( !$found ) {
say "$paraName = $paraVal \# Parameter added by $script";
}
Edit:
The above script does not modify the profile file, but instead writes the modified file to standard output. So it was meant to be used together with Shell redirection to save the output to a new file. To modify the profile file directly, you could use:
use feature qw(say);
use strict;
use warnings;
die "Bad arguments!" if #ARGV != 3;
my ( $paraName, $paraVal, $profile ) = #ARGV;
my $script = $0;
#ARGV = ( $profile );
$^I = '.bak';
my $found = 0;
while (my $line = <<>>) {
chomp $line;
if ( my ($key) = $line =~ /^(\Q$paraName\E)\s*=\s*/) {
say "$key = $paraVal \# Parameter changed by $script";
$found = 1;
}
else {
say $line;
}
} continue {
say "$paraName = $paraVal \# Parameter added by $script" if eof && !$found;
}
This will first save the original profile file to a backup file with .bak extension, and then overwrite the profile file with the modified content.
Try following code as alternative
#!/usr/bin/perl
use strict;
use warnings;
use feature 'say';
use Pod::Usage;
use Getopt::Long;
use Data::Dumper;
my %opt; # program options
my %param; # parameters storage
my $fh; # file handle
GetOptions (
'file|f=s' => \$opt{file},
'name|n=s' => \$opt{name},
'value|v=s' => \$opt{value},
'operation|o=s' => \$opt{op},
'help|h' => \$opt{help},
'man|m' => \$opt{man},
'debug|d' => \$opt{debug}
) or pod2usage(1);
pod2usage(1) if $opt{help};
pod2usage(-exitval => 0, -versose => 2) if $opt{man};
pod2usage(1) unless $opt{file};
open $fh, "< $opt{file}"
or die "Couldn't open $opt{file}";
my #lines = <$fh>;
close $fh;
chomp #lines;
print Dumper(\#lines) if $opt{debug};
push #lines, "$opt{name} = $opt{value}"
if $opt{op} eq 'add';
#lines = map { /$opt{name}\s*=/ ? '' : $_ } #lines
if $opt{op} eq 'del';
#lines = map {
s/($opt{name})\s*=\s*(.*)/$1 = $opt{value}/; $_
} #lines if $opt{op} eq 'mod';
map{ say } #lines
if $opt{op} eq 'view';
map {
/$opt{name}\s*=\s*(.*)/ and say 'Verify: '
. ($1 eq $opt{value} ? 'ok' : 'no')
} #lines if $opt{op} eq 'check';
my %save = map { $_ => 1 } qw/add del mod/;
print Dumper(\#lines) if $opt{debug};
if( $save{ $opt{op} } ) {
open $fh, "> $opt{file}"
or die "Couldn't open $opt{file}";
map { say $fh $_ } #lines;
close $fh;
}
__END__
=head1 NAME
program - modify configuration file
=head1 SYNOPSIS
program [options] [file ...]
Usage:
program -op [add|del|mod|view|check] -n param -v value -f file
Options:
--file,-f configuration filename
--name,-n parameter name
--value,-v parameter value
--operation,-o operation to perform
--help,-h brief help message
--man,-m full documentation
--debug,-d debug mode
=head1 OPTIONS
=over 8
=item B<--file,-f>
Configuration file to edit
=item B<--name,-n>
Configuration parameter name to operate on
=item B<--value,-v>
Configuration parameter value to operate on
=item B<--operation,-o>
Operation to perform on parameter: add, del, mod, view, check
=item B<--debug,-d>
Debug flag to print debug messages.
=item B<--help,-h>
Print a brief help message and exits.
=item B<--man,-m>
Prints the manual page and exits.
=back
=head1 DESCRIPTION
B<This program> allows to operate on configuation files variables.
=head1 AUTHOR
B<Polar Bear> L<https://stackoverflow.com/users/12313309/polar-bear>
=cut
I'm using two text files sampleA.txt and sampleB.txt. I have two fields in each file and I need to compare first record(first row) of sampleA.txt with the first row of sampleB.txt and I want to show matching records as well as miss matching records in command prompt.I need to do that in Perl.
Using the below script I'm getting one output but it is wrong. I need to populate both matching as well as mismatching. How to do that?
sampleA.txt:
1|X
2|A
4|Z
5|A
sampleB.txt:
2|A
2|X
3|B
4|C
Output I'm getting:
2|A
2|X
4|C
Outputs I want:
Matching-Output:
2|A
Miss-matching-Output:
1|X
4|Z
5|A
3|B
4|C
Perl Script:
#!/usr/bin/perl
use strict;
use warnings;
open(FILE1,'C:\Users\sathiya.kumar\Desktop\sampleA.txt') || die $!;
open(FILE2,'C:\Users\sathiya.kumar\Desktop\sampleB.txt') || die $!;
my $interline;
while (my $line= <FILE1>) {
my #fields = split('\|',$line);
parser($fields[0]);
}
sub parser {
my $mergeid = shift;
while (defined $interline || ($interline= <FILE2>)) {
my #fields = split('\|',$interline);
my $key = $fields[0];
if ($key lt $mergeid) {
# Skip non-matching records
$interline = undef;
next;
} elsif ($key gt $mergeid) {
# wait for next key
last;
} else {
print $interline;
$interline = undef;
}
}
}
close(FILE1);
close(FILE2);
Let me know if you need more information.
You left out 2|X:
use strict;
use warnings;
use 5.016;
use Data::Dumper;
#Create a set from the entries in sampleA.txt:
my $fname = 'sampleA.txt';
open my $A_INFILE, '<', $fname
or die "Couldn't open $fname: $!";
my %a;
while (my $line = <$A_INFILE>) {
chomp $line;
$a{$line} = undef;
}
close $A_INFILE;
say Dumper(\%a);
#Create a set from the entries in sampleB.txt:
$fname = 'sampleB.txt';
open my $B_INFILE, '<', $fname
or die "Couldn't open $fname: $!";
my %b;
while (my $line = <$B_INFILE>) {
chomp $line;
$b{$line} = undef;
}
close $B_INFILE;
say Dumper(\%b);
#Divide the entries in both files into matches and mismatches:
my (#matches, #mismatches);
for my $a_val (keys %a) {
if (exists $b{$a_val}) {
push #matches, $a_val;
}
else {
push #mismatches, $a_val;
}
}
for my $b_val (keys %b) {
if (not exists $a{$b_val}) {
push #mismatches, $b_val;
}
}
say Dumper(\#matches);
say Dumper(\#mismatches);
--output:--
$VAR1 = {
'5|A' => undef,
'4|Z' => undef,
'1|X' => undef,
'2|A' => undef
};
$VAR1 = {
'2|X' => undef,
'3|B' => undef,
'4|C' => undef,
'2|A' => undef
};
$VAR1 = [
'2|A'
];
$VAR1 = [
'5|A',
'4|Z',
'1|X',
'2|X',
'3|B',
'4|C'
];
If you evaluate a hash in scalar context, it returns false if the hash is empty. If there are any key/value pairs, it returns true; more precisely, the value returned is a string consisting of the number of used buckets and the number of allocated buckets, separated by a slash. This is pretty much useful only to find out whether Perl's internal hashing algorithm is performing poorly on your data set. For example, you stick 10,000 things in a hash, but evaluating %HASH in scalar context reveals "1/16" , which means only one out of sixteen buckets has been touched, and presumably contains all 10,000 of your items. This isn't supposed to happen. If a tied hash is evaluated in scalar context, the SCALAR method is called (with a fallback to FIRSTKEY ).
http://perldoc.perl.org/perldata.html
I study the High Order Perl book and have an issue with iterators in the Chapter 4.3.4.
The code:
main_script.pl
#!/perl
use strict;
use warnings;
use FindBin qw($Bin);
use lib $Bin;
use Iterator_Utils qw(:all);
use FlatDB;
my $db = FlatDB->new("$Bin/db.csv") or die "$!";
my $q = $db->query('STATE', 'NY');
while (my $rec = NEXTVAL($q) )
{
print $rec;
}
Iterator_Utils.pm
#!/perl
use strict;
use warnings;
package Iterator_Utils;
use Exporter 'import';;
our #EXPORT_OK = qw(NEXTVAL Iterator
append imap igrep
iterate_function filehandle_iterator list_iterator);
our %EXPORT_TAGS = ('all' => \#EXPORT_OK);
sub NEXTVAL { $_[0]->() }
sub Iterator (&) { return $_[0] }
FlatDB.pm
#!/perl
use strict;
use warnings;
package FlatDB;
my $FIELDSEP = qr/:/;
sub new
{
my $class = shift;
my $file = shift;
open my $fh, "<", $file or return;
chomp(my $schema = <$fh>);
my #field = split $FIELDSEP, $schema;
my %fieldnum = map { uc $field[$_] => $_ } (0..$#field);
bless
{
FH => $fh,
FIELDS => \#field,
FIELDNUM => \%fieldnum,
FIELDSEP => $FIELDSEP
} => $class;
}
use Fcntl ':seek';
sub query
{
my $self = shift;
my ($field, $value) = #_;
my $fieldnum = $self->{FIELDNUM}{uc $field};
return unless defined $fieldnum;
my $fh = $self->{FH};
seek $fh, 0, SEEK_SET;
<$fh>; # discard schema line
return Iterator
{
local $_;
while (<$fh>)
{
chomp;
my #fields = split $self->{FIELDSEP}, $_, -1;
my $fieldval = $fields[$fieldnum];
return $_ if $fieldval eq $value;
}
return;
};
}
db.csv
LASTNAME:FIRSTNAME:CITY:STATE:OWES
Adler:David:New York:NY:157.00
Ashton:Elaine:Boston:MA:0.00
Dominus:Mark:Philadelphia:PA:0.00
Orwant:Jon:Cambridge:MA:26.30
Schwern:Michael:New York:NY:149658.23
Wall:Larry:Mountain View:CA:-372.14
Just as in the book so far, right? However I do not get the output (the strings with Adler and Schwern should occur). The error message is:
Can't use string ("Adler:David:New York:NY:157.00") as a subroutine ref while
"strict refs" in use at N:/Perle/Learn/Iterators/Iterator_Utils.pm line 12, <$fh>
line 3.
What am I doing wrong?
Thanks in advance!
FlatDB calls Iterator, which is defined in Iterator_Utils, so it needs to import that function from Iterator_Utils. If you add
use Iterator_Utils qw(Iterator);
after package FlatDB, the program will work.
Thanks very much for finding this error. I will add this to the errata on the web site. If you would like to be credited by name, please email me your name.
I like to use the nifty perl feature where reading from the empty angle operator <> magically gives your program UNIX filter semantics, but I'd like to be able to access this feature through an actual filehandle (or IO::Handle object, or similar), so that I can do things like pass it into subroutines and such. Is there any way to do this?
This question is particularly hard to google, because searching for "angle operator" and "filehandle" just tells me how to read from filehandles using the angle operator.
From perldoc perlvar:
ARGV
The special filehandle that iterates over command-line filenames in #ARGV. Usually written as the null filehandle in the angle operator <>. Note that currently ARGV only has its magical effect within the <> operator; elsewhere it is just a plain filehandle corresponding to the last file opened by <>. In particular, passing \*ARGV as a parameter to a function that expects a filehandle may not cause your function to automatically read the contents of all the files in #ARGV.
I believe that answers all aspects of your question in that "Hate to say it but it won't do what you want" kind of way. What you could do is make functions that take a list of filenames to open, and do this:
sub takes_filenames (#) {
local #ARGV = #_;
// do stuff with <>
}
But that's probably the best you'll be able to manage.
Expanding on Chris Lutz's idea, here is a very rudimentary implementation:
#!/usr/bin/perl
package My::ARGV::Reader;
use strict; use warnings;
use autodie;
use IO::Handle;
use overload
'<>' => \&reader,
'""' => \&argv,
'0+' => \&input_line_number,
;
sub new {
my $class = shift;
my $self = {
names => [ #_ ],
handles => [],
current_file => 0,
};
bless $self => $class;
}
sub reader {
my $self = shift;
return scalar <STDIN> unless #{ $self->{names}};
my $line;
while ( 1 ) {
my $current = $self->{current_file};
return if $current >= #{ $self->{names} };
my $fh = $self->{handles}->[$current];
unless ( $fh ) {
$self->{handles}->[$current] = $fh = $self->open_file;
}
if( eof $fh ) {
close $fh;
$self->{current_file} = $current + 1;
next;
}
$line = <$fh>;
last;
}
return $line;
}
sub open_file {
my $self = shift;
my $name = $self->{names}->[ $self->{current_file} ];
open my $fh, '<', $name;
return $fh;
}
sub argv {
my $self = shift;
my $name = #{$self->{names}}
? $self->{names}->[ $self->{current_file} ]
: '-'
;
return $name;
}
sub input_line_number {
my $self = shift;
my $fh = #{$self->{names}}
? $self->{handles}->[$self->{current_file}]
: \*STDIN
;
return $fh->input_line_number;
}
which can be used as:
package main;
use strict; use warnings;
my $it = My::ARGV::Reader->new(#ARGV);
echo($it);
sub echo {
my ($it) = #_;
printf "[%s:%d]:%s", $it, +$it, $_ while <$it>;
}
Output:
[file1:1]:bye bye
[file1:2]:hello
[file1:3]:thank you
[file1:4]:no translation
[file1:5]:
[file2:1]:chao
[file2:2]:hola
[file2:3]:gracias
[file2:4]:
It looks like this has already been implemented as Iterator::Diamond. Iterator::Diamond also disables the 2-argument-open magic that perl uses when reading <ARGV>. Even better, it supports reading '-' as STDIN, without enabling all the other magic. In fact, I might use it for that purpose just on single files.