7. Subroutines

Created Saturday 19 April 2014

SUBROUTINE SYNTAX

sub IDENTIFIER BLOCK

Example
my $result = random_die_roll();
print $result;
sub random_die_roll {

return 1 + int(rand(6));
}

Argument Handling

sub random_die_roll {
my ($number_of_sides) = @_; # forcing a list context by using ()
# have a useful default if called with no arguments
$number_of_sides ||= 6;
return 1 + int(rand($number_of_sides));
}
OR
sub random_die_roll {
my $number_of_sides = shift;
# more code
}
my $result = &random_die_roll();
my $result = &random_die_roll;

Multiple Arguments

Roll a 6-sided die 3 times and print the result:
sub random_die_roll {

my ($number_of_sides, $number_of_rolls) = @_;
# have a useful default if called with no arguments
$number_of_sides ||= 6;
$number_of_rolls ||= 1;
my $total = 0;
for (1 .. $number_of_rolls) {
$total += 1 + int(rand($number_of_sides));
}
return $total;
}
print random_die_roll(6, 3);
my $number_of_sides = shift;
my $number_of_rolls = shift;
OR
my $number_of_sides = shift @_;
my $number_of_rolls = shift @_;

Named Arguments

print random_die_roll(
number_of_sides => 6,
number_of_rolls => 4,
);

sub random_die_roll {

my %arg_for = @_;
# assign useful defaults
my $number_of_sides = $arg_for{number_of_sides} || 6;
my $number_of_rolls = $arg_for{number_of_rolls} || 1;
my $total = 0;

for (1 .. $number_of_rolls) {
$total += (1 + int(rand($number_of_sides)));
}
return $total;
}
print random_die_roll (
{
number_of_sides => 6,
number_of_rolls => 4,
}
);
sub random_die_roll {
my ($arg_for) = @_;
# assign useful defaults
my $number_of_sides = $arg_for->{number_of_sides} || 6;
my $number_of_rolls = $arg_for->{number_of_rolls} || 1;
my $total = 0;
for (1 .. $number_of_rolls) {
$total += (1 + int(rand($number_of_sides)));
}
return $total;
}

Aliasing

my $number = 40;
inc_by_two($number);
print $number; # 42
sub inc_by_two {
$_[0] += 2;
}
# Also, calling this sub like inc_by_two(40) will generate the following error:
# Modification of a read-only value attempted at ...

State Variables (Pre- and Post-5.10)

A subroutine that tracks the number of times it has been called:
use 5.10.0;
sub how_many {
state $count = 0; # this is initialized only once
$count++;
print "I have been called $count time(s)\n";
}
how_many() for 1 .. 5;
{
my $count = 0;
sub how_many {
$count++;
print "I have been called $count time(s)\n";
}
}

Passing a List, Hash, or Hashref?

how_many() for 1 .. 5;

RETURNING DATA

Returning True/False

sub is_palindrome {

my $word = lc shift;
if($word eq scalar reverse $word) {
return 1;
} else {
# a bare return returns an empty list which evaluates to false
return;
}
}
OR
sub is_palindrome {
my $word = lc shift;
return $word eq scalar reverse $word;
}
sub is_palindrome {
my $word = lc shift;
$word eq scalar reverse $word;
}

Returning Single and Multiple Values

sub some_function {
my @args = @_;
# do stuff
return \@array1, \@array2;
}
my ($arrayref1, $arrayref2) = some_function(@some_data);

wantarray

sub how_was_i_called {
if (not defined wantarray) {
# no return value expected
print "I was called in void context\n";
} elsif (not wantarray) {
# one return value expected
print "I was called in scalar context\n";
} else {
# a list is expected
print "I was called in list context\n";
}
}
how_was_i_called();
my $foo = how_was_i_called();
my ($foo) = how_was_i_called();
my @bar = how_was_i_called();
my ($this, $that) = how_was_i_called();
my %corned_beef = how_was_i_called();

FAIL!

"Wake Up! Time to Die!"

carp and croak

sub reciprocal {
my $number = shift;
if (0 == $number) {
croak "Argument to reciprocal must not be 0";
}
return 1 / $number;
}
reciprocal(0);

eval

String eval

Trying to debug the following example naming the debugged variables:
use Data::Dumper;
$Data::Dumper::Indent = 0;
my @numbers = (1, 2, 3);
my @new = map {$_++} @numbers;
print Data::Dumper->Dump( # Instead of: Dumper(\@numbers, \@new);
[\@numbers, \@new],
[qw/*numbers *new/],
);
eval "use Data::Dumper::Names";
if (my $error = $@) {
warn "Could not load Data::Dumper::Names: $error";
# delay loading until runtime. This is a standard module
# included with Perl
eval "use Data::Dumper";
}
$Data::Dumper::Indent = 0;
my @numbers = (1, 2, 3);
my @new = map {$_++} @numbers;
print Dumper(\@numbers, \@new);

Block eval

sub reciprocal {return 1/shift}
for (0 .. 3) {
my $reciprocal;
eval {
$reciprocal = reciprocal($_);
}; # the trailing semicolon is required
if (my $error = $@) {
print "Could not calculate the reciprocal of $_: $error\n";
} else {
print "The reciprocal of $_ is $reciprocal\n";
}
}

evalGotchas

eval {...};
if (my $error = $@) {
handle_error($error);
}
if (my $result = eval {some_code()}) {
# do something with $result
} else {
warn "Could not calculate result: $@";
}
my $result;
my $ok = eval {$result = some_code(); 1};
if ($ok) {
# do something with $result
} else {
my $error = $@;
warn "Could not calculate result: $error";
}
my $result;
my $ok = do {
local $@;
eval {$result = some_code(); 1};
};

Try::Tiny

use Try::Tiny;
sub reciprocal {return 1/shift}
for my $number (0 .. 3) {
my $reciprocal;
try {
$reciprocal = reciprocal($number);
print "The reciprocal of $number is $reciprocal\n";
} catch {
my $error = $_;
print "could not calculate the reciprocal of $_: $error\n";
} finally { # OPTIONAL
print "We tried to calculate the reciprocal of $number\n";
};
}

SUBROUTINE REFERENCES

Existing Subroutines

sub reciprocal {return 1/shift}
my $reciprocal = \&reciprocal;
1 way of calling:
my $result = &$reciprocal(4);
print $result;
2nd way:
my $result = $reciprocal->(4);
print $result;

Anonymous Subroutines

my $reciprocal = sub {return 1/shift};
print $reciprocal->(4);

Closures

Example on Fibonacci numbers:
F(0) = 0
F(1) = 1
F(n) = F(n-1) + F(n-2)
use strict;
use warnings;
use diagnostics;
sub make_fibonacci {
my ($current, $next) = (0, 1);
return sub {
my $fibonacci = $current;
($current, $next) = ($next, $current + $next);
return $fibonacci;
};
}
my $iterator = make_fibonacci();
for (1 .. 10) {
my $fibonacci = $iterator->();
print "$fibonacci\n";
}

Writing a Dispatch Table
use strict;
use warnings;
use diagnostics;
use Carp 'croak';
my %length_for = (

SCALAR => sub {return length ${$_[0]}},
ARRAY => sub {return scalar @{$_[0]}},
HASH => \&_hash_length,
);
sub _hash_length {return scalar keys %{$_[0]}}
sub mylength {
my $reference = shift;
my $length = $length_for{ref $reference}
|| croak "Don't know how to handle $reference";
return $length->($reference);
}
my $name = 'John Q. Public';
my @things = qw(this that and the other);
my %cheeses = (
good => 'Havarti',
bad => 'Mimolette',
);
print mylength(\$name), "\n";
print mylength(\@things), "\n";
print mylength(\%cheeses), "\n";
print mylength($name), "\n";

PROTOTYPES

sub sreverse($) {
my $string = shift;
return scalar reverse $string;
}
my $raboof = sreverse 'foobar';
print $raboof;
print sreverse 'foobar', 'foobar';

Argument Coercion

sub sreverse($) {
my $string = shift;
return scalar reverse $string;
}
print sreverse("this", "that");
sub foo(@) {
my @args = @_;
...
}
sub random_die_rolls($@) {
my ($number_of_rolls, @number_of_sides) = @_;
my @results;
foreach my $num_sides (@number_of_sides) {
my $total = 0;
$total += int(1 + rand($num_sides)) for 1 .. $number_of_rolls;
push @results, $total;
}
return @results;
}
my @rolls = random_die_rolls 3;
print join "\n", @rolls;

use Data::Dumper;
$Data::Dumper::Sortkeys = 1;
sub my_lc(\%) {
my $hashref = shift;
foreach my $key (keys %$hashref) {
next if ref $hashref->{$key};
$hashref->{$key} = lc $hashref->{$key};
}
}
my $name = 'Ovid';
my %hash = (
UPPER => 'CASE';
Camel => 'Case';
);
# hey, no backslash required!
my_lc %hash;
print Dumper(\%hash);

More Prototype Tricks

sub mylength(\[$@%]) { # tells Perl to pass a single scalar or array or hash as a reference to the subroutine
my $arg = shift;
return
'ARRAY' eq ref $arg ? scalar @$arg
: 'HASH' eq ref $arg ? scalar keys %$arg
: length $arg;
}
my $scalar = "whee!";
print mylength($scalar), "\n";
my @array = (1, 18, 9);
print mylength(@array), "\n";
my %hash = (foo => 'bar');
print mylength(%hash), "\n";

Mimicking Builtins

sub mypush(\@@) {
my ($array, @args) = @_;
@$array = (@$array, @args);
}
mypush @some_array, $foo, $bar, $baz;
mypush @some_array, @some_other_array;
sub mytime(;$) {
my $real_time = shift;
if ($real_time) {
return scalar localtime;
} else {
return "It's happy hour!";
}
}

sub apply (&@) {
my $action = shift;
my @shallow_copy = @_;
foreach (@shallow_copy) {
$action->();
}
return @shallow_copy;
}
use Data::Dumper;
my @numbers = (1, 2, 3);
my @new = apply {$_++} @numbers;
print Dumper(\@numbers, \@new);
my @munged = apply {$_->[0]++} @list;

Forward Declarations

use strict;
use warnings;
use diagonstics;
my $reciprocal = reciprocal 4;
sub reciprocal($) {
return 1/shift;
}
Forward declaration:
use strict;
use warnings;
use diagnostics;
sub reciprocal($);
my $reciprocal = reciprocal 4;
sub reciprocal($) {
return 1/shift;
}
Using parentheses:
use strict;
use warnings;
use diagnostics;
my $reciprocal = reciprocal(4);
sub reciprocal($) {
return 1/shift;
}

Prototype Summary

"Zipping" 2 arrays together into a key/value hash:
use strict;
use warnings;
use diagnostics;
use Carp 'croak';
use Data::Dumper;
sub zip(\@\@;$);
my @names = qw(alice bob charlie);
my @tests = qw(87 72);
my @final = qw(100 53 87);
my %test_grades = zip @names, @tests, 0;
my %final_grades = zip @names, @final;
# uncomment the following line to see how this breaks
# my %blows_up = zip @tests, @final;
print Dumper(\%test_grades, \%final_grades);
sub zip (\@\@;$) {
my ($first, $second, $default) = @_;
# if we don't have a default, croak if arrays are not
# the same length
if (@_ < 3 and (@$first != @$second)) {
$max_index = $#$second;
}
my @zipped;
for my $i (0 .. $max_index) {
my $first_value = $i <= $#$first ? $first->[$i] : $default;
my $second_value = $i <= $#$second ? $second->[$i] : $default;
push @zipped, $first_value, $second_value;
}
return @zipped;
}

RECURSION

Basic Recursion

Fibonacci again:
F(0) = 0
F(1) = 1
F(n) = F(n-1) + F(n-2)
Find the nth Fibonacci number:
sub F {

my $n = shift;
return 0 if $n == 0;
return 1 if $n == 1;
return F($n - 1) + F($n - 2);
}
print F(7);
A binary search:
use strict;
use warnings;
use diagnostics;
my @numbers = man {$_ * 3} (0 .. 1000);
sub search {
my ($numbers, $target) = @_;
return _binary_search($numbers, $target, 0, $#$numbers);
}
sub _binary_search {
my ($numbers, $target, $low, $high) = @_;
return if $high < $low;
# divide array in two
my $middle = int(($low + $high) / 2);
if ($numbers->[$middle] > $target) {
# search the lower half
return _binary_search($numbers, $target, $low, $middle - 1);
}
elsif ($numbers->[$middle] < $target) {
# search the upper half
return _binary_search($numbers, $target, $middle + 1, $high);
}
# found it!
return $middle;
}
print search(\@numbers, 699), "\n";
print search(\@numbers, 28), "\n";

Memoization

use Memoize;
memoize('F');
sub F {
my $n = shift;
return 0 if $n == 0;
return 1 if $n == 1;
return F($n - 1) + F($n - 2);
}
print F(50);

A recursive Maze Generator
use strict;
use warnings;
use diagnostics;
use List::Util 'shuffle';
my ($WIDTH, $HEIGHT) = (10, 10);
my %OPPOSITE_OF = (

north => 'south',
south => 'north',
west => 'east',
east => 'west',
);
my @maze;
tunnel(0, 0, \@maze);
print render_maze(\@maze);
exit;
sub tunnel {
my ($x, $y, $maze) = @_;
my @directions = shuffle keys %OPPOSITE_OF;
foreach my $direction (@directions) {
my ($new_x, $new_y) = ($x, $y);
if ('east' eq $direction) {$new_x += 1;}
elsif ('west' eq $direction) {$new_x -= 1;}
elsif ('south' eq $direction) {$new_y += 1;}
else {$new_y -= 1;}
# if a previous tunnel() through the maze has not visited the square, go there.
# This will replace the _ or | character in the map with a space when rendered
if (have_not_visited($new_x, $new_y, $maze)) {
# make a two-way "path" between the squares
$maze->[$y][$x]{$direction} = 1;
$maze->[$new_y][$new_x]{$OPPOSITE_OF{$direction}} = 1;
# This program will often recurse more than one hundred levels deep and this is
# Perl's default recursion depth level prior to issuing warnings. In this case, we're
# telling Perl that we know that we'll exceed the recursion depth and to not warn
# us about it
no warnings 'recursion';
tunnel($new_x, $new_y, $maze);
}
}
# if we get to here, all squares surround the current square have been visited or are "out of bounds".
# When we return, we may return to a previous tunnel() call while we're digging, or we return
# completely to the first tunnel() call, in which case we've finished generating the maze. This return
# is not strictly necessary, but it makes it clear what we're doing
return;
}
sub have_not_visited {
my ($x, $y, $maze) = @_;
# the first two lines return false if we're out of bounds
return if $x < 0 or $y < 0;
return if $x > $WIDTH - 1 or $y > $HEIGHT - 1;
# this returns false if we've already visited this cell
return if $maze->[$y][$x];
# return true
return 1;
}
# creates the ASCII strings that will make up the maze when printed
sub render_maze {
my $maze = shift;
# $as_string is the string representation of the maze
# start with a row of underscores:
# ------------------------------------------------------------------
my $as_string = "_" x (1 + $WIDTH * 2);
$as_string .= "\n";
for my $y (0 .. $HEIGHT - 1) {
# add the | vertical border at the left side
$as_string .= "|";
for my $x (0 .. $WIDTH - 1) {
my $cell = $maze->[$y][$x];
# if the neighbor is true - we have a path
$as_string .= $cell->{south} ? " " : "_";
$as_string .= $cell->{east} ? " " : "|";
}
$as_string .= "\n";
}
return $as_string;
}



Backlinks: