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:
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]
Row 
0012
1012
2012
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 
0HondaHondaHonda
1ChevyChevyChevy
2DodgeDodgeDodge
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/&lt;/</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&nbsp;"; } 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;\">&nbsp;&#1758;&nbsp;\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&eacute; 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 "&lt;object type=&quot;application/x-shockwave-flash&quot; width=&quot;$width&quot; height=&quot;$height&quot; data=&quot;$url&quot;&gt;<br /> &lt;param name=&quot;movie&quot; value=&quot;$url&quot;&gt;&lt;/param&gt;<br /> &lt;param name=&quot;wmode&quot; value=&quot;transparent&quot;&gt;&lt;/param&gt;<br /> &lt;/object&gt;<p>&nbsp;</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;amp;/g; # substitute &amp; for & globally (/g) in the string. $change =~ s/ /\&amp;nbsp;/g; # substitute &nbsp; for a space globally (/g) in the string. $change =~ s/\"/\&amp;quot;/g; # substitute &quot; for " globally (/g) in the string. $change =~ s/</\&amp;lt;/g; # substitute &lt; for < globally (/g) in the string. $change =~ s/>/\&amp;gt;/g; # substitute &gt; for > globally (/g) in the string. $change =~ s/\'/\&amp;#39;/g; # substitute &#39; for ' globally (/g) in the string. $change =~ s/\n/\<br \/>\&lt;br \/\&gt;/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&hellip;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 "&nbsp;"; # 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:
lastnamefirstnamejersey
MoseleyMark3
TheismannJoe7
GreenDarrell28
RigginsJohn44
ButzDave65
JacobyJoe66
MonkArt81
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:
  1. Combine prints to avoid multiple calls to print.
  2. Avoid global variables where possible.
  3. 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:
  4. 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
  5. Double quotes are an operator in Perl which allows for interpolation.
  6. 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).
  7. If your variable can grow large, use references to pass instead of the variable itself.
  8. 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.
  9. 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

















































"All Your Base Are Belong to Us!" ☺ 
…and your Perl "…and your little dog too!"
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