Perl Code Sample

perl

There are more code samples on other pages as well.

Example A:

#!/usr/bin/perl -w
# Using tail -f to monitor log file while you are debugging is not quite efficient.
# For example, PuTTY can only scrollback certain number of lines, and when there is
# more lines to display, you can't see all of it.  Another problem with using tail -f
# is sometimes you forget to clear your screen when you start a fresh attempt, 
# therefore difficult to distinquish new data from old data.  When there is more than one log
# file to keep your eyes on, using tail -f, you would have to keep your eyes on
# multiple terminal screen.  While using this script, you will still have to use tail -f,
# and multiple terminals, but the data is written to files, and when all terminal stop 
# scrolling, you can press Ctrl+C to terminate this script, and open result files in your
# favorite editor, search for interesting pattern, etc...
use strict;
my $map = {}; # keys are name of log files to monitor, values are names of output file
$map->{'/var/log/qmail/current'} = "/tmp/logCapture/qmail_current";
$map->{'/var/log/qmail/smtpd/current'} = "/tmp/logCapture/qmail_smtpd_current";
my $currentPosition = {};
my $startup = 1;
while(1) {
    if ($startup) {
        foreach my $file (keys(%{$map})) {
            # find the current position of the log file
            open(FIN,"<$file") || die("Can not open $file for reading");
            seek(FIN,0,2); # seek to end of file
            $currentPosition->{$file} = tell(FIN);
            close(FIN);
            my $outfile = $map->{$file};
            # clear out previous captured data
            open(FOU,">$outfile") || die("Cannot open $outfile for writing");
            close(FOU);
        }
        print "Done finding ends of files.  Do whatever you need to do, and press Ctrl+c when the log files stop scrolling.\n";
        $startup = 0;
    } else {
        foreach my $file (keys(%{$map})) {
            open(FIN,"<$file") || die("Cannot open $file for reading $@ $! $^E $??");
            my $outfile = $map->{$file};
            open(FOU,">>$outfile") || die("Cannot open $outfile for writing");
            my $seekto = $currentPosition->{$file};
            seek(FIN,$seekto,0);
            while(my $line = ) {
                print FOU $line;
            }
            close(FOU);
            $currentPosition->{$file} = tell(FIN);
        }
    }
}

Sample B:

This sample code demonstrate:

  • a plugin for Nagios NRPE
  • using DBI::DBI to connect to database
#!/usr/bin/perl -w
# Plugin for Nagios to monitor a service
use strict;
use Getopt::Long;
use DBI;
use DBD::mysql;
use Data::Dumper qw(Dumper);
my $appWriteDB = `grep 'appWriteDB' /etc/mg/setup.conf | cut -f2-3 -d ':'`;
chomp($appWriteDB);
my $dsn = "DBI:mysql:database=mg;host=$appWriteDB";
my $dbh = DBI->connect($dsn,"mg","...");
my $sth = $dbh->prepare("select gurl, unix_timestamp(sendTime) as unix from testDriveGurls where sendTime <= now() order by sendTime ASC limit 1");
$sth->execute();
my $result = $sth->fetchrow_hashref();
my $file = "/tmp/clicker/detect_deadlock";
if ($result) {
    my $gurl = $result->{'gurl'};
    if (open(FIN,"<$file")) {
        my $line = ;
        close(FIN);
        chomp($line);
        my ($g,$t) = split(/\t/,$line,2);
        if (($gurl eq $g) && (time - 60 > $t)) {
            print "CRITICAL - Clicker queue seems stuck\n";
            exit(2);
        }
    } else {
        print "CRITICAL - Can not open $file for reading\n";
        exit(2);
    }
    if (open(FOU,">$file")) {
        print FOU $gurl,"\t",time;
        close(FOU);
    } else {
        print "CRITICAL - Can not open $file for writing\n";
        exit(2);
    }
    if (time - 60 > $result->{'unix'}) {
        my $minutes = int( (time - $result->{'unix'}) / 60 );
        print "CRITICAL - Clicker is $minute behind\n";
        exit(2);
    }
}
print "OK\n";
exit(0);

# 0: OK
# 1: Warning
# 2: Critical

Another sample:

This code demonstrates:

  • Iterating over an array
  • Accessing elements of an array
  • Accessing the argument of a sub-routine using shift
  • Extracting information from a string using regular expression, capturing, and $1 …
  • Using str2time to convert a date into a unix timestamp
  • Pushing data onto arrays that are inside hash
  • Sorting a hash based on its keys
use strict;
use Date::Parse;

my @access_logs = (
    'tomcat1_access_log.2014-03-30.txt',
    'tomcat1_access_log.2014-03-31.txt',
    'tomcat2_access_log.2014-03-30.txt',
    'tomcat2_access_log.2014-03-31.txt'
);
my $baseDirectory = 'C:\Users\kdoan\Desktop\MicroStrategyDocs\Logs\March312014\\';

my $access_log_entries_ping = {};
my $access_log_entries = {};
my $numberOfFiles = scalar(@access_logs);
my $file = '';
my $fh = '';
my $line = '';
my $pingFile = $baseDirectory . 'ping_access_log.txt';
my $pingFH = new IO::File();
if (! $pingFH->open("> $pingFile")) {
    die("Unable to open $pingFile for writing\n");
}
my $mergedFile = $baseDirectory . 'merged_access_log.txt';
my $mergedFH = new IO::File();
if (! $mergedFH->open("> $mergedFile")) {
    die("Unable to open $mergedFile for writing\n");
}

sub extractEpoch {
    $line = shift;
    $line =~ /\[((\d{2})\/(\D+)\/(\d{4}):(\d{2}):(\d{2}):(\d{2})\s+\-(\d{4}))\]/;
    my $date = $1;
    $date = str2time($date);
    return $date;
}

my $epoch = 0;
for (my $i = 0; $i < $numberOfFiles; $i++) {
    $file = $baseDirectory . @access_logs[$i];
    $file =~ /(tomcat\d+)/;
    my $tomcatInstance = $1;
    $fh = new IO::File();
    if ($fh->open("< $file")) {
        while (! $fh->eof()) {
            $line = $fh->getline();
            chomp($line);
            if ($line =~ /172\.16\.\d+\.\d+/) {
                next;
            }
            if ($line =~ /ping|server\-status/) {
                $epoch = extractEpoch($line);
                if (! $access_log_entries_ping->{$epoch}) {
                    $access_log_entries_ping->{$epoch} = [];
                }
                $line = $tomcatInstance . " - " . $line;
                push(@{$access_log_entries_ping->{$epoch}},$line);
            } else {
                if ($line =~ /\.(gif|png|js|css)/) {
                    next;
                }
                $epoch = extractEpoch($line);
                if (! $access_log_entries->{$epoch}) {
                    $access_log_entries->{$epoch} = [];
                }
                $line = $tomcatInstance . " - " . $line;
                push(@{$access_log_entries->{$epoch}},$line);
            }
        }
    } else {
        die("Not able to open $file for reading\n");
    }
}
my @indexes = ();
my $j;
@indexes = sort { $a <=> $b } keys($access_log_entries);
$j = scalar(@indexes);
for (my $i = 0; $i < $j; $i++) {
    $epoch = $indexes[$i];
    my @lines = @{$access_log_entries->{$epoch}};
    my $k = 0;
    my $m = scalar(@lines);
    for ($k = 0; $k < $m; $k++) {
        $line = $lines[$k];
        print $mergedFH $line,"\n";
    }
}
@indexes = sort { $a <=> $b } keys($access_log_entries_ping);
$j = scalar(@indexes);
for (my $i = 0; $i < $j; $i++) {
    $epoch = $indexes[$i];
    my @lines = @{$access_log_entries_ping->{$epoch}};
    my $k = 0;
    my $m = scalar(@lines);
    for ($k = 0; $k < $m; $k++) {
        $line = $lines[$k];
        print $pingFH $line,"\n";
    }
}

Another example:

#!/usr/bin/perl
$queue = "/var/qmail/queue/";
opendir(DIR,"${queue}mess");
@dirlist = grep '/\./', readdir DIR;
closedir DIR;
foreach $dir (@dirlist) {
    if (-e "${queue}mess/$dir/$inode") {
        $mess_loc = "${queue}mess/$dir/$inode";
        last;
    }
}
return $mess_loc;

Another example:

This example demonstrate:

  1. reading from stdin
  2. slurping the content of a file
#!/usr/bin/perl
use strict;
my $string = '';
{
    local $/ = undef;
    open FILE, "khai-pmta-deny-template.txt" or die "Couldn't open file: $!";
    binmode FILE;
    $string = <FILE>;
    close FILE;
}
print $string;
while (<>) {
    my $ip = $_;
    chomp($ip);
    my $x = $string;
    $x =~ s/REPLACEIP/$ip/;
    print $x;
}

Another example:

#!/usr/bin/perl -w
use strict;
use warnings;
use Net::DNS::Resolver;
my $r = Net::DNS::Resolver->new;

while(<>) {
        my $ip = $_;
        chomp($ip);
        my $reverse = join( '.', reverse( split /\./, $ip )) . '.in-addr.arpa';
        if (my $ap = $r->query( $reverse, 'PTR' )) {
                for my $pa ($ap->answer) {
                        print "$ip => ", $pa->ptrdname, $/;
                }
        } else {
                print "$ip => NXDOMAIN\n";
        }
}

The above code read a list of IP addresses from the standard input, do reverse DNS look up, and print the result on the same line.

Unless otherwise stated, the content of this page is licensed under Creative Commons Attribution-ShareAlike 3.0 License