Perl cannot open file; from Ploteig script - perl

I am a total novice when it comes to computer programming and perl, so please forgive me if this question is simple!
I am trying to run a perl script (called ploteig, a component of a free genetics program download, Eigenstrat:Eigenstrat software) that works fine until I get to line 96-
open (YY, ">$dfile") || die "can't open $dfile\n" ;
I am given the error that the file is unable to be opened and the script dies.
Below, I have provided the entire code for you (since honestly, I have no idea what part of the code could be influencing the inability to open the file). The code uses input from a file created previously with Eigenstrat, example of 4 rows, 12 columns:
#eigvals: 20.388 7.503 4.033 2.929 2.822 2.726 2.700 2.590 2.451 2.365
GREY_BI_011_COMSTOCK_11 0.0164 0.0164 0.0382 -0.1283 -0.0658 0.0406 0.0322 0.0105 -0.0851 -0.0625 Case
GREY_BI_014_COMSTOCK_14 0.0191 0.0094 0.0567 -0.0250 0.0804 -0.0531 -0.0165 0.0321 0.1130 -0.0025 Control
GREY_BI_015_COMSTOCK_15 0.0221 -0.0042 -0.0031 0.0091 0.1448 0.0351 0.0430 0.0359 0.0049 0.0791 Control
(rows represent individual sample pca scores, columns specific pcas. First column sample names, last column case or control status)
Additionally, I call the code as follows:
perl ploteig –i combogreyout.pca.evec –p Case:Control –s Out –c 1:2 –x –o utploteig.xtxt –k
I am really unsure where to go from here. I tried changing the file permissions and ensuring it was in the working directory, but it wouldn’t allow me to change permissions and everything pointed to being in the correct directory. However, I am unsure if either of these are the real problem.
I would very much appreciate any help anyone can give me!
Thank you SO much!
> #!/usr/bin/perl -w
### ploteig -i eigfile -p pops -c a:b [-t title] [-s stem] [-o outfile] [-x] [-k] [-y]
[-z sep] [-f fixgreen]
use Getopt::Std ;
use File::Basename ;
## pops : separated -x = make postscript and pdf -z use another separator
## -k keep intermediate files
## NEW if pops is a file names are read one per line
getopts('i:o:p:c:s:d:z:t:xkyf',\%opts) ;
$postscmode = $opts{"x"} ;
$oldkeystyle = $opts{"y"} ;
$kflag = $opts{"k"} ;
$keepflag = 1 if ($kflag) ;
$keepflag = 1 unless ($postscmode) ;
$dofixgreen = ( exists $opts{"f"} ? $opts{"f"} : 0 );
$zsep = ":" ;
if (defined $opts{"z"}) {
$zsep = $opts{"z"} ;
$zsep = "\+" if ($zsep eq "+") ;
}
$title = "" ;
if (defined $opts{"t"}) {
$title = $opts{"t"} ;
}
if (defined $opts{"i"}) {
$infile = $opts{"i"} ;
}
else {
usage() ;
exit 0 ;
}
open (FF, $infile) || die "can't open $infile\n" ;
#L = (<FF>) ;
chomp #L ;
$nf = 0 ;
foreach $line (#L) {
next if ($line =~ /\#/) ;
#Z = split " ", $line ;
$x = #Z ;
$nf = $x if ($nf < $x) ;
}
printf "## number of fields: %d\n", $nf ;
$popcol = $nf-1 ;
if (defined $opts{"p"}) {
$pops = $opts{"p"} ;
}
else {
die "p parameter compulsory\n" ;
}
$popsname = setpops ($pops) ;
print "$popsname\n" ;
$c1 = 1; $c2 =2 ;
if (defined $opts{"c"}) {
$cols = $opts{"c"} ;
($c1, $c2) = split ":", $cols ;
die "bad c param: $cols\n" unless (defined $cols) ;
}
$stem = "$infile.$c1:$c2" ;
if (defined $opts{"s"}) {
$stem = $opts{"s"} ;
}
$gnfile = "$stem.$popsname.xtxt" ;
if (defined $opts{"o"}) {
$gnfile = $opts{"o"} ;
}
#T = () ; ## trash
open (GG, ">$gnfile") || die "can't open $gnfile\n" ;
print GG "## " unless ($postscmode) ;
print GG "set terminal postscript color\n" ;
print GG "set title \"$title\" \n" ;
print GG "set key outside\n" unless ($oldkeystyle) ;
print GG "set xlabel \"eigenvector $c1\" \n" ;
print GG "set ylabel \"eigenvector $c2\" \n" ;
print GG "plot " ;
$np = #P ;
$lastpop = $P[$np-1] ;
$d1 = $c1+1 ;
$d2 = $c2+1 ;
foreach $pop (#P) {
$dfile = "$stem:$pop" ;
push #T, $dfile ;
print GG " \"$dfile\" using $d1:$d2 title \"$pop\" " ;
print GG ", \\\n" unless ($pop eq $lastpop) ;
chomp $dfile;
open (YY, ">$dfile") || die "can't open $dfile\n" ;
foreach $line (#L) {
next if ($line =~ /\#/) ;
#Z = split " ", $line ;
next unless (defined $Z[$popcol]) ;
next unless ($Z[$popcol] eq $pop) ;
print YY "$line\n" ;
}
close YY ;
}
print GG "\n" ;
print GG "## " if ($postscmode) ;
print GG "pause 9999\n" ;
close GG ;
if ($postscmode) {
$psfile = "$stem.ps" ;
if ($gnfile =~ /xtxt/) {
$psfile = $gnfile ;
$psfile =~ s/xtxt/ps/ ;
}
system "gnuplot < $gnfile > $psfile" ;
if ( $dofixgreen ) {
system "fixgreen $psfile" ;
}
system "ps2pdf $psfile " ;
}
unlink (#T) unless $keepflag ;
sub usage {
print "ploteig -i eigfile -p pops -c a:b [-t title] [-s stem] [-o outfile] [-x] [-k]\n" ;
print "-i eigfile input file first col indiv-id last col population\n" ;
print "## as output by smartpca in outputvecs \n" ;
print "-c a:b a, b columns to plot. 1:2 would be common and leading 2 eigenvectors\n" ;
print "-p pops Populations to plot. : delimited. eg -p Bantu:San:French\n" ;
print "## pops can also be a filename. List populations 1 per line\n" ;
print "[-s stem] stem will start various output files\n" ;
print "[-o ofile] ofile will be gnuplot control file. Should have xtxt suffix\n";
print "[-x] make ps and pdf files\n" ;
print "[-k] keep various intermediate files although -x set\n" ;
print "## necessary if .xtxt file is to be hand edited\n" ;
print "[-y] put key at top right inside box (old mode)\n" ;
print "[-t] title (legend)\n" ;
print "[-f] fix green and yellow colors\n";
print "The xtxt file is a gnuplot file and can be easily hand edited. Intermediate files
needed if you want to make your own plot\n" ;
}
sub setpops {
my ($pops) = #_ ;
local (#a, $d, $b, $e) ;
if (-e $pops) {
open (FF1, $pops) || die "can't open $pops\n" ;
#P = () ;
foreach $line (<FF1>) {
($a) = split " ", $line ;
next unless (defined $a) ;
next if ($a =~ /\#/) ;
push #P, $a ;
}
$out = join ":", #P ;
print "## pops: $out\n" ;
($b, $d , $e) = fileparse($pops) ;
return $b ;
}
#P = split $zsep, $pops ;
return $pops ;
}

Related

Next line array if a condition is achieved

I have a text in a file F1 each sentence in line, and another file contain the part of speech(POS) of each word in the text for example:
F1 contains:
he lives in paris\n
he jokes
F2 contains:
he pro\n
lives verb\n
in prep\n
paris adv_pl\n
he pro\n
jokes verb\n
I would like to parse each sentence of F1 and extract the POS of each word. I arrived to extract the POS of the first sentence, but the program can't parse the second line. This is the code:
open( FILE, $filename ) || die "Problème d'ouverture du ficher en entrée";
open( FILEOUT, ">$filenameout" ) || die "Problème d'ouverture";
open( F, "/home/ahmed/Bureau/test/corpus.txt" ) || die " Pb pour ouvrir";
open( F2, "/home/ahmed/Bureau/test/corp.txt" ) || die " Pb pour ouvrir";
my $z;
my $y = 0;
my $l;
my $li;
my $pos;
while ( $ligne = <F> ) {
while ( $li = <F2> ) { # F2 POS
chomp($li);
# prem contain the first word of F2 in each line,
# deux contain the POS of this word
( $prem, $deux ) = ( $li =~ m/^\W*(\w+)\W+(\w+)/ );
print "premier: $prem\n";
chomp($ligne);
#val = split( / /, $ligne ); # corpus de texte
$l = #val;
while ( $y < $l ) { # $l length of sentence
$z = $val[$y];
print "z : $z\n";
if ( $z eq $prem ) {
print "true\n";
$pos .= "POSw" . $y . "=" . $deux . " ";
++$y;
} else {
last;
}
}
}
print FILEOUT "$pos\n";
$pos = "";
}
The result I had in the terminal:
premier: he
z : he
true
premier : lives
z : lives
true
premier : in
z : in
true
premier : paris
z : paris
true
premier : he
premier : jokes
The first sentence has 4 words, when it pass 4, we must go to the next line in the text, I can't arrive to solve it.
There are some issues in your script.
You must always use strict; use warnings; to show the most common syntax and/or typing errors, unused variables, etc.
You should always use the three-parameter open and no global FILEHANDLEs (see opentut).
You should use some sensible names for your filehandles, not FH, FH1, etc. but $fh_sentences and $fh_grammar (or other meaningful names).
So far for the general part. Now let's get more specific:
Your outer loop (F) reads the sentences one by one. The next loop (F2) reads the grammatical types but it does so only once for the first sentence. When the F2 file is read, subsequent calls to <F2> will always return undef because the file was already read. You have to reset the filepointer to the beginning of the file after each sentence or -- even better -- read the file F2 in advance and store its contents in a hash.
Iterating over an array of words in a sentence is easier with foreach my $word (#words). No need to do the housekeeping of index variables (like $y) yourself.
chomping and splitting the sentences should be moved outside the F2 loop because $ligne doesn't change in the loop and only burns CPU cycles.
Putting this together I end up with this:
use strict;
use warnings;
# Read the grammar file, F2, into a hash:
my %grammar;
open( my $fh_grammar, '<', 'F2' ) or die "Pb pour ouvrir F2: $!\n";
while( my $ligne = <$fh_grammar> ) {
my ($prem, $deux) = ( $ligne =~ m/^\W*(\w+)\W+(\w+)/ );
$grammar{$prem} = $deux;
}
close($fh_grammar);
# The hash is now:
# %grammar = (
# 'he' => 'pro',
# 'lives => 'verb',
# 'in' => 'prep',
# 'paris' => 'adv_pl'
# 'jokes' => 'verb'
# );
# Read the sentences from F1 and check the grammar:
open( my $fh_sentences, '<', 'F1' ) or die "Pb pour ouvrir F1: $!\n";
while( my $ligne = <$fh_sentences> ) {
my #words = split(/\s+/, $ligne );
foreach my $word (#words) {
print "z: $word\n";
if ( exists $grammar{$word} ) {
print "true; $grammar{$word}\n";
}
}
print "\n";
}
close($fh_sentences);
Output:
z: he
true; pro
z: lives
true; verb
z: in
true; prep
z: paris
true; adv_pl
z: he
true; pro
z: jokes
true; verb
You can solve the above problem in different way like :
First read the POS file and put it in hash
Code :
my $filename = "F2";
open FH2, $filename or die "Error";
my %POS_hash;
while(<FH2>)
{
chomp($_);
my #arr = split(/ /, $_); # you can change the split function
$POS_hash{$arr[0]} = $arr[1];
}
Now read your file and replace it with the POS
my $filename1 = "F1";
open FH1, $filename1 or die "Error";
while(<FH1>)
{
chomp($_);
my #arr = split(/ /, $_); # you can change the split function
foreach my $val (#arr)
{
if(exists $POS_hash{$val})
{
print "$POS_hash{$val}\t";
}
}
print "\n";
}
I believe this is a better way for your problem. Hope this will solve your problem.

append text after match from multiple file locations

Am a noob when it comes to coding so bear with me... I am trying to write a script that will input data from 3 separate files into 3 specific locations within a text file - for example:
edited to read easier
#start of script
start_of_line1_text "$1" end_of_line1_text
start_of_line2_text "$2" end_of_line2_text
start_of_line3_text "$3" end_of_line3_text
#output to text when done
$1 is the value in text1
$2 is the value in text2
$3 is the value in text3
I am thinking of using sed but cant quite work out how this would be done...
Or just insert a word at $1 after matching random_text? ie:
sed '/start_of_line1_text/ a middle_of_line1_text' input
Also on a larger scale - if text1,2 and 3 had multiple values in how could you import these values 1 at a time and save a new file each time? so for example:
text1 =
a
b
c
text2 =
e
f
g
text3 =
h
i
j
#start of script
start_of_line1_text "line one of text1" end_of_line1_text
start_of_line2_text "line one of text2" end_of_line2_text
start_of_line3_text "line one of text3" end_of_line3_text
#output to text when done
then:
#start of script
start_of_line1_text "line two of text1" end_of_line1_text
start_of_line2_text "line two of text2" end_of_line2_text
start_of_line3_text "line two of text3" end_of_line3_text
#output to text when done
Im not fussy on the language used I am just a bit stuck as to how to fit this all together....
Many thanks in advance
This problem suits very well awk.
Give this a try:
awk '!f[FNR] {f[FNR]=("out" FNR ".txt"); print "#start of script" >f[FNR]} {print "random_text \"" $0 "\" some_other_text" >f[FNR]} END {for(n in f) print "#output to text when done">f[n]}' text1 text2 text3
The output files are generated in current directory out1.txt and out2.txt etc.
You can provide any number of text files as input at the end of the command.
There is below the script file version with additional parameters:
#!/usr/bin/awk -f
!f[FNR] {
f[FNR]=("out" FNR ".txt")
print first >f[FNR]
}
{
print start $0 end >f[FNR]
}
END {
for(n in f) print last>f[n]
}
The test:
chmod +x ./script.awk
./script.awk -v first="#start of script" \
-v start="random_text \"" -v end="\" some_other_text"\
-v last="#output to text when done" \
text1 text2 text3
what I have so far is:
#!/usr/bin/perl
use strict;
use warnings;
sub rtrim { my $s = shift; $s =~ s/\s+$//; return $s };
sub read_file_line {
my $fh = shift;
if ($fh and my $line = <$fh>) {
chomp $line;
return [split(/\t/,$line)];
}
return;
}
open(my $f1, "file1.txt");
open(my $f2, "file2.txt");
open(my $f3, "file3.txt");
open(FILE, ">group.txt") or die "Cannot open file";
my $pair1 = read_file_line($f1);
my $pair2 = read_file_line($f2);
my $pair3 = read_file_line($f3);
while ($pair1 and $pair2 and $pair3) {
printf '%s,',$pair1->[0] ;
printf "%s\n",$pair2->[0] ;
printf '%s,',$pair3->[0] ;
printf FILE " line1_text\n" ;
printf FILE " line2_text\n" ;
printf FILE " line3_text\n" ;
printf FILE " start_of_line4_text\"%s\end_of_line4_text\n",$pair3->[0] ;
printf FILE " start_of_line5_text\"%s\end_of_line5_text\n",$pair2->[0] ;
printf FILE " start_of_line6_text\"%s\end_of_line6_text\n",rtrim($pair1->[0]) ;
printf FILE " line7_text\n" ;
printf FILE " line8_text\n\n\n" ;
$pair1 = read_file_line($f1);
$pair2 = read_file_line($f2);
$pair3 = read_file_line($f3);
}
close($f1);
close($f2);
close($f3);
close(FILE) ;

Perl special variable "#_" in a subroutine not working

This script rips out the urls from a downloaded webpage. I had some trouble with this script - when I use the "my $csv_html_line = #_ ;"
and then print out the "#html_LineArray" - it just prints out "1's". When I replace the
"my $csv_html_line = #_ ;" with "my $csv_html_line = shift ;" the script works fine.
I do not know what the difference is betweeh the "= #_" and shift - becuase I thought that
without specifying something, in a subroutine, shift shift froms "#_".
#!/usr/bin/perl
use warnings;
use strict ;
sub find_url {
my $csv_html_line = #_ ;
#my $csv_html_line = shift ;
my #html_LineArray = split("," , $csv_html_line ) ;
print "#html_LineArray\n" ;
#foreach my $split_line(#html_LineArray) {
# if ($split_line =~ m/"adUrl":"(http:.*)"/) {
# my $url = $1;
# $url =~ tr/\\//d;
# print("$url\n") ;
# }
#}
}
my $local_file = "#ARGV" ;
open(my $fh, '<', "$local_file") or die "cannot open up the $local_file $!" ;
while( my $html_line = <$fh>) {
#print "$html_line\n";
find_url($html_line) ;
}
This is what the above prints out.
1
1
1
1
1
1
1
1
1
1
1
1
This works fine - it uses the shift instead of "#_"
#!/usr/bin/perl
use warnings;
use strict ;
sub find_url {
#my $csv_html_line = #_ ;
my $csv_html_line = shift ;
my #html_LineArray = split("," , $csv_html_line ) ;
#print "#html_LineArray\n" ;
foreach my $split_line(#html_LineArray) {
if ($split_line =~ m/"adUrl":"(http:.*)"/) {
my $url = $1;
$url =~ tr/\\//d;
print("$url\n") ;
}
}
}
my $local_file = "#ARGV" ;
open(my $fh, '<', "$local_file") or die "cannot open up the $local_file $!" ;
while( my $html_line = <$fh>) {
#print "$html_line\n";
find_url($html_line) ;
}
It's
my ($csv_html_line) = #_ ;
The way you wrote the code you evaluated #_ in scalar context and got its length (number of elements). As you noted,
my $csv_html_line = shift;
works because the shift operator takes a list and removes and returns the first element as a scalar.
You need
my ($csv_html_line) = #_ ;
as assigning an array to a scalar will return its length (which is 1 with one parameter)

Run a background process in perl, don't wait for it to finish

EDIT: found a solution here:
http://www.webmasterworld.com/forum13/4416.htm
Apparently it's way easier to do on Linux servers than Windows, google came through.
#Print out whatever you're going to print
print "Stuff in progress. Thanks."
# Close the I/O handles
close(STDIN);
close(STDOUT);
close(STDERR);
# run your other code here
I don't work in perl at all so the easiest solution is best for me. I'm just trying to figure out how to modify this program to make it do what I want.
Basically what this program is the broker for a UI. What it does is take a program name, print commands to a SAS program file including which SAS program to run to create output, then runs the SAS program, which then outputs the $pname.out file at the end, which is what is finally printed to the UI screen.
The latest SAS program created can take a long time, so I plan to to run the SAS program in the background as the child and have the SAS send an email when it's done.
In the foreground i.e. parent, I want to have the perl program return a screen with some basic info.
So my question basically is, how do I tell perl to run the child process in the background and not wait for it to be done?
I tried "&" on the end of the system ("$SASROOT $saschild") command, but it just prevented the program from running at all. If I use the command without "&", the program doesn't return anything to the browser screen until the child is done running.
Any help would be appreciated!
#!perl
use CGI ;
# YOUR MODIFICATIONS START HERE
$TEMPFILES = "c:\\temp"; # This is the directory SAS will write its temporary files
$PROGROOT = "c:\\Inetpub\\wwwroot\\Effectiveness"; # This is the directory that contains the SAS programs to run
$DATAROOT = "c:\\Inetpub\\wwwroot\\Effectiveness" ; # This is the directory that contains the SAS data sets to be analysed
$SASROOT = "D:\\SAS\\SASFoundation\\9.2\\sas.exe"; # This is the full path name of the SAS System
$CGIBIN = "\\" ; # This is the alias of cgi-bin directory
$HTTPURL ="http://10.240.7.172" ;
$WEBROOT = "c:\\Inetpub\\wwwroot\\Effectiveness" ; # This is the root directory of webserver
$SASCFG = "d:\\SAS\\SASFoundation\\9.2\\SASV9.CFG" ; # This is the path to SAS config file
# YOUR MODIFICATIONS END HERE
&get_request;
$PROGFILE = $rqpairs{'_program'};
if (!($PROGFILE =~ /^(\w[\w\.\-]+)$/))
{
&error("The hidden field <CODE>_program</CODE> (= \"$PROGFILE\") is invalid or missing.");
}
$SASPROG="$PROGROOT\\$PROGFILE.sas";
if (!-f $SASPROG)
{
&error("The program file \"$SASPROG\" does not exist.");
}
$pname = "p$$";
$cname = "c$$" ;
$repname = "r$$" ;
$random = int(rand("$$"));
$pname = "$pname$random" ;
$cname = "$cname$random" ;
$repname = "$repname$random" ;
open(OUTCON, "+>>$TEMPFILES\\$cname.sas") ;
print OUTCON "-set outfl \"$TEMPFILES\\$pname.out\" \n" ;
#print OUTCON "%include \"$TEMPFILES\\config.tpl\" \n";
print OUTCON "%include \"$SASCFG\" \n";
close(OUTCON) ;
open(OUTFI,"+>>$TEMPFILES\\$pname.sas");
print OUTFI "options set=cgibin \"$CGIBIN/broker.pl\" ; \n" ;
print OUTFI "options set=location \"$DATAROOT\" ; \n" ;
print OUTFI "options set=webroot \"$WEBROOT\" ; \n" ;
print OUTFI "options set=outfl \"$TEMPFILES\\$pname.out\" ; \n" ;
print OUTFI "options set=outrep \"$WEBROOT\\$repname.xls\" ; \n" ;
print OUTFI "options set=repline \"$HTTPURL\\broker.pl?_program=_result\" ; \n" ;
print OUTFI "options set=excel_file=\"$repname.xls\" ; \n" ;
print OUTFI "options mprint ; \n" ;
while ( ($name,$value) = each %rqpairs )
{
$value =~ s/([%()])/%$1/g ;
# $value =~ tr/ /\n/s ;
# $value =~ tr/,/,\n/s ;
# $in_string =~ tr/\+/ /s; # translate and squeeze multiple spaces
if ($name ne "var")
{
print OUTFI "%let $name = %nrstr($value);\n";
}
}
print OUTFI "%include \"$SASPROG\";\n";
close(OUTFI) ;
$sasoptions = " -nodms -sysin $TEMPFILES\\$pname.sas -log $TEMPFILES\\$pname.log -work $TEMPFILES -sasuser $TEMPFILES" ;
#THIS IS THE FORKING OF THE PROCESS - only fork for rfcost application
my $pid = fork();
if (defined $pid && $pid == 0){
#child
close STDIN; #close connections to webpage
close STDOUT; #close connections to webpage
$saschild = " -nodms -sysin $TEMPFILES\\TestOutput.sas -log $TEMPFILES\\TestOutput.log -work $TEMPFILES -sasuser $TEMPFILES" ;
system ("$SASROOT $saschild");
exit(0);
}
# sleep(120);
system ("$SASROOT $sasoptions");
#system ("$SASROOT -rsasuser -noterminal -sysparm -sysin $TEMPFILES\\$pname.sas -log $TEMPFILES\\$pname.log -config $TEMPFILES\\$cname.sas");
print "HTTP/1.0 200 OK\n";
print "Content-type: text/html\n\n";
&html_trailer;
#print "$sasoptions" ;
open (FILE, "$TEMPFILES\\$pname.out");
while (<FILE>){ print; }
close (FILE);
&html_trailer;
#unlink("$TEMPFILES/$pname.sas");
#unlink("$TEMPFILES/$pname.log");
#unlink("$TEMPFILES/$pname.lst");
#unlink("$TEMPFILES/$pname.out");
#unlink("$TEMPFILES/$cname.sas");
sub get_request
{
if ($ENV{'REQUEST_METHOD'} eq "POST") {
read(STDIN, $request, $ENV{'CONTENT_LENGTH'});
} elsif ($ENV{'REQUEST_METHOD'} eq "GET" ) {
$request = $ENV{'QUERY_STRING'};
}
%rqpairs = ();
#rqarray = &url_decode(split(/[&=]/, $request));
while ( $key = shift(#rqarray) )
{
$value = shift(#rqarray);
if ( $rqpairs{$key} ne "" )
{
$rqpairs{$key} .= "," . $value;
}
else
{
$rqpairs{$key} = $value;
}
}
}
sub url_decode
{
foreach (#_)
{
tr/+/ /;
s/%(..)/pack("c",hex($1))/ge;
}
#_;
}
sub html_header
{
local($title) = #_;
print "HTTP/1.0 200 OK\n";
print "Content-type: text/html\n\n";
print "<html><head>\n";
print "<title>$title</title>\n";
print "</head>\n<body>\n";
}
sub html_trailer
{
local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst)
= gmtime;
local($mname) = ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul",
"Aug", "Sep", "Oct", "Nov", "Dec")[$mon];
local($dname) = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri",
"Sat")[$wday];
# print "<br><p>Date: $hour:$min:$sec on $dname $mday $mname $year</p> \n" ;
print "</body></html>\n";
}
sub error
{
local($msg) = #_;
&html_header("SAS CGI Process Error");
print "<H1>SAS CGI Process Error</H1>\n$msg\n";
&html_trailer;
exit 1;
}
Use exec (as quicoju suggested) to execute a command in background
See here for more details: http://perldoc.perl.org/functions/exec.html
exec PROGRAM LIST
The exec function executes a system command and never returns; use system instead of exec if you want it to return. It fails and returns false only if the command does not exist and it is executed directly instead of via your system's command shell (see below).
A very good answer you will find in this thread: What's the difference between Perl's backticks, system, and exec?
There are various CPAN modules which may make task easier, for example http://search.cpan.org/~bzajac/Proc-Background-1.10/lib/Proc/Background.pm
Having said that, I'd consider introducing some job queue, so your process puts task into the queue and separate process picks it up to handle, more manageable...

How to get perl code output to STDOUT/STDERR and a file, in realtime and cross-platform?

I need to get the output of normal Perl code to the screen and into a logfile at the same time. However a problem is that the runtime of the tool can be hours. Using Capture::Tiny's tee that means the log file will only be written to once the script terminates, which is not very useful.
To further complicate things, i need to capture the output of straight perl from the same process, as well as that of processes called with system().
Lastly, due to employer restrictions it needs to work on Win32 as well.
What other options do i have?
Use PerlIO::Util.
Just tested it under Strawberry Perl 5.12.1 32 bit and it works perfectly, so it'll be cross platform. The below code does exactly as you'd expect. And since it modifies the actual STDOUT and STDERR file handles, any writes to them will automatically be teed.
use strict;
use warnings;
use IO::Handle;
use PerlIO::Util;
use 5.012;
for (*STDOUT, *STDERR) {
$_->autoflush; $_->push_layer(tee => ">>stdout.txt");
}
for (1..10) {
say $_;
warn $_ unless $_ % 2;
}
Since none of the presented solutions were satisfactory i sat down and solved the problem on my own:
Capture::Tiny::Extended
If your program runs on a Linux/Unix platform, then you can use tee command. Tee reads stdin and writes to stdout and to a specified file.
Example:
myprogram.pl 2>&1 |tee mylog.txt
The only caveat is that stdout and stderr will be merged in the same file.
Since you are on a Windows platform, you can search Google por tee.exe, or you can try this minimalistic perl version of tee:
$|=1;
if ( !$ARGV[0] ) {
print "Usage: some_command \| tee.pl [-a] logfile\n";
exit(1);
}
# Append mode
my $mode='>';
if ($ARGV[0] eq '-a')
{
$mode='>>';
shift;
}
my $LOGFILE=$ARGV[0];
while (<STDIN>) {
print;
open( OUT, "$mode $LOGFILE");
print OUT $_;
close OUT;
# Your logic here!
}
Example:
perl myprogram.pl 2>&1 |perl tee.pl mylog.txt
I would really try to avoid modifying source code just to capture STDOUT and/or STDERR more and more if you are going to make system calls.
You can use IO::Tee.
Create an special tee filehandle.
Edit your program. Change all prints to stdout into prints to this filehandle.
When required, redefine the tee filehandle to print to stdout only, or to print to 2 or more files.
Use `` instead os system() to capture programs output and print them to the special filehandle.
If you prefer not using any module, create your own "myprint" function. It could print to stdout and, if a global flag is enabled, print to a logfile too.
sub myPrint
{
print #_;
if ($LOGMODE)
{
open(LOGFILE, ">>$logfile");
print LOGFILE #_;
close LOGFILE;
}
}
package Logger ;
# docs at the end ...
# capture conditionally the output of the command
# $objLogger->LogDebugMsg ( "Running $cmd : \n $cmd " ) ;
# $objLogger->LogDebugMsg ( `$cmd 2>&1` ) ;
use lib '.' ; use strict ; use warnings ; use Carp qw(cluck);
our ( $MyBareName , $LibDir , $RunDir ) = () ;
BEGIN {
$RunDir = '' ;
$0 =~ m/^(.*)(\\|\/)(.*)\.([a-z]*)/;
$RunDir = $1 if defined $1 ;
push ( #INC , $RunDir) ;
#debug print join ( ' ' , #INC ) ;
} #eof sub
use Timer ; use FileHandler ;
# the hash holding the vars
our $confHolder = () ;
# ===============================================================
# START OO
# the constructor
sub new {
my $self = shift;
#get the has containing all the settings
$confHolder = ${ shift #_ } ;
# Set the defaults ...
Initialize () ;
return bless({}, $self);
} #eof new
BEGIN {
# strip the remote path and keep the bare name
$0=~m/^(.*)(\\|\/)(.*)\.([a-z]*)/;
my ( $MyBareName , $RunDir ) = () ;
$MyBareName = $3;
$RunDir= $1 ;
push ( #INC,$RunDir ) ;
} #eof BEGIN
sub AUTOLOAD {
my $self = shift ;
no strict 'refs';
my $name = our $AUTOLOAD;
*$AUTOLOAD = sub {
my $msg = "BOOM! BOOM! BOOM! \n RunTime Error !!!\nUndefined Function $name(#_)\n" ;
print "$self , $msg";
};
goto &$AUTOLOAD; # Restart the new routine.
}
sub DESTROY {
my $self = shift;
#debug print "the DESTRUCTOR is called \n" ;
return ;
}
END {
close(STDOUT) || die "can't close STDOUT: $! \n\n" ;
close(STDERR) || die "can't close STDERR: $! \n\n" ;
}
# STOP OO
# =============================================================================
sub Initialize {
$confHolder = { Foo => 'Bar' , } unless ( $confHolder ) ;
# if the log dir does not exist create it
my $LogDir = '' ;
$LogDir = $confHolder->{'LogDir'} ;
# create the log file in the current directory if it is not specified
unless ( defined ( $LogDir )) {
$LogDir = $RunDir ;
}
use File::Path qw(mkpath);
if( defined ($LogDir) && !-d "$LogDir" ) {
mkpath("$LogDir") ||
cluck ( " Cannot create the \$LogDir : $LogDir $! !!! " ) ;
}
# START set default value if value not specified =========================
# Full debugging ....
$confHolder->{'LogLevel'} = 4
unless ( defined ( $confHolder->{'LogLevel'} ) ) ;
$confHolder->{'PrintErrorMsgs'} = 1
unless ( defined ( $confHolder->{'PrintErrorMsgs'} ) ) ;
$confHolder->{'PrintDebugMsgs'} = 1
unless ( defined ($confHolder->{'PrintDebugMsgs'})) ;
$confHolder->{'PrintTraceMsgs'} = 1
unless ( defined ( $confHolder->{'PrintTraceMsgs'} )) ;
$confHolder->{'PrintWarningMsgs'} = 1
unless ( defined ( $confHolder->{'PrintWarningMsgs'} ) ) ;
$confHolder->{'LogMsgs'} = 1
unless ( defined ( $confHolder->{'LogMsgs'} ) ) ;
$confHolder->{'LogTimeToTextSeparator'} = '---'
unless ( defined ( $confHolder->{'LogTimeToTextSeparator'} ) ) ;
#
# STOP set default value if value not specified =========================
} #eof sub Initialize
# =============================================================================
# START functions
# logs an warning message
sub LogErrorMsg {
my $self = shift ;
my $msg = "#_" ;
my $msgType = "ERROR" ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'LogMsgs'} == 0 ) ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'PrintErrorMsgs'} == 0 ) ;
$self->LogMsg( $msgType , "$msg" ) if ( $confHolder->{'PrintErrorMsgs'} == 1 ) ;
} #eof sub
# logs an warning message
sub LogWarningMsg {
my $self = shift ;
my $msg = "#_" ;
my $msgType = 'WARNING' ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'LogMsgs'} == 0 ) ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'PrintWarningMsgs'} == 0 ) ;
$self->LogMsg( $msgType , "$msg" ) if ( $confHolder->{'PrintWarningMsgs'} == 1 ) ;
} #eof sub
# logs an info message
sub LogInfoMsg {
my $self = shift ;
my $msg = "#_" ;
my $msgType = 'INFO' ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'LogMsgs'} == 0 ) ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'PrintInfoMsgs'} == 0 ) ;
$self->LogMsg( $msgType , "$msg" ) if ( $confHolder->{'PrintInfoMsgs'} == 1 ) ;
} #eof sub
# logs an trace message
sub LogTraceMsg {
my $self = shift ;
my $msg = "#_" ;
my $msgType = 'TRACE' ;
my ($package, $filename, $line) = caller();
# Do not print anything if the PrintDebugMsgs = 0
return if ( $confHolder->{'PrintTraceMsgs'} == 0 ) ;
$msg = "$msg : FROM Package: $package FileName: $filename Line: $line " ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'LogMsgs'} == 0 ) ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'PrintTraceMsgs'} == 0 ) ;
$self->LogMsg( $msgType , "$msg" ) if ( $confHolder->{'PrintTraceMsgs'} == 1 ) ;
} #eof sub
# logs an Debug message
sub LogDebugMsg {
my $self = shift ;
my $msg = "#_" ;
my $msgType = 'DEBUG' ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'LogMsgs'} == 0 ) ;
# Do not print anything if the PrintWarningMsgs = 0
return if ( $confHolder->{'PrintDebugMsgs'} == 0 ) ;
$self->LogMsg( $msgType , "$msg" ) if ( $confHolder->{'PrintDebugMsgs'} == 1 ) ;
} #eof sub
sub GetLogFile {
my $self = shift ;
#debug print "The log file is " . $confHolder->{ 'LogFile' } ;
my $LogFile = $confHolder->{ 'LogFile' } ;
#if the log file is not defined we create one
unless ( $confHolder->{ 'LogFile' } ) {
$LogFile = "$0.log" ;
}
return $LogFile ;
} #eof sub
sub BuildMsg {
my $self = shift ;
my $msgType = shift ;
my $objTimer= new Timer();
my $HumanReadableTime = $objTimer->GetHumanReadableTime();
my $LogTimeToTextSeparator = $confHolder->{'LogTimeToTextSeparator'} ;
my $msg = () ;
# PRINT TO STDOUT if
if ( $msgType eq 'WARNING'
|| $msgType eq 'INFO'
|| $msgType eq 'DEBUG'
|| $msgType eq 'TRACE' ) {
$msg = " $HumanReadableTime $LogTimeToTextSeparator $msgType : #_ \n" ;
}
elsif ( $msgType eq 'ERROR' ) {
$msg = " $HumanReadableTime $LogTimeToTextSeparator $msgType : #_ \n" ;
}
else {
$msg = " $HumanReadableTime $LogTimeToTextSeparator $msgType #_ \n" ;
}
return $msg ;
} #eof sub BuildMsg
sub LogMsg {
my $self = shift ;
my $msgType = shift ;
my $msg = $self->BuildMsg ( $msgType , #_ ) ;
my $LogFile = $self -> GetLogFile();
# Do not print anything if the LogLevel = 0
return if ( $confHolder->{'LogLevel'} == 0 ) ;
# PRINT TO STDOUT if
if (
$confHolder->{'PrintMsgs'} == 1
|| $confHolder->{'PrintInfoMsgs'} == 1
|| $confHolder->{'PrintDebugMsgs'} == 1
|| $confHolder->{'PrintTraceMsgs'} == 1
) {
print STDOUT $msg ;
}
elsif ( $confHolder->{'PrintErrorMsgs'} ) {
print STDERR $msg ;
}
if ( $confHolder->{'LogToFile'} == 1 ) {
my $LogFile = $self -> GetLogFile();
my $objFileHandler = new FileHandler();
$objFileHandler->AppendToFile( $LogFile , "$msg" );
} #eof if
#TODO: ADD DB LOGGING
} #eof LogMsg
# STOP functions
# =============================================================================
1;
__END__
=head1 NAME
Logger
=head1 SYNOPSIS
use Logger ;
=head1 DESCRIPTION
Provide a simple interface for dynamic logging. This is part of the bigger Morphus tool : google code morphus
Prints the following type of output :
2011.06.11-13:33:11 --- this is a simple message
2011.06.11-13:33:11 --- ERROR : This is an error message
2011.06.11-13:33:11 --- WARNING : This is a warning message
2011.06.11-13:33:11 --- INFO : This is a info message
2011.06.11-13:33:11 --- DEBUG : This is a debug message
2011.06.11-13:33:11 --- TRACE : This is a trace message : FROM Package: Morphus
FileName: E:\Perl\sfw\morphus\morphus.0.5.0.dev.ysg\sfw\perl\morphus.pl Line: 52
=head2 EXPORT
=head1 SEE ALSO
perldoc perlvars
No mailing list for this module
=head1 AUTHOR
yordan.georgiev#gmail.com
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2011 Yordan Georgiev
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.1 or,
at your option, any later version of Perl 5 you may have available.
VersionHistory:
1.4.0 --- 2011.06.11 --- ysg --- Separated actions of building and printing msgs. Total refactoring. Beta .
1.3.0 --- 2011.06.09 --- ysg --- Added Initialize
1.2.0 --- 2011.06.07 --- ysg --- Added LogInfoErrorMsg print both to all possible
1.1.4 --- ysg --- added default values if conf values are not set
1.0.0 --- ysg --- Create basic methods
1.0.0 --- ysg --- Stolen shamelessly from several places of the Perl monks ...
=cut