Solved Problems

Output a string to the console

Write the string "Hello World!" to STDOUT
perl
print "Hello World!\n"

Retrieve a string containing ampersands from the variables in a url

My PHP script first does a query to obtain customer info for a form. The form has first name and last name fields among others. The customer has put entries such as "Ron & Jean" in the first name field in the database. Then the edit form script is called with variables such as

"http://myserver.com/custinfo/edit.php?mode=view&fname=Ron & Jean&lname=Smith".

The script variable for first name $_REQUEST['firstname'] never gets beyond the "Ron" value because of the ampersand in the data.

I have tried various functions like urldecode but all to no avail. I even tried encoding the url before the view screen is painted so that the url looks like "http://myserver/custinfo/edit.php?mode=view&fname="Ronxxnbsp;xxamp;xxnbsp;Jean"&lname=SMITH". (sorry I had to add the xx to replace the ampersand or it didn't display meaningful url contents the browser sees.)

Of course this fails for the same reasons. What is a better approach?
perl
print "http://myserver.com/custinfo/edit.php"
."?fname=".urlenc('Ron & Jean')
."&lname=".urlenc('Smith');
sub urlenc{my($s)=@_;$s=~s/([^A-Za-z0-9])/sprintf("%%%02X",ord($1))/seg;$s}

string-wrap

Wrap the string "The quick brown fox jumps over the lazy dog. " repeated ten times to a max width of 78 chars, starting each line with "> "

Expected output:
> The quick brown fox jumps over the lazy dog. The quick brown fox jumps over t
> he lazy dog. The quick brown fox jumps over the lazy dog. The quick brown fox
> jumps over the lazy dog. The quick brown fox jumps over the lazy dog. The qui
> ck brown fox jumps over the lazy dog. The quick brown fox jumps over the lazy
> dog. The quick brown fox jumps over the lazy dog. The quick brown fox jumps o
> ver the lazy dog. The quick brown fox jumps over the lazy dog.
perl
print map"> $_\n",("The quick brown fox jumps over the lazy dog. " x 10)=~/(.{1,77}) ?/g;

write a recursive c function to compute gcd(x,y).

perl
sub gcd {
# Euclid's Algorithm
my ($c, $d) = @_;
return $c unless $d;
return gcd ($d, $c % $d);
}
sub gcd2 {
# Dijkstra's Algorithm
my ($c, $d) = @_;
return $c if $c == $d;
return $c > $d ? gcd2 ($c - $d, $d) : gcd2 ($c, $d - $c);
}

ROT13 in perl

ROT13 is a simple substitution cipher where each letter of the plain text is replaced with the corresponding 13th letter further down the alphabet.
perl
sub rot13 { my $str = shift; $str =~ tr/A-Za-z/N-ZA-Mn-za-m/; $str }
print rot13("A very secret message"),"\n";

Define a string containing special characters

Define the literal string "\#{'}${"}/"
perl
$special = '\#{\'}${"}/';
$special = q(\#{'}${"}/);

Define a multiline string

Define the string:
"This
Is
A
Multiline
String"
perl
$text = 'This
Is
A
Multiline
String';
$text = <<EOF;
This
Is
A
Multiline
String
EOF

Define a string containing variables and expressions

Given variables a=3 and b=4 output "3+4=7"
perl
print "$a+$b=${\($a+$b)}\n";
sprintf("%d+%d=%d", $a, $b, $a + $b);
print $a, '+', $b, '=', $a + $b;

Reverse the characters in a string

Given the string "reverse me", produce the string "em esrever"
perl
$_ = reverse "reverse me"; print

Reverse the words in a string

Given the string "This is a end, my only friend!", produce the string "friend! only my end, the is This"
perl
$reversed = join ' ', reverse split / /, $text;

Text wrapping

Wrap the string "The quick brown fox jumps over the lazy dog. " repeated ten times to a max width of 78 chars, starting each line with "> ", yielding this result:

> The quick brown fox jumps over the lazy dog. The quick brown fox jumps
> over the lazy dog. The quick brown fox jumps over the lazy dog. The
> quick brown fox jumps over the lazy dog. The quick brown fox jumps
> over the lazy dog. The quick brown fox jumps over the lazy dog. The
> quick brown fox jumps over the lazy dog. The quick brown fox jumps
> over the lazy dog. The quick brown fox jumps over the lazy dog. The
> quick brown fox jumps over the lazy dog.
perl
use Text::Wrap;
$text = "The quick brown fox jumps over the lazy dog. ";
$Text::Wrap::columns = 73;
print wrap('> ', '> ', $text x 10);
$_ = "The quick brown fox jumps over the lazy dog. " x 10;
s/(.{0,70}) /> $1\n/g;
print;

Remove leading and trailing whitespace from a string

Given the string "  hello    " return the string "hello".
perl
my $string = " hello ";
$string =~ s{
\A\s* # Any number of spaces at the start of the string
(.+?) # Remember any number of characters until we reach
\s*\z # any number of spaces at the end of the string
}{
$1 # Leave the characters we remembered
}x;
my $string = " hello ";
$string =~ s{\A\s*}{};
$string =~ s{\s*\z}{};

#Modification History:
# 2009-MAR-17: GGARIEPY: [creation] (geoff.gariepy@gmail.com)

$string = " hello ";
$string =~ s/^\s+|\s+$//g; # All the action happens in one regex!

# Regex Notes:
# ^ - anchors to the beginning of the string
# $ - anchors to the end of the string
# g - causes regex to match as many times as possible
# | - logical OR

Simple substitution cipher

Take a string and return the ROT13 and ROT47 (Check Wikipedia) version of the string.
For example:
String is: Hello World #123
ROT13 returns: Uryyb Jbeyq #123
ROT47 returns: w6==@ (@C=5 R`ab
perl
sub rot13 {
my $str = shift;
$str =~ tr/A-Za-z/N-ZA-Mn-za-m/;
return $str;
}

sub rot47 {
my $str = shift;
$str =~ tr/!-~/P-~!-O/;
return $str;
}

my $string = 'Hello World #123';

print "$string\n";
print rot13($string)."\n";
print rot47($string)."\n";

Make a string uppercase

Transform "Space Monkey" into "SPACE MONKEY"
perl
print uc "Space Monkey"

Make a string lowercase

Transform "Caps ARE overRated" into "caps are overrated"
perl
print lc "Caps ARE overRated"

Capitalise the first letter of each word

Transform "man OF stEEL" into "Man Of Steel"
perl
$text =~ s/(\w+)/\u\L$1/g;

Find the distance between two points

perl
use Math::Complex;
$a = Math::Complex->make(0, 3);
$b = Math::Complex->make(4, 0);
$distance = abs($a - $b);
my @a=(0, 3);
my @b=(4, 0);
my $distance = sqrt( ($a[0]-$b[0])**2 + ($a[1]-$b[1])**2 );

Zero pad a number

Given the number 42, pad it to 8 characters like 00000042
perl
sprintf("%08d", 42);

Right Space pad a number

Given the number 1024 right pad it to 6 characters "1024  "
perl
sprintf("%-6d", 1024);

Format a decimal number

Format the number 7/8 as a decimal with 2 places: 0.88
perl
sprintf("%.2f", 7/8);

Left Space pad a number

Given the number 73 left pad it to 10 characters "        73"
perl
sprintf("%10d", 73);

Generate a random integer in a given range

Produce a random integer between 100 and 200 inclusive
perl
my $range = 100;
my $minimum = 100;

my $random_number = int(rand($range)) + $minimum;

print "$random_number\n";

Generate a repeatable random number sequence

Initialise a random number generator with a seed and generate five decimal values. Reset the seed and produce the same values.
perl
srand(12345);
@list1 = map(int(rand(100)+1), (1..5));

srand(12345);
@list2 = map(int(rand(100)+1), (1..5));

print join(', ', @list1) . "\n";
print join(', ', @list2) . "\n";

Check if a string matches a regular expression

Display "ok" if "Hello" matches /[A-Z][a-z]+/
perl
print 'ok' if ('Hello' =~ /[A-Z][a-z]+/);

Check if a string matches with groups

Display "two" if "one two three" matches /one (.*) three/
perl
print $1 if "one two three"=~/^one (.*) three$/

Check if a string contains a match to a regular expression

Display "ok" if "abc 123 @#$" matches /\d+/
perl
print "ok" if ("abc 123 @#\$" =~ m/\d+/)

Loop through a string matching a regex and performing an action for each match

Create a list [fish1,cow3,boat4] when matching "(fish):1 sausage (cow):3 tree (boat):4" with regex /\((\w+)\):(\d+)/
perl
while ($text =~ /\((\w+)\):(\d+)/g) {
push @list, "$1$2"
}

Replace the first regex match in a string with a static string

Transform "Red Green Blue" into "R*d Green Blue" by replacing /e/ with "*"
perl
$text =~s/e/*/;

Replace all regex matches in a string with a static string

Transform "She sells sea shells" into "She X X shells" by replacing /se\w+/ with "X"
perl
$text = "She sells sea shells";
$text =~ s/se\w+/X/g;

Replace all regex matches in a string with a dynamic string

Transform "The {Quick} Brown {Fox}" into "The kciuQ Brown xoF" by reversing words in braces using the regex /\{(\w+)\}/.
perl
$text = "The {Quick} Brown {Fox}";
$text =~ s/\{(\w+)\}/reverse($1)/ge;

Define an empty list

Assign the variable "list" to a list with no elements
perl
@list = ();

Define a static list

Define the list [One, Two, Three, Four, Five]
perl
@list = qw(One Two Three Four Five);
@list = ('One', 'Two', 'Three', 'Four', 'Five');

Join the elements of a list, separated by commas

Given the list [Apple, Banana, Carrot] produce "Apple, Banana, Carrot"
perl
print join ', ', qw(Apple Banana Carrot);
# Longer and less efficient than join(), but illustrates
# Perl's foreach operator, which can be useful for
# less trivial problems with lists

@list = ('Apple', 'Banana', 'Carrot');
foreach $fruit (@list) {
print "$fruit,";
}
print "\n";
my @a = qw/Apple Banana Carrot/;
{
local $, = ", ";
print @a
}
print "\n";
my @a = qw/Apple Banana Carrot/;
{
local $" = ", ";
print "@a\n";
}

Join the elements of a list, in correct english

Create a function join that takes a List and produces a string containing an english language concatenation of the list. It should work with the following examples:
join([Apple, Banana, Carrot]) = "Apple, Banana, and Carrot"
join([One, Two]) = "One and Two"
join([Lonely]) = "Lonely"
join([]) = ""
perl
sub myjoin {
$_ = join ', ', @_;
s/, ([^,]+)$/ and $1/;
return $_;
}


# Note: I don't think this meets the spec --Geoff
sub myjoin {
if ($#_ < 2) {
return join ' and ', @_;
} else {
return join(', ', @_[0..$#_-1]) . ' and ' . $_[-1];
}
}

# Note: I don't think this meets the spec --Geoff
# Previous "myjoin()" responses don't meet the spec of including
# the final comma before the "and" if the list has more than
# two elements...this is one way to meet that spec...it may
# not be the most efficient...

sub AnotherMyJoin {
my @list = @_;

if ($#list == -1) {return}
elsif ($#list == 0) {return $list[0]}
elsif ($#list == 1) {return $list[0].' and '.$list[1]}
else {
return join(", ", @list[0..$#list - 1]) . ', and '. $list[$#list];
}
}
# This is the long way, but it's kind of fun
# It illustrates the use of Perl's reverse()
# operator to work our way through the list
# elements backwards...I wrote this one before
# getting smart and looking at some of the other
# algorithms from the other languages. Still,
# it is only 12 lines of code vs 9 for my other
# solution if you disregard the comments.

sub myjoin {
my @list = reverse(@_); # Reverse original order of elements
my $retval;

# Make our exit here if we were passed an empty list
if ($#list == -1) {return}

# Loop through reversed elements in end-to-start order
for (0..$#list) {
# Add the reversed form of each element plus a space char
$retval .= reverse($list[$_]).' ';

# Add 'and' to lists with two or more elements
# placing it in between final and 'next to final'
$retval .= "dna " if ($#list > 0 and $_== 0);

# Add ',' to each element as long as there are more
# than two elements and the current element isn't the
# final element
$retval .= "," if ($#list > 1 and $_ != $#list);
}

# Remove what will end up as an extraneous leading space
chop($retval);

# Done looping, now reverse things back into correct order and return
$retval = reverse($retval);
return($retval);
}
# Yes, this doesn't meet the spec, the spec is flawed
# the serial comma (Oxford comma) is not required in a list
sub english_join {
return join(', ', @_[0..$#_-1])
. ($#_ ? ' and ' : '' )
. $_[-1];
}

Produce the combinations from two lists

Given two lists, produce the list of tuples formed by taking the combinations from the individual lists. E.g. given the letters ["a", "b", "c"] and the numbers [4, 5], produce the list: [["a", 4], ["b", 4], ["c", 4], ["a", 5], ["b", 5], ["c", 5]]
perl
@letters = qw(a b c);
@numbers = (4, 5);
@list = map { $number=$_; map [$_, $number], @letters; } @numbers;
@letters = qw(a b c);
@numbers = (4, 5);

for $number (@numbers) {
for $letter (@letters) {
push @list, [$letter, $number];
}
}

From a List Produce a List of Duplicate Entries

Taking a list:
["andrew", "bob", "chris", "bob"]

Write the code to produce a list of duplicates in the list:
["bob"]
perl
my @input = ("andrew", "bob", "chris", "bob", "bob");

my %input_count;
my @output = grep { $input_count{$_}++; $input_count{$_} == 2 } @input;

Fetch an element of a list by index

Given the list [One, Two, Three, Four, Five], fetch the third element ('Three')
perl
qw(One Two Three Four Five)[2];
@list = qw(One Two Three Four Five);
$list[2];

Fetch the last element of a list

Given the list [Red, Green, Blue], access the last element ('Blue')
perl
qw(Red Green Blue)[-1];
@list = qw(Red Green Blue);
$list[-1];

Find the common items in two lists

Given two lists, find the common items. E.g. given beans = ['broad', 'mung', 'black', 'red', 'white'] and colors = ['black', 'red', 'blue', 'green'], what are the bean varieties that are also color names?
perl
@beans = qw(broad mung black red white);
@colors = qw(black red blue green);
@seen{@beans} = ();
for (@colors) {
push(@intersection, $_) if exists($seen{$_});
}
print join(', ', @intersection);
@beans = qw(broad mung black red white);
@colors = qw(black red blue green);

my %colors_hash = map { $_ => 1 } @colors;
my @intersection = grep { $colors_hash{$_} } @beans;
print join(', ', @intersection),"\n";
@beans = qw/broad mung black red white/;
@colors = qw/black red blue green/;

print join ', ', grep { $_ ~~ @colors } @beans;

Display the unique items in a list

Display the unique items in a list, e.g. given ages = [18, 16, 17, 18, 16, 19, 14, 17, 19, 18], display the unique elements, i.e. with duplicates removed.
perl
@ages = (18, 16, 17, 18, 16, 19, 14, 17, 19, 18);
@seen{@ages} = ();
@unique = keys %seen;
print join(', ', @unique);
@ages = (18, 16, 17, 18, 16, 19, 14, 17, 19, 18);
@unique = grep(!$seen{$_}++, @ages);
print join(', ', @unique);
@ages = (18, 16, 17, 18, 16, 19, 14, 17, 19, 18);
print join(', ', grep(!$seen{$_}++, @ages));
@ages = (18, 16, 17, 18, 16, 19, 14, 17, 19, 18);
for (@ages) {
push(@unique, $_) unless $seen{$_}++;
}
print join(', ', @unique);
use List::MoreUtils qw(uniq);

@ages = (18, 16, 17, 18, 16, 19, 14, 17, 19, 18);
print join(', ', uniq(@ages));

Remove an element from a list by index

Given the list [Apple, Banana, Carrot], remove the first element to produce the list [Banana, Carrot]
perl
@list = qw(Apple Banana Carrot);
shift @list;
@list = qw(Apple Banana Carrot);
$offset = 0;
splice(@list, $offset, 1);

Rotate a list

Given a list ["apple", "orange", "grapes", "bananas"], rotate it by removing the first item and placing it on the end to yield ["orange", "grapes", "bananas", "apple"]
perl
@list = qw(apple, orange, grapes, bananas);
push @list, shift @list;
@list = qw(apple orange grapes bananas);
@list = @list[1..$#list,0];

Gather together corresponding elements from multiple lists

Given several lists, gather together the first element from every list, the second element from every list, and so on for all corresponding index values in the lists. E.g. for these three lists, first = ['Bruce', 'Tommy Lee', 'Bruce'], last = ['Willis', 'Jones', 'Lee'], years = [1955, 1946, 1940] the result should produce 3 actors. The middle actor should be Tommy Lee Jones.
perl
my @first = ('Bruce', 'Tommy Lee', 'Bruce');
my @last = ('Willis', 'Jones', 'Lee');
my @years = (1955, 1946, 1940);

my @actors;

my $max = scalar @first;
for my $index (0 .. $max) {
push @actors, [ $first[$index], $last[$index], $years[$index] ];
};

List Combinations

Given two source lists (or sets), generate a list (or set) of all the pairs derived by combining elements from the individual lists (sets). E.g. given suites = ['H', 'D', 'C', 'S'] and faces = ['2', '3', '4', '5', '6', '7', '8', '9', '10', 'J', 'Q', 'K', 'A'], generate the deck of 52 cards, confirm the deck size and check it contains an expected card, say 'Ace of Hearts'.
perl
@suites = qw(H D C S);
@faces = qw(2 3 4 5 6 7 8 9 10 J Q K A);
@deck = map { $suite=$_; map $suite.$_, @faces; } @suites;
print 'checking deck size: ' . (@deck == 52 ? 'pass' : 'fail') . "\n";
print 'deck contains "Ace of Hearts": ' . (grep(/^HA$/, @deck) ? 'true' : 'false') . "\n";

Perform an operation on every item of a list

Perform an operation on every item of a list, e.g.
for the list ["ox", "cat", "deer", "whale"] calculate
the list of sizes of the strings, e.g. [2, 3, 4, 5]
perl
my @list = qw{ox cat deer whale};

my @lengths = map {length($_)} @list;

print "@list\n";
print "@lengths\n";

Split a list of things into numbers and non-numbers

Given a list that might contain e.g. a string, an integer, a float and a date,
split the list into numbers and non-numbers.
perl
use Scalar::Util qw(looks_like_number);
my @things = ('hello',25,3.14,scalar(localtime(time)));
my @numbers;
my @others;
for ( @things ) {
if ( looks_like_number $_ ) {
push @numbers, $_;
} else {
push @other, $_;
}
}

Define an empty map

perl
# %map = {}
# This was wrong, that would have created a hash with one key
# of the stringified hash reference (HASH(0xNUMBERSHERE)) and a
# value of 'undef', as well as triggering a
# "Reference found where even-sized list expected" with the warnings
# pragma enabled

my %map;

Define an unmodifiable empty map

perl
# perl does not provide unmodifiable maps/hashes, but you could use "constant
# functions", if you really need them
# 2011-07-06 Not actually true, see Hash::Util::lock_hash;

sub MAP () { {} }
use Hash::Util qw/lock_hash/;
# two lines
my %hash;
lock_hash(%hash);
# or in one line
lock_hash(my %locked_hash);

Define an initial map

Define the map {circle:1, triangle:3, square:4}
perl
%map = (circle => 1, triangle => 3, square => 4);

Check if a key exists in a map

Given a map pets {joe:cat,mary:turtle,bill:canary} print "ok" if an pet exists for "mary"
perl
%pets = (joe => 'cat', mary => 'turtle', bill => 'canary');
print 'ok' if ($pets{'mary'});
%pets = (joe => 'cat', mary => 'turtle', bill => 'canary');
print 'ok' if $pets{'mary'};
print 'ok' if $pets{mary};
print 'ok' if exists $pets{mary}
Starting with a previously suggested solution:

%pets = (joe => 'cat', mary => 'turtle', bill => 'canary');
print 'ok' if $pets{'mary'};

.. there is a case where this will not work as expected- for the case where mary => 0 ..

suggest instead to use the following conditional check if a value of 0 is allowable.:

print 'ok - is defined' if defined $pets{'mary'};

Retrieve a value from a map

Given a map pets {joe:cat,mary:turtle,bill:canary} print the pet for "joe" ("cat")
perl
%pets = (joe => 'cat', mary => 'turtle', bill=>'canary');
print $pets{joe};

Add an entry to a map

Given an empty pets map, add the mapping from "rob" to "dog"
perl
$pets{rob} = 'dog';

Remove an entry from a map

Given a map pets {joe:cat,mary:turtle,bill:canary} remove the mapping for "bill" and print "canary"
perl
print delete $pets{bill};

Create a histogram map from a list

Given the list [a,b,a,c,b,b], produce a map {a:2, b:3, c:1} which contains the count of each unique item in the list
perl
foreach(@list) {
$histogram{$_}++;
}
$histogram{$_}++ for @list;

Categorise a list

Given the list [one, two, three, four, five] produce a map {3:[one, two], 4:[four, five], 5:[three]} which sorts elements into map entries based on their length
perl
@list = qw(one two three four five);
push @{$map{length($_)}}, $_ for (@list);

Perform an action if a condition is true (IF .. THEN)

Given a variable name, if the value is "Bob", display the string "Hello, Bob!". Perform no action if the name is not equal.
perl
if ($name eq "Bob") {
print "Hello, Bob!"
}
print "Hello, Bob!" if $name eq "Bob";

Perform different actions depending on a boolean condition (IF .. THEN .. ELSE)

Given a variable age, if the value is greater than 42 display "You are old", otherwise display "You are young"
perl
if ($age > 42) {
print "You are old"
}
else {
print "You are young"
}
print 'You are ',($age > 42) ? 'old' : 'young';

Perform different actions depending on several boolean conditions (IF .. THEN .. ELSIF .. ELSE)

perl
if ($age > 84) {
print "You are really ancient";
} elsif ($age > 30) {
print "You are middle-aged";
} else {
print "You are young";
}
print 'You are ',
$age > 84 ? 'really ancient!'
: $age > 30 ? 'middle-aged'
: 'young';

Replacing a conditional with many branches with a switch/case statement

Many languages support more compact forms of branching than just if ... then ... else such as switch or case or match. Use such a form to add an appropriate placing suffix to the numbers 1..40, e.g. 1st, 2nd, 3rd, 4th, ..., 11th, 12th, ... 39th, 40th
perl
sub suffix {
my $n = shift;

return 'th' if $n % 100 >= 4 && $n % 100 <= 20;
return 'st' if $n % 10 == 1;
return 'nd' if $n % 10 == 2;
return 'rd' if $n % 10 == 3;
return 'th';

}

foreach my $n (1..40) {
print $n.suffix($n)."\n";
}

Perform an action multiple times based on a boolean condition, checked before the first action (WHILE .. DO)

Starting with a variable x=1, Print the sequence "1,2,4,8,16,32,64,128," by doubling x and checking that x is less than 150.
perl
my $x = 1;
while($x < 150) {
print $x, ",";
$x *=2
}

Perform an action multiple times based on a boolean condition, checked after the first action (DO .. WHILE)

Simulate rolling a die until you get a six. Produce random numbers, printing them until a six is rolled. An example output might be "4,2,1,2,6"
perl
do {
my $number = int(rand(6)+1);
print $number;
print ',' if ($number != 6);
} while ($number != 6);

Perform an action a fixed number of times (FOR)

Display the string "Hello" five times like "HelloHelloHelloHelloHello"
perl
print "Hello" x 5
print "Hello" for (1..5)

Perform an action a fixed number of times with a counter

Display the string "10 .. 9 .. 8 .. 7 .. 6 .. 5 .. 4 .. 3 .. 2 .. 1 .. Liftoff!"
perl
for (my $i = 10; $i > 0; $i--) {
print "$i .. ";
}
print "Liftoff!";
print "$_ .. " for reverse 1..10;
print "Liftoff!";

Read the contents of a file into a string

perl
@file = read()
open(my $fh, '<', $path) or die "can't open $path: $!";
$string = do { local $/; <$fh> };
close $fh;

Process a file one line at a time

Open the source file to your solution and print each line in the file, prefixed by the line number, like:
1> First line of file
2> Second line of file
3> Third line of file
perl
open(my $fh, '<', $path) or die "can't open $path: $!";
$c = 1;
print $c++ . "> $_" for (<$fh>);
close $fh;
open my $fh, '<', $path or die "Can't open $path: $!";
while (<$fh>) {
print "$.> $_";
}

Write a string to a file

perl
open(my $fh, '>', $path) or die "can't open $path: $!";
print $fh "This line overwites file contents!";
close $fh;

Append to a file

perl
open(my $fh, '>>', $path) or die "can't open $path: $!";
print $fh "This line is appended to the file!";
close $fh;

Process each file in a directory

perl
use File::Glob;

for (<*>) {
process_file($_) if (-f);
}

Process each file in a directory recursively

perl
use File::Glob;

process_directory(".");

sub process_directory {
my $dir = shift;
for my $file (<$dir/*>) {
next unless (-r $file);
if (-f $file) {
process_file($file);
} elsif (-d $file) {
process_directory($file);
}
}
}
use File::Find ();

# Traverse desired filesystems
sub process_directory {
my $directory = shift;
File::Find::find({wanted => \&wanted}, $directory);
}

sub wanted {
process_file( $File::Find::name );
}

Parse a date and time from a string

Given the string "2008-05-06 13:29", parse it as a date representing 6th March, 2008 1:29:00pm in the local time zone.
perl
#! /usr/bin/perl
# -*- Mode: CPerl -*-

use strict;
use POSIX;

# Given the string "2008-05-06 13:29", parse it as a date
# representing 6th March, 2008 1:29:00pm in the local time zone.

my $ds = "2008-05-06 13:29";

my $y;
my $m;
my $d;
my $hr;
my $mn;

print "Original: ",$ds,"\n";

if ( $ds =~ /(\d{4})-(\d{2})-(\d{2})\s+(\d{2}):(\d{2})/ ){
$y = $1 - 1900;
$m = $2;
$d = $3;
$hr = $4;
$mn = $5;

printf "Nominal: %s\n",
strftime("%e %B, %Y %l:%M:%S%P",0, $mn , $hr, $d, $m,$y);

my $eth = "";
if ( $d == 1 ){
$eth = "st";
} elsif ( $d == 2 ){
$eth = "nd";
} elsif ( $d == 3 ){
$eth = "rd";
} else {
$eth = "th";
}

printf "As required: %d%s %s\n",$d,$eth,
strftime("%B, %Y %l:%M:%S%P",0, $mn , $hr, $d, $m,$y);
}

#eos
# Shurely you mean 6th MAY? If not, oh well
use Time::Piece;

my $dt_str = '2008-05-06 13:29';
my $tp = Time::Piece->strptime( $dt_str, '%Y-%m-%d %H:%M');
print $tp,"\n";

Display information about a date

Display the day of month, day of year, month name and day name of the day 8 days from now.
perl
#! /usr/bin/perl
# -*- Mode: CPerl -*-

use strict;
use Date::Calc qw(:all);

my $days_in_future = $ARGV[0];
$days_in_future = 8 unless $days_in_future;

my ($year,$month,$day, $hour,$min,$sec, $doy,$dow,$dst) = Localtime();

my ($fyear,$fmonth,$fday) = Add_Delta_Days($year,$month,$day,$days_in_future);

printf "Now: %d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d\n",
$year,$month,$day,$hour,$min,$sec;

printf "Then: %d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d\n",
$fyear,$fmonth,$fday,$hour,$min,$sec;

printf "Then: day of month: %d\n",$fday;
printf "Then: day of year: %d\n",Day_of_Year($fyear,$fmonth,$fday);
printf "Then: day of name: %s\n",
Day_of_Week_to_Text(Day_of_Week($fyear,$fmonth,$fday));
printf "Then: month name: %s\n",Month_to_Text($fmonth);

#eos
use Time::Piece;
use Time::Seconds;

my $t = localtime;
my $t_8 = $t + (ONE_DAY * 8);

printf "Now: %d, %d, %s, %s\n",
$t->day_of_month, $t->day_of_year, $t->fullmonth, $t->fullday;

printf "Then: %d, %d, %s, %s\n",
$t_8->day_of_month, $t_8->day_of_year, $t_8->fullmonth, $t_8->fullday;

Display a date in different locales

Display a language/locale friendly version of New Year's Day for 2009 for several languages/locales. E.g. for languages English, French, German, Italian, Dutch the output might be something like:

Thursday, January 1, 2009
jeudi 1 janvier 2009
giovedì 1 gennaio 2009
Donnerstag, 1. Januar 2009
donderdag 1 januari 2009

(Indicate in comments where possible if any language specific or operating system configuration needs to be in place.)
perl
#!/usr/bin/perl
use warnings;
use strict;

use locale;
use POSIX qw(strftime);
use Time::Local;

my $date=timegm(0,0,0, 1,0,101); #00:00:00 01/01/2001

my $str_time = strftime "%c", gmtime;

print "Date: $str_time\n";

Display the current date and time

Create a Date object representing the current date and time. Print it out.
If you can also do this without creating a Date object you can show that too.
perl
use Class::Date;
my $date = Class::Date->now();
print $date->string()."\n";

print localtime()."\n";
use Time::Piece ();

# Date object
my $date = Time::Piece::localtime;
print "$date\n";
# no object
print scalar(localtime),"\n";
OOP

Define a class

Declare a class named Greeter that takes a string on creation and greets using this string if you call the "greet" method.
perl
{ package Greeter;
sub new {
my $self = {};
my $type = shift;
$self->{'whom'} = shift;
bless $self, $type;
}

sub greet {
my $self = shift;
print "Hello " . $self->{'whom'} . "!\n";
}
}

my $greeter = Greeter->new("world");
$greeter->greet();
{
package Greeter;

sub new {
my $class = shift;
my $whom = shift or die 'Need a name to greet';
bless \$whom, $class;
}

sub greet {
my $self = shift;
print "Hello $$self!\n";
}
}

my $greeter = Greeter->new("Bob");
$greeter->greet();

Instantiate object with mutable state

Reimplement the Greeter class so that the 'whom' property or data member remains private but is mutable, and is provided with getter and setter methods. Invoke the setter to change the greetee, invoke 'greet', then use the getter in displaying the line, "I have just greeted {whom}.".

For example, if the greetee is changed to 'Tommy' using the setter, the 'greet' method would display:

Hello, Tommy!

The getter would then be used to display the line:

I have just greeted Tommy.
perl
package Greeter;
sub new {
my ($class, $whom) = @_;
bless {whom => $whom}, $class;
}
sub whom {
my ($self, $whom) = @_;
if ($whom) { $self->{whom} = $whom; }
else { return $self->{whom} }
}
sub greet {
my ($self) = @_;
my $whom = $self->{whom};
print "Hello, $whom!\n";
}
package main;

my $g = new Greeter ("world");
$g->greet;

$g->whom("Tommy");
$g->greet;
print "I have just greeted " . $g->whom . "\n";

Implement Inheritance Heirarchy

Implement a Shape abstract class which will form the base of an inheritance hierarchy that models 2D geometric shapes. It will have:

* A non-mutable 'name' property or data member set by derived or descendant classes at construction time
* A 'area' method intended to be overridden by derived or descendant classes ( double precision floating point return value)
* A 'print' method (also for overriding) will display the shape's name, area, and all shape-specific values

Two derived or descendant classes will be created:
* Circle    -> Constructor requires a '
radius' argument, and a 'circumference' method to be implemented  
* Rectangle -> Constructor requires '
length' and 'breadth' arguments, and a 'perimeter' method to be implemented 

Instantiate an object of each class, and invoke each objects '
print' method to show relevant details.
perl
package Shapes;

use MooseX::Declare;

class Shape {
use MooseX::ABC;
requires qw/area print/;
has 'name' => (is => 'ro', isa => 'Str', default => '', required => 0, init_arg => undef );

}

class Circle extends Shape {
use constant PI => 4 * atan2(1, 1);

has '+name' => ( default => 'circle' );
has 'radius' => (is => 'ro', isa => 'Num', required => 1, init_arg => 'r' );

sub area { PI * ( $_[0]->radius ** 2 ) }
sub circumference { 2 * PI * ( $_[0]->radius ** 2 ) }

sub print {
my $self = shift;

printf <<"END_OF_BLOCK", map { $self->$_ } qw/name radius area circumference/;
I am a '%s' with
Radius: %.2f
Area: %.2f
Circumference: %.2f
END_OF_BLOCK

}

}

class Rectangle extends Shape {

has '+name' => ( default => 'rectangle' );
has 'length' => (is => 'ro', isa => 'Num', required => 1, init_arg => 'l' );
has 'breadth' => (is => 'ro', isa => 'Num', required => 1, init_arg => 'b' );

sub area { $_[0]->length * $_[0]->breadth }
sub perimeter { 2 * ( $_[0]->length + $_[0]->breadth ) }

sub print {
my $self = shift;

printf <<"END_OF_BLOCK", map { $self->$_ } qw/name length breadth area perimeter/;
I am a '%s' with
Length, Width: %.2f, %.2f
Area: %.2f
Perimeter: %.2f
END_OF_BLOCK

}

}

1;

package main;

my @shapes = ( Circle->new( r => 4.2 ), Rectangle->new(l => 2.7, b => 3.1),
Rectangle->new(l => 6.2, b => 2.6), Circle->new( r => 17.3) );
$_->print for @shapes;
{
package Shapes;

sub new {
my $class = shift;
die 'Invalid parameters' if (@_ % 2);
my %parameters = @_;
die 'Missing name' unless defined $parameters{name};
bless \%parameters, $class
}

sub area {
die
'area() method must be implemented by ',__PACKAGE__.' subclasses';
}
sub print {
my $self = shift;
printf "Name: \t%s\n", $self->{name};
printf "Area: \t%.2f\n", $self->area();
}
}

{
package Circle;
use parent -norequire, 'Shapes';
use Scalar::Util qw/looks_like_number/;
use Math::Trig;

sub new {
my $class = shift;
my $self = $class->SUPER::new(name => 'Circle', @_);
die 'Missing radius' unless defined($self->{radius});
die 'Invalid radius (not a number)'
unless looks_like_number($self->{radius});
$self
}
sub area {
my $self = shift;
pi * ($self->{radius} ** 2)
}
sub circumference {
my $self = shift;
2 * pi * $self->{radius};
}
sub print {
my $self = shift;
$self->SUPER::print;
printf "Circumference: \t%.2f\n", $self->circumference;
}

}

{
package Rectangle;
use parent -norequire, 'Shapes';
use Scalar::Util qw/looks_like_number/;

sub new {
my $class = shift;
my $self = $class->SUPER::new(name => 'Rectangle', @_);
do {
die "Missing $_" unless defined($self->{$_});
die "Invalid $_" unless looks_like_number($self->{$_});
} for qw/length breadth/;
$self;
}
sub area {
my $self = shift;
$self->{length} * $self->{breadth}
}
sub print {
my $self = shift;
$self->SUPER::print();
do {
printf ucfirst($_).": \t%.2f\n", $self->{$_}
} for qw/length breadth/;
}
}


package main;

my @shapes = ( Circle->new( radius => 4.2 ),
Rectangle->new(length => 2.7, breadth => 3.1),
Rectangle->new(length => 6.2, breadth => 2.6),
Circle->new( radius => 17.3) );
$_->print for @shapes;

Implement and use an Interface

Create a Serializable interface consisting of 'save' and 'restore' methods, each of which:

* Accept a stream or handle or descriptor argument for the source or destination
* Save to destination or restore from source the properties or data members of the implementing class (restrict yourself to the primitive types 'int' and 'string')

Next, create a Person class which has 'name' and 'age' properties or data members and implements this interface. Instantiate a Person object, save it to a serial stream, and instantiate a new Person object by restoring it from the serial stream.
perl
package Person;

use Moose;
use MooseX::Storage;
with Storage('format' => 'JSON', 'io' => 'File');

has 'name' => (is => 'rw', isa => 'Str');
has 'age' => (is => 'rw', isa => 'Int');

1;

Person->new( name => 'David B.', age => 28)->store('person.json');

my $p = Person->load('person.json');
{
package Serializable;
use Role::Basic;
use Storable qw'store_fd retrieve_fd';
use Scalar::Util 'blessed';
use IO::Handle;
use Carp;

sub save {
my $self = shift;
my $fd = shift or croak 'Needs target file handle';
$DB::single = (1);
store_fd($self, $fd);
}

sub restore {
my $class = shift;
my $fd = shift or croak 'Needs source file handle';
my $self = retrieve_fd( $fd );
bless $self, $class
}

}
{
package Person;
use Role::Basic 'with';
use Scalar::Util 'looks_like_number';
use Carp;

with 'Serializable';

sub new {
my $class = shift;
croak 'Invalid parameters' if (@_ % 2);
%parameters = @_;

do {
croak "Missing $_" unless defined $parameters{$_}
} for qw/name age/;
croak 'Invalid age' unless looks_like_number($parameters{age});
bless \%parameters, $class
}
sub name {
$self{name}
}
sub age {
$self{age}
}
}

use IO::Handle;
my $p1 = Person->new(age => 42, name => 'Milly Fogg');
open my $fh, '+>', 'person.store';
$p1->save( $fh );
seek $fh, 0, SEEK_SET;
my $p2 = Person->restore( $fh );

Check your language appears on the langref.org site

Your language name should appear within the HTML found at the http://langreg.org main page.
perl
# requires libwww-perl
use LWP::Simple;

if (grep /perl/, get('http://langref.org/')) {
print 'perl appears on langref.org';
} else {
print 'perl does not appear on langref.org';
}

Send an email

Use library functions, classes or objects to create a short email addressed to your own email address. The subject should be, "Greetings from langref.org", and the user should be prompted for the message body, and whether to cancel or proceed with sending the email.
perl
#SendSimpleEmail.pl
#
# Uses NET::SMTP to send an email to a specific email address
#Modification History
# 2009-MAR-17: GGARIEPY: [creation] (note: geoff.gariepy@gmail.com)

use strict;
use Net::SMTP; # See http://search.cpan.org/~gbarr/libnet-1.22/Net/SMTP.pm

my $smtpserver = 'some.smtp.server.fqdn.com'; # FQDN of SMTP server
my $fromaddress = 'somebody.surname@someemail.com';# Authorized user of SMTP server
my $subject = 'Greetings from langref.org'; # Subject of the message
my $recipient = 'geoff.gariepy@gmail.com'; # Recipient address
my @now;

# Prompt user for the message body to send
print "Enter the body of the message to send, then press Enter >";
my $message = <STDIN>; # String containing the body of the email

# Prompt user to see if execution should continue
print "Open connection to SMTP server [$smtpserver] to send your message? y/N [N] >";
my $yesorno = <STDIN>;
unless ($yesorno =~ /y/i ) {
print "Aborting send of message\n";
exit;
}


my $smtp = Net::SMTP->new($smtpserver, Debug => 1);# Connect to the SMTP server, and
# output diagnostics to STDOUT (DEBUG mode)

# Check to make sure connection was established; die if not.
if (!ref($smtp)) {
die("SENDMAIL: Couldn't establish session with $smtpserver! Message not sent!\n");
}

# Start the communication with the SMTP server by telling it we want
# to mail something.
$smtp->mail($fromaddress);

# Perl's NET::SMTP interface specifies the recipient(s) of the message by
# calls to the recipient method.
# Note that the method should be called once for each separate recipient
# (set up a loop to do this.)
# We're only going to do it once, however, since we only have one recipient.
$smtp->recipient($recipient);

# Figure out current date/time for the message date stamp
# Date stamp format is DD Monthname YY HH:MM:SS TIMEZONE
my @monthnames = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@now = gmtime(time);
for (0..$#now) {
# Make single-digit date/time elements two digits
if (length($now[$_]) lt 2) {$now[$_] = '0'.$now[$_];} # (i.e. prefix with '0')
}

# Slice off just the time and date elements we need from the output of gmtime()
my($YY, $MON, $DD, $HH, $MM, $SS) = @now[5,4,3,2,1,0];
$YY += 1900; # gmtime() epoch starts at 1900

my $monthname = $monthnames[$MON]; # Get the name of the month

# Finally build the silly date stamp!
my $datestring = "Date: $DD $monthname $YY $HH:$MM:$SS GMT";

# Tell the SMTP server we're about to send a block of message data
$smtp->data();
$smtp->datasend("$datestring"); # Give it the message date stamp
$smtp->datasend("From: $fromaddress\n"); # Send from address
$smtp->datasend("To: $recipient\n"); # Build the *display* list of 'to:' addresses
$smtp->datasend("Subject: $subject\n\n"); # Send subject delimited by two CRLFs
$smtp->datasend($message); # Send the message body
$smtp->dataend(); # Actually sends the message!!
$smtp->quit(); # Close the link to the SMTP server

__END__

XML

Process an XML document

Given the XML Document:

<shopping>
  <item name="bread" quantity="3" price="2.50"/>
  <item name="milk" quantity="2" price="3.50"/>
</shopping>

Print out the total cost of the items, e.g. $14.50
perl
#! /usr/bin/perl
# -*- Mode: CPerl -*-

use strict;
use XML::Simple;
use Data::Dumper;

# Given the XML Document:
#
# <shopping>
# <item name="bread" quantity="3" price="2.50"/>
# <item name="milk" quantity="2" price="3.50"/>
# </shopping>
#
# Print out the total cost of the items, e.g. $14.50

my $xml =
" <shopping>\n"
." <item name=\"bread\" quantity=\"3\" price=\"2.50\"/>\n"
." <item name=\"milk\" quantity=\"2\" price=\"3.50\"/>\n"
." </shopping>\n";

my $xs = XML::Simple->new();
my $ref = $xs->XMLin($xml);
my $stuff = ${$ref}{item};

my $q;
my $p;
my $t;
my $z;

foreach my $item ( sort keys %{$stuff}){
$q = ${$stuff}{$item}{quantity};
$p = ${$stuff}{$item}{price};
$z = $q*$p;
printf "%5.5s %2d @\$%5.2f = \$%5.2f\n",$item,$q,$p,$z;
$t += $z;
}
printf "Total \$%5.2f\n",$t;

#eos
use strict;
use XML::Twig;

use Data::Dumper;

my $xml = <<ENDXML;
<shopping>
<item name="bread" quantity="3" price="2.50"/>
<item name="milk" quantity="2" price="3.50"/>
</shopping>
ENDXML

my $xt = XML::Twig->parse( $xml );

my $price;
foreach my $item ($xt->root->children('item')) {
$price += ($item->{att}{price} * $item->{att}{quantity})
}

printf "Total Cost: %.2f\n", $price


create some XML programmatically

Given the following CSV:

bread,3,2.50
milk,2,3.50

Produce the equivalent information in XML, e.g.:

<shopping>
  <item name="bread" quantity="3" price="2.50" />
  <item name="milk" quantity="2" price="3.50" />
</shopping>
perl
#! /usr/bin/perl
# -*- Mode: CPerl -*-

use strict;
use XML::Simple;
use Data::Dumper;

# bread,3,2.50
# milk,2,3.50
#
# Produce the equivalent information in XML, e.g.:
#
# <shopping>
# <item name="bread" quantity="3" price="2.50" />
# <item name="milk" quantity="2" price="3.50" />
# </shopping>
#

my $line;
my $item;
my $q;
my $p;
my $z;

my $xs = XML::Simple->new();
my %d = ();
while($line=<DATA>){
chomp $line;
($item,$q,$p) = split ",",$line;
$d{shopping}{item}{$item}{quantity} = $q;
$d{shopping}{item}{$item}{price} = $p;
}

$xml = $xs->XMLout(\%d, KeepRoot => 1);
print $xml,"\n";

__DATA__
bread,3,2.50
milk,2,3.50
use strict;
use XML::Writer;
use Text::CSV;

my $csv = <<ENDOFCSV;
bread,3,2.50
milk,2,3.50
ENDOFCSV

open my $fh, '<', \$csv or die "Can't open string, $!\n";
my $csv = Text::CSV->new;
my $writer = XML::Writer->new(DATA_MODE => 1, DATA_INDENT => 2);

$writer->startTag('shopping');

while (my $arr_ref = $csv->getline($fh)) {
my %attributes;
@attributes{qw/name quantity price/} =
@{$arr_ref}[0..2];
$writer->emptyTag('item' => %attributes)
}
$writer->endTag('shopping');


Find all Pythagorean triangles with length or height less than or equal to 20

Pythagorean triangles are right angle triangles whose sides comply with the following equation:

a * a + b * b = c * c

where c represents the length of the hypotenuse, and a and b represent the lengths of the other two sides. Find all such triangles where a, b and c are non-zero integers with a and b less than or equal to 20. Sort your results by the size of the hypotenuse. The expected answer is:

[3, 4, 5]
[6, 8, 10]
[5, 12, 13]
[9, 12, 15]
[8, 15, 17]
[12, 16, 20]
[15, 20, 25]
perl
#!/usr/bin/perl
my @results;
for my $x (1..20) {
for my $y ($x..20) {
my $z = sqrt($x**2+$y**2);
push @results, [$x,$y,$z] if $z == int($z);
}
}
for my $triangle ( sort { $a->[2] <=> $b->[2] } @results) {
print "[".join(',',@$triangle)."]\n";
}
print
map"[".join(",",@$_{qw/x y z/})."]\n",
sort{ $$a{z}<=>$$b{z} }
grep{ $$_{z}=~/^\d+$/ }
map{my$x=$_;map{x=>$x,y=>$_,z=>sqrt($x*$x+$_*$_)},
($x..20)}(1..20);

Greatest Common Divisor

Find the largest positive integer that divides two given numbers without a remainder. For example, the GCD of 8 and 12 is 4.

perl
sub gcd {
my ($a, $b) = @_;
($a,$b) = ($b,$a) if $a > $b;

while ($a) { ($a, $b) = ($b % $a, $a) }

return $b;
}

print gcd( 8, 12 );
my $g = gcd (8, 12);
print $g;

sub gcd {
# Euclid's Algorithm - recursive
my ($c, $d) = @_;
return $c unless $d;
return gcd ($d, $c % $d);
}
my $g = gcd2 (8, 12);
print $g;

sub gcd2 {
# Dijkstra's Algorithm - recursive
my ($c, $d) = @_;
return $c if $c == $d;
return $c > $d? gcd2 ($c - $d, $d) : gcd2 ($c, $d - $c);
}
Fun

produces a copy of its own source code

In computing, a quine is a computer program which produces a copy of its own source code as its only output.
perl
seek DATA,0,0;
print <DATA>;
__DATA__
Cheating quine.
$_=q(print qq(\$_=q($_);eval\n));eval
$x=q($x=q(%s);printf($x,$x););printf($x,$x);

Create a multithreaded "Hello World"

Create a program which outputs the string "Hello World" to the console, multiple times, using separate threads or processes.

Example:

-Output-

Thread one says Hello World!
Thread two says Hello World!
Thread four says Hello World!
Thread three says Hello World!

-Notice that the threads can print in any order.
perl
use threads;

foreach my $tid ("one","two","three","four") {
threads->create(
sub { print("Thread $tid says Hello World!\n"); }
)->join();
}