Perl Tutorial - Practical Extraction and Reporting Language (Perl)

Please leave a remark at the bottom of each page with your useful suggestion.

Perl Subroutine / Function Program

Accessing variables in subroutines

 # In your subroutines, you can access the value of any global variable.
# A global variable is a variable that is accessible across the entire Perl script. 
  
# A subroutine can use data set up by other parts of your Perl scripts:
#!/usr/bin/perl -w
# Accessing global variables in subroutines.
$a = 1;
$b = 4;
$value = add();
print "$a plus $b is $value.\n";
sub add {
 return ($a + $b);
}
# sub3.pl

A closure is an anonymous subroutine

 my $name="Tommy";
{my $name = "Tom";  
 my $age = 6;
 $ref = sub{ return "$name is $age.\n"; }
}
print "$name is back\n";
print &{$ref};

Adding two arrays in a subroutine

 @a = (1, 2, 3);
@b = (4, 5, 6);
@array = addem (\@a, \@b);
print @array;
sub addem
{
 my ($ref1, $ref2) = @_;
 while (@{$ref1}) {
  unshift @result, pop(@{$ref1}) + pop(@{$ref2});
 }
 return @result;
}

Ading two arrays together

 @a = (1, 2, 3);
@b = (4, 5, 6);
sub addem {
 local(*array1, *array2) = @_;
 while (@array1) {
  unshift @result, pop(@array1) + pop(@array2);
 }
 return @result
}
@result = addem(*a, *b);
print join(", ", @result);

A nested subroutine.

 #!/usr/local/bin/perl 
($wordcount, $charcount) = &getcounts(3); 
print ("Totals for three lines: "); 
print ("$wordcount words, $charcount characters\n"); 
sub getcounts { 
my ($numlines) = @_; 
my ($charpattern, $wordpattern); 
my ($charcount, $wordcount); 
my ($line, $linecount); 
my (@retval); 
$charpattern = ""; 
$wordpattern = "\\s+"; 
$linecount = $charcount = $wordcount = 0; 
while (1) { 
 $line = <STDIN>; 
 last if ($line eq ""); 
 $linecount++; 
 $charcount += &count($line, $charpattern); 
 $line =~ s/^\s+|\s+$//g; 
 $wordcount += &count($line, $wordpattern); 
 last if ($linecount == $numlines); 
}; 
@retval = ($wordcount, $charcount); 
} 
sub count { 
my ($line, $pattern) = @_; 
my ($count); 
if ($pattern eq "") { 
@items = split (//, $line); 
} else { 
@items = split (/$pattern/, $line); 
} 
$count = @items; 
}

Anonymous functions

 #!/usr/bin/perl
use warnings;
use strict;
my $productRef = sub
{
my $product = 1;
foreach ( @_ ) {
$product *= $_;
}
return $product;
};
my $printVal = &$productRef( 1, 2, 3, 4 );
print( join( ' * ', 1, 2, 3, 4  ), " = " );
print( "$printVal\n" );

Anonymous Subroutines

 #!/bin/perl
my $subref = sub { print @_ ; };
&$subref('a','b','c');
print "\n";

A recursive subroutine to perform arithmetic.

 #!/usr/local/bin/perl 
$inputline = <STDIN>; 
$inputline =~ s/^\s+|\s+$//g; 
@list = split (/\s+/, $inputline); 
$result = &rightcalc (0); 
print ("The result is $result.\n"); 
sub rightcalc { 
 my ($index) = @_; 
 my ($result, $operand1, $operand2); 
 
 if ($index+3 == @list) { 
  $operand2 = $list[$index+2]; 
 } else { 
  $operand2 = &rightcalc ($index+2); 
 } 
 $operand1 = $list[$index+1]; 
 if ($list[$index] eq "+") { 
  $result = $operand1 + $operand2; 
 } elsif ($list[$index] eq "*") { 
  $result = $operand1 * $operand2; 
 } elsif ($list[$index] eq "-") { 
 $result = $operand1 - $operand2; 
 } else { 
  $result = $operand1 / $operand2; 
 } 
}

A subroutine is defined by the sub keyword and the block of code that follows.

 #!/usr/local/bin/perl -w
 # Declare the subroutine named usage
 sub usage
 {
 my ($program, $exitCode) = @_;
 print "Usage: $program [-v] [-h]\n";
 exit $exitCode;
 }
 usage ($0, 1);

A subroutine that returns a scalar or a list.

 @array = scalarOrList();  
$" = "\n"; 
print "Returned:\n@array\n";
print "\nReturned: " . scalarOrList();  # scalar context
sub scalarOrList
{
if ( wantarray() ) {# if list context
return 'this', 'is', 'a', 'list', 'of', 'strings';
}
else {# if scalar context
return 'hello'; 
}
}

A subroutine that returns a value

 for ( 1 .. 10 ) {
print square( $_ ), " ";
}
print "\n";
sub square
{
$value = shift; # use shift to get first argument
return $value ** 2;# returns the result of $value ** 2
}

BEGIN and END Subroutines (Startup and Finish)

 #A BEGIN subroutine is executed immediately, before the rest of the file is even parsed. 
#If you have multiple BEGINs, they will be executed in the order they were defined.
#The END subroutine is executed when all is done. 
#Multiple END blocks are executed in reverse order.
#The keyword sub is not necessary when using these special subroutines.
#!/bin/perl
chdir("/mydir") || die "Can't cd: $!\n";
BEGIN{ print "Welcome to my Program.\n"};
END{ print "Bailing out somewhere near line ",__ LINE__," So long.\n"};

calculate 1000th element of standard Fibonacci sequence

 #!/usr/bin/perl
use warnings;
use strict;
sub fibonacci3 {
 my ($count, $aref) = @_;
 
 unless ($aref) {
  # first call - initialize
  $aref = [1,1];
  $count -= scalar(@{$aref});
 }
 if ($count--) {
  my $next = $aref->[-1] + $aref->[-2];
  push @{$aref}, $next;
  @_ = ($count, $aref);
  goto &fibonacci3;
 } else {
  return wantarray?@{$aref}:$aref->[-1];
 }
}
print scalar(fibonacci3(1000)), "\n";

Call a subroutine and use it

 printhello;
sub printhello
{
 print "Hello!";
}

Call a subroutine through its reference

 sub subroutine
{
 print "Hello!\n";
}
$codereference= \&subroutine;
&$codereference;

Call a subroutine without defining it

 #!/bin/perl
sub AUTOLOAD {
  my(@arguments) = @_;
  my($package, $command)=split("::",$AUTOLOAD, 2);
  return '$command @arguments';# Command substitution
}
$day=date("+%D");  # date is an undefined subroutine
print "Today is $day.\n";
print cal(3,2007); # cal is an undefined subroutine

Calling a sub routine with &

 sub my_subroutine {
 print "In a subroutine.\n";
}
print "Before subroutine.\n";
&my_subroutine;
print "After subroutine.\n";

Calling a sub routine with 'subroutine_name();'

 sub my_subroutine {
 print "In a subroutine.\n";
}
print "Before subroutine.\n";
my_subroutine();
print "After subroutine.\n";

Calling function in print statement

 print "${&getmessage}";
sub getmessage {
 $msg = "Hello!";
 return "msg"
};

Calling subroutines that are not defined before use

 print "Using & and ():\n";
&definedAfterWithoutArguments();
# subroutine with no arguments defined after it is used
sub definedAfterWithoutArguments
{
print "definedAfterWithoutArguments\n";
}

Call sub

 #!/usr/bin/perl
use warnings;
use strict;
sub do_list {
 my ($subref, @in) = @_;
  
 return map { &$subref ($_) } @in;
}
sub add_one {
 return $_[0] + 1;
}
$, = ",";
print do_list (\&add_one, 1, 2, 3);# prints 2, 3, 4

Call subroutine with parameter by using its reference

 $codereference = sub {print shift};
&$codereference("Hello!\n");

Call the subroutine with $number

 #!/usr/bin/perl
$number=<>; # read a number from the keyboard
chomp $number; # remove linefeed
$factorial=factorial($number);
# The subroutine
sub factorial {
 $input = shift; # read passed argument
 return 0 if $input==0;
 $result=1;
 foreach (1 .. $input) { # '..' generates a range
  $result *= $_;
 }
 return $result;
}
print "$number factorial is $factorial\n";

Check the prototype

 #!/usr/bin/perl
use strict;
use warnings;
sub add_two ($$) {
 return $_[0]+$_[1];
}
print prototype(\&add_two),"\n"; # produces '$$'
print prototype('add_two'),"\n"; # likewise

Closure in action

 sub paint {
 my $color = shift; 
 my $ref = sub { 
  my $object=shift;
  print "Paint the $object $color.\n"; # $color still in scope
 };
 return $ref; 
}
my $p1=paint("red");
my $p2=paint("blue");  
$p1->("flower");  
$p2->("sky");

Context and Subroutines

 @now = localtime;  # List context
print "@now\n";# Scalar context
$now = localtime;
print "$now\n";
print localtime, "\n"; # prints in list context
print scalar localtime,"\n"; # Forced to scalar context

Create a subroutine

 #!/usr/bin/perl 
print "Content-Type: text/html \n\n"; 
print "Program starts.\n"; 
&bigHeader; 
print "Program ends.\n"; 
# subroutines below this line 
sub bigHeader { 
 print "<h1>Welcome to Auto!</h1>\n"; 
}

Declaration with prototype

 sub mynumbs(@$;$); # Declaration with prototype
@list=(1,2,3);
mynumbs(@list, 25);
sub mynumbs(@$;$) {# Match the prototypes
  my ($scalar)=pop(@_);
  my(@arr) = @_;
  print "The array is: @arr","\n";
  print "The scalar is $scalar\n";
}

Define local variable in subroutine by using my

 sub printifOK
{
 my $localvalue = $value;
 if ($localvalue > 10 ) {
  print "Value is $value.\n";
 } else {
  print "Value is too small.\n";
 }
}
$value = 10;
printifOK;
$value = 12;
printifOK;

Define subroutine and call it with using global variable

 sub printifOK
{
 if ($value > 10 ) {
  print "Value is $value.\n";
 } else {
  print "Value is too small.\n";
 }
}
$value = 10;
printifOK;
$value = 12;
printifOK;

Define subroutine prototype

 sub addem;
$value = addem 2, 2;
print "2 + 2 = $value\n";
sub addem
{
 ($value1, $value2) = @_;
 $value1 + $value2;
}

Define subroutine then use it

 sub addem
{
 ($value1, $value2) = @_;
 $value1 + $value2;
}
$value = addem 2, 2;
print "2 + 2 = $value\n";

Difference between my and local

 $friend="friend"; # Global variables
$pal="Tom";
print "$friend and $pal are global.\n";
sub guests {
  my $friend="Pat"; # Lexically scoped variable
  local $pal="Chris";  # Dynamically scoped variable
  print "$friend and $pal are welcome guests.\n";
  &who_is_it; 
}
sub who_is_it {
  print "global, $friend, here.\n";
  print "pal is now $pal.\n";  # Dynamically scoped
}
&guests;  
print "Global friends are back: $friend and $pal.\n";

displays all the arguments

 displayArguments( "A", "B", 2, 15, 73, 2.79 );
# output the subroutine arguments using special variable @_
sub displayArguments
{
# the following statement displays all the arguments
print "All arguments: @_\n";
}

Duplicate global and local variable name (use strict;)

 #!/usr/bin/perl -w
use strict;
$record = 4;
print "We're at record ", $record, "\n";
{
 my $record;
 $record = 7;
 print "Inside the block:", $record, "\n";
}
print "Outside, we're still at record ", $record, "\n";

factorial with recursive function

 #!/usr/bin/perl
use warnings;
use strict;
sub fibonaccil {
 my ($count, $aref) = @_;
 unless ($aref) {
  # first call - initialize
  $aref = [1,1];
  $count -= scalar(@{$aref});
 }
 if ($count--) {
  my $next = $aref->[-1] + $aref->[-2];
  push @{$aref}, $next;
  return fibonaccil($count, $aref);
 } else {
  return wantarray?@{$aref}: $aref->[-1];
 }
}
print scalar(fibonaccil(10)), "\n";
print scalar(fibonaccil(10, [2, 4])), "\n";
my @sequence = fibonaccil(10);
print "Sequence: @sequence \n";
sub fibonacci2 {
 my ($count, $internal) = @_;
 if ($count <= 2) {
  return $internal ? [1,1] : 1;
 } else {
  my $result = fibonacci2($count -1, 'internal'); 
  my $next = $result->[-1] + $result->[-2];
  if ($internal) {
push @{$result}, $next;
return $result;
  } else {
return $next;
  }
 }
}
foreach (1..20) {
 print "Element $_ is ", fibonacci2($_), "\n";
}

Is a parameter defined

 sub addem
{
 ($value1, $value2) = @_;
 if (!defined($value2)) {
  $value2 = 1
 };
 print "$value1 + $value2 = " . ($value1 + $value2);
}
addem(2);

Local variable shadows the gloabl variable

 $value = 1;
sub printem() {print "\$value = $value\n"};
sub makelocal()
{
 local $value = 2;
 printem;
}
makelocal;
printem;

Local variable shadows the global variable in a subroutine

 #!/usr/bin/perl -w
$x = 10;
print "before: $x\n";
change_global_not();
print "after:  $x\n";
sub change_global_not {
 my $x = 20;
 print "in change_global_not(): $x\n";
}

Local variables in subroutines

 # Perl allows you to create local variables inside subroutines. 
# The local variables can have the same names as any global variables.
# The local won't overwrite the global variables.
# To make a variable local, use the my command 
#!/usr/bin/perl -w
$a = 1;
$b = 4;
# sum is global.
$sum = 10;
$value = add();
print "$a plus $b is $value.\n";
print "Global sum remains $sum.\n";
sub add {
 # This sum is local.
 my($sum) = $a + $b;
 print "Local sum=$sum.\n";
 return $sum;
}

my, local and global variable

 $value1 = 1;
my $value2 = 2;
local $value3 = 3;
print join(", ", keys %::);

my ($program, $exitCode) = @_; creates two local variables, $program and $exitCode, from @_.

 #!/usr/local/bin/perl -w
 # Declare the subroutine named usage
 sub usage
 {
 my ($program, $exitCode) = @_;
 print "Usage: $program [-v] [-h]\n";
 exit $exitCode;
 }
 usage ($0, 1);

My value scope

 #!/usr/bin/perl
use warnings;
use strict;
my $file_scope = "my value";
print $file_scope, "\n";
sub topsub {
 my $top_scope = "visible in 'topsub'";
 if (1 > 0.5) {
  my $if_scope = "visible inside 'if'";
  print "$file_scope, $top_scope, $if_scope \n";
 }
 bottomsub();
 print "$file_scope, $top_scope\n";
}
sub bottomsub {
 my $bottom_scope = "visible in 'bottomsub'";
 print "$file_scope, $bottom_scope \n";
}
topsub();
print $file_scope, "\n";

my variable

 #!/usr/bin/perl -w
use strict;
my $name = "Tom";
print 'My name is $name\n';

my variable is initialized each time

 sub incrementcount {
 my $count;
 return ++$count;
}
print incrementcount . "\n";
print incrementcount . "\n";
print incrementcount . "\n";
print incrementcount . "\n";

Nested method

 #!/usr/bin/perl -w
use strict;
oneMethod(1,2,3);
sub oneMethod {
 print "In oneMethod, arguments are @_\n";
 anotherMethod(4,5,6);
 print "Back in oneMethod, arguments are @_\n";
}
sub anotherMethod {
 print "In anotherMethod, arguments are @_\n";
}

nested subroutine

 sub outer
{
 my $s = "Inside the inner subroutine.\n";
 sub inner
 {
  my $s2 = $s;
  print $s2;
 }
 inner();
}
outer();

Nested subroutine with local variable

 $value = 1;
sub printem() {
print "\$value = $value\n"
};
sub makelocal() {
 my $value = 2;
 printem;
}
makelocal;
printem;

output the subroutine arguments using special variable @_

 displayArguments( "A", "B", 2, 15, 73, 2.79 );
# output the subroutine arguments using special variable @_
sub displayArguments
{
# the following loop displays each individual argument
for ( $i = 0; $i < @_; ++$i ) {
print "Argument $i: $_[ $i ]\n";
}
}

Pass file handle global reference to a subroutine

 sub printhello
{
 my $handle = shift;
 print $handle "Hello!\n";
}
open FILEHANDLE, ">file.tmp" or die "Can't open file.";
printhello(\*FILEHANDLE);

Passing an array and modifying it,as a reference

 #!/usr/bin/perl -w
@array = (1,2,3,4,5,6,7,8,9);
print "Before: @array.\n";
mod_array( \@array );
print "After:  @array.\n";
sub mod_array {
 my( $arrayref ) = $_[0];
 @$arrayref = reverse( @$arrayref );
}

Passing a range of value to a subroutine

 #!/usr/bin/perl -w
use strict;
total(1, 7, 5, 4, 9);
total(1...10);
sub total {
 my $total = 0;
 $total += $_ foreach @_;
 print "The total is $total\n";
}

Passing Arrays

 #!/usr/bin/perl
use warnings;
use strict;
sub check_same (\@\@);
my @a = (1, 2, 3, 4, 5);
my @b = (1, 2, 4, 5, 6);
my @c = (1, 2, 3, 4, 5);
print "\@a is the same as \@b" if check_same(@a,@b);
print "\@a is the same as \@c" if check_same(@a,@c);
sub check_same (\@\@) {
 my ($ref_one, $ref_two) = @_;
 
 return 0 unless @$ref_one == @$ref_two;
 for my $elem (0..$#$ref_one) {
  return 0 unless $ref_one->[$elem] eq $ref_two->[$elem];
 }
 
 return 1;
}

Passing arrays to a function

 #!/usr/bin/perl
use warnings;
use strict;
my @array1 = ( 1 .. 8 );
my @array2 = ( 'a' .. 'e' );
my @mixed = arrayMixer( \@array1, \@array2 );
print( "@mixed\n" );
sub arrayMixer
{
my @firstArray = @{ $_[ 0 ] };
my @secondArray = @{ $_[ 1 ] };
my ( $first, $second, @array );
while ( ( $first = shift( @firstArray ) ) && ( $second = shift( @secondArray ) ) ) {
push( @array, $first, $second );
}
return @array;
}

Passing array to a subroutine

 #!/usr/bin/perl -w
use strict;
my(@nums1, @nums2);
@nums1 = (2, 4, 6);
@nums2 = (8, 10, 12);
process_arrays(@nums1, @nums2);
sub process_arrays {
 my(@a, @b) = @_;
 print "contents of \@a\n";
 print "[$_] " foreach @a;
 print "contents of \@b\n";
 print "[$_] " foreach @b;
}

Passing by reference with pointers

 @list1= (1..100);
@list2 = (5..200);
display(@list1, @list2); # Pass two arrays
print "-" x 35,"\n";
display(\@list1, \@list2); # Pass two pointers
sub display{
  print "@_\n";
}

Passing different number of parameter to a subroutine

 #!/usr/bin/perl -w
use strict;
log_warning("A", "B");
log_warning("C");
log_warning();
sub log_warning {
 my $message = shift || "Something's wrong";
 my $time = shift || localtime; # Default to now.
 print "[$time] $message\n";
}

Passing hash to a subroutine

 $hash{fruit} = peach;
$hash{vegetable} = broccoli;
$hash{pie} = blueberry;
sub printem
{
 %hash = @_;
 foreach $key (keys %hash) {
  print "$key => $hash{$key}\n";
 }
}
printem(%hash);

Passing parameters to subroutines

 # Perl places all the parameters into an array named @_.
# You can access this array directly with the @_ syntax, or access individual parameters. 
#!/usr/bin/perl -w
$value = add(5, 6);
print "Value from add=$value.\n";
$value = add(25, 1);
print "Value from add=$value.\n";
sub add {
 my($a, $b) = @_;
 my($sum) = $a + $b;
 return $sum;
}

Passing References to a Subroutine

 #!/usr/bin/perl
use warnings;
use strict;
my $a = 5;
increment(\$a);
print $a;
sub increment {
 my $reference = shift;
 $$reference++;
}

Passing two values to a subroutine

 sub addem
{
 ($value1, $value2) = @_;
 return $value1 + $value2;
}
print "2 + 2 = " . addem(2, 2) . "\n";

Pass reference to a subroutine to another subroutine

 sub printhello
{
 print "Hello!\n";
}
sub printem
{
 &{@_[0]};
}
printem \&printhello;

Pass two array reference to a subroutine

 @a = (1, 2, 3);
@b = (4, 5, 6);
sub addem
{
 my ($reference1, $reference2) = @_;
 for ($loop_index = 0; $loop_index <= $#$reference1; $loop_index++) {
  $result[$loop_index] = @$reference1[$loop_index] + @$reference2[$loop_index];
 }
 return @result;
}
@array = addem (\@a, \@b);
print join (', ', @array);

Prototypes

 A prototype tells declare what types of arguments the subroutine should get. 
my $a=5;
my $b=6;
my $c=7;
@list=(100,200,300);
sub myadd($$) { # myadd requires two scalar arguments
  my($x, $y)=@_;
  print $x + $y,"\n";
}
myadd($a, $b);  # Okay
myadd(5, 4); # Okay

Recursive factorial subroutine

 foreach ( 0 .. 10 ) {
print "$_! = " . factorial( $_ ) . "\n";
}
sub factorial
{
my $number = shift;# get the argument
if ( $number <= 1 ) { # base case
return 1;
}
else { # recursive step
return $number * factorial( $number - 1 );
}
}

Recursive fibonacci function.

 @sampleValues = (0, 1, 2, 3, 4, 5, 6, 10, 20, 30, 35);
foreach ( @sampleValues ) {
print "fibonacci( $_ ) = ", fibonacci( $_ ), "\n";
}
sub fibonacci
{
my $number = shift;  # get the first argument
if ( $number == 0 or $number == 1 ) { # base case
return $number;
} 
else {  # recursive step
return fibonacci( $number - 1 ) + fibonacci( $number - 2 );
}
}

Recursive subroutine

 sub factorial
{
 my $value = shift (@_);
 return $value == 1 ? $value : $value * factorial ($value - 1);
}
$result = factorial(6);
print $result;

References to subroutines.

 #!/usr/bin/perl 
sub print_coor{ 
 my ($x,$y,$z) = @_; 
 print "$x $y $z \n"; 
 return $x;
}; 
$k = 1; 
$j = 2; 
$m = 4; 
$this = print_coor($k,$j,$m); 
$that = print_coor(4,5,6);

Return a reference from a sub

 #!/usr/bin/perl
use warnings;
use strict;
sub now { return \scalar(localtime) };
print "The time is ${&now}\n";

Return a subroutine from a subroutine

 sub printem
{
 my $string1 = shift;
 return sub {my $string2 = shift; print "$string1 $string2\n";};
}
$hellosub = printem("Hello");
&$hellosub("today.");
&$hellosub("there.");

Return hash value from subroutine

 sub gethash ()
{
 $hash{fruit} = peach;
 $hash{vegetable} = broccoli;
 $hash{pie} = blueberry;
 return %hash;
}
%myhash = gethash;
foreach $key (keys %myhash) {
 print "$key => $myhash{$key}\n";
}

Returning arrays from subroutines

 #!/usr/bin/perl -w
# Checks for desired return type.
@ar = get_value();
print "Wanted array.  Got back: @ar\n";
$v = get_value();
print "Wanted scalar. Got back: $v\n";
sub get_value {
 my(@array) = (1, 2, 3);
 my($val)= 55;
 
 if (wantarray) {
  return @array;
 } else {
  return $val;
 }
 
}

Returning data from subroutines

 # Subroutines return the value of the last expression evaluated. 
# Or you can use the return statement to clearly delineate the value you want returned from the subroutine..
#!/usr/bin/perl -w
$value = two();
print "Two is $value.\n";
sub two {
return 2;
}

Return more than one value from subroutine

 #!/usr/bin/perl -w
use strict;
my ($hours, $minutes, $seconds) = second2HourMinuteSecond(999);
print "999 seconds is $hours hours, $minutes minutes and $seconds seconds";
print "\n";
sub second2HourMinuteSecond {
 my ($h,$m);
 my $seconds = shift;; # defaults to shifting @_
 $h = int($seconds/(60*60)); 
 $seconds %= 60*60;
 $m = int($seconds/60);
 $seconds %= 60;
 ($h,$m,$seconds);
}

Return reference from a function

 #!/usr/bin/perl
use strict;
use warnings;
my @array = qw( A B C D E );
my $arrayReference = \@array;
sub returnReference
{
return \@array;
}
print( "\${returnReference()}[ 1 ] = ${returnReference()}[ 1 ]\n\n" );

Return reference to variable

 #!/usr/bin/perl
use warnings;
use strict;
sub definelexical {
 my $lexvar = "the original value";
 return \$lexvar;
}
sub printlexicalref {
 my $lexvar = ${$_[0]};# dereference the reference
 print "The variable still contains $lexvar \n";
}
my $ref = definelexical();
printlexicalref($ref);

Return two array references from a subroutine

 sub getarrays
{
 @a = (1, 2, 3);
 @b = (4, 5, 6);
 return \@a, \@b;
}
($aref, $bref) = getarrays;
print "@$aref\n";
print "@$bref\n";

Return two arrays from subroutine

 sub getarrays
{
 @a = (1, 2, 3);
 @b = (4, 5, 6);
 return \@a, \@b;
}
($aref, $bref) = getarrays;
print "@$aref\n";
print "@$bref\n";

Return Value

 #!/bin/perl
sub MAX {
  my($max) = shift(@_);
  foreach $foo ( @_ ){
$max = $foo if $max < $foo;
print $max,"\n";
  }
  $max;
}
sub MIN {
  my($min) = pop( @_ );
  foreach $foo ( @_ ) {
$min = $foo if $min > $foo;
print $min,"\n";
  }
  return $min;
}
my $biggest = &MAX ( 2, 3, 4, 10, 100, 1 );
my $smallest= &MIN ( 200, 2, 12, 40, 2, 20 );
print "$biggest / $smallest.\n";

Return value based on context

 #!/usr/bin/perl
use warnings;
use strict;
sub list_files {
 die "Function called in void context" unless defined wantarray;
 my $path = shift;
 return unless defined $path;
 chomp $path;
 $path.='/*' unless $path =~/\*/;  
 my @files = glob $path;
 return wantarray?@files:\@files;
}
my $path = $ARGV[0] || print("Enter Path: ") && <>;
# call subroutine in list context
print "Get files as list:\n";
my @files = list_files($path);
foreach (sort @files) {
 print "\t$_\n";
}
# call subroutine in scalar context
print "Get files as scalar:\n";
my $files = list_files($path);
foreach (sort @{$files}) {
 print "\t$_ \n";
}

Return value from subroutine reference

 $codereference = sub {100};
$s = &$codereference;
print $s;

Return value from subroutine without using the return statement

 sub addem
{
 ($value1, $value2) = @_;
 $value1 + $value2;
}
print "2 + 2 = " . addem(2, 2) . "\n";

Scalar and list Context

 print "What is your full name? ";
($first, $middle, $last)=split(" ", <STDIN>);# STDIN scalar context
print "Hi $first $last.\n";

shift parameter

 sub addem
{
 $value1 = shift;
 $value2 = shift;
 print "$value1 + $value2 = " . ($value1 + $value2) . "\n";
}
$value = addem 2, 2;
print $value;

Subroutine parameter default value

 sub addem 
{
 my %hash = 
 (
  OPERAND1 => 2,
  OPERAND2 => 3,
  @_,
 );
 return $hash{OPERAND1} + $hash{OPERAND2};
}
print "The result is: " . addem();
print "\n";
print "The result is: " . addem(OPERAND1 => 3);

Subroutine with arguments defined before it is used

 sub definedBeforeWithArguments
{
print "definedBeforeWithArguments: @_\n";
}
# calling subroutines that are defined before use
print "Using & and ():\n";
&definedBeforeWithArguments( 1, 2, 3 );

Subroutine with no arguments defined after it is used: using ()

 print "\nUsing only ():\n";
definedAfterWithoutArguments(); 
sub definedAfterWithoutArguments
{
print "definedAfterWithoutArguments\n";
}

Subroutine with no arguments defined before it is used

 sub definedBeforeWithoutArguments
{
print "definedBeforeWithoutArguments\n";
}
print "Using & and ():\n";
&definedBeforeWithoutArguments();

Swap array value by using the sub range

 #!/usr/bin/perl -w
use strict;
my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
print @months;
@months[3,4] = @months[4,3];
print @months;

The last statement is the value to return

 #!/usr/bin/perl -w
use strict;
my $total = total(1, 7, 5, 4, 9);
print "the total is: $total\n";
my $sum_of_100 = total(1..100);
print "the sum of 100 is: $sum_of_100\n";
sub total {
 my $total = 0;
 $total += $_ for @_;
 $total;
}

The loop displays each individual argument

 displayArguments( "A", "B", 2, 15, 73, 2.79 );
# output the subroutine arguments using special variable @_
sub displayArguments
{
# the following loop displays each individual argument
for ( $i = 0; $i < @_; ++$i ) {
print "Argument $i: $_[ $i ]\n";
}
}

The return values of the ref function: hash

 #!/usr/bin/perl
use strict;
my %hash = ( key => "data" );
print( 'ref(\%hash) = ', ref( \%hash ), "\n" );

The scope of my variables

 my $name = "Raimo";
print "$name\n";
  {  
  print "My name is $name\n";
  my $name = "my name";
  print "Now name is $name\n";
  my $love = "another name";
  print "My love is $love.\n";
  }  
print "$name is back.\n";
print "$love.\n";

The wantarray Function and User-Defined Subroutines

 #When you want a subroutine to behave in a certain way based on the context in which it was called. 
#!/usr/bin/perl
print "Name? ";
chomp($fullname=<STDIN>);
@arrayname = title($fullname);# Context is array
print "$arrayname[0] / $arrayname[2]!\n";
print "book name? ";
chomp($bookname=<STDIN>);
$scalarname = title($bookname);  # Context is string
print "The book $arrayname[0] is reading is $scalarname.\n";
sub title{
 my $text=shift;
 my $newstring;
 my$text=lc($text);
 my @newtext=split(" ", $text); 
 foreach my $word ( @newtext ){
 $word = ucfirst($word); # Capitalize the first letter
 $newstring .= "$word "; 
 }
 @newarray = split(" ", $newstring);
 chop($newstring);# Remove trailing whitespace
 return wantarray ? @newarray : $newstring;  
}

Use my to declare local variable

 #!/usr/bin/perl -w
$record = 4;
print "We're at record ", $record, "\n";
{
 my $record;
 $record = 7;
 print "Inside the block: ", $record, "\n";
}
print "Outside, we're still at record ", $record, "\n";

Using closures.

 #!/usr/bin/perl 
sub errorMsg { 
 my $lvl = shift; 
 
 return sub { 
  my $msg = shift; 
  print "Err Level $lvl:$msg\n";
 };
} 
$severe = errorMsg("Severe"); 
&$severe("Divide by zero");

Using -> operator to call a subroutine by its reference

 $codereference = sub {print shift};
$codereference->("Hello!\n");

Using local

 sub printifOK
{
 local $localvalue = $value;
 if ($localvalue > 10 ) {
  print "Value is $value.\n";
 } else {
  print "Value is too small.\n";
 }
}
$value = 10;
printifOK;
$value = 12;
printifOK;

Using my

 #!/usr/bin/perl -w
use strict;
my $record;
$record = 4;
print "We're at record ", $record, "\n";
{
 my $record;
 $record = 7;
 print "Inside the block, we're at record ", $record, "\n";
}
print "Outside, we're still at record ", $record, "\n";

Using my if statement

 $testvalue = 10;
if ((my $variable1 = 10) > $testvalue ) {
 print "Value, $variable1, is greater than the test value.\n";
} elsif ($variable1 < $testvalue) {
 print "Value, $variable1, is less than the test value.\n";
} else {
 print "Value, $variable1, is equal to the test value.\n";
}

Using my to declare the local variable in a subroutine

 #!/usr/bin/perl -w
$x = 10;
print "before: $x\n";
change_global_not();
print "after:  $x\n";
sub change_global_not {
 my $x = 20;
 print "in change_global_not(): $x\n";
}

Using return statement

 print "${&getmessage}";
sub getmessage {
 $msg = "Hello!";
 return "msg"
};

Using shift(@_) to get value passed into a subroutine

 $value = 10;
printifOK ($value);
sub printifOK
{
 my $internalvalue = shift(@_);
 if ($internalvalue > 10 ) {
  print "Value is $value.\n";
 } else {
  print "Value is too small.\n";
 }
}

Using the return statement.

 #!/usr/local/bin/perl 
$total = &get_total; 
if ($total eq "error") { 
print ("No input supplied.\n"); 
} else { 
print("The total is $total.\n"); 
} 
sub get_total { 
$value = 0; 
$inputline = <STDIN>; 
$inputline =~ s/^\s+|\s*\n$//g; 
if ($inputline eq "") { 
return ("error"); 
} 
@subwords = split(/\s+/, $inputline); 
$index = 0; 
while ($subwords[$index] ne "") { 
$value += $subwords[$index++]; 
} 
$retval = $value; 
}

Wantarray function.

 #!/usr/local/bin/perl 
@array = &mysub(); 
$scalar = &mysub(); 
sub mysub { 
 if (wantarray()) { 
  print ("true\n"); 
 } else { 
  print ("false\n"); 
 } 
}

wantarray() returns true if caller wants list, false if caller wants scalar, and an undefined value if the caller wants nothing.

 #!/usr/bin/perl -w
# Checks for desired return type.
@ar = get_value();
print "Wanted array.  Got back: @ar\n";
$v = get_value();
print "Wanted scalar. Got back: $v\n";
sub get_value {
 my(@array) = (1, 2, 3);
 my($val)= 55;
 
 if (wantarray) {
  return @array;
 } else {
  return $val;
 }
 
}

Write recursive subroutines

 sub Factorial {
  my($n) = @_;
  $n <= 2 and return $n;
  return $n * Factorial($n-1);
 }
 for $i (1..9) {
  print "$i Factorial =\t", Factorial($i), "\n";
 }

Write Your Comments or Suggestion...

Perl Tutorial - Practical Extraction and Reporting Language (Perl)

Table of Contents

Perl Subroutine / Function Program