how-do-i-add-lines-to-the-top-and-bottom-of-a-file-in-perl

use Tie::File;

tie @array, 'Tie::File', filename or die ...;
$array[13] = 'blah';     # line 13 of the file is now 'blah'
print $array[42];        # display line 42 of the file

$n_recs = @array;        # how many records are in the file?
$#array -= 2;            # chop two records off the end

for (@array) {
    s/PERL/Perl/g;         # Replace PERL with Perl everywhere in the file
}

# These are just like regular push, pop, unshift, shift, and splice
# Except that they modify the file in the way you would expect
push @array, new recs...;
my $r1 = pop @array;
unshift @array, new recs...;
my $r2 = shift @array;
@old_recs = splice @array, 3, 7, new recs...;

untie @array;            # all finished

Reference:

http://stackoverflow.com/questions/1230654/how-do-i-add-lines-to-the-top-and-bottom-of-a-file-in-perl

how-can-i-create-xml-from-perl

Reference: http://stackoverflow.com/questions/154762/how-can-i-create-xml-from-perl 

use strict;
use warnings;
use XML::LibXML;

my $doc = XML::LibXML::Document->new('1.0', 'utf-8');

my $root = $doc->createElement("my-root-element");
$root->setAttribute('some-attr'=> 'some-value');

my %tags = (
    color => 'blue',
    metal => 'steel',
);

for my $name (keys %tags) {
    my $tag = $doc->createElement($name);
    my $value = $tags{$name};
    $tag->appendTextNode($value);
    $root->appendChild($tag);
}

$doc->setDocumentElement($root);
print $doc->toString();

output:

<?xml version="1.0" encoding="utf-8"?>
<my-root-element some-attr="some-value">
    <color>blue</color>
    <metal>steel</metal>

</my-root-element>

how-do-you-round-a-floating-point-number-in-perl

    use POSIX;
    $ceil   = ceil(3.5);                        # 4
    $floor  = floor(3.5);                     # 3

Reference: http://stackoverflow.com/questions/178539/how-do-you-round-a-  floating-point-number-in-perl 

Difference between my $var and $main::var

#!/usr/bin/perl

use strict; 
use warnings; 
use diagnostics;
package main;
my $foo = "hello"; $main::foo = "world";
print "$foo $main::foo\n";

my $foo under the package main would manipulate the symbol table such that $foo were equal to $main::foo. 

If $foo and $main::foo were the same variable, then the program would print world world,which it does not.

If you fully qualify your variables in package main, then you don't need to worry with declaring them with my, nor with our, nor with use vars, as can also be seen in the program above (see that $main::foo is not declared; yet, the compiler doesn't complain about it, even though the program is running under use strict).

Checking size of log file and taking backup

I want to check the size of a logfile and if it exceeds 10KB :

1)I need to move to  [logfile_time_pid.log]  .

2)Truncate  backup logfile (remove top lines until size of logfile is less than 10KB)

3)Write them back to backup logfile.

4)Create a fresh new logfile.

Here is the code I wrote:

my $MaxLogSize=10240 if ! $MaxLogSize;
if( -s "$LOGFILE" > $MaxLogSize ) {
    my $logbkp_name = time . "_" . $$; # backup logname
    my $OLD = $LOGFILE; # storing originial logname in a new variable
    $LOGFILE =~ s/\.log$/\_$logbkp_name\.log/; #substitute original log name with backuplog name
    rename($OLD,$LOGFILE); #move original file to backup file
    my @lines = qx(tail -c 10240 $LOGFILE); #get the 10KB size lines removing toplines
    open(OUT,">$LOGFILE") or die "$!\n"; #recreate backup file
    foreach (@lines)
    {
      print OUT $_ ; #write the lines to backup file
    }
    close(OUT);
    open(FH,">$OLD") or die "$!\n"; create a fresh original logfile
    }

Passing Files as Arguments

The Glob method of passing files is very Perlistic, and as such appears incredibly inobvious to general purpose programmers not using Perl on a regular basis. The Glob method is useful when retrofitting file passing in programs using Perl's syntax. If you're starting fresh, consider filehandles.

Here's the Glob method:

sub printFile($)
{
my $fileHandle = $_[0];
while (<$fileHandle>)
{
my $line = $_;
chomp($line);
print "$line\n";
}
}

open(MYINPUTFILE,"<filename");
printFile(\*MYINPUTFILE);
close(MYINPUTFILE);


Output files work similarly.

If you need to assign the glob to an actual variable, you can do that also. The code in the subroutine remains the same, and the following is the code doing the passing:

open(MYINPUTFILE, "<filename");
my $fileGlob = \*MYINPUTFILE;
printFile($fileGlob);
close(MYINPUTFILE);

IPC

Another approach to IPC is to make your program talk to itself, in a manner of speaking. Actually, your process talks over pipes to a forked copy of itself. It works much like the piped open we talked about in the last section, except that the child process continues executing your script instead of some other command.

To represent this to the open function, you use a pseudocommand consisting of a minus. So the second argument to open looks like either "-|" or "|-", depending on whether you want to pipe from yourself or to yourself. As with an ordinary fork command, the open function returns the child's process ID in the parent process but 0 in the child process. Another asymmetry is that the filehandle named by the open is used only in the parent process. The child's end of the pipe is hooked to either STDIN or STDOUT as appropriate. That is, if you open a pipe to minus with |-, you can write to the filehandle you opened, and your kid will find this in STDIN:

if (open(TO, "|-")) { print TO $fromparent; } else { $tochild = <STDIN>; exit; }

< If you open a pipe from minus with -|, you can read from the filehandle you opened, which will return whatever your kid writes to STDOUT:

if (open(FROM, "-|")) { $toparent = <FROM>; } else { print STDOUT $fromchild; exit; }

One common application of this construct is to bypass the shell when you want to open a pipe from a command. You might want to do this because you don't want the shell to interpret any possible metacharacters in the filenames you're trying to pass to the command. If you're running release 5.6.1 or greater of Perl, you can use the multi-argument form of open to get the same result.

Set Date for a Logfile

sub SetDate

{

my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);

$year+=1900;

$mon++;

my $CurDate = sprintf("%02d/%02d/$year %02d:%02d:%02d",$mon,$mday,$hour,$min,$sec);

return $CurDate;

}

Fork a child process from parent and execute a child

This can be done using Fork and Exec Combination as said by Larry Wall:



FORK: {

if ($pid=fork) { # assign result of fork to $pid,

# see if it is non-zero.

# Parent process here

# Child pid is in $pid

print "child pid : $pid\n";

sleep $delay;

backup_log();

if(kill 0 => $pid) {#kill 0 checks whether a process is alive or not

push @pids,$pid; #Collect child pids who exceeded time limit or alive after delay

}

foreach my $pid (@pids) {

kill 9,$pid;

Debug("killing child script process $pid");

Debug("child script process $pid exited with RC=32;$RCDesc{32}");

}

Debug("Ending gsma_wrapper");

Debug("---------------------");

exit(0);

} elsif (defined($pid)) {

# Child process here

# parent process pid is available with getppid

my $ppid = getppid();

print "parent pid : $ppid\n";

# exec will transfer control to the child process, and will

# finish (exit) when the scirpt is done.

my $cmd = "sh $action_script";

Debug("executing action_script $cmd");

exec("$cmd 1>./stdout 2>./stderr") or log_exit("Action script $action_script failed with RC=10;$RCDesc{10}");

Debug("$RCDesc{0}");

} elsif ($! == EAGAIN) {

# EAGAIN is the supposedly recoverable fork error

sleep 5;

redo FORK;

} else {

#weird fork error

Debug("Can't fork action script $action_script: $!");

}

}

# wait for the action scrpt to complete and return status (like system does)

waitpid($pid,0);

$status = $?;

Handling timeouts in perl scripts

Reference link: http://larsmichelsen.com/perl/handing-timeouts-in-perl-scripts/



These timeouts can occur for several reasons. Mostly some network connections via SSH, SNMP or HTTP-Gets which run longer than the default check timeout in Nagios. I usually use a global check timeout of 15 seconds in Nagios. This means a check script which runs more than 15 seconds will be killed. In this case Nagios returns a CRITICAL state with a “(Service check timed out)” message. This is bad cause I don’t want those timeouts to result in CRITICAL state and some CRITICAL notifications.

Now read how to catch such timeouts…

I use the alarm(13) function in my Perl script. This functions sets a timer to the given number of seconds – in this case 13 seconds. When the timer reached zero it will throw a SIGALRM. Thankfully you can customize the event on SIGALRM. This gives my script the possibility to print some output and exit the script regular with a UNKNOWN exit code.



Here is my snippet to catch timeouts in perl scripts:



# Handle SIGALRM (timeout triggered by alarm() call)

$SIG{ALRM} = sub {

print "UNKNOWN: Script timed out\n";

exit -1;

};



# Start the timer to script timeout

alarm(13);



Other good source: http://www.trevorbowen.com/tag/perlstuff/

The Perl system() function is very powerful and elegant. It forks a child process, suspends the parent process, executes the provided command (potentially calling your shell to help parse the arguments), while seamlessly redirecting all IO between the parent and child process! The usage is simple, but what happens behind the scenes is amazing!

Unfortunately, there is no way to interrupt the system() function in Perl. Sure, you can kill the main Perl program, but that’s not what I want. I want to call system() with 2 additional arguments: timeout and maxattempts. This subroutine would operate just like the traditional system() function, unless operation time exceeded the timeout value, in which case, the command would be killed and restarted, until the maximum number of attempts was exceeded.

You can find many resources that detail how to timeout a long Perl operation, like so:

eval {

   local $SIG{ALRM} = sub { die "alarm clock restart" };

   alarm 10;

   flock(FH, 2);   # blocking write lock

   alarm 0;

};

if ($@ and $@ !~ /alarm clock restart/) { die }

Unfortunately, there is a little footnote that says you should not try this with system calls; otherwise, you get zombies. Sure enough, if you substitute a system() function for the above flock, the parent Perl script is alarmed by the timeout and exits the eval. Normally, this would kill the flock or any other function. But the system function persits. The parent may even complete the remainder of its program and exit, but the child will keep on ticking – not what I wanted. The second problem is that there is no way to get, or access the process id of the command executed by the system() function; therefore, there is no way to kill a system function call by the parent Perl process – at least, no way that I have found.

The above link suggests using fork and exec to create your own function, which is ultimately what I did. So, let’s jump straight to the chase scene, shall we? Here’s my final solution.

Preferred Solution

#!/usr/bin/perl -w

use strict 'refs';

use POSIX "sys_wait_h";



sub timedSystemCall {



 my ($cmd, $timeout, $maxattempts, $attempt, $origmax) = @_;



 # degenerate into system() call - infinite timeout, if timeout is undefined or negative

 $timeout = 0 unless defined($timeout) && ($timeout > 0);

 # degenerate into system() call - 1 attempt, if max attempts is undefined or negative

 $maxattempts = 1 unless defined($maxattempts) && ($maxattempts > 0);

 $attempt = 1 unless defined($attempt) && ($attempt > 0);

 $origmax = $maxattempts unless defined $origmax;



 local ($rc, $pid);



 eval {

   local $SIG{ALRM} = sub { die "TIMEOUT" };



   # Fork child, system process

 FORK: {

     if ($pid = fork) {

       # parent picks up here, with $pid = process id of child; however...

       # NO-OP - Parent does nothing in this case, except avoid branches below...

     } elsif (defined $pid) {  # $pid is zero if here defined

       # child process picks up here - parent process available with getppid()

       # execute provided command, or die if fails

       exec($cmd) || die("(E) timedSystemCall: Couldn't run $cmd: $!\n");

       # child never progresses past here, because of (exec-or-die) combo

     } elsif ($! =~ /No more processes/) {

       # Still in parent:  EAGAIN, supposedly recoverable fork error

       print STDERR "(W) timedSystemCall: fork failed.  Retrying in 5-seconds. ($!)\n";

       sleep 5;

       redo FORK;

     } else {

       # unknown fork error

       die "(E) timedSystemCall:  Cannot fork: $!\n";

     }

   }



   # set alarm to go off in "timeout" seconds, and call $SIG{ALRM} at that time

   alarm($timeout);

   # hang (block) until program is finished

   waitpid($pid, 0);



   # program is finished - disable alarm

   alarm(0);

   # grab output of waitpid

   $rc = $?;

 };                            # end of eval



 # Did eval exit from an alarm timeout?

 if (($@ =~ "^TIMEOUT") || !defined($rc)) {

   # Yes - kill process

   kill(KILL => $pid) || die "Unable to kill $pid - $!";

   # Collect child's remains

   ($ret = waitpid($pid,0)) || die "Unable to reap child $pid (ret=$ret) - $!";

   # grab exit output of child process

   if ($rc = $?) {

     # exit code is lower byte: shift out exit code, leave top byte in $rc

     my $exit_value = $rc >> 8;

     # killing signal is lower 7-bits of top byte, which was shifted to lower byte

     my $signal_num = $rc & 127;

     # core-dump flag is top bit

     my $dumped_core = $rc & 128;

     # Notify grandparent of obituary

     print STDERR "(I) timedSystemCall:  Child $pid obituary: exit=$exit_value, kill_signal=$signal_num, dumped_core=$dumped_core\n";

   }

   # Can we try again?

   if ($maxattempts > 1) {

     # Yes! Increment counter, for print messages

     $attempt++;

     print STDERR "(W) timedSystemCall:  Command timed-out after $timeout seconds.  Restarting ($attempt of $origmax)...\n";

     # Recurse into self, while decrementing number of attempts. Return value from deepest recursion

     return timedSystemCall($cmd, $timeout, $maxattempts-1, $attempt, $origmax);

   } else {

     # No!  Out of attempts...

     print STDERR "(E) timedSystemCall:  Exhausted maximum attempts ($origmax) for command: $cmd\nExiting!\n";

     # Return error code of killed process - will require interpretation by parent

     return $rc;

   }

 } else {

   # No - process completed successfully!  Hooray!!!  Return success code (should be zero).

   return $rc;

 }

}



exit timedSystemCall("inf.pl", 5, 3);

find the size of the largest file in current directory

#!usr/bin/perl

opendir(DIR,"./");
my @files = grep { -f $_ } readdir(DIR);
print "@files\n";
my $maxsize=0;
foreach my $file (@files)
{
$maxsize = (stat($file))[7] if (-s $file > $maxsize);
}
print "$maxsize\n";

Little info about stat function : ( perldoc -f stat from unix command line)

stat FILEHANDLE
stat EXPR
stat Returns a 13-element list giving the status info for a file, either the file opened via FILEHANDLE, or named by EXPR. If EXPR is omitted,
it stats $_. Returns a null list if the stat fails. Typically used as follows:

($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
= stat($filename);

Not all fields are supported on all filesystem types. Here are the meanings of the fields:

0 dev device number of filesystem
1 ino inode number
2 mode file mode (type and permissions)
3 nlink number of (hard) links to the file
4 uid numeric user ID of fileâs owner
5 gid numeric group ID of fileâs owner
6 rdev the device identifier (special files only)
7 size total size of file, in bytes
8 atime last access time in seconds since the epoch
9 mtime last modify time in seconds since the epoch
10 ctime inode change time in seconds since the epoch (*)
11 blksize preferred block size for file system I/O
12 blocks actual number of blocks allocated

(The epoch was at 00:00 January 1, 1970 GMT.)

(*) The ctime field is non-portable. In particular, you cannot expect it to be a "creation time", see "Files and Filesystems" in perlport
for details.

If "stat" is passed the special filehandle consisting of an underline, no stat is done, but the current contents of the stat structure
from the last "stat", "lstat", or filetest are returned. Example:

if (-x $file && (($d) = stat(_)) && $d < 0) {
print "$file is executable NFS file\n";
}

(This works on machines only for which the device number is negative under NFS.)

Because the mode contains both the file type and its permissions, you should mask off the file type portion and (s)printf using a "%o" if
you want to see the real permissions.

$mode = (stat($filename))[2];
printf "Permissions are %04o\n", $mode & 07777;

In scalar context, "stat" returns a boolean value indicating success or failure, and, if successful, sets the information associated with
the special filehandle "_".

The File::stat module provides a convenient, by-name access mechanism:

use File::stat;
$sb = stat($filename);
printf "File is %s, size is %s, perm %04o, mtime %s\n",
$filename, $sb->size, $sb->mode & 07777,
scalar localtime $sb->mtime;
continued...............