Perl Examples


Check Daylight Savings Time

####################  Subroutine  #########################################
sub checkDaylightSavingsTime {

  # Check to see if the daylight savings time is currently in effect.
  # It starts the first Sunday in April and ends the last Sunday in October.

  # Initialize variables
  my ($daylightSavingsTime,$apr,$oct) = ("no",3,9);

  # Get the current time
  my ($day,$month,$weekday) = (localtime)[3,4,6];

  if ($month > $apr && $month < $oct) {
     $daylightSavingsTime = "yes";
  } elsif ($month == $apr) {
     $daylightSavingsTime = "yes" if ($day - $weekday) >= 1;
  } elsif ($month == $oct) {
     my $daysUntilSunday = (7 - $weekday);
     $daylightSavingsTime = "yes" if ($day + $daysUntilSunday) <= 31;
  } # end if

  return ($daylightSavingsTime);

} # end sub


Combine and Sort Arrays

use strict;

my @array1 = qw/Jim Beth Laurie Inga Kathy/;
my @array2 = qw/Laurie Sally Jim Carol/;

&combineAndSortArrays (\@array1, \@array2);

print "@array1\n";

# Output will be: Beth Carol Inga Jim Kathy Laurie Sally

####################  Subroutine  #########################################
sub combineAndSortArrays {

  # Combine the two arrays and make sure each element is unique
  # The arrays are passed in as a reference

  my($rarray1, $rarray2) = @_;

  # Combine the two groups
  push(@$rarray1, @$rarray2);

  # Remove duplicates
  my %temp = ();
  @$rarray1 = grep ++$temp{$_} <2, @$rarray1;

  # Sort
  @$rarray1 = sort @$rarray1;

} # end sub


Elements Unique To One Array

use strict;

my @array1 = qw/Jim Beth Laurie Inga Kathy/;
my @array2 = qw/Laurie Sally Jim Carol/;
my @array1only = ();

&elementsUniqueToArray (\@array1, \@array2, \@array1only);

print "@array1only \n";

# Output will be: Beth Inga Kathy

####################  Subroutine  #########################################
sub elementsUniqueToArray {

  # Find the elements in array1 but not array2
  # The arrays are passed in as a reference

  my($rarray1, $rarray2, $rarray1only) = @_;

  my %seen = (); 

  foreach my $item (@$rarray2) {
    $seen{$item} = 1;
  } # end foreach

  foreach my $item (@$rarray1) {
    unless ($seen{$item}) {
      # it's not in %seen, so add it to @array1only
      push @$rarray1only, $item;
    } # end unless
  } # end foreach

} # end sub


Intersection of Two Arrays

use strict;

my @array1 = qw/Jim Beth Laurie Inga Kathy/;
my @array2 = qw/Laurie Sally Jim Carol/;
my @isect = ();

&intersectionOfArrays (\@array1, \@array2, \@isect);

print "@isect\n";

# Output will be: Jim Laurie

####################  Subroutine  #########################################
sub intersectionOfArrays {

  # Show the intersection of two arrays
  # The arrays are passed in as a reference

  my($rarray1, $rarray2, $risect) = @_;

  # Initialize variables
  my (%union, %isect, $e);
  %union = %isect = (); 

  foreach $e (@$rarray1) {
    $union{$e} = 1;
  } # end foreach

  foreach $e (@$rarray2) {
    $isect{$e} = 1 if $union{$e};
  } # end foreach

  @$risect = keys %isect;

} # end sub


Current Time

####################  Subroutine  #########################################
sub currentTime {

  # This is an example of the code to supply the system date and time
  # The output format is: Tue 03/02/99 13:34:58

  my ($sec,$min,$hour,$mday,$mon,$year,$wday)=localtime(time);
  my $thisday = ("Sun","Mon","Tue","Wed","Thu","Fri","Sat")[$wday];
  $year = substr($year,-2);
  my $time = (sprintf("%s %02d/%02d/%s %02d:%02d:%02d",
             $thisday,++$mon,$mday,$year,$hour,$min,$sec));

  return $time;

} # end sub


Get Real Name

####################  Subroutine  #########################################
sub getRealName {

  my ($person) = @_;

  # Get the real name of the user running this script
  my $gcos = (getpwnam($person))[6] if defined $person;

  # Compensate for a poor SATCOM gcos field
  if (defined $gcos) {
    $gcos =~ s/\s\D{1,3}\d.*//;    # Remove the badge # to the end of line
    $gcos =~ s/(\w+)/\u\L$1/g;     # Lower case except 1st character
    $gcos =~ s/\bMc(.)/Mc\u$1/g;   # Take care of Mc last names
    $gcos = substr($gcos,0,17);    # Limit the length
    $gcos =~ s/\s+$//;             # Remove any trailing spaces
  } else {
    $gcos = "";
  } # end if

  return ($gcos);

} # end sub


Leap Year

####################  Subroutine  #########################################
sub isLeapYear {

  my ($year) = @_;

  my $leapYear = "no";

  if ( (($year % 4 == 0) && ($year % 100 != 0)) || ($year % 400) == 0)  {
    $leapYear = "yes";
  } # end if

  return ($leapYear);

} # end sub


Calculate Days Until

use Time::Local;

my $date = "7/13/02";

my $days = &daysUntil ($date);

print "$days days until some event\n";

####################  Subroutine  #########################################
sub daysUntil {

  my ($date) = @_;

  my ($month,$day,$year) = split ('/',$date);
  $month--;

  # Get the future day in epoch days
  my $futureTime = timelocal(0,0,0,$day,$month,$year);
  my $futureDays = int($futureTime / (24*60*60));

  # Get the current time in epoch days
  my $currentDays = int(time / (24*60*60));

  return ($futureDays - $currentDays);

} # end sub


Remove Spaces

$one = "  word";
$two = "word2   ";

($one,$two) = &removeSpaces ($one,$two);
print "| $one $two |\n";

$one = &removeSpaces ($one);
print "| $one |\n";

####################  Subroutine  #########################################
sub removeSpaces {

  my (@strings) = @_;

  foreach my $string (@strings) {

    $string =~ s/^\s+//;  # Get rid of white space at the beginning of $string
    $string =~ s/\s+$//;  # Get rid of white space at the end of $string
    chomp ($string);

  } # end foreach

  return wantarray ? @strings : $strings[0];

} # end sub


Print Columns

use POSIX;

my $numberOfColumns = 3; # Must be a number from 1 to 5
my $width = 10; # How wide do you want each column

my @array = qw/0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21/;
&printMultipleColumns (\@array, $numberOfColumns, $width);

####################  Subroutine  #########################################
sub printMultipleColumns { 

  my ($rarray, $numberOfColumns, $width) = @_;

  my $numElm = ceil(@$rarray/$numberOfColumns);

  for (my $x = 0; $x < $numElm; $x++) {
    printf "%-${width}s%-${width}s%-${width}s%-${width}s%-s\n",
            $$rarray[$x], $$rarray[$x+$numElm], $$rarray[$x+(2*$numElm)], 
            $$rarray[$x+(3*$numElm)], $$rarray[$x+(4*$numElm)];
  } # end for

} # end sub


Fun With File Permissions

use strict;

my $perm = "750";

$perm = &setPermissions ($perm);

print "permissions = $perm\n";
# output is: permissions = rwxr-x---

$perm = &goTheOtherWay ($perm);

print "permissions = $perm\n";
# output is: permissions = 750

###############################################################
sub setPermissions {

  my ($permissions) = @_;

  # Define permissions array
  my @array = qw(--- --x -r- -rx r-- r-x rw- rwx);

  # Break the permissions down to its components
  my ($owner, $group, $world) = split //, $permissions;

  # Return permissions
  return ("$array[$owner]$array[$group]$array[$world]");

} # end sub
###############################################################
sub goTheOtherWay {

  my ($permissions) = @_;

  # Build a permissions hash
  my %numbers;
  my @array = qw(--- --x -r- -rx r-- r-x rw- rwx);
  for (my $x = 0; $x <= $#array; $x++) {
    $numbers{$array[$x]} = $x;
  } # end for

  # Break the permissions down to its components
  my ($owner, $group, $world) = unpack ("A3 A3 A3", $permissions);

  # Return permissions
  return ("$numbers{$owner}$numbers{$group}$numbers{$world}");

} # end sub


Commify

use strict;

my $num = 123456789;

print &commify ($num), "\n";
# output would be: 123,456,789

####################  Subroutine  #########################################
sub commify {

  # Adds commas to numbers

  my ($text) = @_;

  $text = reverse $_[0];
  $text =~ s/(\d\d\d)(?=\d)(?!d*\.)/$1,/g;
  return scalar reverse $text;

} # end sub


Generate Password

####################  Subroutine  #########################################
sub generatePasswd {

  my ($number, $character);

  # This is a subroutine to generate a password.  All alpha chars are in lower case.
  # The character "l" and the numbers "0" and "1" are not used because they may
  # generate confusion with other characters.

  # Create random password
  my @chars = ("a" .. "k","m" .. "z", 2 .. 9);
  my $password = join ("", @chars [ map { rand @chars } (1 ..8) ]);

  # If there isn't at least one number in the password, put one there.
  if ($password !~ /\d/) {
    @chars = (2 .. 9);
    $number = join ("", @chars [ map { rand @chars } (1) ]);
    substr ($password,2,1) = $number;
  } # end if

  # If there isn't at least one character in the password, put one there.
  if ($password !~ /[a-z]/) {
    @chars = ("a" .. "k","m" .. "z");
    $character = join ("", @chars [ map { rand @chars } (1) ]);
    substr ($password,3,1) = $character;
  } # end if

  return ($password);

} # end sub


Encrypt Password

####################  Subroutine  #########################################
sub encryptPasswd {

  my ($passwd) = @_;

  # Generate a random salt
  my @chars = ("A" .. "Z","a" .. "z", 0 .. 9, qw(! @ $ ^ & *));
  my $salt  = join ("", @chars [ map { rand @chars } (1..2) ]);

  # Encrypt password
  my $cpasswd = crypt ($passwd, $salt);

  return $cpasswd;

} # end sub


Check Password

####################  Subroutine  #########################################
sub checkPasswd {

  my ($epasswd, $password) = @_;
  my $valid;

  my $salt = substr $epasswd, 0, 2;

  if (crypt ($password, $salt) ne $epasswd) {
    $valid = "not-valid";
  } else {
    $valid = "valid";
  }# end if

  return $valid;

} # end if


Scramble Password

####################  Subroutine  #########################################
sub scramblePassword {

  # This is not meant to be any sort on encryption.  It is only to make
  # sure the causal observer does not see your password if the
  # configuration file is being edited or printed.

  # Each apha character is shifted over three positions. An "a" becomes
  # a "d", a "b" becomes an "e" and so forth.

  my ($compassPasswd) = @_;

  $compassPasswd =~ tr [a-zA-Z0-9] [d-zabcD-ZABC2-701];

  return $compassPasswd;

} # end sub
########### Sub ###################################################
sub unscramblePassword {

  my ($compassPasswd) = @_;

  $compassPasswd =~ tr [d-zabcD-ZABC2-701] [a-zA-Z0-9];

  return $compassPasswd;

} # end sub


Script used to write this page

#############################################################################
#
# File Name: writePage
#
# Description: This script writes a webpage in HTML.  It is used to tie
#              a series of subroutines or examples together to form a webpage 
#              which can be used for reference anywhere. Each time a subroutine
#              or example is changed, this script can be rerun to update 
#              the page.
#
#              A configuration file called "config" is needed to run this 
#              script. As example config file is included at the end of
#              this script.
#
#              The configuration file must not have any blank lines.
#              The first line is the title for the page. The second
#              line is the title of the example or subroutine.  The third
#              line is the name of the file where the example or subroutine
#              is located.  The file for the third line is then inserted 
#              into the page.
#
# Usage: writePage
#
# Version: 1.0
#
#############################################################################

# Open output file 
open (OUT,">data.html") or die "Could not open file: data";

# Load config file array
my @configArray = ();
&loadConfigArray (\@configArray);

# Write header
my ($title) = (split (':\s*',$configArray[0],2))[1];
chomp $title;
&writeHeader ($title,\*OUT);

# Generate top link table
&generateTopLinkTable (\*OUT, \@configArray);

# Process the config file and do the work
for (my $x = 1; $x <= $#configArray; $x += 2) {

  my ($title) = (split(':\s*',$configArray[$x],2))[1];
  my $fileName = $configArray[$x + 1];
  chomp ($title, $fileName);

  # Write file to output
  &catFile ($title, $fileName, "JUMPTO$x", \*OUT);
} # end for

# Write footer
&writeFooter (\*OUT);

close (OUT);
############# Sub ############################################
sub generateTopLinkTable {

  my ($fileHandle, $rconfigArray) = @_;

  print $fileHandle "<center><table><tr><td><ul>\n";
  my $x = 1;
  foreach (@$rconfigArray) {
    if (/^TITLE:/) {
      chomp;
      my ($title) = (split (':\s*',$_,2))[1];
      print $fileHandle "<LI><A HREF=\"#JUMPTO$x\">$title</A></LI>\n";
      $x += 2;
    } # end if
  } # end foreach
  print $fileHandle "</ul></td></tr></table></center>\n";

} # end sub
############# Sub ############################################
sub catFile {

  my ($title, $fileToCat, $lable, $fileHandle) = @_;

  print $fileHandle "<P><hr><P><center><h3><A NAME=\"$lable\">$title</A>";
  print $fileHandle "</h3></center><P>\n\n<pre>\n";

  # Load file to array
  my @fileArray = ();
  open (OUT1, "$fileToCat") or die "Could not open $fileToCat";
    while (<OUT1>) {
      # Change things that look like <FILEHANDLE> to symbols so
      # they are not interpreted a HTML Tag.
      s/</</g; # The second < is really a "& lt;" without the space
      s/>/>/g; # The second > is really a "& gt;" without the space
      push @fileArray, $_;
    } # end while
  close (OUT1);

  # Remove the beginning and ending blank lines 
  &removeBegAndEndBlankLines (\@fileArray);  

  # Write to the output file
  print $fileHandle @fileArray;

  print $fileHandle "</pre>\n";

} # end sub
############# Sub ############################################
sub removeBegAndEndBlankLines  {

  my ($rarray) = @_;

  # Remove the beginning blank lines as well as the shebang line
  for (my $x = 0; $x <= $#$rarray; $x++) {
    unless ($$rarray[$x] =~ /^\s*$/ || $$rarray[$x] =~ /\/perl/) {
      # shorten the array $x elements starting from the 0th element
      splice @$rarray, 0, $x;
      last;
    } # end unless
  } # end for

  # Remove the blank lines at the end of the file array
  for (my $x = $#$rarray; $x >= 0; $x-- ){ # read the array in reverse
    if ($$rarray[$x] =~ /\S/) {         # look for non-blank line
      last;
    } else {
      pop @$rarray;                     # shorten the array by one element
    } # end if
  } # end for

} # end sub
############# Sub ############################################
sub writeHeader {

  my ($title,$fileHandle) = @_;

  (my $text = <<"  end_tag") =~ s/^\s+//gm;

  <html>
  <head>
  <title>$title</title>
  </head>
  <body background="images/glotextb.gif" bgcolor=#FFFCC">
  <center>
  <table width=85%><tr><td>
  <center><h1>$title</h1></center>
  end_tag

  print $fileHandle $text, "\n\n";

} # end sub
############# Sub ############################################
sub writeFooter {

  my ($fileHandle) = @_;

  (my $text = <<"  end_tag") =~ s/^\s+//gm;

  <p>
  </td></table>
  </center>
  </body>
  </html>
  end_tag

  print $fileHandle $text;

} # end sub
############# Sub ############################################
sub loadConfigArray {

  my ($rconfigArray) = @_;

  # Since this is a user edited file, make it flexable in terms
  # of white space and comments
  open (CONFIG,"config") or die "Could not open file: config";
    while (<CONFIG>) {
      s/#.*//;          # no comments
      s/^\s+//;         # no leading white
      s/\s+$//;         # no trailing white
      next unless /\S/; # no blank lines
      push @$rconfigArray, $_;
    } # end while
  close (CONFIG);

} # end sub
############# Example config file ############################

#    PAGETITLE: Perl Examples
#    TITLE: Check Daylight Savings Time
#    checkDaylightSavingsTime
#    TITLE: Combine and Sort Arrays
#    combineAndSortArrays
#    TITLE: Current Time
#    currentTime
#    TITLE: Get Real Name
#    getRealName
#    TITLE: Leap Year
#    isLeapYear
#    TITLE: Calculate Days Until
#    par
#    TITLE: Remove Spaces
#    removeSpaces
#    TITLE: Print Columns
#    thirds
#    TITLE: Generate Password
#    generatePasswd
#    TITLE: Encrypt Password
#    encryptPasswd
#    TITLE: Check Password
#    checkPasswd
#    TITLE: Scramble Password
#    scramblePasswd
#    TITLE: Script used to write this page
#    writePage