Amazing Perl

A Simple Perl Logger with Log Timestamp in Milliseconds

2015-02-15T16:12:00.000+08:00

A simple Per Logger with log timestamp in milliseconds.

#!/usr/bin/perl
use strict;
use Time::HiRes qw/gettimeofday/;
use POSIX qw/strftime/;

log_error("This is error");
log_info("This is information");

############################################################
# Logger - Error
############################################################
sub log_error {
    my $message = shift;
    log_it( $message, "ERROR" );
}

############################################################
# Logger - Info
############################################################
sub log_info {
    my $message = shift;
    log_it( $message, "INFO" );
}

############################################################
# Logger - Info
############################################################
sub log_it {
    my $message = shift;
    my $level   = shift;
    my ( $time, $ms ) = gettimeofday();
    my $logtimestamp = 
         strftime( "%Y-%m-%d %H:%M:%S", localtime($time) );

    $ms = sprintf( "%03d", $ms / 1000 );
    printf( "%s.%03d %-5s %s\n", 
         $logtimestamp, $ms, $level, $message );
}

Sample Output

2015-02-15 16:27:34.822 ERROR This is error
2015-02-15 16:27:34.823 INFO  This is information

How to Find UTC Time Offset from your Local Time?

2015-01-22T21:11:00.001+08:00

This is the sample script to find the offset in seconds of your local time from GMT.

#!/usr/bin/perl
use strict;

use POSIX;

my @local = localtime();
my @utc   = gmtime();

my $timezone_offset = mktime(@local) - mktime(@utc);

print "Offset in second(s) from GMT = $timezone_offset\n";
print "Offset in hour(s) from GMT = " . ($timezone_offset / 3600) . "\n";

Output:

Offset in second(s) from GMT = 28800
Offset in hour(s) from GMT = 8

Use Notepad++ as Perl IDE

2013-01-12T23:58:00.001+08:00

If you are looking for a fast and small in size text editor as Perl IDE, Notepad++ probably one of the best choice. By default, Notepad++ will not run Perl script within the editor, you need install and configure "NppExec" plugin to allow this.
Follows the below steps:

Install "NppExec" from "Plugin Manager".
After installed the plugin, from "Plugins" menu, choose "NppExec" -> "Execute...".
Copy the following script and click "Save..." to save it as "Run Perl". Click "OK" to close the dialog.
```
NPP_SAVE
cd "$(CURRENT_DIRECTORY)"
C:\perl\bin\perl "$(FILE_NAME)" 
```
From "Plugins" menu, choose "NppExec" -> "Advanced Options...".
Check "Place to the Macros submenu" which allows us to execute the script from "Macros" menu.
Type "Run Perl" in "Item name" text box and associate it with "Run Perl" script, and click "Add/Modify" to create it. menu item. Click "OK" to save the settings.
Now, assign a shortcut key e.g. "Ctrl+Shift+B" to execute the script. From "Settings" menu, choose "Shortcut Mapper" -> "Plugin commands" tab, select "Run Perl" and click "Modify" to assign "Ctrl+Shift+B" or any preferable key. Click "OK" to save it.
Restart Notepad++.
After restarted, you can execute an opened Perl script by pressing "Ctrl+Shift+B".

How to Convert a file from Windows format to Linux format

2012-04-13T21:00:00.000+08:00

This is a Perl implementation of "dos2unix" (a utility to convert Windows/DOS file format to Linux/UNIX file format.

#!/usr/bin/perl
use strict;

use File::Copy;
use File::Temp;

my $FILENAME = "MY_FILE.txt";

dos2ux($FILENAME);

sub dos2ux {
    my $infile = shift;
    my $is_converted = 0;

    # Make a temp file which will self delete automatically.
    my $tmp = File::Temp->new(
        UNLINK => 1);

    if (open(INFILE, $infile)) {
        if (open (OUTFILE, ">", $tmp->filename)) {
            binmode(OUTFILE);
            while () {
                s/\r\n$/\n/;
                print OUTFILE $_;
            }
            close(OUTFILE);
            $is_converted = 1;
        }

        close(INFILE);
    } else {
        print "Fail to open $infile\n";
    }

    if ($is_converted) {
        copy($tmp->filename, $infile);
    }
}

Remove Old Log Files with Keeping Minimum Number of Copies

2012-04-08T12:16:00.000+08:00

It is very common that not all the application will purge their old log files. Hence, you need to purge the old log files (backup ZIP files) before the system runs out of space.

Normally, we will purge the old files based on date. If the application does not run for long time, all the log files will be purged. Sometime, we would like to keep the minimum number of old log files to find out when it was run.

The script will be based on the following conditions:

1. Keep Minimum Number of Copies - If the application does not run, we will keep the log files even they are few months old. It will not proceed to check the keep days if failed to meet this condition.

2. Keep Days - It will remove all the logs that older than the specify days. To keep up to today log, specify zero day.


#!/usr/bin/perl
# $Id: purge_files.pl,v 1.4 2012/04/19 13:38:55 chinsiang Exp chinsiang $
#
use strict;
use Getopt::Long;
use POSIX;
use File::Spec;
use File::Glob;

my $VERSION = "1.0";
# 0 = keep today, 1 = keep today & yesterday, etc
my $BACKUP_DAYS_TO_KEEP = 14;
# Specify number of copies to keep. If less the this number, 
# housekeeping will be aborted.
my $BACKUP_COPY_TO_KEEP = 10;

my $FILE_PATTERN = '*.log';

my %option;
die unless GetOptions(
    "file-pattern=s" => \$option{'file-pattern'},
    "backup-copy=i"  => \$option{'backup-copy'},
    "keep-days=i"    => \$option{'keep-days'},
    "test"           => \$option{'test'},
    "verbose"        => \$option{'verbose'},
    "help"           => \$option{'help'},
);

if (defined( $option{'help'} )) {
    print_usage();
}

if (!defined($option{'file-pattern'})) {
    $option{'file-pattern'} = $FILE_PATTERN;
}


if (!defined($option{'backup-copy'})) {
    $option{'backup-copy'} = $BACKUP_COPY_TO_KEEP;
}

if (!defined($option{'keep-days'})) {
    $option{'keep-days'} = $BACKUP_DAYS_TO_KEEP;
}

if (!defined($option{'test'})) {
    $option{'test'} = 0;
}


purge_files($option{'file-pattern'}, 
            $option{'keep-days'}, 
            $option{'backup-copy'},
            $option{'test'},
            $option{'verbose'});

##############################################################################
# Purge the files
sub purge_files() {
    my $file_pattern   = shift;
    my $keep_days      = shift;
    my $backup_to_keep = shift;
    my $test           = shift;
    my $verbose        = shift;
    
    my $DAY_IN_SECONDS = 86400;
    
    my %files = get_sorted_files($file_pattern);
        
    my $file_count = scalar(keys(%files));                
    my $now = time();
    my $delete_time = $now - ($DAY_IN_SECONDS * $keep_days);
    
    # Adjust to localtime 12am    
    $delete_time -= (($delete_time % $DAY_IN_SECONDS ) + tzoffset()); 
    
    if ($verbose) {   
        print "Delete file older than " 
              . strftime("%Y-%m-%d %H:%M:%S", localtime($delete_time)) . "\n";
    }
            
    
    if ($verbose) {
        print "Found files\n";
        my $index = 0;
        foreach my $file (sort { $files{$a} cmp $files{$b} } keys %files) {
            $index++;
            printf("%2d. %s %s\n", 
                    $index,
                    $file,
                    strftime("%Y-%m-%d %H:%M:%S", localtime( $files{$file} ))
                    );
        }
    }
            
    foreach my $file (sort { $files{$a} cmp $files{$b} } keys %files) {                
        my $file_modified = $files{$file};


        if ($file_count > $backup_to_keep) {              
            if ($file_modified < $delete_time) {
                $file_count--;                

                if ($test) {
                    print "Test: Delete $file, "
                          . "Modified: " 
                          . strftime("%Y-%m-%d %H:%M:%S", localtime($file_modified)) 
                          . "\n";
                }
                else {
                    if (unlink($file) > 0) {
                        print "Deleted: $file, "
                              . "Modified: " 
                              . strftime("%Y-%m-%d %H:%M:%S", localtime($file_modified)) 
                              . "\n";
                    }
                }

            }
        }     
        else {
            # Exit the loop
            last;
        }            
    }
}

##############################################################################
# Get sorted files into a hash table.
sub get_sorted_files {
    my $path  = shift;
    my $regex = shift;

    my @files = glob($path);
    my %hash = ();

    foreach my $file (@files) {
        $hash{$file} = (stat($file))[9];
    }

    return %hash;
}

##############################################################################
# Find the timezone in seconds.
sub tzoffset {
    my $t = time();
    my $utc = mktime(gmtime($t));
    my $local = mktime(localtime($t));

    return ($local - $utc);
}

##############################################################################
# Print usage
sub print_usage {
    my $usage =<<EOF
DESCRIPTION:
    Purge old records    

OPTIONS:
    --[f]ile-pattern File pattern in regex to purge. (Default: $FILE_PATTERN)
    --[b]ackup-copy  Minimum backup copy to keep. (Default: $BACKUP_COPY_TO_KEEP copies)
    --[k]eep-days    Number of days to keep. 
                     0 = Today, 1 = Today & Yesterday, etc.
                     (Default: $BACKUP_DAYS_TO_KEEP days)
    --[t]est         Test run without purge the files.
    --[v]erbose      Increase verbosity.
    --[h]elp         Show this help text.
   

EXAMPLE:
    \$ $0 --keep-days 10 --backup-copy 1 --file-pattern "~/tmp/*log" --v
EOF
    die($usage);
}

__END__

Perl Quick References

2011-11-16T22:18:00.005+08:00

Posting my personal Perl quick reference.

Perl Quick Start Template

2011-10-31T23:16:00.003+08:00

When starting a new script, you can use this template as a base which consists of:

RCS, CVS or SVN "Id" keyword to keep the version information.
Support script arguments.
Show usage function.
A trim function.


#!/usr/bin/perl -w
# $Id: $
#
use strict;
use Getopt::Long;

my $VERSION = "1.0";

my %option;
die unless GetOptions(
    "help"         => \$option{'help'},
);

if (defined( $option{'help'} )) {
    print_usage();
}

...


# Perl trim function to remove whitespace from the start and end of the string
sub trim {
    my $string = shift;
    $string =~ s/^\s+//;
    $string =~ s/\s+$//;
    return $string;
}

# Print usage
sub print_usage {
    my $usage = <<EOF;
DESCRIPTION:
    

OPTIONS:
    --[h]elp    Show this help text.

EXAMPLE:
    \$ $0
EOF
    die($usage);
}

How to Change Linux Password via SSH

2011-10-08T22:29:00.011+08:00

Script to change Linux password remotely via SSH.

Prerequisite
For ActivePerl users, you need to download the Net::SSH2 package. Version 5.10.x

C:\>ppm install http://cpan.uwinnipeg.ca/PPMPackages/10xx/Net-SSH2.ppd

Version 5.12.x

C:\>ppm install http://cpan.uwinnipeg.ca/PPMPackages/12xx/Net-SSH2.ppd

Scripts


#!/usr/bin/perl 

use strict;
use Net::SSH2;

use Getopt::Long;

my %option = (
    'server'       => 'localhost',
    'userid'       => '',
    'password'     => '',
    'newpassword'  => '',
);

if (!GetOptions("server|s=s"       => \$option{'server'},
                "userid|u=s"       => \$option{'userid'}, 
                "password|p=s"     => \$option{'password'}, 
                "newpassword|n=s"  => \$option{'newpassword'})) {
    print_usage();  
}

my $ssh2 = Net::SSH2->new();

$ssh2->connect($option{'server'}) or die "Unable to connect Host $option{'server'} \n";

$ssh2->auth_password($option{'userid'}, $option{'password'}) or die "Unable to login\n";

my $chan = $ssh2->channel();
$chan->blocking(0);
$chan->ext_data('merge');

my $cmd = "chage -l $option{'userid'}; " 
        . "echo -e \"$option{'password'}\\n$option{'newpassword'}\\n$option{'newpassword'}\\n\" | passwd 2>&1\n";

# print $cmd;

$chan->exec($cmd);

while (<$chan>) { 
    print $_;
} 

#########################################################################
# Subroutines
#########################################################################
sub print_usage {
    # ...
}

Check for Holiday with Perl

2011-04-02T22:08:00.001+08:00

In some cases we would like to avoid to execute the script during public holiday e.g. Don’t send alert during holiday. This script contains 2 functions i.e. “load_holiday_file” and “is_holiday” where you can include in your script to check for holiday.

#!/usr/bin/perl
use strict;

my @holidays = ();
my @now = localtime(time());

my $date = sprintf("%02d-%02d-%04d", $now[3], $now[4]+1, $now[5]+1900 );

load_holiday_file(\@holidays, 'holiday.txt');

if (is_holiday(\@holidays, $date)) {
    print "Today is holiday";
}

# Check the date is holiday
# "date_to_check" is in "DD-MM-YYYY" format.
sub is_holiday {
    my $holidays = shift;
    my $date_to_check = shift;
       
    my $counter = 0;
    my $found = 0;
       
    while($counter <= $#{holidays} && !$found) {
        my $holiday = $holidays->[$counter];
               
        if ($date_to_check =~ /^$holiday/) {
            $found = 1;
        }
        else {           
            $counter++;
        }   
    }

    return $found;
}

# Load holiday file
# Holiday file
# 1. DD-MM-YYYY
# 2. DD-MM (Every year on this date)
sub load_holiday_file {
    my $holidays     = shift;
    my $holiday_file = shift;
       
    if (open(HOLIDAY_FILE, $holiday_file)) {
   
        my $line;
        while (defined($line = <HOLIDAY_FILE>)) {   
            chomp($line);
             
            next if ($line =~ /^\s*#/ );
            next if ($line =~ /^$/);
           
            # Trim the string
            $line =~ s/^\s+//;   
            $line =~ s/\s+$//;
                                               
            push @{holidays}, $line;
        }        
        close(HOLIDAY_FILE);
    }
} 












Holiday File
# Holiday file
# 1. DD-MM-YYYY
# 2. DD-MM (Every year on this date)
27-01-2011       
03-02-2011
03-02-2011
22-04-2011
02-05-2011
17-05-2011
09-08-2011
30-08-2011
26-10-2011
06-11-2011
26-12-2011
02-01-2012

Sort Date in "DD MMM YYYY" format

2010-09-12T14:20:00.007+08:00

To sort date in "DD MMM YYYY" format (e.g. "02 DEC 2010")


#/usr/bin/perl -w
use strict;

# Constants
my %MONTH_NUMBER = (
    'JAN' => 1,
    'FEB' => 2,
    'MAR' => 3,
    'APR' => 4,
    'MAY' => 5,
    'JUN' => 6,
    'JUL' => 7,
    'AUG' => 8,
    'SEP' => 9,
    'OCT' => 10,
    'NOV' => 11,
    'DEC' => 12,    
);

my @myarray = (
    '08-DEC-10',
    '30-NOV-10',
    '26-NOV-10',
    '25-NOV-10',
    '25-NOV-10',
    '24-NOV-10',
    '11-NOV-10',
    '10-NOV-10',
    '10-NOV-10',
    '08-NOV-10',
    '03-NOV-10',
    '02-NOV-10',    
    '01-NOV-10',
);

my @sorted_array = sort sort_func @myarray;

print "@sorted_array"; 

####################
# Subroutine
####################
# Sort function
sub sort_func() {
    # To sort in desc, just swap $a and $b
    #return convert_datenumber($b) 
    #   cmp convert_datenumber($a);
  
    return convert_datenumber($a) 
       cmp convert_datenumber($b);
}

# Convert "DD MMM YYYY" into "YYYYMMDD"
sub convert_datenumber() {
    my $in_date = $_[0];
    
    my $out_date = 0;
            
    if (length($in_date)) {
        my $day        = substr($in_date, 0, 2);
        my $month      = $MONTH_NUMBER{ substr($in_date, 3, 3) };
        my $year       = substr($in_date, 7);
        
        $out_date = $year * 10000 
                  + $month * 100
                  + $day;                                    
    }
        
    return $out_date;
}

Output:


01-NOV-10 02-NOV-10 03-NOV-10 08-NOV-10 10-NOV-10 10-NOV-10 11-NOV-10 24-NOV-10 25-NOV-10 25-NOV-10 26-NOV-10 30-NOV-10 08-DEC-10

Arguments By Reference

2010-06-07T23:43:00.007+08:00

Modify scalar, hash and list through a subroutine.

#!/usr/bin/perl -w
use strict;

my $name;
my %contacts;
my @children;

&my_function(\$name, \%contacts, \@children);


print "Name = $name\n";

foreach my $key ( keys(%contacts) ) {
    print "$key = $contacts{$key}\n";
}
 
foreach my $child (@children) {
    print "Child = $child\n";
}

sub my_function() {
    my $ref_name      = $_[0];
    my $ref_contacts  = $_[1];
    my $ref_children  = $_[2];
    
    $$ref_name = "Harry";
    $$ref_contacts{'home'} = '1234567890';
    $ref_contacts->{'work'} = '9876543210';

    push(@$ref_children, 'James');
    push(@$ref_children, 'Mary');

    print "Name = $$ref_name\n";
    
    foreach my $key ( keys(%$ref_contacts) ) {
        print "$key = $$ref_contacts{$key}\n";
    }
    
    foreach my $child (@$ref_children) {
        print "Child = $child\n";
    }
    print "\n";       
}

Handle Command Line Arguments

2010-06-05T08:20:00.010+08:00

Command line argument is commonly use in passing in the configuration to a Perl script. Fortunately, Perl's core module come with a parsing library i.e. GetOpt::Long which ease the parsing of arguments.

Here is the sample code:

#!/usr/bin/perl
use Getopt::Long;

my @files = ();
my $outputfile;

# Checking for missing arguments
if (@ARGV == 0 || 
  !GetOptions("input=s{1,}" => \@files, 
              "output|dest=s" => \$outputfile) || 
  @files == 0 || 
  !defined($outputfile)) { 
  # Print Usage
  print "Invalid arguments!\n"; 
  exit 1;
}
print "Total Input File: " . @files . "\n";
foreach my $file (@files) {
  print "-> $file\n";
}
print "Output File: $outputfile\n";

Output:


D:\>GetOptions.pl -i a.txt b.txt -d my.txt
Total Input File: 2
-> a.txt
-> b.txt
Output File: my.txt

The checking for the missing arguments:

Check for zero argument: if (@ARGV == 0 ||
Check options are in "s" or "o" or "d": !GetOptions("input=s{1,}" => \@files, "output|dest=s" => \$outputfile)
Check for no input files: @files == 0
Check for missing output file: !defined($outputfile)

To get multiple values the option, you can use "input=s{1,}", it will store the values into a list (@files).

NOTE: In Perl, a subroutine parameter start with back slash ("\") e.g. \@files, indicates pass by reference. It means the parameter can be changed through the subroutine.

How to Process Multiple Files from Wildcard Arguments

2010-05-31T21:50:00.004+08:00

To process multiple files from wildcard arguments, use glob() function.

#!/usr/bin/perl
@files = glob("@ARGV");
foreach (@files) {
    print "File: $_\n";
}

Please notice that the @ARGV is surrounded by double quotes. Without double quotes, it will return the count of arguments.

Example:

D:\>process_files.pl test*.pl myperl.pl exec_cmd.pl
File: TestBack.pl
File: TestCSV.pl
File: TestDate.pl
File: myperl.pl
File: exec_cmd.pl

Execute an External Command

2010-05-29T07:37:00.000+08:00

In Perl, to execute an external command and capture its output can be done in one line.


#!/usr/bin/perl

# Use backticks (``) operator 
@output = `tasklist.exe`;

# Display the output
foreach $line (@output) {
    print "$line";
}

Output:


D:\>exec_cmd.pl

Image Name        PID Session Name  Session# Mem Usage
================= === ============= ======== ==========
System              4 Services             0   32,236 K
smss.exe          332 Services             0      760 K
csrss.exe         436 Services             0    1,728 K
wininit.exe       476 Services             0    2,020 K
csrss.exe         488 Console              1    8,268 K

You can use Perl to analysis the output and send an email alert if any error detected.

How to Debug a Perl Script

2010-05-28T20:50:00.000+08:00

Programmers do not know how to debug is blind. Perl comes with a built-in debugger that allows you to do debugging without separately install a debugger.

To debug a Perl script, simply use "-d" flag:


Here are the common use commands:

s - Single step. It will step into a subroutine.
n - Next, steps over subroutines.
r - Return from the subroutine.
c - Continue until a breakpoint if any.
b [ln|event|sub] - Set a breakpoint.
l [line|sub] - List source code.
p expr - Print expression.
q - Quit.

For details, visit http://perldoc.perl.org/perldebug.html. Cheers!

Perl: Easy way to read a fixed length file

2010-05-28T10:28:00.000+08:00

To parse a fixed length string, you can use unpack() function:

#Name(10), Age(2), Sex(6)
#Sample data:
# "John 20MALE  "
# "Mary 22FEMALE"
my $templateformat = "A10A2A5"; # Read unpack() documentations.
my @fields = unpack( $templateformat , "John 20MALE  ");

This is a simple example to read a fixed length file:

#!/usr/bin/perlopen(INFILE, $ARGV[0]);
my $templateformat = "A10A2A5";
while (<INFILE>) {
  my @fields = unpack( $templateformat , $_);
  print "$fields[0] is $fields[1] years old\n";
}
close(INFILE);

To run it:

C:\> readfixedlength.pl sampledata.txt

Output:

John is 20 years old
Mary is 22 years old

You can store the file format in a configuration file. It makes the script much easier to read and maintain. The script keeps the configuration after the __DATA__ token. NOTE: __DATA__ is a token that marks end of script. You can use DATA filehandle the text after it.

#!/usr/bin/perl
my @header_names = ();
my @header_lengths = ();
&load_template(\@header_names, \@header_lengths);
my $templateformat;
foreach (@header_lengths) { 
  $templateformat .= "A" . $_;
}
open(INFILE, $ARGV[0]);
while (<INFILE>) {
  my @fields = unpack( $templateformat , $_);
  print "$fields[0] is $fields[1] years old\n";
}
close(INFILE);
# Load from the template __DATA__ section
sub load_template() {
  # By-ref parameters
  my $ref_header_names = $_[0];
  my $ref_header_lengths = $_[1];
  # Load the file template from __DATA__  
  while (<DATA>) {
    chomp;
    # Skip comment or empty line.
    next if (/^#/ || /^$/);
    my @fields = split(",");
    push(@$ref_header_names, $fields[0]);
    push(@$ref_header_lengths, $fields[1]);
  }
}
__DATA__
FIELD_NAME,10
FIELD_AGE,2
FIELD_SEX,6

It is very simple, right?