Perl
(Practical Extraction and Report Language)
Also…CGI and Apache
General Info [|<< Don't forget about the menu above]
# is a single-line comment
Here's a multi-line comment:
=comment
Multiple lines of code to
be commented out go here.
=cut
#!/usr/bin/perl -w (first line also called the "shbang" line) indicates that this is a perl program and not a shell program.
The -w switch produces warnings for potentially dangerous constructs when developing.
It is the same as having use warnings; in your program. For a complete list
of switches, which can be used at command line, please visit:
http://blob.perl.org/books/beginning-perl/3145_Chap09.pdf (p. 290).
print ("Hello, world!\n"); prints "Hello, world!" on a line and goes to next line.
NOTE: print qq(mystring); is print ("mystring");
qq puts double quotes around the string, which can get around having to "escape out"
double quotes, i.e., using the \ method. However, if you want to use an escape
character within the qq, you would have to use a different delimiter besides \.
Any non-alphanumeric character will do.
Here are some common escape codes:
$name = <STDIN>; gets a line from the terminal and assigns it to the scalar variable $name
chomp ($variablename); removes the newline \n from the end of the variable when obtained with <STDIN>
print "Hello, $name!\n"; how to print a string containing the variable value
NOTE: Single-quoted strings differ from double-quoted strings in that they are not interpolated
(i.e., nothing is processed within single quotes). You can use special characters
without escaping them. However, if I do print '$name'; it will not print the value of
the variable, but literally print $name.
Here's a "Here Document" (works like a double-quoted string):
print<<EOF;
blahblahblahblahblahblahblahblahblahblahblahblahblahblahblah
blahblahblahblahblahblahblahblahblahblahblahblahblahblahblahblah
blahblahblahblahblah
EOF
Some other quick Tidbits to help you along your way:
** exponential operator
% modulo
<=> returns 0 if equal, -1 if right hand side greater, 1 if left-hand side is greater.
x repetition operator;
print "RAH! "x3; would yield RAH! RAH! RAH!
ord("#") gives the ASCII value for the character #
Want to pause a program for 2 seconds? sleep 2;
Conditional Statements & Loops [<<rewind]
Here's an if-then example:
my ($a, $b);
$b = 10;
if (defined $a) { # checks to see if $a has a value assigned to it.
print "\$a has a value.\n";
}
if (defined $b) { # checks to see if $b has a value assigned to it.
print "\$b has a value.\n";
}
if ($name eq "Jamie") { eq is equals for strings
# some action here
} elsif ($name eq "James") {
# some action here
} else {
# some action here
} an if else-if else statement
Use conditional operators like ||, !, && similar to JavaScript.
You can also use and as well as or, which are the same as &&
and ||, respectively. Note that the "and" logical operators are of
higher precedence than the "or" operators, though the symbols are
higher precedence logical operators than the words.
Note: There is a conditional test similar to if conditions, which is called unless.
Basically, unless condition is similar to if not condition.
unless can be used for looping, too.
while ($var1 ne $var2) { ne is not equals for strings
# actions
} a while loop
Note: You see eq and ne above for use with strings. For greater than, you would
use gt. For greater than or equal to, you would use ge. For less than, use lt
and for less than or equal to, use le. For numbers, the syntax is different
than for strings, but it is identical to JavaScript syntax (except for the $variable format).
Final items related to loops:
do { <actions> } while (<condition>)
last in the loop body will end the program or break out of the loop. You can set it up also conditionally:
last if $_ eq "QUIT";
next in a loop will go to the next iteration of the loop.
redo will allow you to go back to the top of the loop without testing the current condition.
You can label loops and use the label to skip parts of a loop if a certain condition is met:
OUTER: while (...) {
...
INNER: for ... {
....
last OUTER if <condition>;
}
...
}
Avoid multiple if-elsif-elsif-...-else using something similar to case statements:
my $choice=<STDIN>;
for ($choice) {
$_ == 1 && some action;
$_ == 2 && some action;
$_ == 3 && some action;
$_ == 4 && some action;
$_ == 5 && some action;
...
}
You can see a good use of case statements in the Param Section.
There is more information on for loops in the next section. [quicklink]
Arrays & Loops [<<rewind]
While not an array in the traditional sense, one can consider the following use of print
like an array:
print (
"Get on your ".('head','shoulders','knees','toes')[2]." and pray!"
);
The [2] points to the 3rd element (Remember: starts at 0) in the list passed to the print function: knees.
Note: we could have just left out the double quotes and sent the list with the element index.
Here's the output:
Get on your knees and pray!
Now onto what we usually consider when thinking of arrays:
@presidents = ("Washington", "Madison", "Lincoln"); array with 3 elements
push(@presidents, "Washington"); Putting Washington into an empty presidents array.
push(@presidents, ("Washington", "Madison", "Lincoln")); Putting multiple persons into an empty presidents array.
my $first = shift(@presidents); Sets $first to Washington and *removes* Washington from the above array.
my $last = pop(@presidents); Sets $last to Lincoln and *removes* Lincoln from the above array.
push @presidents, "Eisenhower"; would put Eisenhower at the end of the list.
pop @presidents; would remove Eisehower - the last element - from the list.
push/pop work in a LILO fashion where push puts in a last element and pop takes out the last element.
unshift/shift work in a FIFO fashion where unshift puts in a first element and shift takes out the first element.
my $preslen = scalar(@presidents); $preslen is the number of elements in the array.
A shorthand way of doing this: my $preslen=@presidents; Since $preslen is scalar,
as designated by $ it won't pull in the elements, but just count them.
print $preslen; will print the number of elements in the array @presidents.
print scalar @presidents; is another way to print the number of elements in the array.
The Perl motto holds true: "There's more than one way to do it."
(a.k.a. TMTOWTDI "Tim Toady")
$presidents[0] is Washington and shows how to reference elements of the above array
$presidents[$preslen-1] OR $presidents[$#presidents] Gives the last element of the array.
my @presidents = ("Washington","Madison","Lincoln");
foreach my $i (@presidents) {
print "$i\n";
} #a foreach loop which will print the contents of the array.
Here's a shorthand version of the above:
foreach (@presidents) {
print "$_\n"; # $_ is the current array element, an implicit part Perl, needs no declaration.
}
Move to the next iteration in a foreach loop using next;
Break out of a foreach loop using last; but note that by default,
this only affects the loop where it occurs when considering nested loops.
If you add labels such as MYLOOP: foreach … you can break the specific loop using last MYLOOP;
my @presidents = ("Washington", "Madison", "Lincoln");
foreach my $i (0..$#presidents) {
print "President $i is $presidents[$i]\n";
} #Notice the use of the range in the foreach loop.
For loops have syntax like JavaScript or Java, except for the $variable format.
If you need to change the iterator, make a local copy:
foreach (1, 2, 3) {
my $i = $_;
$i++;
}
my @slice = @presidents[0..1]; sets @slice to ("Washington", "Madison").
NOTE: The .. signifies a range. Another convention is to use discrete elements.
You can print slices based on discrete elements as follows:
print (@presidents[0,1]);
my @found = grep(/Regex for pattern you want/,@presidents); Search an array
For example: my @found = grep(/on/,@presidents); will return Washington and Madison, but not Lincoln.
For an exact match, use /^string$/ since ^ marks the beginning of the string and $ marks the end.
my @ABCpresidents = sort(@presidents); @ABCpresidents is an alphabetically sorted @presidents array.
my @backwdpresidents = reverse(@presidents); Reverse the order of the array and save it into @backwdpresidents.
Combine these with @presidents = reverse(sort(@presidents));
NOTE: In the above line, I rewrite the original array since I store the reverse/sort in @presidents.
If you are doing this with numbers, be careful to note that a first-character comparison
would put 10 before 3, etc. So you have to do this:
my @numbers = (7, 2, 6, 16, 5, 8, 14);
my @orderednumbers = sort( {$a <=> $b;} @numbers);
Double them: for (@array) { $_ *= 2 }
Merge the @presidents array into a single string (with each element separated by a comma and a space) like this:
my $prezstring = join(", ",@presidents);
which will make $prezstring become "Washington, Madison, Lincoln".
For many of these, you can substitute a list of values for an array. Look at the following examples:
my $president = ("Washington", "Adams", "Jefferson")[1];
# $president is "Adams"
my $prezstring = join(", ", ("Washington", "Adams", "Jefferson"));
# $prezstring is now "Washington, Adams, Jefferson"
my ($first, $second, $third) = sort("Washington", "Adams", "Jefferson");
# $first is "Adams", $second is "Jefferson", $third is "Washington"
@presidents = qw(Washington Madison Lincoln); array with 3 elements without
needing to type commas and quotes
Here is helpful information about stacks and queues:
Stacks and Queues by Mark W. Naylor with comment editing by James A. Johnson
#! /usr/bin/env perl
use strict;
use warnings;
# Comments in the code and prints when run provide explanations.
#Examples of stacks, Last In First Out data structures.
my @leftStack = ();
my @rightStack = ();
print("Load the two stacks.\n");
for (my $i = 1; $i <= 15; ++$i) {
unshift(@leftStack, $i);
push(@rightStack, $i);
}
print("@leftStack\n");
print("@rightStack\n\n");
print("Get the last 3 values from the \"right-hand\" stack.\n");
print(pop(@rightStack) . "\n");
print(pop(@rightStack) . "\n");
print(pop(@rightStack) . "\n");
print("Get the last 3 values from the \"left-hand\" stack.\n");
print(shift(@leftStack) . "\n");
print(shift(@leftStack) . "\n");
print(shift(@leftStack) . "\n");
print("\nState of the stacks after popping\n");
print("@leftStack\n");
print("@rightStack\n\n");
# As demonstrated, either the push/pop or the unshift/shift pairs can be used to
# implement stacks in Perl. Personally, I would stick with the push/pop way,
# since these are the terms traditionally used with stacks. It even holds for
# the stack-based language Forth and in assembly language programming where
# return addresses and actual parameters are pushed prior to jumping to the
# address of the function code.
#Examples a queue, First In First Out data structure.
print("-" x 30 . "\n\n");
print("Load the queue.\n");
my @queue = ();
for (my $i = 5; $i <= 100; $i += 5) {
push(@queue, $i);
}
print("@queue\n");
print("\nGet the first 3 entries of the queue.\n");
print(shift(@queue) . "\n");
print(shift(@queue) . "\n");
print(shift(@queue) . "\n");
print("\nNew state of the queue.\n");
print("@queue\n");
# I could have loaded the queue by unshift and taking elment by pop, but then the
# line would have formed formed "backwards" with the end at the left and the
# beginning at the right. The method I used has the natural left-to-right order
# when the whole list is printed. Maybe if I was Hebrew or Arabic, I would have
# chosen the other method :-)
# Stacks tend to get more attention than queues in Comp Sci. Perhaps it is
# because stacks go hand-in-hand with recursion. Look up "depth first
# search/traversal" in relation to tree (often binary tree) traversal. Queues
# are excellent for doing a "breadth first search/traversal". Maybe this is not
# addressed as much because you can do breadth first via looping constructs,
# which aren't as sexy/cool as recursion.
The output looks like this:
Load the two stacks.
15 14 13 12 11 10 9 8 7 6 5 4 3 2 1
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
Get the last 3 values from the "right-hand" stack.
15
14
13
Get the last 3 values from the "left-hand" stack.
15
14
13
State of the stacks after popping
12 11 10 9 8 7 6 5 4 3 2 1
1 2 3 4 5 6 7 8 9 10 11 12
------------------------------
Load the queue.
5 10 15 20 25 30 35 40 45 50 55 60 65 70 75 80 85 90 95 100
Get the first 3 entries of the queue.
5
10
15
New state of the queue.
20 25 30 35 40 45 50 55 60 65 70 75 80 85 90 95 100
Hashes & Loops [<<rewind]
You can develop a hash from an array:
@array = qw (Redskins NFL Capitals NHL Orioles MLB);
%teams = @array;
This gives you the following hash:
Redskins NFL
Capitals NHL
Orioles MLB
Say you have a hash called %batters arranged as such ($name => $average):
"Jamie Johnson" => 416
Casey => 800
.
.
.
What do you do if a user inputs to read from the hash and inputs an average or batter not in the hash?
if (not exists $batters{$name} {
die "I don't know anything about $name as a batter.\n";
}
if (not exists $batters{$average} {
die "I don't have a batter with $average as a batting average.\n";
}
Here's another example:
%heroes = qw(
ObiWan Ben_Kenobi
Superman Clark_Kent
Batman Bruce_Wayne
Spiderman Peter_Parker
); This is a hash where each item in the first column corresponds to one item in the second column.
Or it could be done this way:
my %heroes = ( "ObiWan", "Ben Kenobi",
"Superman", "Clark Kent",
"Batman", "Bruce Wayne",
"Spiderman", "Peter Parker");
Or it could be done this way:
my %heroes = ( ObiWan => "Ben Kenobi",
Superman => "Clark Kent",
Batman => "Bruce Wayne",
Spiderman => "Peter Parker");
In the above, the first column consists of keys while the second column consists of values.
$secret_identity = $heroes{$name}; # get the secret identity of the hero
Use curly brackets, not parentheses. So, if $name is "Batman", then $heroes{$name}
is the value associated with that key, which is "Bruce Wayne" or you could reference it
directly with $heroes{'Batman'} or $heroes{Batman} if there are no special characters.
foreach my $hero (keys %heroes) {
print "$heroes{$hero}=$hero\n";
} #prints out all the values, but in random order.
foreach my $hero ("Obi Wan Kenobi","Superman","Batman","Spiderman") {
print "$heroes{$hero}=$hero\n";
} #print out the hash in exact order.
To add a new hero to a hash, do the following:
$heroes{Tankman} = "Napoleon Dynamite";
heroes is the hash name, Tankman is the new key, and Napoleon Dynamite is the new value.
if (exists $heroes{Ironman}) {
print "Ironman is in the hash.<br />\n";
} else {
$heroes{Ironman} = "Tony Edward Stark";
} Looks for Ironman in the heroes hash and if not there, it adds him.
Say the Ironman key is in the hash, you can delete him like this: delete $heroes{Ironman};
or you could kill off all the heroes with a swift %heroes = ();
my @keyslice = keys %heroes; a list in random order of the heroes' keys (Batman, et. al.).
my @valueslice = values %heroes; a list in random order of the heroes' values (Bruce Wayne, et. al.).
Are there any heroes? scalar ($heroes); yields a true or false depending on if there are any pairs.
How many heroes? scalar(keys(%heroes));
References [<<rewind]
A reference points to where data is located in memory. To create a reference for a variable,
just put \ in front of the variable like this: \$name or \@presidents or \%heroes.
References can be treated like scalar variables but cannot be hash keys. Using references is what
allows you to do things such as store arrays in an array (a matrix) or hashes inside of hashes.
CAREFUL: Arrays and references to those same arrays point at the same data. Now, let's look at
an example:
my @presidents = (\@eighteenthCentury, \@nineteenthCentury, \@twentiethCentury, \@twentyFirstCentury);
If you did this: my $presidentsRef = ["Washington", "Madison", "Lincoln"];
using square brackets [] then you directly deal with a reference. For a hash, you would use the
curly brackets {} instead of parentheses to do likewise.
Say you had this reference: my $presidentsRef = \@presidents; and you wanted to dereference it.
Do so using the curly brackets: my @prezArray = { $presidentsRef };
If you have this: ${$presidentsRef}, you can use this instead: $presidentsRef->
To finally remove a reference: undef $presidentsRef;
Matrices
If you want to get as complex as matrix, this is a good way to do it: $array[$row]->[$column]
To get the element referenced by 1, you would use this: $arrayname[1]->[1]
That is, the row 1, column 1.
Now say that each element represented a car. You could populate it like this:
#!/usr/bin/perl
use warnings;
use strict;
my @carlot; # my array
for (0..2) {
$carlot[0]->[$_] = "Honda "; # 3 Hondas in Row 0
$carlot[1]->[$_] = "Chevy "; # 3 Chevies in Row 1
$carlot[2]->[$_] = "Dodge "; # 3 Dodges in Row 2
}
Roughly, your data could be conceptualized like this:
| ↓Row | |
| 0 | → | Honda | Honda | Honda |
| 1 | → | Chevy | Chevy | Chevy |
| 2 | → | Dodge | Dodge | Dodge |
You could then add the following to print it out:
for my $i (0..2) { # Rows 0 to 2
for my $j (0..2) { # Columns 0 to 2
print $carlot[$1]->[$j];
}
print "\n"; # New line at end of row
}
And here's the output:
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
More discussion about references appears here.
Regular Expressions (regex) [<<rewind]
Let's play some with regex (Regular Expressions)...
if ($name =~ /Batman/) { Action if the regex pattern 'Batman' is found. }
Or a simpler example:
$_ = "I'm Batman.";
if (/Batman/) { actions }
Not equals for regex is as follows: !~ as in if ($name !~ /Batman/) { actions }
if ($name =~ /^Bat/) { regex used with the slashes
# Bat is at the begining of the string using the ^ anchor
}
/^bat\b/i bat is at the beginning of the string with a boundary (meaning no letter or digit following
as denoted by b in the regex) irregardless of case (i)
if ($name =~ /$man/) {
# man is at the end of the string using the $ anchor
}
$name =~ s/\W.*//; s followed by regex (substitute) followed by make the contents of $name find the first
nonword character (\W) and erase from there to the end like wildcard (.*) and then slashes for regex.
This kills all after first word.
$name =~ tr/A-Z/a-z/; transliterate A to Z to a to z; i.e., make all lower-case
The above uses transliteration, which follows tr/what to change/what to change it to/;
If you are just wanting to return the upper-case or lower-case use uc or lc, respectively.
For example:
my $stuff = "STOP SCREAMING!";
my $otherstuff = "get tough!";
print (lc $stuff); # NOTE: lc is the lower-case of LC
print "\n";
print (uc $otherstuff);
This will print the following:
stop screaming!
GET TOUGH!
You will have to escape out (\) the following
characters if you want to use them literally
since they have meaning in regex:
. * ? + [ ] ( ) { } ^ $ | \ -
Or you can use \Q to turn off special meanings,
rendering the above as their literal selves.
\E or the end of the regex will turn off \Q.
For example: if (/\Q$mystring\/E) { actions }
if /\.$/ match a full stop, then the end of the string using the $ anchor.
if /B[aeiou]tman/ looks for Batman, Betman, Bitman, Botman, or Butman.
if /B[^eiou]tman/ looks for B followed by anything except e, i, o, or u then tman.
You can also do a range in the above using numbers [0-9] or letters [a-z]
and you can have multiple brackets within a regex.
| is or. For example: /Badman|Batman/ searches for Badman or Batman or you could do it this way:
/Ba(d|t)man/ And you can use ranges and other regex within this method.
Qualifiers:
/Bat?man/ matches Baman or Batman. The t may or may not be in it (0 or 1).
/Bat+man/ matches Batman, Battman, Batttman, … The t is in it 1 or more times.
/Bat*man/ matches Baman, Batman, Battman, Batttman, … The t is in it 0 or more times.
/o{x,y}/ looks for o repeated at least x times in a row, but no more than y times in a row.
/o{2}/ looks for 2 o's in a row.
Let's walk through this regex condition:
if($myvalue=~/^[a-z|A-Z|'|"|~|`|\.|,|\-| |\*]+$/) { ... }
For the condition to be true, the variable $myvalue must match the regex expresion (=~/.../) from beginning
(^) to have any of these characters ([...]): lower-case a to z (a-z) or (|) capitalized A to Z (A-Z) or a
single quote (') or a double-quote (") or a tilde (~) or a left single quote (`) or a literal (escaped \)
period (.) or a comma (,) or a literal (escaped \) hyphen (-) or a space ( ) or a literal (escaped \)
asterisk (*) and there will be 1 or more (+) of these characters to the end stop per the expression ($/)
Backreference Variables keep track of what is found given a regex pattern.
Say you have the following:
$_ = 'When in the course of human events, it becomes necessary to dissolve a political band.';
When you run a regex pattern in parentheses against it, the $1 backreference variable
will equal what stores the result of the first regex pattern, the $2 backreference variable
will equal what stores the result of the second regex pattern, and so on.
Say you have the following program:
#!/usr/bin/perl/
# Regex.pl
$_ = 'When in the course of human events, it becomes necessary to dissolve a political band.';
print "Enter a regular expression: ";
my $pattern = <STDIN>;
chomp ($pattern);
if (/$pattern/) {
print "The text matches the pattern '$pattern'.\n";
print "\$1 is '$1'\n" if defined $1;
print "\$2 is '$2'\n" if defined $2;
print "\$3 is '$3'\n" if defined $3;
} else {
print "'$pattern' was not found.\n";
}
Then say you run the following iterations of it:
>c:\perl\bin\perl Regex.pl
Enter a regular expression: ([a-z]+)
The text matches the pattern ’([a-z]+)’.
$1 is ’hen’
Why not When? Because you only regexed for one or more lower-case letter(s).
Where's W? Try this:
>c:\perl\bin\perl Regex.pl
Enter a regular expression: ([A-Z])([a-z]+)
The text matches the pattern ’([A-Z])([a-z]+)’.
$1 is ’W’
$2 is ’hen’
The two sets of parentheses set what $1 and $2 are.
You searched for one upper-case letter and then searched for one or more lower-case letter(s).
Let's see if we can search and get When as the result for $1:
>c:\perl\bin\perl Regex.pl
Enter a regular expression: ([A-Z|a-z]*)
The text matches the pattern ’([A-Z|a-z]*)’.
$1 is ’When’
And yes, you could have used ([A-Z|a-z]+) instead in this prior example.
In the example you searched for 0 or more upper-case or lower-case letters. If you
used + instead of *, you would have searched for 1 or more of such a pattern.
Let's go for it all now:
>c:\perl\bin\perl Regex.pl
Enter a regular expression: ([A-Z|a-z|\W]+)
The text matches the pattern ’([A-Z|a-z|\W]+)’.
$1 is ’When in the course of human events, it becomes necessary to dissolve a
political band.’
You searched for the same as the above example, but this time also had
"or non-word characters" as designated by \W. And that pretty much
captures it all.
Let's do one more and utilize $1 through $3:
>c:\perl\bin\perl Regex.pl
Enter a regular expression: (\bn[a-z]+)(\Wto?)(\Wdis{2}[a-z]*)
The text matches the pattern ’(\bn[a-z]+)(\Wto?)(\Wdis{2}[a-z]*)’.
$1 is ’necessary’
$2 is ’to’
$3 is ’dissolve’
This example is not an efficient use of regex, but plays with it to show functionality.
I searched for a boundary between a non-word and word character followed by n with one
or more lower-case letter(s), giving a value to $1. Then, I searched for a non-word
value followed by the letter t and 0 or 1 o, giving a value to $2. Finally, I
searched for a non-word character followed by di, 2 s characters, and 0 or more lower-case
letters.
Look at this example, which uses backreference variables and Regex:
#!/usr/bin/perl
# MyNumbers.pl by Jamie Johnson
# This finds 2 numbers between and including 1 and 9
# and sets the first as $first and second as $second else it returns 99.
# If the first number is within range and the second is not,
# then the second gets the value of the first.
# Finally, it prints out the results for each array element.
use warnings;
use strict;
my $first = "99";
my $second = "99";
my $element = -1;
my @myNumbers = (
"Your Momma don't dance and your daddy don't rock and roll",
"1-6",
"3",
"2 or 6",
"3or6",
"4 to 6",
"5to6",
"6 - 6",
"Howdy7 to 9",
"8 to 6 to 9",
"23",
"1 or 23",
"23 or 1",
"0",
"-1",
"867-5309",
"1-800-CALL-STEVE",
"4 -9",
"5--7"
);
foreach my $i (@myNumbers) {
$element++;
print "Element $element ($i): ";
$_ = $i;
if (m/^(\d+)$/) { # Only one number
if ($1>=1&&$1<10) {
$first = $1;
$second = $1;
}
else { $first=$second="99"; }
}
elsif (m/(\d+)(\D+)(\d+)/) { # first numeric, non-numeric, numeric
if ($1>=1&&$1<10) {
$first = $1;
if ($3>=1&&$3<10) {
$second = $3;
} else { $second = $first; }
}
}
else { $first = "99"; $second = "99"; }
print "first: $first second: $second\n";
}
Modifiers allow one to treat strings in certain ways. Some have already
been demonstrated. Here are some modifiers:
| Modifier |
What it does |
| /i |
ignore case |
| /g |
apply globally substitution OR apply in multiple matches where \G anchors the beginning of the regex |
| /m |
treat as multiple lines |
| /s |
treat as a single lines |
| /x |
"breaks down" complex regex so that whitespace and comments are allowed in formulating the regex |
Split and Join
split - just think of this as you would in JavaScript as applied to a string,
but with a regex flavor, and think of join as applied to an array:
my $quote = "Oh:my:horses";
my @words = split /:/, $quote;
print "$words[0] $words[1] $words[2]";
my $requote = join " ", @words; #join it together with spaces between the words
print $requote;
(?# This is an inline comment which is ignored within regex)
(?i) Ignores case when within a regex pattern, e.g., /(?i)Biblical/
This matches Biblical or biblical.
/One nation under ((?-i)God)/ only matches God with a capital G.
You can do this with other modifiers above.
(?:some expression) groups only instead of putting it into a backreference variable
/Dark(?= Knight)/ This optimizes regex matching in that
it only considers the word Dark if the next word is Knight.
/Dark(?! Knight)/ This only considers the word Dark if the
next word is NOT Knight.
/(?<=Dark )Knight/ This only considers the word Knight if
the word before it is Dark.
/(?<!Dark )Knight/ This only considers the word Knight if
the word before it is NOT Dark.
Here are some helpful shortcuts and references from http://blob.perl.org/books/beginning-perl/3145_Chap05.pdf:
Example of more Regex (Regular Expression) use
Additional use of regex is seen in the next section below.
Routines, etc. (more arrays, input, routines, etc.) [<<rewind]
Let's play some arrays, input, and routines...
sub subroutine_name {
my($somehero, $someID) = @_; # name the parameters which are passed into @_
#stuff here
} A subroutine, similar to a Java method or a JavaScript function where the my() defines the
parameters with a block scope and for this subroutine, they are placed in the array @_. You can
also use return statements similar to what you do in JavaScript or Java. One convention is to
prefix the subroutine with the & sign. However, it is worth mentioning that in the world of Perl,
a function is usually something built into the programming language while a subroutine is defined
by the programmer. Call a subroutine, like this:
subroutine_name(myhero, myheroID);
You can also specify the amount and type of data to be passed. In the example subroutine
below, 2 scalars are passed to the subroutine, each represented by $.
sub calculator($$) { … }
Conventionally, the subroutine calls from the main section of the program are placed at the
top of the code and then the subroutines themselves follow.
You can pass a single array to a subroutine, but there are special considerations
if you are passing multiple parameters. For an array called myarray and
a hash called <ôt>myhash, you would do as follows:
subroutine_name(\@myarray, \%myhash); # Note the use of references
and then you would structure the subroutine as such:
sub subroutine_name {
my($myarrayref, $myhashref) = @_;
}
Notice that within the subroutine, the "refs" are references to the
array and hash, respectively, but realize that if you change a reference element,
you are altering that element in the original array or hash. In the example above,
to change a reference element, you would use the following for array and hash,
respectively:
$myarrayref->[1]
$myhashref->[1]
If I wanted to dereference my array or hash in the subroutine, I could use the
following respectively:
my @derefarray = @{$myarrayref};
my @derefhash = %{$myhashref};
Since these would be localized to the subroutine, changing the values of @derefarray
and @derefhash will not change the values in the original array and hash, respectively.
Find more information about references here.
Now back to our hero example:
What if the empty string <IDLIST> is undefined?
while ( defined ($hero = <IDLIST>) ) { takes care of this problem. You could also use die function to break the program as needed.
What is $! for? It is a variable with a system error message.
Perl Operator -M retruns how many days since file modification.
You can set a program to mail you, too:
open MAIL, "|mail email@server.com"; The pipe symbol opens a command line.
print MAIL "Some message and you can put $variables in it, also.\n\nSincerely, \nYour Perl Mail Porgram";
close MAIL;
Here's a simple and fun little program I wrote in PERL:
#!/usr/bin/perl
init_arrays();
$arraysize = 15;
$quitter = false;
print "\n\nWhat hero or villain are you? ";
$heroname = <STDIN>;
chomp $heroname;
if ($heroname=~ /^beacon deacon\b/i) {
print "Hello, Jamie!\n";
} else {
print "Hello, $heroname!\n";
}
$arrayindex = 0;
$found = 0;
while ($found eq 0) {
$findheroname = $heroname;
while ($arrayindex < $arraysize) {
$comparefindheroname = $heroes[$arrayindex];
$findheroname =~ s/\W.*//;
$findheroname =~ tr/A-Z/a-z/;
$comparefindheroname =~ s/\W.*//;
$comparefindheroname =~ tr/A-Z/a-z/;
if ($findheroname eq $comparefindheroname) {
$found = $found + 1;
}
$arrayindex = $arrayindex + 1;
}
if ($found eq 0) {
$found = 0;
$arrayindex = 0;
print "\n\nNot on record! Try again!\nWhat hero or villain are you? ";
$heroname = <STDIN>;
chomp $heroname;
if ($heroname=~ /^beacon deacon\b/i) {
print "Hello, Jamie!\n";
} else {
print "Hello, $heroname!\n";
}
}
}
print "What is your secret identity (Type 'quit' to quit the program)? ";
$guess = <STDIN>;
chomp ($guess);
while (! good_ID($heroname,$guess)) {
print "Invalid!\nWhat is your secret identity (Type 'quit' to quit the program)? ";
$guess = <STDIN>;
chomp ($guess);
}
if (good_ID($heroname,$guess)) {
if ($quitter ne true) {
print "\n\n$guess, a.k.a. $heroname, your access has been granted!\n\n";
$indx = 0;
while ($indx < $arraysize) {
print "The secret identity of $heroes[$indx] is $IDs[$indx].\n";
$indx = $indx + 1;
}
print "\n";
} else {
print "\nExitting Program. Goodbye.\n\n";
}
}
## subroutines from here down
sub init_arrays {
@heroes = ("Batman", "Spiderman", "Destro", "Superman", "Darth Vader", "Beacon Deacon", "Captain America", "Wonder Woman", "Hulk", "Green Hornet", "Green Arrow", "Judge Dredd", "Lone Ranger", "Robin", "Stormshadow");
@IDs = ("Bruce Wayne", "Peter Parker", "James McCullen", "Clark Kent", "Anakin Skywalker", "Jamie Johnson", "Steve Rogers", "Diana Prince", "Robert Bruce Banner", "Britt Reid", "Oliver Queen", "Joe Dredd", "John Reid", "Dick Grayson", "Thomas Arashikage");
}
sub good_ID {
my($somename,$someguess) = @_; # name the parameters
$somename =~ s/\W.*//; # delete everything after first word
$somename =~ tr/A-Z/a-z/; # lower-case everything
$someguess =~ s/\W.*//;
$someguess =~ tr/A-Z/a-z/;
$idx = 0;
if ("quit" eq $someguess) {
$quitter = true;
return 1;
}
while ($idx ne $arraysize) {
$comparehero = $heroes[$idx];
$comparehero =~ s/\W.*//;
$comparehero =~ tr/A-Z/a-z/;
$compareID = $IDs[$idx];
$compareID =~ s/\W.*//;
$compareID =~ tr/A-Z/a-z/;
if ($somename eq $comparehero) {
if ($someguess eq $compareID) {
return 1; # return value is true
} else {
return 0; # return value is false
}
}
$idx = $idx + 1;
}
}
↓ externalize a subroutine ↓
Do you have a subroutine you use often and would like to repeat its use in other scripts?
Consider externalizing it as shown below. So, what about external subroutines, such as where you
want to call a perl routine from an external .pl file from your .cgi script?
Do this in your CGI where myfctn.pl is the arbitrarily-named external file containing the
subroutine, somefctn is the arbitrarily-named subroutine (notice that & is not
required in front of the subroutine name) in the file, and $myparam is an arbitrarily-named
variable you pass as a parameter to the subroutine:
if(-e -r -s "myfctn.pl"){ # check that there -exists a -readable -system file over 0 bytes
do "myfctn.pl"; # "read" in the external script file with the function
somefctn($myparam); # call the function - no & needed
}
And then your subroutine is in an executable perl script (the myfctn.pl file) set up similar to this:
#!/usr/bin/perl
use strict;
sub myfctn {
$_[0] =~ s/</</g; # where $_[0] is the parameter you passed.
}
1;
I am just running a simple RegEx line, but you have at your disposal a perl script to do all sorts
of things in a centralized way!
Apache and CGI.pm [<<rewind]
CGI is the Common Gateway Interface - scripts web servers use to run scripts.
For Apache server, don't forget to enable CGI in the httpd.conf with the following: ExecCGI
For Apache server 2.2, DO NOT use the following in the httpd.conf file: UserDir
CGI.pm
In Perl, if you are using print <<EndOfHTML to print a section of HTML, then make sure you
put a return after the final EndOfHTML. If it is the end of the program, you can put exit;
The shbang line might be #!/usr/bin/perl -w OR #!/perl/bin/perl -wT but it needs proper path.
CGI.PM: (After shbang line - allows use of functions from the module): use CGI qw(:standard);
Functions in CGI.PM:
header;
start_html;
end_html;
print start_html("Hello World");
will print out the following:
<html>
<head>
<title>Hello World</title>
<head>
<body>
You can also set the page colors and background image with start_html:
print start_html(-title=>"Hello World",
-bgcolor=>"#cccccc", -text=>"#999999",
-background=>"bgimage.jpg");
Notice that with multiple arguments, you have to specify the name of each argument
with -title=>, -bgcolor=>, etc. This example generates the same HTML as above,
only the body tag indicates the page colors and background image:
<body bgcolor="#cccccc" text="#999999" background="bgimg.jpg">
The end_html function prints out the closing HTML tags:
</body>
</html>
Check Syntax and Logs [<<rewind]
use CGI::Carp qw(warningsToBrowser fatalsToBrowser); Use the Carp Module in CGI.pm.
perl -cwT myscript.cgi Use this to test from command line to check syntax without running myscript.cgi.
I've also noticed that checking syntax will work when using CGI qw standard and what makes it
work is perl -c.
More info? Logs are often located in the following directories:
/usr/local/etc/httpd/logs/error_log
/var/log/httpd/error_log
In Unix, view the end of the log file (which contains the error message in the final line) using the following:
tail /var/log/apache/error_log
Using Perl/CGI to redirect a web page is described here.
More on CGI:
http://search.cpan.org/dist/CGI.pm/
http://blob.perl.org/books/beginning-perl/3145_Chap12.pdf
Environment Variables [<<rewind]
Thanks to http://www.cgi101.com/book/ch3/text.html
Key Value
DOCUMENT_ROOT The root directory of your server
HTTP_COOKIE The visitor's cookie, if one is set
HTTP_HOST The hostname of the page being attempted
HTTP_REFERER The URL of the page that called your program
HTTP_USER_AGENT The browser type of the visitor
HTTPS "on" if the program is being called through a secure server
PATH The system path your server is running under
QUERY_STRING The query string (see GET, below)
REMOTE_ADDR The IP address of the visitor
REMOTE_HOST The hostname of the visitor (if server has reverse-name-lookups on; otherwise IP address)
REMOTE_PORT The port the visitor is connected to on the web server
REMOTE_USER The visitor's username (for .htaccess-protected pages)
REQUEST_METHOD GET or POST
REQUEST_URI The interpreted pathname of the requested document or CGI (relative to the document root)
SCRIPT_FILENAME The full pathname of the current CGI
SCRIPT_NAME The interpreted pathname of the current CGI (relative to the document root)
SERVER_ADMIN The email address for your server's webmaster
SERVER_NAME Your server's fully qualified domain name (e.g. www.cgi101.com)
SERVER_PORT The port number your server is listening on
SERVER_SOFTWARE The server software you're using (e.g. Apache 1.3)
print "Caller = $ENV{HTTP_REFERER}\n"; # print URL of the page that called the program.
Print all environment variables! Check this out!
#!/usr/bin/perl -w
# PRINT ALL ENVIRONMENT VARIABLES
use strict;
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
print header;
print start_html("Environment");
foreach my $key (sort(keys(%ENV))) {
print "$key = $ENV{$key}<br />\n";
}
print end_html;
Remote Host Program:
#!/usr/bin/perl -w
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use strict;
use Socket;
print header;
print start_html("Remote Host");
my $hostname = gethostbyaddr(inet_aton($ENV{REMOTE_ADDR}), AF_INET);
print "Welcome, visitor from $hostname!<p>\n";
print end_html;
Browser Detection Program: [<<rewind]
#!/usr/bin/perl -w
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use strict;
print header;
print start_html("Browser Detect");
my($ua) = $ENV{HTTP_USER_AGENT};
print "User-agent: $ua<p>\n";
if (index($ua, "MSIE") > -1) {
print "Your browser is Internet Explorer.<p>\n";
} elsif (index($ua, "Netscape") > -1) {
print "Your browser is Netscape.<p>\n";
} elsif (index($ua, "Safari") > -1) {
print "Your browser is Safari.<p>\n";
} elsif (index($ua, "Opera") > -1) {
print "Your browser is Opera.<p>\n";
} elsif (index($ua, "Mozilla") > -1) {
print "Your browser is probably Mozilla.<p>\n";
} else {
print "unknown browser<p>\n";
}
print end_html;
Look! I've been having fun with some of this. I made a form which accepts your name and then makes a certificate.
Here's the form:
<html>
<head>
<title>Certifiable</title>
</head>
<body>
<form action="/cgi-bin/computing/johns2ja/certifiable.cgi" method="GET">
Your First and Last names below: <br />
First Name: <input type="text" name="first_name" size=30 /><br />
Last Name: <input type="text" name="last_name" size=30 /><br />
<input type="submit"><p>
</form>
</body>
</html>
Here's the cgi script:
#!/usr/bin/perl -w
use strict;
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
print header;
print start_html("Environment");
my @values = split(/&/,$ENV{QUERY_STRING});
print "<div align=\"center\">\n";
print "<div align=\"center\" style=\"padding:50px;border:3px solid navy;background-image:url(http://www.beacondeacon.com/brightsky.jpg);width:500px;\">\n";
print "<span style=\"font-family:cambri;color:navy;font-size:50px;\">";
my $name;
foreach my $j (@values) {
my($fieldname, $data) = split(/=/, $j);
$name = "$data";
$name =~ s/\+/ /g; # in case someone inputs multiple names in a field, this substitutes the + with a space.
print "$name ";
}
print "</span>\n";
print "<br /><p style=\"font-style:italic;font-family:times;font-size:20px;\">is successfully serving as Chairman of the Crazy Klub!</p><p></p>\n";
print "<div style=\"float:right;font-size:50px;color:blue;\">~~~~~~~~~~~~~~~<br />~~~~~~~~~~~~~~~</div><br />\n";
print "<div align=\"left\">\n";
print "<div align=\"center\" style=\"padding:5px; width:50px; background-color:blue;font-size:35px;color:white;\"> ۞ \n<br /><span style=\"font-size:11px;\">Seal of Insanity</span></div>\n";
print "</div>\n";
print "<div style=\"clear:right;\"> </div>\n";
print "</div>\n";
print "</div>\n";
print end_html;
param [<<rewind]
Here is some useful information regarding param from http://www.cgi101.com/book/ch3/text.html:
If you're sending more than one value in the query string, it's best to use CGI.pm to parse it. This requires that your query string be of the form:
fieldname1=value1
For multiple values, it should look like this:
fieldname1=value1&fieldname2=value2&fieldname3=value3
This will be the case if you are using a form, but if you're typing the URL directly then you need to be sure to use a fieldname, an equals sign, then the field value.
CGI.pm provides these values to you automatically with the param function:
param('fieldname');
This returns the value entered in the fieldname field. It also does the URL-decoding for you, so you get the exact string that was typed in the form field.
You can get a list of all the fieldnames used in the form by calling param with no arguments:
my @fieldnames = param();
param is NOT a Variable!
param is a function call. You can't do this:
print "$p = param($p)<br />\n";
If you want to print the value of param($p), you can print it by itself:
print param($p);
Or call param outside of the double-quoted strings:
print "$p = ", param($p), "<br />\n";
You won't be able to use param('fieldname') inside a here-document. You may find it easier to assign the form values to individual variables:
my $firstname = param('firstname');
my $lastname = param('lastname');
Another way would be to assign every form value to a hash:
my(%form);
foreach my $p (param()) {
$form{$p} = param($p);
}
You can achieve the same result by using CGI.pm's Vars function:
use CGI qw(:standard Vars);
my %form = Vars();
The Vars function is not part of the "standard" set of CGI.pm functions, so it must be included specifically in the use statement.
Either way, after storing the field values in the %form hash, you can refer to the individual field names by using $form{'fieldname'}. (This will not work if you have a form with multiple fields having the same field name.)
A couple more things to remember with param: use CGI; And for params using post use the name attribute from the passing script.
***********************************************************************************
*** For the above form examples: Avoid using GET for sending confidential data. ***
*** One can see the entry as part of the URL. Use POST instead. ***
***********************************************************************************
Passing parameters via links and processing with a case statement:
If you are interested in passing parameters via a link so that the "page" processes
itself and displays information in the format URL/file?param=value,
you can do something like shown below (and it shows good use of a case statement):
#!/usr/bin/perl -w
# cgi-bin/ani: program to answer choice
use CGI qw(param);
use Switch;
my $choice = param("option");
print <<END_of_Start;
Content-type: text/html
<html>
<head>
<title>Anakin Skywalker Info</title>
</head>
<body>
<h1>Anakin Skywalker Information</h1>
<p>Click a link for more info:</p>
<p><a href="?option=early">early years</a></p>
<p><a href="?option=middle">middle years</a></p>
<p><a href="?option=later">later years</a></p>
END_of_Start
if ($choice ne '') {
print "<h2>Anakin Skywalker - the $choice years</h2>";
switch ($choice) {
case "early" { print "<p>Anakin was a slave on Tatooine, son of Shmi Skywalker. He was brought to the Jedi by Qui-Gon Jinn.</p>"; }
case "middle" { print "<p>Anakin became a powerful Jedi. He married Padmé Amidala of Naboo and she became pregnant with twins (Luke and Leia). He was later seduced by Emperor Palpatine/Darth Sidious and became the Sith Lord Darth Vader. He then proceeded to destroy the Jedi.</p>"; }
case "later" { print "<p>As Darth Vader, he discovered that he had a son Luke Skywalker and later a daughter Princess Leia Organa. He tried to turn his son to the Dark Side, but it was Luke who turned Darth Vader back to Anakin Skywalker - to the Light Side. While Palpatine was on the verge of killing Luke, Vader killed Palpatine and sacrificed himself for his son.</p>"; }
else { print "<p>Make a choice!</p>"; }
}
}
print "</body></html>";
Note that the link showing ?option=early is short for ani.cgi?option=early
(assuming the program file is called ani.cgi). This may mean that say you have another page where
you have the phrase "When Anankin was younger", you could link the word younger to
the following: ani.cgi?option=early
Processing Forms [<<rewind]
When parsing form code for decoding, use CGI.pm. To upgrade an older program,
do the following:
my %FORM;
foreach my $field (param()) {
$FORM{$field} = param($field);
}
Or use the Vars function:
use CGI qw(:standard Vars);
my %FORM = Vars();
Make sure you have unique identifiers for fields for this to function properly!
Also make sure to validate your forms. Say you have a mail form. You could
validate it with something like the following:
if (param('from') eq "" or param('to') eq "") {
&dienice("Please fill out the fields for your email address and the recipient\'s email address.");
} # NOTE: dienice is a function. Note the use of the ampersand.
Checkboxes
<strong>Mission Commander, choose your crew:</strong><br />
<form action="commander.cgi" method="POST">
<input type="checkbox" name="Han Solo" id="Han Solo" value="1"> Han Solo<br />
<input type="checkbox" name="Luke Skywalker" id="Luke Skywalker" value="1"> Luke Skywalker<br />
<input type="checkbox" name="Chewbacca" id="Chewbacca" value="1"> Chewbacca<br />
<input type="checkbox" name="Obi-Wan Kenobi" id="Obi-Wan Kenobi" value="1"> Obi-Wan Kenobi<br />
<input type="submit" />
</form>
And here is the script commander.cgi:
#!/usr/bin/perl -w
use strict;
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
print header;
print start_html("Mission Commander");
print "<h1>Mission Commander</h1>";
my @commanders = ("Han Solo","Luke Skywalker","Chewbacca","Obi-Wan Kenobi");
foreach my $commander (@commanders) {
if (param($commander)) {
print "$commander will join the assault on the Death Star.<br />\n";
}
}
print end_html;
NOTE: In the above form, you could have the name and id attributes the same and vary the value attribute as shown below:.
<strong>Choose your crew</strong><br />
<form action="commander2.cgi" method="POST">
<input type="checkbox" name="commander" id="commander" value="Han Solo"> Han Solo<br />
<input type="checkbox" name="commander" id="commander" value="Luke Skywalker"> Luke Skywalker<br />
<input type="checkbox" name="commander" id="commander" value="Chewbacca"> Chewbacca<br />
<input type="checkbox" name="commander" id="commander" value="Obi-Wan Kenobi"> Obi-Wan Kenobi<br />
<input type="submit" />
</form>
However, you will then need to change the CGI script, ensuring that the name/id is commander as referenced in the script:
#!/usr/bin/perl -w
use strict;
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
print header;
print start_html("Mission Commander");
print "<h1>Mission Commander</h1>";
my @commanders = param('commander');
foreach my $commander (@commanders) {
print "$commander will join the assault on the Death Star.<br />\n";
}
print end_html;
Radio Buttons
Say you don't want to pick the crew, but the one commander, then you wouuld use radio buttons.
Here's the form:
<h1>Mission Commander</h1>
<strong>Choose the Mission Commander</strong><br />
<form action="commander3.cgi" method="POST">
<input type="radio" name="commander" id="commander" value="Han Solo"> Han Solo<br />
<input type="radio" name="commander" id="commander" value="Luke Skywalker"> Luke Skywalker<br />
<input type="radio" name="commander" id="commander" value="Chewbacca"> Chewbacca<br />
<input type="radio" name="commander" id="commander" value="Obi-Wan Kenobi"> Obi-Wan Kenobi<br />
<input type="submit" />
</form>
Here's the script commander3.cgi:
#!/usr/bin/perl -w
use strict;
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
print header;
print start_html("Mission Commander");
print "<h1>Mission Commander</h1>";
my $commander = param('commander'); # Notice how the param commander matches the name/id in the form
print "$commander will lead the assault on the Death Star.<br />\n";
print end_html;
You could add some validation to ensure that the user actually selected a value in the above:
if (exists $commanders{$commander}) {
# Your Code to Output the result here
} else {
print "The Imperialists will win if you fail to choose!";
}
Drop-Downs
HTML Form:
<strong>Choose the Mission Commander</strong><br />
<form action="commander4.cgi" method="POST">
<select name="commander" size="4">
<option value="Han Solo"> Han Solo</option>
<option value="Luke Skywalker"> Luke Skywalker</option>
<option value="Chewbacca"> Chewbacca</option>
<option value="Obi-Wan Kenobi"> Obi-Wan Kenobi</option>
</select>
<input type="submit" />
</form>
CGI Script:
#!/usr/bin/perl -w
use strict;
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
print header;
print start_html("Mission Commander");
print "<h1>Mission Commander</h1>";
my @commanders = param('commander');
foreach my $commander (@commanders) {
print "$commander will lead the assault on the Death Star.<br />\n";
}
print end_html;
CAUTION! Anyone can send data to your CGI script!
YouTube Code Converter by Jamie Johnson [<<rewind]
YouTube's code to embed videos is not standard. So, I wrote a converter using form processing and
regex items mentioned on this page.
Here's the HTML form:
<h1>YouTube Code Conversion</h1>
<br /><br /><br />
<h2>Paste your code here:</h2>
<form action="/cgi-bin/computing/utubeconv.cgi" enctype="application/x-www-form-urlencoded" method="post">
<textarea cols="75" id="YouTubeHTML" name="YouTubeHTML" rows="10" wrap="soft"></textarea>
<br />
<input type="submit" value="Convert Code" /><input type="reset" value="Clear" />
</form>
And here's script which does the magic:
#!/usr/bin/perl
# utube.cgi by Jamie Johnson
use warnings;
use strict;
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
my $height=0;
my $width=0;
my $url="ERROR";
my $change="init";
my %form;
$form{'YouTubeHTML'} = param('YouTubeHTML');
$change = param('YouTubeHTML');
# BEGIN FOR STRING TEST ONLY!
# You will have to comment out the above param line when you uncomment the next line.
# $change = "<object width=\"425\" height=\"344\"><param name=\"movie\" value=\"http://www.youtube.com/v/GxibToE1S7A&hl=en&fs=1\"></param><param name=\"allowFullScreen\" value=\"true\"></param><embed src=\"http://www.youtube.com/v/GxibToE1S7A&hl=en&fs=1\" type=\"application/x-shockwave-flash\" allowfullscreen=\"true\" width=\"425\" height=\"344\"></embed></object>";
# END FOR STRING TEST ONLY!
chomp($change);
$_ = $change;
if (m/height=\"(\d+)/) { # match one or more digits only after height=" and before "
$height = $1;
}
if (m/width=\"(\d+)/) { # match one or more digits only after width=" and before "
$width = $1;
}
if (m/src=\"(.+)\&/) { # match one or more of any character only after src=" and before &
$url = $1;
}
$url =~ s/&.+//; # Remove the & and all after it from the URL if it still exists.
print header;
print start_html("Your converted code");
print h1("Thank you for using the YouTube Code Converter.<br />Here is your converted code:");
print "\n\n";
if ($height==0||$width==0||$url eq "ERROR") { $change="ERROR"; }
if ($change eq "ERROR") {
print "<p>Please input valid code.</p><p><a href=\"/wm2/docs/youtubeconv.shtml\">Back</a></p>";
}
else {
print "<object type="application/x-shockwave-flash" width="$width" height="$height" data="$url"><br />
<param name="movie" value="$url"></param><br />
<param name="wmode" value="transparent"></param><br />
</object><p> </p><p><a href=\"/wm2/docs/youtubeconv.shtml\">Back</a></p>";
}
print end_html;
HTML to Entity Converter by Jamie Johnson [<<rewind]
I decided to take some of the above concepts and make myself a tool,
which will actually help with this page. Basically, I can paste HTML
code into a form and it will convert it to use entities so I can have
the code show up in the browser. Note the use of Regex (Regular Expressions).
Here's my form:
<h1>HTML to Entity Converter</h1>
<h2>by Jamie Johnson</h2>
<p>This converts HTML code to entities so you can display it on a web page.</p>
<p>Paste your code here:</p>
<form action="/cgi-bin/computing/johns2ja/convHTML.cgi" method="POST">
<textarea name="convHTML" id="convHTML" rows="20" cols="100"></textarea><br />
<input type="submit" value="Convert HTML to Entity" /><input type="reset" value="Clear" />
</form>
Here's my script convHTML.cgi:
Your converted code:
#!/usr/bin/perl -w
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use strict;
print header;
print start_html("Your converted code");
print h1("Thank you for using the HTML to Entity Converter by Jamie Johnson.<br />Here is your converted code:");
my %form;
foreach my $p (param()) {
$form{$p} = param($p);
my $change = $form{$p};
$change =~ s/\&/\&amp;/g; # substitute & for & globally (/g) in the string.
$change =~ s/ /\&nbsp;/g; # substitute for a space globally (/g) in the string.
$change =~ s/\"/\&quot;/g; # substitute " for " globally (/g) in the string.
$change =~ s/</\&lt;/g; # substitute < for < globally (/g) in the string.
$change =~ s/>/\&gt;/g; # substitute > for > globally (/g) in the string.
$change =~ s/\'/\&#39;/g; # substitute ' for ' globally (/g) in the string.
$change =~ s/\n/\<br \/>\<br \/\>/g; # substitute both an actual and rendered <br /> for \n globally (/g) in the string.
print "$change<br />\n";
}
print "<p><a href=\"http://www.jmu.edu/computing/jamie/convHTML.html\"><span style=\"color:blue;text-decoration:none;\">HTML to Entity Converter</span></a></p>";
print end_html;
See it in action!
There is already a module in Perl called HTML::Entities, which can do this for you.
To learn about it, visit http://search.cpan.org/dist/HTML-Parser/lib/HTML/Entities.pm.
File I/O [<<rewind]
Opening Files
open(MYF, "myfile.txt") or &dienice("myfile.txt cannot be opened for reading: $!"); # opens myfile.txt for reading and the $! stores the error code.
open(MYF, ">myfile.txt") or &dienice("myfile.txt cannot be opened for writing: $!"); # opens myfile.txt for overwriting as designated by > Use print
open(MYF, ">>myfile.txt") or &dienice("myfile.txt cannot be opened for appending: $!"); # opens myfile.txt for appending as designated by >>
open(MYF, "+<myfile.txt") or &dienice("myfile.txt cannot be opened for reading/writing: $!"); # opens existing myfile.txt reading/writing as designated by +<
MYF is an arbitrary name. It is a filehandler just like <STDIN>.
You can also use directory handle similarly when using the opendir command to open a directory.
NOTE: You would use then use the following with a directory handle:
while ($_ = readdir(directoryHandle)) { actions }
If you use _ in the loop, since you are reading one directory, this will refer to the current
file or sub-directory in the directory referenced by the directory handle.
In some cases, you may have to use the full path of the file instead of just the filename.
If you wanted to specify a path in the above, in the double quotes, you could put the path as
shown here: open(MYF,"c:\perldata\myfile.txt"). Remember that the \
does not need to be escaped in double quotes. Also remember in the above that $! is
perl's special variable for holding error messages. Note for the above, also, you could do
this instead: open MYF, "myfile.txt" or die "Houston, we have a problem: $!";
or simply (but not as nice): open MYF, "myfile.txt" or die $!;
use Fcntl qw(:flock); This is used to lock files so that the file won't lose data.
Use LOCK_SH shared lock when reading a file and LOCK_EX exclusive lock when writing a file.
After you open a file using:
open(MYF, "myfile.txt") or &dienice("Cannot open file myfile.txt: $!");
You then use flock(MYF, LOCK_SH); to lock (shared) the file. The file will remain locked
until the program terminates or the file is closed. Ensure that the program doing the file I/O uses
flock.
If another user is writing a file, you should reset the file pointer so that you won't pick up
where the other user left off. Here's how you would do it using the example above:
seek(MYF,0,2) places pointer at end of file
seek(MYF,0,0) places pointer at beginning of file
However if you include use Fcntl qw(:flock :seek); you can do the following instead:
seek(MYF,0,SEEK_SET) Beginning of File
seek(MYF,0,SEEK_CUR) Current Position in File
seek(MYF,0,SEEK_END) End of File
Finally, you simply close the file using the filehandle (MYF in the example): close(MYF);
Reading & Closing Files
After you open the file, using
open(MYF,"myfile.txt") or &dienice("Cannot open myfile.txt: $!");
you do the following (using the MYF filehandler in the example above:
my $myfileline = <MYF>; # reads one line from the file into the scalar variable $myfileline
my @mywholefile = <MYF>; # reads the whole file into the array @mywholefile
Then you close the file as so:
close(MYF); # closes the file referenced by the filehandler MYF
If you wanted the read the file line-by-line, you would do as follows:
open(MYF,"myfile.txt") or &dienice("Cannot open myfile.txt: $!");
my @mywholefile = <MYF>;
close(MYF);
foreach my $line (@mywholefile) {
print $line;
}
OR to use less memory:
open(MYF,"myfile.txt") or &dienice("Cannot open myfile.txt: $!");
while (my $line = <MYF>) {
print $line;
}
close(MYF);
Or even less...
while (<MYF>) {
print $_;
}
One can do as follows if using the command-line to refer to the file:
>perl myfileprocessor.pl myfile.txt
while (<>) {
actions
} # <> is an abbreviation for <ARGV>, which refers to myfile.txt
This uses ARGV to work. Refer to ARGV for more information.
sort and shift files similarly to how you do with arrays.
*MYF = *STDIN The * allows the filehandle STDIN's referred contents to be put in to MYF's reference.
This is part of glob("*.extension") which lists filenames matching the *.ext name and uses * like a wildcard
just as you would in a command-line environment. Likewise, ? is the wildcard for a single character.
For example:
my @dirlist=glob("*"); is like doing ls * in Unix shell or dir *.* in DOS commmand-line
and feedingit into the array @dirlist.
File tests check the status of files so one can program in a manner that
prevents problems during the execution of a program that utilizes file I/O. The following
chart is a helpful resource from http://blob.perl.org/books/beginning-perl/3145_Chap06.pdf:
Usage: if (Test $variableContainingFileName) { actions }
Gravity Petition by Jamie Johnson [<<rewind]
Here's a fun example of File I/O -- a petition. Here's the form:
<html>
<head>
<title>Gravity Petition</title>
</head>
<body>
<h1>Gravity Petition…Keeping things down to earth</h1>
<h2>Please sign our petition!</h2>
<p>By entering your first and last name below, you are supporting the Law of Gravity!</p>
<p>Gravity... while it might get you down, respect it for it shows no favoritism!</p>
<p>Gravity keeps you down to earth.</p>
<form action="gravity.cgi" method="GET">
Enter your First and Last names below: <br />
First Name: <input type="text" name="first_name" size=30 /><br />
Last Name: <input type="text" name="last_name" size=30 /><br />
<input type="submit"><p>
</form>
</body>
</html>
And here's the CGI script:
#!/usr/bin/perl -w
use CGI qw(:standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use strict;
print header;
print start_html("Results");
print "<h2>Thank You</h2>";
# now write (append) to the file
open(OUT, ">>petition.txt") or &dienice("Couldn't open output file: $!");
my $i = 0;
foreach my $p (param()) {
print OUT param($p), " ";
$i++; # counting the params
if ($i==2) {
$i = 0;
print "\n"; # After every 2 params, a break is put in the file (new line)
}
}
print OUT "\n";
close(OUT);
print "<p>Here are the supporters of Gravity:</p><tt>";
open(OUT,"petition.txt") or &dienice("Cannot open petition.txt: $!");
my @mywholefile = <OUT>;
my $counter = 0;
foreach (@mywholefile) {
$counter++; # I added this variable so the lines of the file would show up numbered.
print "$counter. ";
if ($counter < 10) {
print " "; # This line puts in an extra space for 1-9 show that things line up nicely.
}
print"$_\n<br />"; # $_ is the current array element, an implicit part Perl, needs no declaration.
}
print "</tt>";
print <<EndHTML;
<p>Return to our <a href="gravitypetition.html">home page</a>.</p>
EndHTML
print end_html;
sub dienice {
my($errmsg) = @_;
print "<h2>Error</h2>\n";
print "<p>$errmsg</p>\n";
print end_html;
exit;
}
DBI [<<rewind]
The rundown - some pseudocode:
Database handler - $dbh - set up connection
[cartridge] OBDC, CSV, Oracle, etc.
Statement handler - $sth [SQL Clipboard]
$query = "SELECT * FROM mytable";
prepare($query);
execute (loop & do)
finish sth
disconnect dbh
exit;
Imagine a table called redskins arranged as such:
| lastname | firstname | jersey |
| Moseley | Mark | 3 |
| Theismann | Joe | 7 |
| Green | Darrell | 28 |
| Riggins | John | 44 |
| Butz | Dave | 65 |
| Jacoby | Joe | 66 |
| Monk | Art | 81 |
The actual file looks like this:
Moseley,Mark,3
Theismann,Joe,7
Green, Darrell,28
Riggins,John,44
Butz,Dave,65
Jacoby,Joe,66
Monk,Art,81
There is a necessary carriage return after Monk,Art,81 so that if another entry is made,
the program knows it is on a new line.
Now the script to read, insert, or delete data:
#!/usr/bin/perl -w
use DBI; # loads the DBI module
my $dbh = DBI->connect('DBI:CSV:n_dir=/af/it/johns2ja/wip/browsers/browse~1/perl/redskins')
or die "Cannot connect: " . DBI->errstr;
# redskins is the database name and it is at N:\af\it\johns2ja\wip\browsers\browse~1\perl\
$dbh->{'csv_tables'}->{'redskins'} = { 'col_names' => ["lastname","firstname","jersey"]};
# the column names are set in the above statement
$query = "SELECT * FROM redskins WHERE lastname = ?"; # The ? will receive data from user input
my $sth = $dbh->prepare($query) or die "Couldn't prepare statement: " . $dbh->errstr;
print "\n\nEnter last name of player or command (newskin, cleanup, or exit): ";
my @data; # This array holds the data
while ($lastname = <>) {
# Get data from user
chomp $lastname; # remove \n from the end of the input
my $cmd = $lastname;
$cmd =~ tr/A-Z/a-z/;
if ($cmd eq ""||$cmd eq " "||$cmd eq "exit"||$cmd eq "quit") {
$sth->finish;
$dbh->disconnect;
print "\n\nThank you for checking out the 'Skins!\n\n";
exit;
}
my $dataentry = 0; # There is no data entry occuring
my $datadel = 0; # There is no data deletion occuring
if ($cmd eq "cleanup") {
$datadel = 1; # data deletion is occurring
clearskin(); # calling the subroutine to delete non-original data
}
if ($cmd eq "newskin") {
my $ln;
my $fn;
my $jnum;
print "Enter last name of player: ";
$ln = <>;
chomp $ln;
print "Enter first name of player: ";
$fn = <>;
chomp $fn;
print "Enter jersey number of player: ";
$jnum = <>;
chomp $jnum;
my $query2 = "INSERT INTO redskins VALUES ('$ln','$fn','$jnum')";
my $sth2 = $dbh->prepare($query2) or die "Couldn't prepare statement: " . $dbh->errstr;
$sth2->execute();
$sth2->finish;
$dataentry = 1;
}
$sth->execute($lastname) # Run the query - think of sth as an SQL Clipboard - looking for lastname
or die "Couldn't execute statement: " . $sth->errstr;
my $no_rows=1;
while (@data = $sth->fetchrow_array()) {
# fetchrow_array is built-in and returns the elements that have matching data as per query
$no_rows=0;
my $firstname = $data[1]; my $jersey = $data[2];
print "\n\n$firstname $lastname wore jersey number $jersey for the Washington Redskins.\n\n";
}
if ($no_rows==1&&$dataentry==0&&$datadel==0) {
print "That name is not in the database.\n\n";
}
print "\n\nEnter last name of player or command (newskin, cleanup, or exit): ";
}
sub clearskin {
my $query3 = "DELETE FROM redskins WHERE jersey <> 3 AND jersey <> 7 AND jersey <> 28 AND jersey <> 44 AND jersey <> 65 AND jersey <> 66 AND jersey <> 81";
# The above query deletes any entries which were not in the original file
my $sth3 = $dbh->prepare($query3) or die "Couldn't prepare statement: " . $dbh->errstr;
print "\n\nAre you sure you want to clean the database? (y/n):";
my $rusure = <>;
chomp $rusure; # Have to chomp it so it clears the end and the next statement works
if ($rusure eq "y") {
$sth3->execute();
$sth3->finish;
print "\n\nDatabase cleaned up.\n\n";
} else {
$sth3->finish;
}
}
$sth->finish;
$dbh->disconnect;
exit;
A shortcut
$dbh->do('DELETE FROM redskins WHERE jersey > 85');
This above statement prepares, executes, and finishes the statement.
If you want an automatic commit after each successful query, do the following:
my $dbh = DBI->connect('redskins',
{AutoCommit => 1},
)
or die "Couldn't connect to database: " . DBI->errstr;
If you want to abort your program when an error occurs, do this:
my $dbh = DBI->connect('redskins',
{RaiseError => 1},
)
or die "Couldn't connect to database: " . DBI->errstr;
And finally, some very useful code for CGI with databases:
# Initialize connection to the "database"
# *** NOTE *** This assumes that $pkey is already defined.
# *** This also assumes that ~ is used as the separator character for the CSV file mydb.txt instead of a comma
my $dbh = DBI->connect(qq{DBI:CSV:csv_eol=\n;csv_sep_char=\\~}); # Database Handler
$dbh->{'csv_tables'}->{'MYDB'} = {'file' => 'mydb.txt','col_names' => ["PrimaryKey","First","Last"]};
# Setup error variables
$dbh->{'RaiseError'} = 1;
$@ = '';
#Setup query for bulk of data
my $dbquery = "SELECT First,Last FROM MYDB WHERE PrimaryKey = '$pkey'"; # or whatever SQL Query you need to do
my $sth = $dbh->prepare($dbquery); # Statement Handler
$sth->execute( );
while (my $row = $sth->fetchrow_hashref)
{ # START FETCH FROM MYDB and while fetching, it defines the variables with the values obtained from the query
$pkey = $row->{'PrimaryKey'};
my $first = $row->{'First'};
my $last = $row->{'Last'};
}
$sth->finish();
$dbh->disconnect();
HTML::Template [<<rewind]
#!/usr/bin/perl -w
use CGI qw( :standard :html3 );
use strict;
use HTML::Template;
#PRINT HEADER FOR HTML File
#Notice how it mimics attributes and tags in HTML for title, bgcolor, script, Doctype, head, and link
#Note, print header is shorthand for print "Content-Type: text/html\n\n";
print header, start_html(-title=>'This shows up in the title tag', -BGCOLOR=>'#FFFFFF',
-script=>({-language=>'javascript', -src=>'myscript.js'}),
-dtd=>'-//W3C//DTD HTML 4.01 Transitional//EN',
-head=>[
Link({-rel=>'stylesheet',-href=>'mystylesheet.css'})
]
);
#HTML TEMPLATES - These are just files with HTML
my $header = HTML::Template->new(filename => 'header_begin.shtml');
my $nav = HTML::Template->new(filename => 'nav.shtml');
my $headerend = HTML::Template->new(filename => 'header_end.shtml');
my $leftcontent_index = HTML::Template->new(filename => 'leftcontent_index.shtml');
my $footer = HTML::Template->new(filename => 'footer.shtml');
#---------------------- HTML Content Starts Here ------------------------------------------------
print $header->output;
print "<h1>My page</h1>";
print $nav->output;
print $headerend->output;
print $leftcontent_index->output;
print <<MyHTML;
<p>This is where your page content goes.</p>
MyHTML
print $footer->output;
exit;
That's about it!
Calling/embedding Perl in HTML [<<rewind]
Calling or embedding Perl in HTML is rather simple if you have Apache on your server. Simply use SSI.
For example, if you use CGI scripts to execute Perl on you server, then in your HTML code, put an include
statement to your Perl script where you want it to execute:
<!--#include virtual="/cgi-bin/myscript.cgi"-->
That's it!
Cookies [<<rewind]
Cookies can be set and read using Perl. Below are two scripts, which accomplish this:
setMyCookie.cgi:
#!/usr/bin/perl
# Jamie Johnson 17 August 2009
use strict;
use CGI;
use CGI qw( :standard :html3 );
use CGI::Cookie;
my $fut_time=gmtime(time()+60)." GMT"; # Add 1 minute
my $mydata="Oreo".",".$fut_time;
print "Set-Cookie: KEEBLER=$mydata; expires=$fut_time\n";
#PRINT HEADER FOR HTML File
# Example of print header...
print header, start_html(-title=>'C is for Cookie', -BGCOLOR=>'tan', -style => "body { font-weight:bold;font-family:arial; } ",-dtd=>'-//W3C//DTD HTML 4.01 Transitional//EN', -head=>[Link({-rel=>'stylesheet',-href=>''})]);
print <<StartHTML;
<!-- CONTENT AREA BEGINS HERE-->
<div class="content">
StartHTML
print <<MainHTML;
<!-- CONTENT BLOCK START -->
<p>
Hello! <br />
---------------<br />
$mydata cookie has been set.
<hr />
</p>
<p><a href="readMyCookie.cgi">Read the cookie...</a></p>
<!-- CONTENT BLOCK END -->
<!-- CONTENT AREA ENDS HERE-->
MainHTML
print <<CloseOfHTML;
</div>
</body>
</html>
CloseOfHTML
exit;
Sample Output:
Hello!
---------------
Oreo,Mon Aug 17 20:37:52 2009 GMT cookie has been set.
readMyCookie.cgi:
#!/usr/bin/perl
# Jamie Johnson 17 August 2009
use strict;
use CGI;
use CGI qw( :standard :html3 );
use CGI::Cookie;
#PRINT HEADER FOR HTML File
# Example of print header...
print header, start_html(-title=>'C is for Cookie', -BGCOLOR=>'tan', -style => "body { font-weight:bold;font-family:arial; } ",-dtd=>'-//W3C//DTD HTML 4.01 Transitional//EN', -head=>[Link({-rel=>'stylesheet',-href=>''})]);
# READ COOKIE
my $outputString;
my $querystr = new CGI;
my $Ceid = $querystr->cookie('KEEBLER');
my @cookieData = split /,/, $Ceid;
my $CexpDate=$cookieData[1];
my $CeidName = $cookieData[0];
my $currDate = gmtime(time())." GMT"; # Current Date
if (($CeidName eq 'Oreo')&&($CexpDate gt $currDate)) { $outputString="Yummy!" } else { $outputString="NO COOKIE FOR YOU!"; }
print <<StartHTML;
<!-- CONTENT AREA BEGINS HERE-->
<div class="content">
StartHTML
print <<MainHTML;
<!-- CONTENT BLOCK START -->
cookie: $Ceid
<br />
NAME: $CeidName
<br />
EXPIRE: $CexpDate
<br />
CURRENT: $currDate
<p>
Hello! <br />
---------------<br />
$outputString;
<br />
<p>You can <a href="readMyCookie.cgi">refresh</a> this screen to see the current time at any moment. When current time exceeds one minute beyond the cookie set time, the cookie expires. if you keep refreshing, you will see the cookie disappear.</p>
<p><a href="setMyCookie.cgi">Set the cookie...</a></p>
<hr />
</p>
<!-- CONTENT BLOCK END -->
<!-- CONTENT AREA ENDS HERE-->
MainHTML
print <<CloseOfHTML;
</div>
</body>
</html>
CloseOfHTML
exit;
Sample Output:
cookie: Oreo,Mon Aug 17 20:37:52 2009 GMT
NAME: Oreo
EXPIRE: Mon Aug 17 20:37:52 2009 GMT
CURRENT: Mon Aug 17 20:37:44 2009 GMT
Hello!
---------------
Yummy!;
You can refresh this screen to see the current time at any moment. When current time exceeds
one minute beyond the cookie set time, the cookie expires. if you keep refreshing, you will
see the cookie disappear.
Cookies Tutorial
ARGV [<<rewind]
ARGV is another special perl feature that holds what comes after it.
<ARGV> is a filehandler that holds the file after it such as if you ran
>perl myfileprocessor.pl myfile.txt and in this case,
<ARGV> would contain myfile.txt. Note that <ARGV> can be
abbreviated as <>. When used in this manner, the variable $ARGV
holds the filename, which can be printed, etc. Refer to File I/O for
more information about file input and output.
@ARGV
@ARGV holds the text after the command on command-line.
In away in the above, the text in question is the filename.
#!/usr/bin/perl
#addup.pl
use warnings;
use strict;
my $sum=0;
$sum += $_ for @ARGV;
print "Total Summation = $sum\n";
Now run it like this:
>perl addup.pl 8 6 7 5 3 0 9
Total Summation = 38
>
@INC & Modules[<<rewind]
@INC
is yet another special feature of Perl which is an array containing
the locations of modules. However, if you are developing your own modules,
you may want to add to this array. You can do so using the I switch:
perl -Ipathname program
do
is a module that reminds me of using call in a DOS batch script where
one batch script would call another. do does the same thing!
do "myperlapp.pl"
If you have a Perl program called myperlapp.pl, then you can use do
within another Perl program too run myperlapp.pl.
require
Same as do, but can only be used with one file one time in the program; otherwise, it's ignored.
However, you can use barewords with require like this:
require myperlapp;
which means it would be looknig for myperlapp.pm in the paths of @INC.
You can also be even more specific like this:
require Yo::Joe;
which will look for Yo.pm in the Joe directory. This can be handy
for organizing modules both in calling them and in storing them.
use
This is used (no pun intended) throughout the examples on this page!
use works just like require but consider how it is used on the examples
on this page. It is used in a manner that shows how it differs from require:
What is used is done before the rest of the program executes, while require
occurs in the order in which it is encountered as the program runs.
If someone wants to add to @INC before the program proceeds with executing,
then one could use lib like this:
use lib "module_path";
use mymodule;
BEGIN
use is not the only thing that runs before the rest of the program executes.
BEGIN allows this as well. If you wanted to put something in the @INC array
when the program is compiling as opposed to when the rest of the program executes.
Now all of this is nice and all, but let's show it in action. Say you have
your Perl program in a directory that also contains a subdirectory called Yo,
which contains a module for the program. How do you tell the program about the module
and use the functions from the module? The code below shows a program that does just
that:
#!/usr/bin/perl
use strict;
use warnings;
use lib "Yo/"; # Yo/ is the directory we want to use.
require Joe; # Joe.pm is the module in the Yo/ directory.
breaker(); # This is a subroutine defined below (following convention)
print "Contents of the \@INC array:\n\n"; # I had to escape the @
foreach my $element (@INC) {
print "$element\n";
}
breaker();
my $mydir = $INC[0]; # Let's look at the directory I just put in the @INC array, i.e. Yo/
print "Contents of $mydir directory:\n\n";
opendir DH, $mydir or die "Couldn't open the $mydir directory: $!";
while ($_ = readdir(DH)) {
if ($_ !~ /^\./) { # Don't consider . or .. (. at the beginning of the filename).
print $_;
print "\n";
}
}
breaker();
print "Now, let's use a function from the module Joe.pm:";
cobra(); # Look at the module below to see what this function contains.
breaker();
print "Let's use another function from the module Joe.pm:";
GIJoe(); # Look at the module below to see what this function contains.
# Subroutine
sub breaker {
print "\n-------------------------------\n";
}
Now here's the module Joe.pm in the Yo/ directory:
#!/usr/bin/perl
use strict;
use warnings;
my $mystr=" ";
# I put in the above string that is not used to prevent the error when the
# main program is run that "Joe.pm did not return a true value..."
# Essentially, this dummy line allows Joe.pm to pass a true value to the
# main program.
sub cobra {
print "\n";
print " ____\n";
print ' @____@';
print "\n";
print " /=' v__v '=\\\n";
print " /==|______|==\\\n";
print " /===|______|===\\\n";
print " (====|______|====)\n";
print " \\===|______|===/\n";
print " \\==|______|==/\n";
print " \\=| |=/\n";
print " \\| |/\n";
print " ` '\n\n";
print " COBRA!!!";
}
sub GIJoe {
print "\n";
print " ________________________________________________________\n";
print " / ___|| |_/\\_ | | / _ \\ | ___/ ////////////////////////\n";
print "| / __ | |\\ / | | | | | | | |_ ////////////////////////\n";
print "| ||_ || ||/\\| | | | | | | | _| / /\n";
print " \\ \\_||| | | |_| | | |_| | | |__/ /\n";
print " \\___||_| \\_____/ \\___/ |___////////////////////////\n";
print "//////////////////////////////////////////////////////\n";
}
Note the excercise in escaping out certain characters in the above!
And when you run the main program, you will receive output looking something like this:
-------------------------------
Contents of the @INC array:
Yo/
C:/Perl/site/lib
C:/Perl/lib
.
-------------------------------
Contents of Yo/ directory:
Joe.pm
-------------------------------
Now, let's use a function from the module Joe.pm:
____
@____@
/=' v__v '=\
/==|______|==\
/===|______|===\
(====|______|====)
\===|______|===/
\==|______|==/
\=| |=/
\| |/
` '
COBRA!!!
-------------------------------
Let's use another function from the module Joe.pm:
________________________________________________________
/ ___|| |_/\_ | | / _ \ | ___/ ////////////////////////
| / __ | |\ / | | | | | | | |_ ////////////////////////
| ||_ || ||/\| | | | | | | | _| / /
\ \_||| | | |_| | | |_| | | |__/ /
\___||_| \_____/ \___/ |___////////////////////////
//////////////////////////////////////////////////////
And remember: The use of a module allows its subroutines to be available to various Perl programs,
much like an externalized JavaScript being available to various web documents. This is different
from just a typical subroutine which is available at various times within the run of a single program
only (unless that subroutine is in a module :)
Detailed information about @INC and modules can be found at http://blob.perl.org/books/beginning-perl/3145_Chap10.pdf.
Object Orientation [<<rewind]
Hopefully, you have some familiarity with object orientation -
encapsulation, inheritance, information hiding, and inheritance.
Let's look at some code, which uses a class, constructor, objects, and
accessors (Read the comments!):
First, setting up a class (save as transformer.pm):
#!/usr/bin/perl
package Transformer;
# class for storing Transformer data
# transformer.pm
use warnings;
use strict;
my $Robots=0;
sub new { # constructor
my $class = shift; #takes the class name passed from transformers.pl
my $self = {@_}; # hash storing attributes we passed from transformers.pl
bless ($self, $class); # bless turns the $self reference into the object designated by the package $class
$Robots++;
return $self; # returns the object
}
sub name { # accessor method to return the name
my $self = shift;
unless (ref $self) {
print "ERROR: You should call name() with an object, not a class.";
}
return $self->{name}
}
sub surname { # accessor method to return the surname
my $self = shift;
unless (ref $self) {
print "ERROR: You should call surname() with an object, not a class.";
}
return $self->{surname}
}
sub alliance { # accessor method to return the alliance
my $self = shift;
unless (ref $self) {
print "ERROR: You should call alliance() with an object, not a class.";
}
return $self->{alliance}
}
sub position { # accessor method to return the position
my $self = shift;
unless (ref $self) {
print "ERROR: You should call position() with an object, not a class.";
}
return $self->{position}
}
# The above Object accessor methods could have been written as follows:
# sub position { $_[0]->{position }=$_[1]; $_[0]->{position } }
# Class accessor method
sub tally { $Robots }
# If transformer.pl's sub output was here, it would be a utility method
1; # return a true so this .pm file works, i.e., is known to have loaded correctly.
Next, setting up the program, which creates objects, accesses them, and produces output
(save as transformers.pl):
#!/usr/bin/perl
# transformers.pl
use warnings;
use strict;
use Transformer; # This uses the package Transformer in transformer.pm
# Get ready for the attributes below
my $optimus = Transformer->new ( # object designated by $optimus
name => "Optimus",
surname => "Prime",
alliance => "Autobot",
position => "Commander"
);
my $megatron = Transformer->new ( # object designated by $megatron
name => "Megatron",
surname => "",
alliance => "Decepticon",
position => "Commander"
);
print "Databank:\n\n";
output($optimus); # if below sub was in transformer.pm as utility method, you'd use $optimus->output;
output($megatron); # if below sub was in transformer.pm as utility method, you'd use $megatron->output;
sub output { # if this were in transformer.pm, it would be a utility method
print "------------------------------------------------------\n";
my $logo = "";
my ($robot) = @_; # parameter passed to @_
print $robot->name; # this follows the accessor syntax of $object->attribute
if ($robot->surname) {
print " ", $robot->surname;
}
print " is the ", $robot->position, " of the ";
my $side = $robot->alliance;
if ($side eq "Autobot") {
print "heroic ";
$logo = "\n_____________\n\\== \\ / ==/\n |<o\>| |<o\>|\n | | |_| | |\n | | ___ | |\n \\|/___\\|/\n";
}
if ($side eq "Decepticon") {
print "evil ";
$logo = "\n/\\__\\__/__/\\\n\\ _ \\/ _ /\n \\ \\| |/ /\n \\ ` ' /\n |\\\\ //|\n |_\\\\ //_|\n \\/\n";
}
print $side,"s.";
print $logo;
print "\n\n";
}
# Transformer->name;
# If the above item is uncommented, then you will receive the following error from transformer.pm:
# ERROR: You shouuld call name() with an object, not a class.
print "------------------------------------------------------\n";
my $verb="are";
my $noun="Transformers";
if (Transformer->tally==1) { # Allows grammar change if there is only 1 Transformer.
$verb = "is";
$noun = "Transformer";
}
print "There $verb ", Transformer->tally, " $noun.\n";
And here's the output:
Databank:
------------------------------------------------------
Optimus Prime is the Commander of the heroic Autobots.
_____________
\== \ / ==/
|<o>| |<o>|
| | |_| | |
| | ___ | |
\|/___\|/
------------------------------------------------------
Megatron is the Commander of the evil Decepticons.
/\__\__/__/\
\ _ \/ _ /
\ \| |/ /
\ ` ' /
|\\ //|
|_\\ //_|
\/
------------------------------------------------------
There are 2 Transformers.
Notice how you could set up all kinds of Transformers (objects). In the example
above, I set up two. Copy and paste the code and create a few more.
If you wanted to set up a subclass, you could do it like this:
#!/usr/bin/perl
package Targetmaster;
# Targetmaster.pm
use Transformer;
use warnings;
use strict;
our @ISA = qw(Transformer); # @ISA is built into Perl
This uses inheritance so we now inherit the methods of Transformer.pm.
You can find more advanced topics about object orientation in Perl at http://blob.perl.org/books/beginning-perl/3145_Chap11.pdf.
Encryption & Decryption [<<rewind]
So how do you encrypt data, but also decrypt it? Here's a script showing how:
#! /usr/bin/perl
use Crypt::DES; # Include Perl DES encryption module
use Crypt::CBC; # Include CBC interface
use Getopt::Long; # Include Getoptions
use strict;
#------------------------Declare variables--------------------
my $action; # what to do
my $data="My secret data";
my $key="12345789";
my $salt="12345678901";
my $hiddendata="";
my $hiddenkey="";
my $showndata="";
my $shownkey="";
#-----------------------Now Encrypt-------------------------
# use CBC algorithm
print "Data = $data|$key\n";
my $cipher = Crypt::CBC->new($salt,'DES') || die "Couldn't create CBC object";
$action = "e"; # encrypt
print "Encrypted = \n";
$cipher->start($action);
$hiddendata = $hiddendata . $cipher->encrypt_hex($data);
$hiddenkey = $hiddenkey . $cipher->encrypt_hex($key);
print " 1:$hiddendata\n";
print " 2:$hiddenkey\n";
#-----------------------Now Decrypt-------------------------
$action = "d"; # decrypt
print "Decrypted = \n";
$cipher->start($action);
$showndata = $cipher->decrypt_hex($hiddendata);
$shownkey = $cipher->decrypt_hex($hiddenkey);
print " 1:$showndata\n";
print " 2:$shownkey\n";
$showndata = $showndata . $cipher->finish;
exit;
Here's the output:
Data = My secret data|12345789
Encrypted =
1:53616c7465645f5f17b6d77910c2ef18960464c912cfd164fbfc239196c45aaa
2:53616c7465645f5f978eaf9093c6723838529e95f7a8481bd3b3a44e529a9012
Decrypted =
1:My secret data
2:12345789
Shell Scripts and Commands [<<rewind]
Sometimes, you may want to run a shell script or command from cgi using perl. Here's how:
#!/usr/bin/perl -w
use strict;
use CGI qw( :standard :html3 );
use HTML::Template; # if needed
new CGI;
print header, start_html(-title=>'Shell Script or Command from Perl', -BGCOLOR=>'#FFFFFF', -style => "body {} ",
-dtd=>'html'
);
## OPTIONAL ,
#-head=>[
# Link({-rel=>'stylesheet',-href=>'yourstyles.css'})
# ]
open(MYFILE,"sh script.sh OR command |") || die "Failed: $!\n"; # using open to execute the shell script or command
while ( )
{
print $_; # print line from "file", i.e., a line of output
print "
";
}
close (MYFILE);
print end_html;
exit;
Is my server down (404 error)? [<<rewind]
Do you want to see if your server is down? Here's an example checking to see if the site http://beacondeacon.com is down:
#!/usr/bin/perl -w
use strict;
use CGI qw( :standard :html3 );
use HTML::Template; # if needed
use LWP::Simple;
print header, start_html(-title=>'Is a server down', -BGCOLOR=>'#FFFFFF',
-dtd=>'-//W3C//DTD XHTML 1.0 Strict//EN');
my $url="http://beacondeacon.com";
if (! head($url)) {
die "The Server $url is DOWN!!!!"
} else {
print "The Server $url is up!";
}
exit;
Optimization and Benchmarking [<<rewind]
Below is a quick (and basic) list of ideas I gleaned from http://perl.apache.org/docs/1.0/guide/performance.pdf:
- Combine prints to avoid multiple calls to print.
- Avoid global variables where possible.
- Printing lists of strings to a file is faster than printing the interpolation of strings to a file, which is faster than concatenation of strings to a file as shown below:
use Benchmark;
use Symbol;
my $fh = gensym;
open $fh, ">/dev/null" or die;
my ($one, $two, $three, $four) = map { $_ x 1000 } ('a'..'d'); # 1000 character strings
timethese(500_000,
{
interp => sub {
print $fh "$one$two$three$four";
},
list => sub {
print $fh $one, $two, $three, $four;
},
conc => sub {
print $fh $one.$two.$three.$four;
},
});
# source is sect 1.7.8 at http://perl.apache.org/docs/1.0/guide/performance.pdf
- Double quotes are an operator in Perl which allows for interpolation.
- For large files, "try to process a line at a time and print it back to the file. If you need to modify the file itself, use a temporary file. When finished, overwrite the source file. Make sure you use a locking mechanism!" (SOURCE: sect 1.9.1.1 at http://perl.apache.org/docs/1.0/guide/performance.pdf).
- If your variable can grow large, use references to pass instead of the variable itself.
- For relational DB, let SQL get the rows the program needs and only work with them. Say you are displaying DB contents. Instead of getting the whole DB and then printing row by row, print each row right after it is fetched.
- Replace prepare() with prepare_cached() in DBI use.
Source: http://perl.apache.org/docs/1.0/guide/performance.pdf
Here's a simple command-line benchmarking tool I wrote, which times a Perl program:
#!/usr/bin/perl
use Benchmark;
use Symbol;
use warnings;
use strict;
# benchmarkit.pl by James Arthur Johnson
# Use syntax: perl benchmarkit.pl filename.pl
# ask for count
print "Enter number of iterations:\n";
my $count = <STDIN>;
# Read code from command-line:
my $code;
my @codeArray = <>; # <> is an abbreviation for <ARGV> which reads the code specified by the filename in the command-line into an array.
foreach my $line (@codeArray) {
$code=$code.$line;
}
chomp ($code);
$/ = "END";
print "\nProcessing...\n";
# run code and display result
timethis($count, $code);
print "\n\nResult of running the program $count times.\n\n";
And here's sample execution/output from the program using the carlot.pl
example from the References Section.
>perl benchmarkit.pl carlot.pl
Enter number of iterations:
100000
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
…
This repeats for many lines
…
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
Honda Honda Honda
Chevy Chevy Chevy
Dodge Dodge Dodge
timethis 100000
: 18 wallclock secs ( 1.95 usr + 0.66 sys = 2.61 CPU) @ 38314.18/s (n=100000)
Result of running the program 100000
times.
Perl Manual [<<rewind]
If at first you don't succeed, read the directions, right? :)
Remember using this command at a Unix prompt: man perl
Or you can do one of the items below after man
PERL(1) Perl Programmers Reference Guide PERL(1)
perl Perl overview (this section)
perlintro Perl introduction for beginners
perltoc Perl documentation table of contents
Tutorials
perlreftut Perl references short introduction
perldsc Perl data structures intro
perllol Perl data structures: arrays of arrays
perlrequick Perl regular expressions quick start
perlretut Perl regular expressions tutorial
perlboot Perl OO tutorial for beginners
perltoot Perl OO tutorial, part 1
perltooc Perl OO tutorial, part 2
perlbot Perl OO tricks and examples
perlstyle Perl style guide
perlcheat Perl cheat sheet
perltrap Perl traps for the unwary
perldebtut Perl debugging tutorial
perlfaq Perl frequently asked questions
perlfaq1 General Questions About Perl
perlfaq2 Obtaining and Learning about Perl
perlfaq3 Programming Tools
perlfaq4 Data Manipulation
perlfaq5 Files and Formats
perlfaq6 Regexes
perlfaq7 Perl Language Issues
perlfaq8 System Interaction
perlfaq9 Networking
Reference Manual
perlsyn Perl syntax
perldata Perl data structures
perlop Perl operators and precedence
perlsub Perl subroutines
perlfunc Perl built-in functions
perlopentut Perl open() tutorial
perlpacktut Perl pack() and unpack() tutorial
perlpod Perl plain old documentation
perlpodspec Perl plain old documentation format specification
perlrun Perl execution and options
perldiag Perl diagnostic messages
perllexwarn Perl warnings and their control
perldebug Perl debugging
perlvar Perl predefined variables
perlre Perl regular expressions, the rest of the story
perlreref Perl regular expressions quick reference
perlref Perl references, the rest of the story
perlform Perl formats
perlobj Perl objects
perltie Perl objects hidden behind simple variables
perldbmfilter Perl DBM filters
perlipc Perl interprocess communication
perlfork Perl fork() information
perlnumber Perl number semantics
perlthrtut Perl threads tutorial
perlothrtut Old Perl threads tutorial
perlport Perl portability guide
perllocale Perl locale support
perluniintro Perl Unicode introduction
perlunicode Perl Unicode support
perlebcdic Considerations for running Perl on EBCDIC platforms
perlsec Perl security
perlmod Perl modules: how they work
perlmodlib Perl modules: how to write and use
perlmodstyle Perl modules: how to write modules with style
perlmodinstall Perl modules: how to install from CPAN
perlnewmod Perl modules: preparing a new module for distribution
perlutil utilities packaged with the Perl distribution
perlcompile Perl compiler suite intro
perlfilter Perl source filters
perlglossary Perl Glossary
Internals and C Language Interface
perlembed Perl ways to embed perl in your C or C++ application
perldebguts Perl debugging guts and tips
perlxstut Perl XS tutorial
perlxs Perl XS application programming interface
perlclib Internal replacements for standard C library functions
perlguts Perl internal functions for those doing extensions
perlcall Perl calling conventions from C
perlapi Perl API listing (autogenerated)
perlintern Perl internal functions (autogenerated)
perliol C API for Perl's implementation of IO in Layers
perlapio Perl internal IO abstraction interface
perlhack Perl hackers guide
Miscellaneous
perlbook Perl book information
perltodo Perl things to do
perldoc Look up Perl documentation in Pod format
perlhist Perl history records
perldelta Perl changes since previous version
perl587delta Perl changes in version 5.8.7
perl586delta Perl changes in version 5.8.6
perl585delta Perl changes in version 5.8.5
perl584delta Perl changes in version 5.8.4
perl583delta Perl changes in version 5.8.3
perl582delta Perl changes in version 5.8.2
perl581delta Perl changes in version 5.8.1
perl58delta Perl changes in version 5.8.0
perl573delta Perl changes in version 5.7.3
perl572delta Perl changes in version 5.7.2
perl571delta Perl changes in version 5.7.1
perl570delta Perl changes in version 5.7.0
perl561delta Perl changes in version 5.6.1
perl56delta Perl changes in version 5.6
perl5005delta Perl changes in version 5.005
perl5004delta Perl changes in version 5.004
perlartistic Perl Artistic License
perlgpl GNU General Public License
Language-Specific
perlcn Perl for Simplified Chinese (in EUC-CN)
perljp Perl for Japanese (in EUC-JP)
perlko Perl for Korean (in EUC-KR)
perltw Perl for Traditional Chinese (in Big5)
Platform-Specific
perlaix Perl notes for AIX
perlamiga Perl notes for AmigaOS
perlapollo Perl notes for Apollo DomainOS
perlbeos Perl notes for BeOS
perlbs2000 Perl notes for POSIX-BC BS2000
perlce Perl notes for WinCE
perlcygwin Perl notes for Cygwin
perldgux Perl notes for DG/UX
perldos Perl notes for DOS
perlepoc Perl notes for EPOC
perlfreebsd Perl notes for FreeBSD
perlhpux Perl notes for HP-UX
perlhurd Perl notes for Hurd
perlirix Perl notes for Irix
perllinux Perl notes for Linux
perlmachten Perl notes for Power MachTen
perlmacos Perl notes for Mac OS (Classic)
perlmacosx Perl notes for Mac OS X
perlmint Perl notes for MiNT
perlmpeix Perl notes for MPE/iX
perlnetware Perl notes for NetWare
perlopenbsd Perl notes for OpenBSD
perlos2 Perl notes for OS/2
perlos390 Perl notes for OS/390
perlos400 Perl notes for OS/400
perlplan9 Perl notes for Plan 9
perlqnx Perl notes for QNX
perlsolaris Perl notes for Solaris
perltru64 Perl notes for Tru64
perluts Perl notes for UTS
perlvmesa Perl notes for VM/ESA
perlvms Perl notes for VMS
perlvos Perl notes for Stratus VOS
perlwin32 Perl notes for Windows
Resources [<<rewind]
Primary Resource: http://www.cgi101.com/
Database Interface (DBI): http://www.perl.com/pub/a/1999/10/DBI.html
HTML::Template: http://www.sitepoint.com/article/introducing-html-template
Perl CGI Tutorial: http://inconnu.islug.org/~ink/perl_cgi/index.html
Beginning Perl by Simon Cozens: http://www.perl.org/books/beginning-perl/
Performance Tuning: http://perl.apache.org/docs/1.0/guide/performance.pdf
HTML::Entities: http://search.cpan.org/dist/HTML-Parser/lib/HTML/Entities.pm
AAA LL LL BB :):):):):)
AA AA LL LL BB :) :)
AA AA LL LL YY YY OOO UU UU RR R BBBB AAA SSSS EEE :) @ @ :)
AA AA LL LL YY YY OO OO UU UU RRRR BB BB AA SS EE EE :) :)
AAAAA LL LL YY YY OO OO UU UU RR BB BB AAAA SSSSS EEEEE :) :)
AA AA LL LL YYYY OO OO UU UU RR BB BB AA AA SS EE :) \____/ :)
AA AA LL LL YY OOO UUUU RR BBBB AAAA SSSS EEEE :) :)
YYY :):):):):)
BB LL TT
BB LL TT
AAA RR R EEE BBBB EEE LL OOO NNNN GGGG TTT OOO UU UU SSSS
AA RRRR EE EE BB BB EE EE LL OO OO NN NN GG GG TT OO OO UU UU SS
AAAA RR EEEEE BB BB EEEEE LL OO OO NN NN GG GG TT 00 OO UU UU SSSSS
AA AA RR EE BB BB EE LL OO OO NN NN GGGG TT OO OO UU UU SS
AAAA RR EEEE BBBB EEEE LL OOO NN NN GG TT OOO UUUU SSSS
GGG