Useful Perl Code Snippets

This is one of those articles you'll either never use or use sometime in the future, in which case you'll want to save the article somewhere or at least bookmark the URL where it can be found.

It's simply a list of nine Perl code snippets that I use often and keep handy for copying and pasting:

1. Getting the values submitted with a form.

2. Checking if a directory allows programs to create files.

3. Check formatting of email address.

4. Getting a directory listing of certain types of files.

5. When needing a subroutine within a subroutine.

6. Sending email.

7. Sorting.

8. Sending an error message to the user.

9. Adding a module search directory.

These snippets could make the programming portion of your life a bit easier.

-- Getting the values submitted with a form --

A version of this subroutine is in every from processing script I write. It parses the information submitted with the form, submitted with either method GET or method POST. The values are put in the FORM variable with hash names identical to the form field names. In other words, whatever is type into this form field

<input type="text" name="email">

would be stored in $FORM{"email"}

The subroutine also puts all form field values with identical field names into the same $FORM{"___"} variable, with the values separated by a tab character. This is useful if you use checkbox form fields that all have the same field name, for example.

Here is the snippet:

my %In = ();

sub Parse
{
my $buffer;
if ($ENV{REQUEST_METHOD} eq 'GET') 
{ $buffer = $ENV{QUERY_STRING}; }
else 
{ read(STDIN,$buffer,$ENV{CONTENT_LENGTH}); }
my @p = split(/&/,$buffer);
foreach(@p)
{
$_ =~ tr/+/ /;
my ($n,$v) = split(/=/,$_,2);
$n =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
$v =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
if($FORM{"$n"}) { $FORM{"$n"} .= "\t$v"; }
else { $FORM{"$n"} = $v; }
}
}

&Parse;

-- Checking if a directory allows programs to create files --

When you need to know whether or not a directory allows CGI programs to create files, to prepare an error message if disallowed, for example, I use the following snippet.

It tries to create a test file. If successful, it deletes the test file and prints "Permissions are OK." If not successful, it prints "Permission denied ..." (Change the value of $filename to suit.)

Here is the snippet:

my $filename = 'check.txt';
if(open F,">$filename")
{
close F;
unlink "$filename"';
print 'Permissions are OK.';
}
else
{ print 'Permission denied for writing files!' }

-- Check formatting of email address --

Often, CGI programs need to check whether or not an email address is validly formatted -- before attempting to send an email to it, for example. This doesn't check that the email address can be delivered, just that it's formatted correctly.

Here is the snippet:

sub ValidEmail
{
return 0 if $_[0] =~ 
/(?:[\.\-\_]{2,})|(?:@[\.\-\_])|(?:[\.\-\_]@)|(?:\A\.)/;
return 1 if $_[0] =~ 
/^[\w\.\-\_]+\@\[?[\w\.\-\_]+\.(?:[\w\.\-\_]{2,}|[0-9])\]?$/;
return 0;
}

if(ValidEmail('name@example.com') { print "OK" }
else { print "Ouch!"; }

-- Getting a directory listing of certain types of files --

Using the grep function, one can get a directory listing of files that match certain expressions. The following snippet puts a list of file names from the current directory that end with either ".cgi" or ".pl" into array @d

Here is the snippet:

opendir D,'.';
my @d = grep /^.*?\.(cgi|pl)$/i,readdir D;
closedir D;

print join "\n<br>",@d;

-- When needing a subroutine within a subroutine --

Sometimes a subroutine uses the same code several times, which is usually a good indication that the repetitive code should be put into its own subroutine.

However, sometimes there are situations where the repetitive code is used only in that one subroutine. So it would make sense to nest the subroutine in the subroutine that's using it.

It can be done with a local variable holding the address of an anonymous subroutine.

Here is the snippet:

sub X
{
	local *Test = sub
	{
		my($n,$v) = @_;
		print "HI :)\n<br>$n\n<br>$v";
		return "$v - $n";
	};
	my $result = Test('One','Two');
}

-- Sending email --

This snippet demonstrates one of the most popular ways to send email from a Perl script:

my $SendmailLocation = '/sbin/sendmail -t';
my $ToAddress = 'name@isp.com';
open MAIL,"|$SendmailLocation";
print MAIL <<EMAIL;
To: $ToAddress
Subject: Testing

Testing, testing, testing, ...
EMAIL
close MAIL;

-- Sorting --

Below is the code for a number of different sorts.

The default Perl sort is by ASCII values. Thus, the "_" character would come before the "9" character, capital letters before lowercase like "B" before "a", and "22" before "3".

The snippet for the default Perl sort is:

@array = sort @array;

Here is the snippet to sort according to alphabetical values, with capital letters sorting before lower-case ("A" comes before "a", and "a" comes before "B"):

@array = sort { $a cmp $b } @array;

To sort alphabetical reversed, use:

@array = sort { $b cmp $a } @array;

Here is the snippet to sort according to alphabetical values insensitive to case, with capital letters and lower-case both having the same sorting value ("A" and "a" have the same value):

@array = sort { lc $a cmp lc $b } @array;

To sort case insensitive alphabetical reversed, use:

@array = sort { lc $b cmp lc $a } @array;

Here is the snippet to sort numbers (so "3" comes before "22"):

@array = sort { $a <=> $b } @array;

To sort numbers reversed, use:

@array = sort { $b <=> $a } @array;

-- Sending an error message to the user --

When programming, it's nice to have a subroutine handy that will provide an error message to the user.

The following will create a web page and display any messages you send to the subroutine. You can send one or many messages all at once.

Here is the snippet:

sub ErrorHTML
{
	my $s = join "</li>\n<li>",@_;
	print "Content-type: text/html\n\n";
	print <<HTML;
<html>
<body bgcolor="white">
<blockquote><blockquote><h4>Message:</h4><ul>
<li>$s</li>
</ul></blockquote></blockquote></body></html>
HTML
	exit;
}

-- Adding a module search directory --

Sometimes your program will need to pick up modules or include files in directories other than the default directories Perl searches. You might need to use a module installed in another cgi-bin subdirectory for a different program, for example. There's no reason to install the module in a second location when you can use it where it's at.

This is the snippet:

BEGIN { push @INC,'/www/example/cgi-bin/subdirectory'; }

I hope you can find a good use for the snippets.

Will Bontrager