Mine Perl Script
my$sth = $dbh->prepare("SELECT city,state address FROM address ");
$sth->execute;
DBI::dump_results($sth);
The above script works fine and it showing output well as bellow
'aaa', 'aa'
'aaa', 'aa'
'city', 'KA'
'city', 'KA'
'city', 'KA'
My question is the resultent output is should be saved in .csv file in my local machine . Is it possible achieve as my requirement, Please let me know
Try this:
my $csv = Text::CSV->new ( { eol => "\n" } );
my $sql = "SELECT city,state address FROM address";
my $rows = $dbh->selectall_arrayref($sql);
open $fh, ">", "new.csv" or die "new.csv: $!";
for my $row (#$rows) {
$csv->print ($fh, $row);
}
close $fh or die "new.csv: $!";
Fetch from the $sth and use Text::CSV_XS or Text::CSV to produce CSV data:
my $select = $db->prepare('select city, state address from address');
$select->execute;
my $c = 'Text::CSV'->new({ eol => "\n" });
open my $OUT, '>', 'new.csv' or die $!;
while (my $row = $select->fetchrow_arrayref) {
$c->print($OUT, $row);
}
close $OUT or die $!;
This is all you need, tested code.
my $csv = Text::CSV->new( { eol => "\n" } );
open my $fh, ">", "data.csv" or die $!;
foreach my $row ( #{ $dbh->selectall_arrayref("SELECT city,state address FROM address") } ) {
$csv->print( $fh, $row );
}
close $fh;
Related
I have a standardized way of writing comments before and after a function.
For example before declaring any function I write,
!---------------------------
! NAME_OF_FUNC (no)
!---------------------------
where no is the nth function in a given file containing multiple functions.
I know that a function e.g begins with (Fortran convention) either subroutine NAME_OF_SUB or function NAME_OF_FUNC. Hence, my end result would be
!---------------------------
! NAME_OF_FUNC (no)
!---------------------------
function NAME_OF_FUNC(...)
end function
!---------------------------
Can somebody show an example of how to write a bash script or in any other scripting language a code that can go through all my source files and the standard convention I just showed an example of?
Here is an example in Perl. It does not take backup before overwriting (I would recommend that you try to improve this script and add backup functionality). It also does not add the end of subroutine marker. But it would easy to add that functionality, please try. It also assumes that you want to modify all *.f95 files in the current directory and all its sub directories:
use feature qw(say state);
use strict;
use warnings;
use File::Find::Rule;
my #files = File::Find::Rule->new->name('*.f95')->in('.');
for my $fn (#files) {
open ( my $fh, '<', $fn ) or die "Could not open file '$fn': $!";
my $txt = do {local $/; <$fh>};
close $fh;
process_txt( \$txt );
save_txt( $fn, \$txt );
}
sub save_txt {
my ( $fn, $txt ) = #_;
open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!";
print $fh $$txt;
close $fh;
}
sub process_txt {
my ( $txt ) = #_;
my $i = 1;
$$txt =~ s/^(.*(?i:function|subroutine)\s+)([a-zA-Z_]+)(\s*\(.*$)/
do_substitution($1, $2, $3, $i++)/egmx;
}
sub do_substitution {
my ( $head, $name, $end, $i ) = #_;
my $line = $head . $name . $end;
$line =~ s/\s+$//;
my $N = length $line;
my $cline = '!' . '-' x $N;
my $mline = '! ' . $name;
my $snum = "($i)";
my $M = (length $mline) + (length $snum);
my $mspc = ($N > $M) ? (' ' x ($N-$M)) : ' ';
$mline = $mline . $mspc . $snum;
my $new_txt = join "\n", $cline, $mline, $cline, $line;
return $new_txt;
}
Using Strawberry Perl 5.22.0 in Windows 7. Is there a more "perlish" way to write this snippet of code? I hate the duplication of file open sections, but cannot think of a way to make it only open once because of the requirement to test the creation time.
...
my $x;
my $fh;
my $sentinelfile = "Logging.yes"; #if this file exists then enable logging
my $logfile = "transfers.log";
my $log = 0; #default to NO logging
$log = 1 if -e $sentinelfile; #enable logging if sentinel file exists
if($log){
#logfile remains open after this so remember to close at end of program!
if (-e $logfile) { #file exists
open($fh, "<", $logfile); #open for read will NOT create if not exist
chomp ($x = <$fh>); #grab first row
close $fh;
if (((scalar time - $x)/3600/24) > 30) { #when ~30 days since created
rename($logfile, $logfile . time); #rename existing logfile
open($fh, ">", $logfile); #open for write and truncate
print $fh time,"\n"; #save create date
print $fh "--------------------------------------------------\n";
} else { #file is not older than 30 days
open($fh, ">>", $logfile); #open for append
}
} else { #file not exist
open($fh, ">", $logfile); #open new for write
print $fh time,"\n"; #save create date
print $fh "--------------------------------------------------\n";
}
} #if $log
...
To recap: logfile logs stuff. First row of file contains the logfile creation date. Second row contains horizontal rule. Rest of file contains text. Around 30 days after file was created, rename file and start a new one. After the above chunk of code the logfile is open and ready for logging stuff. It gets closed at the end of the rest of the program.
There are other, non-cosmetic problems with your code: a) You do not ever check if your calls to open succeeded; b) You are creating a race condition. The file can come into existence after the -e check has failed. The subsequent open $fh, '>' ... would then clobber it; c) You don't check if your rename call succeeded etc.
The following would be a partial improvement on your existing code:
if ($log) {
if (open $fh, '<', $logfile) { #file exists
chomp ($x = <$fh>);
close $fh
or die "Failed to close '$logfile': $!";
if (((time - $x)/3600/24) > 30) {
my $rotated_logfile = join '.', $logfile, time;
rename $logfile => $rotated_logfile
or die "Failed to rename '$logfile' to '$rotated_logfile': $!";
open $fh, '>', $logfile
or die "Failed to create '$logfile'";
print $fh time, "\n", '-' x 50, "\n";
}
else {
open $fh, '>>', $logfile
or die "Cannot open '$logfile' for appending: $!";
}
}
else {
open $fh, '>', $logfile
or die "Cannot to create '$logfile': $!";
print $fh time, "\n", '-' x 50, "\n";
}
}
It would be better to abstract every bit of discrete functionality to suitably named functions.
For example, here is a completely untested re-write:
use autouse Carp => qw( croak );
use constant SENTINEL_FILE => 'Logging.yes';
use constant ENABLE_LOG => -e SENTINEL_FILE;
use constant HEADER_SEPARATOR => '-' x 50;
use constant SECONDS_PER_DAY => 24 * 60 * 60;
use constant ROTATE_AFTER => 30 * SECONDS_PER_DAY;
my $fh;
if (ENABLE_LOG) {
if (my $age = read_age( $logfile )) {
if ( is_time_to_rotate( $age ) ) {
rotate_log( $logfile );
}
else {
$fh = open_log( $logfile );
}
}
unless ($fh) {
$fh = create_log( $logfile );
}
}
sub is_time_to_rotate {
my $age = shift;
return $age > ROTATE_AFTER;
}
sub rotate_log {
my $file = shift;
my $saved_file = join '.', $file, time;
rename $file => $saved_file
or croak "Failed to rename '$file' to '$saved_file': $!"
return;
}
sub create_log {
my $file = shift;
open my $fh, '>', $file
or croak "Failed to create '$file': $!";
print $fh time, "\n", HEADER_SEPARATOR, "\n"
or croak "Failed to write header to '$file': $!";
return $fh;
}
sub open_log {
my $file = shift;
open my $fh, '>>', $file
or croak "Failed to open '$file': $!";
return $fh;
}
sub read_age {
my $file = shift;
open my $fh, '<', $file
or return;
defined (my $creation_time = <$fh>)
or croak "Failed to read creation time from '$file': $!";
return time - $creation_time;
}
If you need to read a line of a file, rename it and then work with it, you have to open it twice.
However, you can also do away with using that first line.
On Windows, according to perlport (Files and Filesystems), the inode change time time-stamp (ctime) "may really" mark the file creation time. This is likely to be completely suitable for a log file that doesn't get manipulated and moved around. It can be obtained with the -C file-test operator
my $days_float = -C $filename;
Now you can numerically test this against 30. Then there is no need to print the file's creation time to its first line (but you may as well if it is useful for viewing or other tools).
Also, there is the module Win32API::File::Time, with the purpose to
provide maximal access to the file creation, modification, and access times under MSWin32
Plese do read the docs for some caveats. I haven't used it but it seems tailored for your need.
A good point is raised in a comment: apparently the OS retains the original time-stamp as the file is being renamed. In that case, when the file's too old copy it into a new one (with the new name) and delete it, instead of using rename. Then open that log file anew, so with a new time-stamp.
Here is a complete example
archive_log($logfile) if -f $logfile and -C $logfile > 30;
open my $fh_log, '>>', $logfile or die "Can't open $logfile: $!";
say $fh_log "Log a line";
sub archive_log {
my ($file) = #_;
require POSIX; POSIX->import('strftime');
my $ts = strftime("%Y%m%d_%H:%M:%S", localtime); # 20170629_12:44:10
require File::Copy; File::Copy->import('copy');
my $archive = $file . "_$ts";
copy ($file, $archive) or die "Can't copy $file to $archive: $!";
unlink $file or die "Can't unlink $file: $!";
}
The archive_log archives the current log by copying it and then removes it.
So after that we can just open for append, which creates the file if not there.
The -C tests for file existence but since its output is used in a numerical test we need -f first.
Since this happens once a month I load modules at runtime, with require and import, once the log actually need be rotated. If you already use File::Copy then there is no need for this. As for the time-stamp, I threw in something to make this a working example.
I tested this on UNIX, by changing -C to -M and tweaking the timestamp by touch -t -c.
Better yet, to reduce the caller's code fully move the tests into the sub as well, for
my $fh_log = open_log($logfile);
say $fh_log "Log a line";
sub open_log {
my ($file) = #_;
if (-f $file and -C $file > 30) {
# code from archive_log() above, to copy and unlink $file
}
open my $fh_log, '>>', $file or die "Can't open $file: $!";
return $fh_log;
}
Note. On UNIX the file's creation time is not kept anywhere. The closest notion is the ctime above, but this is of course different. For one thing, it changes with many operations, for instance mv, ln, chmod, chown, chgrp (and probably others).
I have hundreds of files, each with different number of entries (>xxxx) and want to keep only shared entries among all files, separately. I'm not sure what is the best method to do this, maybe perl! I used sort, uniq of bash, but I didn't get the correct answer. The format of IDs start with > and follows 4 characters among all files.
1.fa
>abcd
CTGAATGCC
2.fa
>abcd
AAATGCGCG
>efgh
CGTAC
3.fa
>abcd
ATGCAATA
>efgh
TAACGTAA
>ijkl
TGCAA
Final results, of this example would be:
1.fa
>abcd
CTGAATGCC
2.fa
>abcd
AAATGCGCG
3.fa
>abcd
ATGCAATA
This Perl program will do as you ask. It uses Perl's built-in edit in place functionality and renames the original files to 1.fa.bak etc. It shouldn't have a problem with blank lines in your data as long as the sequence is always on one line immediately following the ID
use strict;
use warnings 'all';
my #files = glob '*.fa';
printf "Processing %d file%s\n", scalar #files, #files == 1 ? "" : "s";
exit if #files < 2;
my %ids;
{
local #ARGV = #files;
while ( <> ) {
++$ids{$1} if /^>(\S+)/;
}
}
# remove keys that aren't in all files
delete #ids{ grep { $ids{$_} < #files } keys %ids };
my $n = keys %ids;
printf "%d ID%s common to all files\n", $n, $n == 1 ? '' : "s";
exit unless $n;
{
local #ARGV = #files;
local $^I = '.bak';
while ( <> ) {
next unless /^>(\S+)/ and $ids{$1};
print;
print scalar <>;
}
}
Here is Perl solution, that may help you:
use feature qw(say);
use strict;
use warnings;
my $file_dir = 'files';
chdir $file_dir;
my #files = <*.fa>;
my $num_files = scalar #files;
my %ids;
for my $file (#files) {
open ( my $fh, '<', $file) or die "Could not open file '$file': $!";
while (my $id = <$fh>) {
chomp $id;
chomp (my $sequence = <$fh>);
$ids{$id}++;
}
close $fh;
}
for my $file (#files) {
open ( my $fh, '<', $file) or die "Could not open file '$file': $!";
my $new_name = $file . '.new';
open ( my $fh_write, '>', $new_name ) or die "Could not open file '$new_name': $!";
while (my $id = <$fh>) {
chomp $id;
chomp (my $sequence = <$fh>);
if ( $ids{$id} == $num_files ) {
say $fh_write $id;
say $fh_write $sequence;
}
}
close $fh_write;
close $fh;
}
It assumes that all the .fa files are located in the directory named $file_dir, and it writes the new sequences to new files in the same directory. The new file names get the .new extension.
<>
while running a perl script in unix , which works perfectly in windows strawberry, i am getting following error:
cant locate object method "new" via package "Text::CSV"
Any insights to identify this is highly appreciated
Scripts:
#!/usr/bin/perl
use strict;
use warnings;
use Net::LDAP;
use Text::CSV;
use Net::LDAP::E#ntry;
use File::Basename;
use File::chmod;
use Config::Tiny;
use File::Copy;
use Text::Trim;
use Data::Dumper qw(Dumper);
use Net::LDAP::Util qw(ldap_error_text);
use Net::LDAP::Constant;
my $config = Config::Tiny->read('config.ini');
#Variable Declaration section
my ($bindhost,$port,$bindpwd,$binddn,$base_search,$ldap,$customerCode,$logDir,$entry,$result,$csv,$file,$line,$data,$cn,$dn,$entry2,$start_timestamp,$new,$u,$ct,$old,$logfile,$max,$stop_timestamp);
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
$start_timestamp = sprintf ( "%04d%02d%02d %02d:%02d:%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec);
foreach my $section (keys %{$config}) {
#LDAP Binding Connectivity variables declaration
$bindhost = $config->{$section}->{'ldap_host'};
$port = $config->{$section}->{'ldap_port'};
$bindpwd = $config->{$section}->{'ldap_password'};
$binddn = $config->{$section}->{'ldap_user'};
$base_search = $config->{$section}->{'ldap_customers_ou_dn'};
$logDir = $config->{$section}->{'log_dir'};
# connect to the ldap server
my $ldap = Net::LDAP->new($bindhost,port=>$port,timeout=>240) or die "Could not bind to ldap server: $! - $#\n";
$result = $ldap->bind
(
dn => trim($binddn), password=>trim($bindpwd)
);
#Open Script directory over here
opendir(DIR, ".");
my #files = grep(/\.csv$/,readdir(DIR));
closedir(DIR);
$csv = Text::CSV->new({ sep_char => ',' });
#print "\n Script starts processing for the timings $start_timestamp";
#Visit each .csv file by checking its naming convention over here
my $fileCt = 0;
if($file=$ARGV[0]){
print "\n Script starts processing for the timings $start_timestamp";
$ct = 1;
open($data, '<', $file) or die "Could not open given file \n";
open($logfile, '>>', 'logfile.txt');
print $logfile "Script started running for file $file at ".$start_timestamp."\n";
close $logfile;
while ($line = <$data>){
if ($csv->parse($line)) {
my #fields = $csv->fields();
$customerCode = $fields[0];
$result = $ldap->search(
base => "$base_search",
filter => "(&(customerCode=$customerCode))",
);
die ldap_error_text($result->code) if $result->code;
$max = $result->count;
if($max == 0) {
open($logfile, '>>', 'logfile.txt');
print $logfile "This customerCode $customerCode was not found in LDAP and was not reset\n";
close $logfile
}
else {
open($logfile, '>>', 'logfile.txt');
print $logfile "This customerCode $customerCode was found in LDAP and is reset\n";
close $logfile
}
for (my $index = 0 ; $index < $max ; $index++) {
my $entry = $result->entry($index);
$u = ${$entry->get('uid')}[0];
$dn = "uid=$u,$base_search";
}
my #all = ();
#all = trim($result->entries);
foreach $entry (#all){}
$entry = Net::LDAP::Entry->new;
$entry->dn($dn);
$entry->replace(
'cn' => " ",
'userPassword'=> "",
'challengeQuestion'=> "",
'challengeAnswer'=> "",
'ctscPasswordCreationDate'=> "",
'ctscPasswordExpirationDate'=> "",
'ctscPasswordHistory'=> "",
'ctscPasswordResetAttempts'=> "",
'ctscPasswordLockoutEnable'=> "",
'ctscLastResetDate'=> "",
'ctscFailedLoginCount'=> "",
);
$entry->update ($ldap);
$old = ${$entry->get('cn')}[0];
$old = ${$entry->get('userPassword')}[0];
$old = ${$entry->get('challengeQuestion')}[0];
$old = ${$entry->get('challengeAnswer')}[0];
$old = ${$entry->get('ctscPasswordCreationDate')}[0];
$old = ${$entry->get('ctscPasswordExpirationDate')}[0];
$old = ${$entry->get('ctscPasswordHistory')}[0];
$old = ${$entry->get('ctscPasswordResetAttempts')}[0];
$old = ${$entry->get('ctscPasswordLockoutEnable')}[0];
$old = ${$entry->get('ctscLastResetDate')}[0];
$old = ${$entry->get('ctscFailedLoginCount')}[0];
$entry2 = $entry->clone; # copies entry
$ldap->modify($dn, replace => {'cn' => "" });
$ldap->modify($dn, replace => {'userPassword' => "" });
$ldap->modify($dn, replace => {'challengeQuestion' => "" });
$ldap->modify($dn, replace => {'challengeAnswer' => "" });
$ldap->modify($dn, replace => {'ctscPasswordCreationDate' => "" });
$ldap->modify($dn, replace => {'ctscPasswordExpirationDate' => "" });
$ldap->modify($dn, replace => {'ctscPasswordHistory' => "" });
$ldap->modify($dn, replace => {'ctscPasswordResetAttempts' => "" });
$ldap->modify($dn, replace => {'ctscPasswordLockoutEnable' => "" });
$ldap->modify($dn, replace => {'ctscLastResetDate' => "" });
$ldap->modify($dn, replace => {'ctscFailedLoginCount' => "" });
}
else {
warn "Line could not be parsed: $line\n";
}
$ct++;
} #End while loop
my ($sec1,$min1,$hour1,$mday1,$mon1,$year1,$wday1,$yday1,$isdst1)=localtime(time);
$stop_timestamp = sprintf ( "%04d%02d%02d %02d:%02d:%02d",$year1+1900,$mon1+1,$mday1,$hour1,$min1,$sec1);
print "\n Script ends Here for the timings - $stop_timestamp ";
open($logfile, '>>', 'logfile.txt');
print $logfile "Processing stopped at ".$stop_timestamp."\n";
close $logfile;
close $data;
} #if file pattern checking loop ends
else {
print "\n Please provide a .csv file as an input";
}
}
CSV.pm:
use Text::CSV;
my #rows;
my $csv = Text::CSV->new ( { binary => 1 } ) # should set binary attribute.
or die "Cannot use CSV: ".Text::CSV->error_diag ();
open my $fh, "<:encoding(utf8)", "test.csv" or die "test.csv: $!";
while ( my $row = $csv->getline( $fh ) ) {
$row->[2] =~ m/pattern/ or next; # 3rd field should match
push #rows, $row;
}
$csv->eof or $csv->error_diag();
close $fh;
$csv->eol ("\r\n");
open $fh, ">:encoding(utf8)", "new.csv" or die "new.csv: $!";
$csv->print ($fh, $_) for #rows;
close $fh or die "new.csv: $!";
#
# parse and combine style
#
$status = $csv->combine(#columns); # combine columns into a string
$line = $csv->string(); # get the combined string
$status = $csv->parse($line); # parse a CSV string into fields
#columns = $csv->fields(); # get the parsed fields
$status = $csv->status (); # get the most recent status
$bad_argument = $csv->error_input (); # get the most recent bad argument
$diag = $csv->error_diag (); # if an error occured, explains WHY
$status = $csv->print ($io, $colref); # Write an array of fields
# immediately to a file $io
$colref = $csv->getline ($io); # Read a line from file $io,
# parse it and return an array
# ref of fields
$csv->column_names (#names); # Set column names for getline_hr ()
$ref = $csv->getline_hr ($io); # getline (), but returns a hashref
$eof = $csv->eof (); # Indicate if last parse or
# getline () hit End Of File
$csv->types(\#t_array); # Set column types
I don't know what your second block of code is for. It looks like you copied the SYNOPSIS from the CPAN page of Text::CSV.
However, in your program you have a use TEXT::CSV and then you get this error message:
cant locate object method "new" via package "Text::CSV"
That error message is a dead givaway.
You don't have Text::CSV installed on your Unix box. Install it from CPAN.
I have hash which looks like this:
$VAR1 = {
'638047' => {
'commands' => 'perl nSWIFT/bin/tqtest.pl -var clist=',
},
'638049' => {
'commands' => 'perl nSWIFT/bin/tqtest.pl-var clist=',
}
};
I want to create a directory such that the file name starts with hash values and it stores the numbers that are generated by running the commands given as perl nswift/bin/tqtest.pl -var clist=. The numbers should be stored in the same file as their key. For example:
'638047' -> '638050' and '638049' -> '638051'
then it should be stored accordingly.
It have tried this but not getting there.
my %stat
my #qbsid_filename = keys %stat;
foreach (#qbsid_filename){
open QBS, ">/root/qbsid/$_";
}
my $newqbsid, #files;
opendir (DIREC, '/root/qbsid') or die $!;
foreach my $qbsid ( keys %stat){
my $cmd = $stat{$qbsid}->{commands};
if ($cmd =~ m/perl(.*)/){
$ex_cmd = $1;
}
$newqbsid = qx | perl $ex_cmd|;
}
close (DIREC);
I am not very good with algorithms. So, finding it difficult.
Please inform me if I am going wrong somewhere or you need more information. Thanks.
Try this:
my %stat = { ... };
while (my ($qbsid_filename, $qbsid) = each %stat) {
my $cmd = $qbsid->{commands};
next unless $cmd =~ m/^perl/;
open my $qbs, '>', "/root/qbsid/$qbsid_filename"
or die "Cannot open $qbsid_filename: $!";
open my $qbscmd, '-|', "$cmd"
or die "Cannot execute $cmd: $!";
while (<$qbscmd>) {
print $qbs $_;
}
close ($qbscmd);
close ($qbs);
}