Perl Examples
#################### 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
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
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
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
#################### 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
#################### 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
#################### 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
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
$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
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
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
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
#################### 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
#################### 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
#################### 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
#################### 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
#############################################################################
#
# 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
|