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.

Another example:

#!/opt/local/bin/perl
use strict;
use warnings;
use Getopt::Long;
use IO::File ();
use LWP ();
use HTML::TreeBuilder ();
use WWW::Mechanize ();

my $infile;
my $outfile;

GetOptions(
    "infile=s" => \$infile,
    "outfile=s" => \$outfile
);

my $fho = IO::File->new();
if (! $fho->open(">>$outfile")) {
    die("Error: Not able to open $outfile for writing.");
}

my $mech = WWW::Mechanize->new();

my $fhi = IO::File->new();
my $cnt = 1;
if ($fhi->open("<$infile")) {
    my $line;
    while ($line = <$fhi>) {
        chomp($line);
        if ($line eq "") {
            next;
        }
        my $uri = URI->new($line);
        if ($uri->scheme eq "http") {
            $uri->scheme("https");
        }
        $line = $uri->as_string();
        $mech->get($line);
        my $body = $mech->content();
        my $root = HTML::TreeBuilder->new_from_content($body);
        $root->elementify();
        my ($title) = $root->look_down('_tag','title');
        $title = $title->as_text;
        $title =~ s/\-\s*YouTube//g;
        print $fho $line . ' - ' . $title,"\n";
        print STDOUT "Processing line #". $cnt . ",URL: " . $line,"\n";
        $cnt = $cnt + 1;
    }
} else {
    die("Error: Not able to open $infile for reading.");
}
$fhi->close();
$fho->close();