Perl Cheat Sheet

Get information on a function by typing, e.g., perldoc -f chomp at the command line.

Scalar variables	while (defined ($x=<>)) {code}	False if variable has never been set (or when you try to read past the end of an input file)
	length($x)	Length of a string
	chomp($line);	Remove a newline at the end of a string
	$short=substr ($long, 2, 5)	Characters 3-7 of $long (first char is 0!)
Arrays	push @arr, $x	Add to end of array
	$x = pop @arr;	Remove last element of array, put in $x
	shift @arr; (See also unshift)	Remove first element of an arrray, put in $x
	$size = scalar @arr;	Number of things in the array
	See also: split, join, splice, sort	split string->array, join array->string, delete part of array, sort array in many ways
Hashes	@key = keys %hash	The lookup terms in the hash
Hashes	if (exists $hh{“Hsp”}) {...}	See whether hash %hh has a value for that key
Input/Output and Files	open(HANDLE, ">outfile") or die “Can’t open $outfile: $!\n”	Open outfile for writing, and associate it with filehandle HANDLE. Use “<infile” for reading
	print $x; print HANDLE $x;	Prints to standard output (screen), Print to filehandle HANDLE
	warn “Something wrong\n”;	Prints to standard error (screen)
	$x=<HANDLE>	Read a line from filehandle HANDLE, put in $x
	close(HANDLE);	Stop reading/writing a previously opened file
Exit	exit;	Exits the program
Exit	die "Something broke!\n";	Exits the program with error message

Operators and Loops

Assign value	$x = 1	Sets variable to a value. Don’t confuse with ==, which tests whether numerical values are equal
Math	print 1 * (2 + 3/4)	Regular math symbols
	10%3==1; 12%3==0	Modulus (remainder) operator
	$x += 4;	Same as $x=$x=4; Also -= *= /=
	$x++;	Same as $x=$x+1;
Conditions	if (.1 == 0.1) {print “same num”}	Are numbers equal? Don’t confuse with =
	if (1 != 2) {print “diff num”}	Are numbers different?
	> < >= <=	Are numbers greater than, less than, etc.
	if (“a” eq “a”) {print “same text”}	Does text have exactly the same letters?
	if (“A” ne “a”) {print “diff text”}	Does text have different letters?
	if (($x > 1) && ($x < 2)) {code}	AND (true if both sides are true)
	if (($x > 10) \|\| ($x < -10)) {code}	OR (true if one or both sides are true)
	=~ !~	Test for a match: See Matching cheat sheet
Loops	foreach $i (1 .. 100) {code} (for and foreach are equivalent)	Sets $i to 1 and does code. Sets $i to 2, … up to (and including) 100
	while ($a < $b) {code}	Does code while the condition is true (If condition is false, never enters the loop.)

Matching and Regular Expressions

Test for Match	=~	Test for match	if ($x =~ /abc/) { ...}	Does $x have the string “abc” anywhere in it?
	!~	Test for non-match	if ($x !~ /abc/) { ...}	Does $x NOT have the string “abc” anywhere in it?
	$_	Default variable	if (/abcd/) { s/bc/x/ }	// and s/// work on $_ by default, no =~ needed
Substitute	s///	Do a Substitution	$x =~ s/abc/def/;	Replace (only) first occurrence of “abc” in $x with def
Options to Search / Substitution	i	Ignore case.	/abc/i	Matches abc, ABC, aBc, etc.
Options to Search / Substitution	g	Global substitution.	s/a/c/g	Replace ALL occurrences
Special Match Items	.	Any one character (except \n)	/a.c/	“arc”, “a9c”, but not “ac”.
	[ ]	Any one of.	/[abc]/	Any one of “a”, “b”, or “c”. [a-zA-Z] matches any letter
	\d	Digit (Same as [0-9])	/\d\d:\d\d/	“10:30” (but not “9:30”)
	\s	Space, tab, or newline	/^\s*$/	An empty line.
	\	Literally match special characters: + * ( ) / [ ] \ \| { } ^ $ @	/1\+2/	“1+2”, not “1112”. The backslash “quotes” or “escapes” the plus sign.
Item Locations	^	Beginning of a line	/^a/	"arginine" but not "valine”.
Item Locations	$	End of a line	/a$/	"beta" but not "beat".
Item Repetitions	?	An optional thing	/ab?c/	“ac” or “abc”.
	*	Any number of copies OR nothing at all	/a*/	"", "a", "aaa".
	+	Any number of copies	/a+b/	"ab" or "aaab" but not "b".
	{ }	m to n copies	/ab{2,4}c/	“abbc”, “abbbc”, “abbbbc”, but not “abc” or “abbbbbc”
Misc	\|	One or the other	/abc\|def/	“abc” or “def”
Misc	( )	Group things together AND capture in numbered variables	/a(b(..)e)f/	“abcdef”. This will also set $1 to “c” and $2 to “bcde”.

#####################################

1:An Overview of Perl/Getting Started

#####################################

print "Howdy, world!\n";

######################################################################

1:An Overview of Perl/Natural and Artificial Languages/Variable Syntax

######################################################################

$phrase = "Howdy, world!\n"; # Set a variable.

print $phrase; # Print the variable.

####################################################################################

1:An Overview of Perl/Natural and Artificial Languages/Variable Syntax/Singularities

####################################################################################

$answer = 42; # an integer

$pi = 3.14159265; # a "real" number

$avocados = 6.02e23; # scientific notation

$pet = "Camel"; # string

$sign = "I love my $pet"; # string with interpolation

$cost = 'It costs $100'; # string without interpolation

$thence = $whence; # another variable's value

$salsa = $moles * $avocados; # a gastrochemical expression

$exit = system("vi $file"); # numeric status of a command

$cwd = `pwd`; # string output from a command

--------------

$ary = \@myarray; # reference to a named array

$hsh = \%myhash; # reference to a named hash

$sub = \&mysub; # reference to a named subroutine

$ary = [1,2,3,4,5]; # reference to an unnamed array

$hsh = {Na => 19, Cl => 35}; # reference to an unnamed hash

$sub = sub { print $state }; # reference to an unnamed subroutine

$fido = new Camel "Amelia"; # ref to an object

--------------

$camels = '123';

print $camels + 1, "\n";

--------------

$fido = new Camel "Amelia";

if (not $fido) { die "dead camel"; }

$fido->saddle();

##########################################################################################

1:An Overview of Perl/Natural and Artificial Languages/Variable Syntax/Pluralities/Arrays.

##########################################################################################

@home = ("couch", "chair", "table", "stove");

--------------

($potato, $lift, $tennis, $pipe) = @home;

--------------

($alpha,$omega) = ($omega,$alpha);

--------------

$home[0] = "couch";

$home[1] = "chair";

$home[2] = "table";

$home[3] = "stove";

##########################################################################################

1:An Overview of Perl/Natural and Artificial Languages/Variable Syntax/Pluralities/Hashes.

##########################################################################################

%longday = ("Sun", "Sunday", "Mon", "Monday", "Tue", "Tuesday",

"Wed", "Wednesday", "Thu", "Thursday", "Fri",

"Friday", "Sat", "Saturday");

--------------

%longday = (

"Sun" => "Sunday",

"Mon" => "Monday",

"Tue" => "Tuesday",

"Wed" => "Wednesday",

"Thu" => "Thursday",

"Fri" => "Friday",

"Sat" => "Saturday",

);

--------------

$wife{"Adam"} = "Eve";

###################################################################################

1:An Overview of Perl/Natural and Artificial Languages/Variable Syntax/Complexities

###################################################################################

$wife{"Jacob"} = ("Leah", "Rachel", "Bilhah", "Zilpah");

--------------

$wife{"Jacob"} = ["Leah", "Rachel", "Bilhah", "Zilpah"];

--------------

$wife{"Jacob"}[0] = "Leah";

$wife{"Jacob"}[1] = "Rachel";

$wife{"Jacob"}[2] = "Bilhah";

$wife{"Jacob"}[3] = "Zilpah";

--------------

$kids_of_wife{"Jacob"} = {

"Leah" => ["Reuben", "Simeon", "Levi",

"Judah", "Issachar", "Zebulun"],

"Rachel" => ["Joseph", "Benjamin"],

"Bilhah" => ["Dan", "Naphtali"],

"Zilpah" => ["Gad", "Asher"],

};

--------------

$kids_of_wife{"Jacob"}{"Leah"}[0] = "Reuben";

$kids_of_wife{"Jacob"}{"Leah"}[1] = "Simeon";

$kids_of_wife{"Jacob"}{"Leah"}[2] = "Levi";

$kids_of_wife{"Jacob"}{"Leah"}[3] = "Judah";

$kids_of_wife{"Jacob"}{"Leah"}[4] = "Issachar";

$kids_of_wife{"Jacob"}{"Leah"}[5] = "Zebulun";

$kids_of_wife{"Jacob"}{"Rachel"}[0] = "Joseph";

$kids_of_wife{"Jacob"}{"Rachel"}[1] = "Benjamin";

$kids_of_wife{"Jacob"}{"Bilhah"}[0] = "Dan";

$kids_of_wife{"Jacob"}{"Bilhah"}[1] = "Naphtali";

$kids_of_wife{"Jacob"}{"Zilpah"}[0] = "Gad";

$kids_of_wife{"Jacob"}{"Zilpah"}[1] = "Asher";

--------------

$fido = new Camel "Amelia";

###################################################################################

1:An Overview of Perl/Natural and Artificial Languages/Variable Syntax/Simplicities

###################################################################################

package Camel;

--------------

package Camel;

$fido = &fetch();

--------------

package Dog;

$fido = &fetch();

--------------

$fido = new Camel "Amelia";

--------------

$fido->saddle();

--------------

use Camel;

--------------

$fido = new Camel "Amelia";

--------------

use Some::Cool::Module;

--------------

use strict;

############################################################

1:An Overview of Perl/Natural and Artificial Languages/Verbs

############################################################

print "Adam's wife is $wife{'Adam'}.\n";

--------------

$e = exp(1); # 2.718281828459 or thereabouts

########################################

1:An Overview of Perl/An Average Example

########################################

#!/usr/bin/perl

open(GRADES, "grades") or die "Can't open grades: $!\n";

while ($line = <GRADES>) {

($student, $grade) = split(" ", $line);

$grades{$student} .= $grade . " ";

}

foreach $student (sort keys %grades) {

$scores = 0;

$total = 0;

@grades = split(" ", $grades{$student});

foreach $grade (@grades) {

$total += $grade;

$scores++;

}

$average = $total / $scores;

print "$student: $grades{$student}\tAverage: $average\n";

}

#####################################################

1:An Overview of Perl/An Average Example/How to Do It

#####################################################

% perl -e 'print "Hello, world!\n";'

--------------

% perl gradation

--------------

#!/usr/bin/perl

--------------

% gradation

--------------

% ../bin/gradation

--------------

#!/bin/sh -- # perl, to stop looping

eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'

if 0;

--------------

#!/usr/bin/perl -w

#################################

1:An Overview of Perl/Filehandles

#################################

open(SESAME, "filename") # read from existing file

open(SESAME, "<filename") # (same thing, explicitly)

open(SESAME, ">filename") # create file and write to it

open(SESAME, ">>filename") # append to existing file

open(SESAME, "| output-pipe-command") # set up an output filter

open(SESAME, "input-pipe-command |") # set up an input filter

--------------

print STDOUT "Enter a number: "; # ask for a number

$number = <STDIN>; # input the number

print STDOUT "The number is $number.\n"; # print the number

--------------

chop($number = <STDIN>); # input number and remove newline

--------------

$number = <STDIN>; # input number

chop($number); # remove newline

################################################

1:An Overview of Perl/Operators/String Operators

################################################

$a = 123;

$b = 456;

print $a + $b; # prints 579

print $a . $b; # prints 123456

--------------

$a = 123;

$b = 3;

print $a * $b; # prints 369

print $a x $b; # prints 123123123

--------------

print $a . ' is equal to ' . $b . ".\n"; # dot operator

print $a, ' is equal to ', $b, ".\n"; # list

print "$a is equal to $b.\n"; # interpolation

--------------

print "-" x $scrwid, "\n";

####################################################

1:An Overview of Perl/Operators/Assignment Operators

####################################################

$a = $b;

$a = $b + 5;

$a = $a * 3;

--------------

$a *= 3;

--------------

$line .= "\n"; # Append newline to $line.

$fill x= 80; # Make string $fill into 80 repeats of itself.

$val ||= "2"; # Set $val to 2 if it isn't already "true".

--------------

$a = $b = $c = 0;

--------------

($temp -= 32) *= 5/9;

--------------

chop($number = <STDIN>);

##########################################################
1:An Overview of Perl/Operators/Unary Arithmetic Operators
##########################################################

$a = 5; # $a is assigned 5
$b = ++$a; # $b is assigned the incremented value of $a, 6
$c = $a--; # $c is assigned 6, then $a is decremented to 5

#################################################
1:An Overview of Perl/Operators/Logical Operators
#################################################

open(GRADES, "grades") or die "Can't open file grades: $!\n";

########################################################
1:An Overview of Perl/Operators/Some File Test Operators
########################################################

-e "/usr/bin/perl" or warn "Perl is improperly installed\n";
-f "/vmlinuz" and print "I see you are a friend of Linus\n";

#######################################################
1:An Overview of Perl/Control Structures/What Is Truth?
#######################################################

0 # would become the string "0", so false.
1 # would become the string "1", so true.
10 - 10 # 10-10 is 0, would convert to string "0", so false.
0.00 # equals 0, would convert to string "0", so false.
"0" # the string "0", so false.
"" # a null string, so false.
"0.00" # the string "0.00", neither "" nor "0", so true!
"0.00" + 0 # the number 0 (coerced by the +), so false.
\$a # a reference to $a, so true, even if $a is false.
undef() # a function returning the undefined value, so false.

####################################################################################
1:An Overview of Perl/Control Structures/What Is Truth?/The if and unless statements
####################################################################################

if ($debug_level > 0) {
# Something has gone wrong. Tell the user.
print "Debug: Danger, Will Robinson, danger!\n";
print "Debug: Answer was '54', expected '42'.\n";
}

--------------

if ($city eq "New York") {
print "New York is northeast of Washington, D.C.\n";
}
elsif ($city eq "Chicago") {
print "Chicago is northwest of Washington, D.C.\n";
}
elsif ($city eq "Miami") {
print "Miami is south of Washington, D.C. And much warmer!\n";
}
else {
print "I don't know where $city is, sorry.\n";
}

--------------

unless ($destination eq $home) {
print "I'm not going home.\n";
}

######################################################################################################
1:An Overview of Perl/Control Structures/Iterative (Looping) Constructs/The while and until statements
######################################################################################################

while ($tickets_sold < 10000) {
$available = 10000 - $tickets_sold;
print "$available tickets are available. How many would you like: ";
$purchase = <STDIN>;
chomp($purchase);
$tickets_sold += $purchase;
}

--------------

print "This show is sold out, please come back later.\n";

--------------

while (@ARGV) {
process(shift @ARGV);
}

#########################################################################################
1:An Overview of Perl/Control Structures/Iterative (Looping) Constructs/The for statement
#########################################################################################

for ($sold = 0; $sold < 10000; $sold += $purchase) {
$available = 10000 - $sold;
print "$available tickets are available. How many would you like: ";
$purchase = <STDIN>;
chomp($purchase);
}

#############################################################################################
1:An Overview of Perl/Control Structures/Iterative (Looping) Constructs/The foreach statement
#############################################################################################

foreach $user (@users) {
if (-f "$home{$user}/.nexrc") {
print "$user is cool... they use a perl-aware vi!\n";
}
}

--------------

foreach $key (sort keys %hash) {

###################################################################################################
1:An Overview of Perl/Control Structures/Iterative (Looping) Constructs/Breaking out: next and last
###################################################################################################

foreach $user (@users) {
if ($user eq "root" or $user eq "lp") {
next;
}
if ($user eq "special") {
print "Found the special account.\n";
# do some processing
last;
}
}

--------------

LINE: while ($line = <ARTICLE>) {
last LINE if $line eq "\n"; # stop on first blank line
next LINE if $line =~ /^#/; # skip comment lines
# your ad here
}

#########################################
1:An Overview of Perl/Regular Expressions
#########################################

if (/Windows 95/) { print "Time to upgrade?\n" }

--------------

s/Windows/Linux/;

--------------

($good, $bad, $ugly) = split(/,/, "vi,emacs,teco");

--------------

while ($line = <FILE>) {
if ($line =~ /http:/) {
print $line;
}
}

--------------

while (<FILE>) {
print if /http:/;
}

--------------

while (<FILE>) {
print if /http:/;
print if /ftp:/;
print if /mailto:/;
# What next?
}

#####################################################
1:An Overview of Perl/Regular Expressions/Quantifiers
#####################################################

$_ = "fred xxxxxxx barney";
s/x*//;

#############################################################
1:An Overview of Perl/Regular Expressions/Nailing Things Down
#############################################################

/\bFred\b/

--------------

next LINE if $line =~ /^#/;

########################################################
1:An Overview of Perl/Regular Expressions/Backreferences
########################################################

s/(\S+)\s+(\S+)/$2 $1/

#####################################
1:An Overview of Perl/List Processing
#####################################

@array = (1 + 2, 3 - 4, 5 * 6, 7 / 8);

--------------

sort @dudes, @chicks, other();

--------------

print reverse sort map {lc} keys %hash;

--------------

($hour, $min, $sec, $ampm) = /(\d+):(\d+):(\d+) *(\w+)/;

--------------

@hmsa = /(\d+):(\d+):(\d+) *(\w+)/;

#####################################
2:Bits and Pieces/Built-in Data Types
#####################################

$x = $y;

--------------

$x = $y + 1;

###########################
2:Bits and Pieces/Variables
###########################

@days = 1 .. 7;

#######################
2:Bits and Pieces/Names
#######################

$Santa::Helper::Reindeer::Rudolph::nose

####################################
2:Bits and Pieces/Names/Name Lookups
####################################

$bert

--------------

${ some_expression() }

################################################
2:Bits and Pieces/Scalar Values/Numeric literals
################################################

$x = 12345; # integer
$x = 12345.67; # floating point
$x = 6.02e23; # scientific notation
$x = 4_294_967_296; # underline for legibility
$x = 0377; # octal
$x = 0xffff; # hexadecimal
$x = 0b1100_0000; # binary

###############################################
2:Bits and Pieces/Scalar Values/String literals
###############################################

$Price = '$100'; # not interpolated
print "The price is $Price.\n"; # interpolated

--------------

$days{'Feb'}

--------------

$days{Feb}

--------------

$days{'February 29th'} # Ok.
$days{"February 29th"} # Also ok. "" doesn't have to interpolate.
$days{ February 29th } # WRONG, produces parse error.

--------------

@days{'Jan','Feb'} # Ok.
@days{"Jan","Feb"} # Also ok.
@days{ Jan, Feb } # Kinda wrong (breaks under use strict)

--------------

print "\n"; # Ok, print a newline.
print \n ; # WRONG, no interpolative context.

####################################################
2:Bits and Pieces/Scalar Values/Pick your own quotes
####################################################

$single = q!I said, "You said, 'She said it.'"!;

$double = qq(Can't we get some "good" $variable?);

$chunk_of_code = q {
if ($condition) {
print "Gotcha!";
}
};

--------------

tr (a-f)
[A-F];

--------------

s {foo} # Replace foo
{bar}; # with bar.

tr [a-f] # Translate lowercase hex
[A-F]; # to uppercase hex

################################################################
2:Bits and Pieces/Scalar Values/Or leave the quotes out entirely
################################################################

@days = (Mon,Tue,Wed,Thu,Fri);
print STDOUT hello, ' ', world, "\n";

--------------

@days = qw(Mon Tue Wed Thu Fri);
print STDOUT "hello world\n";

--------------

use strict 'subs';

--------------

no strict 'subs';

--------------

"${verb}able"
$days{Feb}

##########################################################
2:Bits and Pieces/Scalar Values/Interpolating array values
##########################################################

$temp = join( $", @ARGV );
print $temp;

print "@ARGV";

################################################
2:Bits and Pieces/Scalar Values/"Here" documents
################################################

print <<EOF; # same as earlier example
The price is $Price.
EOF

print <<"EOF"; # same as above, with explicit quotes
The price is $Price.
EOF

print <<'EOF'; # single-quoted quote
All things (e.g. a camel's journey through
A needle's eye) are possible, it's true.
But picture how the camel feels, squeezed out
In one long bloody thread, from tail to snout.
-- C.S. Lewis
EOF

print << x 10; # print next line 10 times
The camels are coming! Hurrah! Hurrah!

print <<"" x 10; # the preferred way to write that
The camels are coming! Hurrah! Hurrah!

print <<`EOC`; # execute commands
echo hi there
echo lo there
EOC

print <<"dromedary", <<"camelid"; # you can stack them
I said bactrian.
dromedary
She said llama.
camelid

funkshun(<<"THIS", 23, <<'THAT');
Here's a line
or two.
THIS
And here's another.
THAT

--------------

print <<'odd'
2345
odd
+ 10000; # prints 12345

--------------

($quote = <<'QUOTE') =~ s/^\s+//gm;
Christians and camels receive
their blessings on their knees.
QUOTE

--------------

@sauces = <<End_Lines =~ m/(\S.*\S)/g;
normal tomato
spicy tomato
green chile
pesto
white wine
End_Lines

#################################################
2:Bits and Pieces/Scalar Values/V-String Literals
#################################################

$crlf = v13.10; # ASCII carriage return, line feed

--------------

"\x{1}\x{14}\x{12c}\x{fa0}"
pack("U*", 1, 20, 300, 4000)
chr(1) . chr(20) . chr(300) . chr(4000)

--------------

print v9786; # prints UTF-8 encoded SMILEY, "\x{263a}"
print v102.111.111; # prints "foo"
print 102.111.111; # same thing

use 5.6.0; # require a particular Perl version (or later)

$ipaddr = 204.148.40.9; # the IPv4 address of oreilly.com

#################################################
2:Bits and Pieces/Context/Scalar and list context
#################################################

$x = funkshun(); # scalar context
$x[1] = funkshun(); # scalar context
$x{"ray"} = funkshun(); # scalar context

--------------

@x = funkshun(); # list context
@x[1] = funkshun(); # list context
@x{"ray"} = funkshun(); # list context
%x = funkshun(); # list context

--------------

($x,$y,$z) = funkshun(); # list context
($x) = funkshun(); # list context

--------------

my $x = funkshun(); # scalar context
my @x = funkshun(); # list context
my %x = funkshun(); # list context
my ($x) = funkshun(); # list context

#########################################
2:Bits and Pieces/Context/Boolean context
#########################################

unlink @files; # Delete all files, ignoring errors.

--------------

while (@files) {
my $file = shift @files;
unlink $file or warn "Can't delete $file: $!\n";
}

######################################
2:Bits and Pieces/Context/Void context
######################################

"Camel Lot";

########################################
2:Bits and Pieces/List Values and Arrays
########################################

@stuff = ("one", "two", "three");

--------------

$stuff = ("one", "two", "three");

--------------

@stuff = ("one", "two", "three");
$stuff = @stuff;

--------------

(@stuff,@nonsense,funkshun())

--------------

@releases = (
"alpha",
"beta",
"gamma",
);

--------------

@froots = qw(
apple banana carambola
coconut guava kumquat
mandarin nectarine peach
pear persimmon plum
);

--------------

# Stat returns list value.
$modification_time = (stat($file))[9];

# SYNTAX ERROR HERE.
$modification_time = stat($file)[9]; # OOPS, FORGOT PARENS

# Find a hex digit.
$hexdigit = ('a','b','c','d','e','f')[$digit-10];

# A "reverse comma operator".
return (pop(@foo),pop(@foo))[0];

# Get multiple values as a slice.
($day, $month, $year) = (localtime)[3,4,5];

########################################################
2:Bits and Pieces/List Values and Arrays/List assignment
########################################################

($a, $b, $c) = (1, 2, 3);

($map{red}, $map{green}, $map{blue}) = (0xff0000, 0x00ff00, 0x0000ff);

--------------

($dev, $ino, undef, undef, $uid, $gid) = stat($file);

--------------

($a, $b, @rest) = split;
my ($a, $b, %rest) = @arg_list;

--------------

() = funkshun();

--------------

$x = ( ($a, $b) = (7,7,7) ); # set $x to 3, not 2
$x = ( ($a, $b) = funk() ); # set $x to funk()'s return count
$x = ( () = funk() ); # also set $x to funk()'s return count

--------------

while (($login, $password) = getpwent) {
if (crypt($login, $password) eq $password) {
print "$login has an insecure password!\n";
}
}

#####################################################
2:Bits and Pieces/List Values and Arrays/Array length
#####################################################

@days + 0; # implicitly force @days into a scalar context
scalar(@days) # explicitly force @days into a scalar context

--------------

@whatever = ();
$#whatever = -1;

--------------

scalar(@whatever) == $#whatever + 1;

########################
2:Bits and Pieces/Hashes
########################

%map = ('red',0xff0000,'green',0x00ff00,'blue',0x0000ff);

--------------

%map = (); # clear the hash first
$map{red} = 0xff0000;
$map{green} = 0x00ff00;
$map{blue} = 0x0000ff;

--------------

%map = (
red => 0xff0000,
green => 0x00ff00,
blue => 0x0000ff,
);

--------------

$rec = {
NAME => 'John Smith',
RANK => 'Captain',
SERNO => '951413',
};

--------------

$field = radio_group(
NAME => 'animals',
VALUES => ['camel', 'llama', 'ram', 'wolf'],
DEFAULT => 'camel',
LINEBREAK => 'true',
LABELS => \%animal_names,
);

###########################################
2:Bits and Pieces/Typeglobs and Filehandles
###########################################

$fh = *STDOUT;

--------------

$fh = \*STDOUT;

--------------

sub newopen {
my $path = shift;
local *FH; # not my() nor our()
open(FH, $path) or return undef;
return *FH; # not \*FH!
}
$fh = newopen('/etc/passwd');

--------------

*foo = *bar;

--------------

*foo = \$bar;

--------------

local *Here::blue = \$There::green;

###################################################################
2:Bits and Pieces/Input Operators/Command input (backtick) operator
###################################################################

$info = `finger $user`;

--------------

$perl_info = qx(ps $$); # that's Perl's $$
$shell_info = qx'ps $$'; # that's the shell's $$

#############################################################
2:Bits and Pieces/Input Operators/Line input (angle) operator
#############################################################

while (defined($_ = <STDIN>)) { print $_; } # the longest way
while ($_ = <STDIN>) { print; } # explicitly to $_
while (<STDIN>) { print; } # the short way
for (;<STDIN>;) { print; } # while loop in disguise
print $_ while defined($_ = <STDIN>); # long statement modifier
print while $_ = <STDIN>; # explicitly to $_
print while <STDIN>; # short statement modifier

--------------

while (<FH1> && <FH2>) { ... } # WRONG: discards both inputs
if (<STDIN>) { print; } # WRONG: prints old value of $_
if ($_ = <STDIN>) { print; } # suboptimal: doesn't test defined
if (defined($_ = <STDIN>)) { print; } # best

--------------

while (local $_ = <STDIN>) { print; } # use local $_

--------------

while (my $line = <STDIN>) { print $line; } # now private

--------------

$one_line = <MYFILE>; # Get first line.
@all_lines = <MYFILE>; # Get the rest of the lines.

--------------

while (<>) {
... # code for each line
}

--------------

@ARGV = ('-') unless @ARGV; # assume STDIN iff empty
while (@ARGV) {
$ARGV = shift @ARGV; # shorten @ARGV each time
if (!open(ARGV, $ARGV)) {
warn "Can't open $ARGV: $!\n";
next;
}
while (<ARGV>) {
... # code for each line
}
}

--------------

# default to README file if no args given
@ARGV = ("README") unless @ARGV;

--------------

while (@ARGV and $ARGV[0] =~ /^-/) {
$_ = shift;
last if /^--$/;
if (/^-D(.*)/) { $debug = $1 }
if (/^-v/) { $verbose++ }
... # other switches
}
while (<>) {
... # code for each line
}

--------------

$fh = \*STDIN;
$line = <$fh>;

--------------

open($fh, "<data.txt");
$line = <$fh>;

############################################################
2:Bits and Pieces/Input Operators/Filename globbing operator
############################################################

@files = <*.xml>;

--------------

@files = glob("*.xml");

--------------

while (glob "*.c") {
chmod 0644, $_;
}

--------------

while (<*.c>) {
chmod 0644, $_;
}

--------------

chmod 0644, <*.c>;

--------------

($file) = <blurch*>; # list context

--------------

$file = <blurch*>; # scalar context

--------------

@files = <$dir/*.[ch]>; # Works, but avoid.
@files = glob("$dir/*.[ch]"); # Call glob as function.
@files = glob $some_pattern; # Call glob as operator.

############################
3:Unary and Binary Operators
############################

! $x # a unary operator
$x * $y # a binary operator
$x ? $y : $z # a trinary operator
print $x, $y, $z # a list operator

--------------

2 + 3 * 4 # yields 14, not 20

--------------

2 * 3 * 4 # means (2 * 3) * 4, left associative
2 ** 3 ** 4 # means 2 ** (3 ** 4), right associative
2 != 3 != 4 # illegal, non-associative

################################################################
3:Unary and Binary Operators/Terms and List Operators (Leftward)
################################################################

chdir $foo || die; # (chdir $foo) || die
chdir($foo) || die; # (chdir $foo) || die
chdir ($foo) || die; # (chdir $foo) || die
chdir +($foo) || die; # (chdir $foo) || die

--------------

chdir $foo * 20; # chdir ($foo * 20)
chdir($foo) * 20; # (chdir $foo) * 20
chdir ($foo) * 20; # (chdir $foo) * 20
chdir +($foo) * 20; # chdir ($foo * 20)

--------------

rand 10 * 20; # rand (10 * 20)
rand(10) * 20; # (rand 10) * 20
rand (10) * 20; # (rand 10) * 20
rand +(10) * 20; # rand (10 * 20)

--------------

@ary = (1, 3, sort 4, 2);
print @ary; # prints 1324

--------------

# These evaluate exit before doing the print:
print($foo, exit); # Obviously not what you want.
print $foo, exit; # Nor this.

# These do the print before evaluating exit:
(print $foo), exit; # This is what you want.
print($foo), exit; # Or this.
print ($foo), exit; # Or even this.

--------------

print ($foo & 255) + 1, "\n"; # prints ($foo & 255)

###############################################
3:Unary and Binary Operators/The Arrow Operator
###############################################

$aref->[42] # an array dereference
$href->{"corned beef"} # a hash dereference
$sref->(1,2,3) # a subroutine dereference

--------------

$yogi = Bear->new("Yogi"); # a class method call
$yogi->swipe($picnic); # an object method call

############################################################
3:Unary and Binary Operators/Autoincrement and Autodecrement
############################################################

print ++($foo = '99'); # prints '100'
print ++($foo = 'a0'); # prints 'a1'
print ++($foo = 'Az'); # prints 'Ba'
print ++($foo = 'zz'); # prints 'aaa'

##############################################
3:Unary and Binary Operators/Binding Operators
##############################################

$string !~ /pattern/
not $string =~ /pattern/

--------------

if ( ($k,$v) = $string =~ m/(\w+)=(\w*)/ ) {
print "KEY $k VALUE $v\n";
}

#####################################################
3:Unary and Binary Operators/Multiplicative Operators
#####################################################

print '-' x 80; # print row of dashes

print "\t" x ($tab/8), ' ' x ($tab%8); # tab over

--------------

@ones = (1) x 80; # a list of 80 1's
@ones = (5) x @ones; # set all elements to 5

--------------

@keys = qw(perls before swine);
@hash{@keys} = ("") x @keys;

--------------

$hash{perls} = "";
$hash{before} = "";
$hash{swine} = "";

###############################################
3:Unary and Binary Operators/Additive Operators
###############################################

$almost = "Fred" . "Flintstone"; # returns FredFlintstone

--------------

$fullname = "$firstname $lastname";

############################################
3:Unary and Binary Operators/Shift Operators
############################################

1 << 4; # returns 16
32 >> 4; # returns 2

################################################################
3:Unary and Binary Operators/Named Unary and File Test Operators
################################################################

sleep 4 | 3;

--------------

(sleep 4) | 3;

--------------

print 4 | 3;

--------------

print (4 | 3);

--------------

next if length < 80;

--------------

next if length() < 80;
next if (length) < 80;
next if 80 > length;
next unless length >= 80;

--------------

while (<>) {
chomp;
next unless -f $_; # ignore "special" files
...
}

--------------

next unless -f $file && -T $file;

--------------

print "Can do.\n" if -r $a || -w _ || -x _;

stat($filename);
print "Readable\n" if -r _;
print "Writable\n" if -w _;
print "Executable\n" if -x _;
print "Setuid\n" if -u _;
print "Setgid\n" if -g _;
print "Sticky\n" if -k _;
print "Text\n" if -T _;
print "Binary\n" if -B _;

--------------

next unless -M $file > .5; # files older than 12 hours
&newfile if -M $file < 0; # file is newer than process
&mailwarning if int(-A) == 90; # file ($_) accessed 90 days ago today

--------------

$^T = time;

##############################################
3:Unary and Binary Operators/Bitwise Operators
##############################################

"123.45" & "234.56"

--------------

"020.44"

--------------

"123.45" & 234.56

--------------

123.45 & 234.56

--------------

123 & 234

--------------

if ( "fred" & "\1\2\3\4" ) { ... }

--------------

if ( ("fred" & "\1\2\3\4") =~ /[^\0]/ ) { ... }

######################################################################
3:Unary and Binary Operators/C-style Logical (Short Circuit) Operators
######################################################################

open(FILE, "somefile") || die "Can't open somefile: $!\n";

--------------

$home = $ENV{HOME}
|| $ENV{LOGDIR}
|| (getpwuid($<))[7]
|| die "You're homeless!\n";

--------------

@a = @b || @c; # This doesn't do the right thing
@a = scalar(@b) || @c; # because it really means this.
@a = @b ? @b : @c; # This works fine, though.

###########################################
3:Unary and Binary Operators/Range Operator
###########################################

if (101 .. 200) { print; } # print 2nd hundred lines
next line if (1 .. /^$/); # skip header lines
s/^/> / if (/^$/ .. eof()); # quote body

--------------

for (101 .. 200) { print; } # prints 101102...199200
@foo = @foo[0 .. $#foo]; # an expensive no-op
@foo = @foo[ -5 .. -1]; # slice last 5 items

--------------

@alphabet = ('A' .. 'Z');

--------------

$hexdigit = (0 .. 9, 'a' .. 'f')[$num & 15];

--------------

@z2 = ('01' .. '31'); print $z2[$mday];

--------------

@combos = ('aa' .. 'zz');

--------------

@bigcombos = ('aaaaaa' .. 'zzzzzz');

#################################################
3:Unary and Binary Operators/Conditional Operator
#################################################

$a = $ok ? $b : $c; # get a scalar
@a = $ok ? @b : @c; # get an array
$a = $ok ? @b : @c; # get a count of an array's elements

--------------

printf "I have %d camel%s.\n",
$n, $n == 1 ? "" : "s";

--------------

$leapyear =
$year % 4 == 0
? $year % 100 == 0
? $year % 400 == 0
? 1
: 0
: 1
: 0;

--------------

$leapyear =
$year % 4
? 0
: $year % 100
? 1
: $year % 400
? 0
: 1;

--------------

$leapyear =
$year % 4 ? 0 :
$year % 100 ? 1 :
$year % 400 ? 0 : 1;

--------------

printf "Yes, I like my %s book!\n",
$i18n eq "french" ? "chameau" :
$i18n eq "german" ? "Kamel" :
$i18n eq "japanese" ? "\x{99F1}\x{99DD}" :
"camel"

--------------

($a_or_b ? $a : $b) = $c; # sets either $a or $b to equal $c

--------------

$a % 2 ? $a += 10 : $a += 2 # WRONG

--------------

(($a % 2) ? ($a += 10) : $a) += 2

#################################################
3:Unary and Binary Operators/Assignment Operators
#################################################

$var[$a++] += $value; # $a is incremented once
$var[$a++] = $var[$a++] + $value; # $a is incremented twice

--------------

($tmp = $global) += $constant;

--------------

$tmp = $global + $constant;

--------------

($a += 2) *= 3;

--------------

$a += 2;
$a *= 3;

--------------

($new = $old) =~ s/foo/bar/g;

--------------

$a = $b = $c = 0;

--------------

while (($key, $value) = each %gloss) { ... }

next unless ($dev, $ino, $mode) = stat $file;

############################################
3:Unary and Binary Operators/Comma Operators
############################################

$a = (1, 3);

--------------

@a = (1, 3);

--------------

atan2(1, 3);

##########################################################
3:Unary and Binary Operators/Logical and, or, not, and xor
##########################################################

unlink "alpha", "beta", "gamma"
or gripe(), next LINE;

--------------

unlink("alpha", "beta", "gamma")
|| (gripe(), next LINE);

--------------

$xyz = $x || $y || $z;

--------------

$xyz = $x or $y or $z; # WRONG

--------------

$xyz = ( $x or $y or $z );

##########################################################
3:Unary and Binary Operators/C Operators Missing from Perl
##########################################################

$ref_to_var = \$var;

###############################################
4:Statements and Declarations/Simple Statements
###############################################

$trash->take('out') if $you_love_me;
shutup() unless $you_want_me_to_leave;

--------------

$expression++ while -e "$file$expression";
kiss('me') until $I_die;

--------------

s/java/perl/ for @resumes;
print "field: $_\n" foreach split /:/, $dataline;

--------------

do {
$line = <STDIN>;
...
} until $line eq ".\n";

#################################################
4:Statements and Declarations/Compound Statements
#################################################

unless (open(FOO, $foo)) { die "Can't open $foo: $!" }
if (!open(FOO, $foo)) { die "Can't open $foo: $!" }

die "Can't open $foo: $!" unless open(FOO, $foo);
die "Can't open $foo: $!" if !open(FOO, $foo);

open(FOO, $foo) || die "Can't open $foo: $!";
open FOO, $foo or die "Can't open $foo: $!";

--------------

chdir $dir or die "chdir $dir: $!";
open FOO, $file or die "open $file: $!";
@lines = <FOO> or die "$file is empty?";
close FOO or die "close $file: $!";

######################################################
4:Statements and Declarations/If and Unless Statements
######################################################

unless ($x == 1) ...

--------------

if ($x != 1) ...

--------------

if (!($x == 1)) ...

--------------

if ((my $color = <STDIN>) =~ /red/i) {
$value = 0xff0000;
}
elsif ($color =~ /green/i) {
$value = 0x00ff00;
}
elsif ($color =~ /blue/i) {
$value = 0x0000ff;
}
else {
warn "unknown RGB component `$color', using black instead\n";
$value = 0x000000;
}

########################################################################
4:Statements and Declarations/Loop Statements/While and Until Statements
########################################################################

while (my $line = <STDIN>) {
$line = lc $line;
}
continue {
print $line; # still visible
}
# $line now out of scope here

#######################################################
4:Statements and Declarations/Loop Statements/For Loops
#######################################################

LABEL:
for (my $i = 1; $i <= 10; $i++) {
...
}

--------------

{
my $i = 1;
LABEL:
while ($i <= 10) {
...
}
continue {
$i++;
}
}

--------------

for ($i = 0, $bit = 0; $i < 32; $i++, $bit <<= 1) {
print "Bit $i is set\n" if $mask & $bit;
}
# the values in $i and $bit persist past the loop

--------------

for (my ($i, $bit) = (0, 1); $i < 32; $i++, $bit <<= 1) {
print "Bit $i is set\n" if $mask & $bit;
}
# loop's versions of $i and $bit now out of scope

--------------

$on_a_tty = -t STDIN && -t STDOUT;
sub prompt { print "yes? " if $on_a_tty }
for ( prompt(); <STDIN>; prompt() ) {
# do something
}

--------------

for (;;) {
...
}

--------------

while (1) {
...
}

###########################################################
4:Statements and Declarations/Loop Statements/Foreach Loops
###########################################################

$sum = 0; foreach $value (@array) { $sum += $value }

for $count (10,9,8,7,6,5,4,3,2,1,'BOOM') { # do a countdown
print "$count\n"; sleep(1);
}

for (reverse 'BOOM', 1 .. 10) { # same thing
print "$_\n"; sleep(1);
}

for $field (split /:/, $data) { # any LIST expression
print "Field contains: `$field'\n";
}

foreach $key (sort keys %hash) {
print "$key => $hash{$key}\n";
}

--------------

foreach $pay (@salaries) { # grant 8% raises
$pay *= 1.08;
}

for (@christmas, @easter) { # change menu
s/ham/turkey/;
}
s/ham/turkey/ for @christmas, @easter; # same thing

for ($scalar, @array, values %hash) {
s/^\s+//; # strip leading whitespace
s/\s+$//; # strip trailing whitespace
}

--------------

for my $i (1 .. 10) { ... } # $i always lexical
for our $Tick (1 .. 10) { ... } # $Tick always global

--------------

for ($i = 0; $i < @ary1; $i++) {
for ($j = 0; $j < @ary2; $j++) {
if ($ary1[$i] > $ary2[$j]) {
last; # Can't go to outer loop. :-(
}
$ary1[$i] += $ary2[$j];
}
# this is where that last takes me
}

--------------

WID: foreach $this (@ary1) {
JET: foreach $that (@ary2) {
next WID if $this > $that;
$this += $that;
}
}

##########################################################
4:Statements and Declarations/Loop Statements/Loop Control
##########################################################

next LINE if /^#/; # discard comments

--------------

LINE: while (<STDIN>) {
last LINE if /^$/; # exit when done with mail header
...
}

--------------

LINE: while (<STDIN>) {
next LINE if /^#/; # skip comments
next LINE if /^$/; # skip blank lines
...
} continue {
$count++;
}

--------------

while (<>) {
chomp;
if (s/\\$//) {
$_ .= <>;
redo unless eof; # don't read past each file's eof
}
# now process $_
}

--------------

LINE: while (defined($line = <ARGV>)) {
chomp($line);
if ($line =~ s/\\$//) {
$line .= <ARGV>;
redo LINE unless eof(ARGV);
}
# now process $line
}

--------------

ARG: while (@ARGV && $ARGV[0] =~ s/^-(?=.)//) {
OPT: for (shift @ARGV) {
m/^$/ && do { next ARG; };
m/^-$/ && do { last ARG; };
s/^d// && do { $Debug_Level++; redo OPT; };
s/^l// && do { $Generate_Listing++; redo OPT; };
s/^i(.*)// && do { $In_Place = $1 || ".bak"; next ARG; };
say_usage("Unknown option: $_");
}
}

--------------

open FILE, $file
or warn "Can't open $file: $!\n", next FILE; # WRONG

--------------

open FILE, $file
or warn("Can't open $file: $!\n"), next FILE; # okay

--------------

unless (open FILE, $file) {
warn "Can't open $file: $!\n";
next FILE;
}

#########################################
4:Statements and Declarations/Bare Blocks
#########################################

if (/pattern/) {{
last if /alpha/;
last if /beta/;
last if /gamma/;
# do something here only if still in if()
}}

--------------

do {{
next if $x == $y;
# do something here
}} until $x++ > $z;

--------------

{
do {
last if $x = $y ** 2;
# do something here
} while $x++ <= $z;
}

--------------

DO_LAST: {
do {
DO_NEXT: {
next DO_NEXT if $x == $y;
last DO_LAST if $x = $y ** 2;
# do something here
}
} while $x++ <= $z;
}

--------------

for (;;) {
next if $x == $y;
last if $x = $y ** 2;
# do something here
last unless $x++ <= $z;
}

#########################################################
4:Statements and Declarations/Bare Blocks/Case Structures
#########################################################

SWITCH: {
if (/^abc/) { $abc = 1; last SWITCH; }
if (/^def/) { $def = 1; last SWITCH; }
if (/^xyz/) { $xyz = 1; last SWITCH; }
$nothing = 1;
}

--------------

SWITCH: {
/^abc/ && do { $abc = 1; last SWITCH; };
/^def/ && do { $def = 1; last SWITCH; };
/^xyz/ && do { $xyz = 1; last SWITCH; };
$nothing = 1;
}

--------------

SWITCH: {
/^abc/ && do {
$abc = 1;
last SWITCH;
};
/^def/ && do {
$def = 1;
last SWITCH;
};
/^xyz/ && do {
$xyz = 1;
last SWITCH;
};
$nothing = 1;
}

--------------

if (/^abc/) { $abc = 1 }
elsif (/^def/) { $def = 1 }
elsif (/^xyz/) { $xyz = 1 }
else { $nothing = 1 }

--------------

for ($very_nasty_long_name[$i++][$j++]->method()) {
/this pattern/ and do { push @flags, '-e'; last; };
/that one/ and do { push @flags, '-h'; last; };
/something else/ and do { last; };
die "unknown value: `$_'";
}

--------------

for ($user_color_preference) {
$value = /red/ ? 0xFF0000 :
/green/ ? 0x00FF00 :
/blue/ ? 0x0000FF :
0x000000 ; # black if all fail
}

--------------

%color_map = (
azure => 0xF0FFFF,
chartreuse => 0x7FFF00,
lavender => 0xE6E6FA,
magenta => 0xFF00FF,
turquoise => 0x40E0D0,
);

--------------

$value = $color_map{ lc $user_color_preference } || 0x000000;

##################################
4:Statements and Declarations/Goto
##################################

goto(("FOO", "BAR", "GLARCH")[$i]); # hope 0 <= i < 3

@loop_label = qw/FOO BAR GLARCH/;
goto $loop_label[rand @loop_label]; # random teleport

#################################################
4:Statements and Declarations/Global Declarations
#################################################

sub count (@); # Compiler now knows how to call count().
my $x; # Compiler now knows about lexical variable.
$x = count(3,2,1); # Compiler can validate function call.
sub count (@) { @_ } # Compiler now knows what count() means.

--------------

sub myname;
$me = myname $0 or die "can't get myname";

--------------

sub myname ($);
$me = myname $0 || die "can't get myname";

##############################################################################
4:Statements and Declarations/Scoped Declarations/Scoped Variable Declarations
##############################################################################

my $nose;
our $House;
local $TV_channel;

--------------

my ($nose, @eyes, %teeth);
our ($House, @Autos, %Kids);
local (*Spouse, $phone{HOME});

--------------

my ($foo) = <STDIN>;
my @array = <STDIN>;

--------------

my $foo = <STDIN>;

--------------

my $foo, $bar = 1; # WRONG

--------------

my $foo;
$bar = 1;

--------------

sub check_warehouse {
for my $widget (our @Current_Inventory) {
print "I have a $widget in stock today.\n";
}
}

###################################################################################
4:Statements and Declarations/Scoped Declarations/Lexically Scoped Variables: C<my>
###################################################################################

my $name = "fred";
my @stuff = ("car", "house", "club");
my ($vehicle, $home, $tool) = @stuff;

--------------

{
my $state = 0;

sub on { $state = 1 }
sub off { $state = 0 }
sub toggle { $state = !$state }
}

--------------

my $x = $x;

##############################################################################################
4:Statements and Declarations/Scoped Declarations/Lexically Scoped Global Declarations: C<our>
##############################################################################################

sub check_warehouse {
our @Current_Inventory;
my $widget;
foreach $widget (@Current_Inventory) {
print "I have a $widget in stock today.\n";
}
}

--------------

our $PROGRAM_NAME = "waiter";
{
our $PROGRAM_NAME = "server";
# Code called here sees "server".
...
}
# Code executed below still sees "server".

--------------

my $i = 10;
{
my $i = 99;
...
}
# Code compiled below sees outer variable.

local $PROGRAM_NAME = "waiter";
{
local $PROGRAM_NAME = "server";
# Code called here sees "server".
...
}
# Code executed below sees "waiter" again.

--------------

{
local our @Current_Inventory = qw(bananas);
check_warehouse(); # no, we haven't no bananas :-)
}

########################################################################################
4:Statements and Declarations/Scoped Declarations/Dynamically Scoped Variables: C<local>
########################################################################################

{
local $var = $newvalue;
some_func();
...
}

--------------

{
$oldvalue = $var;
$var = $newvalue;
some_func();
...
}
continue {
$var = $oldvalue;
}

--------------

# WARNING: Changes are temporary to this dynamic scope.
local $Some_Global = $Some_Global;

#####################################
4:Statements and Declarations/Pragmas
#####################################

use warnings;
use strict;
use integer;
use bytes;
use constant pi => ( 4 * atan2(1,1) );

##########################################################
4:Statements and Declarations/Pragmas/Controlling Warnings
##########################################################

use warnings; # Enable warnings from here till end of file.
...
{
no warnings; # Disable warnings through end of block.
...
}
# Warnings are automatically enabled again here.

--------------

{
local $^W = 0;
...
}

####################################################################
4:Statements and Declarations/Pragmas/Controlling the Use of Globals
####################################################################

use strict 'vars';

--------------

no strict 'vars'

##################
5:Pattern Matching
##################

match( $string, $pattern );
subst( $string, $pattern, $replacement );

##################################################
5:Pattern Matching/The Regular Expression Bestiary
##################################################

/Frodo/

--------------

/Frodo|Pippin|Merry|Sam/

--------------

/(Frodo|Drogo|Bilbo) Baggins/

--------------

/(Frod|Drog|Bilb)o Baggins/

--------------

/(bar){3}/

#############################################
5:Pattern Matching/Pattern Matching Operators
#############################################

$foo = "bar";
/$foo$/;

--------------

/bar$/;

--------------

print "matches" if $somestring =~ $somepattern;

--------------

print "matches" if $somestring =~ m/$somepattern/;

--------------

$haystack =~ m/needle/ # match a simple pattern
$haystack =~ /needle/ # same thing

$italiano =~ s/butter/olive oil/ # a healthy substitution

$rotate13 =~ tr/a-zA-Z/n-za-mN-ZA-M/ # easy encryption (to break)

--------------

/new life/ and # search in $_ and (if found)
/new civilizations/ # boldly search $_ again

s/sugar/aspartame/ # substitute a substitute into $_

tr/ATCG/TAGC/ # complement the DNA stranded in $_

--------------

"onshore" =~ s/on/off/; # WRONG: compile-time error

--------------

if ((lc $magic_hat->fetch_contents->as_string) =~ /rabbit/) {
print "Nyaa, what's up doc?\n";
}
else {
print "That trick never works!\n";
}

--------------

if ($song !~ /words/) {
print qq/"$song" appears to be a song without words.\n/;
}

--------------

$path =~ s#/tmp#/var/tmp/scratch#;

if ($dir =~ m[/bin]) {
print "No binary directories please.\n";
}

--------------

s(egg)<larva>;
s{larva}{pupa};
s[pupa]/imago/;

--------------

s (egg) <larva>;
s {larva} {pupa};
s [pupa] /imago/;

--------------

"hot cross buns" =~ /cross/;
print "Matched: <$`> $& <$'>\n"; # Matched: <hot > cross < buns>
print "Left: <$`>\n"; # Left: <hot >
print "Match: <$&>\n"; # Match: <cross>
print "Right: <$'>\n"; # Right: < buns>

--------------

$_ = "Bilbo Baggins's birthday is September 22";
/(.*)'s birthday is (.*)/;
print "Person: $1\n";
print "Date: $2\n";

###############################################################
5:Pattern Matching/Pattern Matching Operators/Pattern Modifiers
###############################################################

m/\w+:(\s+\w+)\s*\d+/; # A word, colon, space, word, space, digits.

m/\w+: (\s+ \w+) \s* \d+/x; # A word, colon, space, word, space, digits.

m{
\w+: # Match a word and a colon.
( # (begin group)
\s+ # Match one or more spaces.
\w+ # Match another word.
) # (end group)
\s* # Match zero or more spaces.
\d+ # Match some digits
}x;

--------------

# Find duplicate words in paragraphs, possibly spanning line boundaries.
# Use /x for space and comments, /i to match the both `is'
# in "Is is this ok?", and use /g to find all dups.
$/ = ""; # paragrep mode
while (<>) {
while ( m{
\b # start at a word boundary
(\w\S+) # find a wordish chunk
(
\s+ # separated by some whitespace
\1 # and that chunk again
) + # repeat ad lib
\b # until another word boundary
}xig
)
{
print "dup word '$1' at paragraph $.\n";
}
}

#########################################################################
5:Pattern Matching/Pattern Matching Operators/The m// Operator (Matching)
#########################################################################

if ($shire =~ m/Baggins/) { ... } # search for Baggins in $shire
if ($shire =~ /Baggins/) { ... } # search for Baggins in $shire

if ( m#Baggins# ) { ... } # search right here in $_
if ( /Baggins/ ) { ... } # search right here in $_

--------------

if (($key,$value) = /(\w+): (.*)/) { ... }

--------------

if (@perls = $paragraph =~ /perl/gi) {
printf "Perl mentioned %d times.\n", scalar @perls;
}

--------------

$string = "password=xyzzy verbose=9 score=0";

--------------

%hash = (password => "xyzzy", verbose => 9, score => 0);

--------------

%hash = $string =~ /(\w+)=(\w+)/g;

--------------

open DICT, "/usr/dict/words" or die "Can't open words: $!\n";
while (<DICT>) {
$first = $1 if ?(^neur.*)?;
$last = $1 if /(^neur.*)/;
}
print $first,"\n"; # prints "neurad"
print $last,"\n"; # prints "neurypnology"

##############################################################################
5:Pattern Matching/Pattern Matching Operators/The s/// Operator (Substitution)
##############################################################################

$lotr = $hobbit; # Just copy The Hobbit
$lotr =~ s/Bilbo/Frodo/g; # and write a sequel the easy way.

--------------

if ($lotr =~ s/Bilbo/Frodo/) { print "Successfully wrote sequel." }
$change_count = $lotr =~ s/Bilbo/Frodo/g;

--------------

s/revision|version|release/\u$&/g; # Use | to mean "or" in a pattern

--------------

s/version ([0-9.]+)/the $Names{$1} release/g;

--------------

s{
version
\s+
(
[0-9.]+
)
}{
$Names{$1}
? "the $Names{$1} release"
: $&
}xge;

###########################################################################################################
5:Pattern Matching/Pattern Matching Operators/The s/// Operator (Substitution)/Modifying strings en passant
###########################################################################################################

$lotr = $hobbit;
$lotr =~ s/Bilbo/Frodo/g;

--------------

($lotr = $hobbit) =~ s/Bilbo/Frodo/g;

--------------

for (@chapters) { s/Bilbo/Frodo/g } # Do substitutions chapter by chapter.
s/Bilbo/Frodo/g for @chapters; # Same thing.

--------------

@oldhues = ('bluebird', 'bluegrass', 'bluefish', 'the blues');
for (@newhues = @oldhues) { s/blue/red/ }
print "@newhues\n"; # prints: redbird redgrass redfish the reds

--------------

for ($string) {
s/^\s+//; # discard leading whitespace
s/\s+$//; # discard trailing whitespace
s/\s+/ /g; # collapse internal whitespace
}

--------------

$string = join(" ", split " ", $string);

--------------

for ($newshow = $oldshow) {
s/Fred/Homer/g;
s/Wilma/Marge/g;
s/Pebbles/Lisa/g;
s/Dino/Bart/g;
}

##################################################################################################################################
5:Pattern Matching/Pattern Matching Operators/The s/// Operator (Substitution)/When a Global Substitution Just Isn't Global Enough
##################################################################################################################################

# put commas in the right places in an integer
1 while s/(\d)(\d\d\d)(?!\d)/$1,$2/;

# expand tabs to 8-column spacing
1 while s/\t+/' ' x (length($&)*8 - length($`)%8)/e;

# remove (nested (even deeply nested (like this))) comments
1 while s/$[^()]*$//g;

# remove duplicate words (and triplicate (and quadruplicate...))
1 while s/\b(\w+) \1\b/$1/gi;

##################################################################################
5:Pattern Matching/Pattern Matching Operators/The tr/// Operator (Transliteration)
##################################################################################

$message =~ tr/A-Za-z/N-ZA-Mn-za-m/; # rot13 encryption.

--------------

tr/aeiou/!/; # change any vowel into a !
tr{/\\\r\n\b\f. }{_}; # change strange chars into an underscore

tr/A-Z/a-z/ for @ARGV; # canonicalize to lower case ASCII

$count = ($para =~ tr/\n//); # count the newlines in $para
$count = tr/0-9//; # count the digits in $_

$word =~ tr/a-zA-Z//s; # bookkeeper -> bokeper

tr/@$%*//d; # delete any of those
tr#A-Za-z0-9+/##cd; # remove non-base64 chars

# change en passant
($HOST = $host) =~ tr/a-z/A-Z/;

$pathname =~ tr/a-zA-Z/_/cs; # change non-(ASCII)alphas to single underbar

tr [\200-\377]
[\000-\177]; # strip 8th bit, bytewise

--------------

tr/AAA/XYZ/

--------------

$count = eval "tr/$oldlist/$newlist/";
die if $@; # propagates exception from illegal eval contents

#################################################
5:Pattern Matching/Metacharacters and Metasymbols
#################################################

\ | ( ) [ { ^ $ * + ? .

######################################################################
5:Pattern Matching/Metacharacters and Metasymbols/Wildcard Metasymbols
######################################################################

if ($pathname =~ /\.(.)\z/s) {
print "Ends in $1\n";
}

--------------

use utf8;
use charnames qw/:full/;
$BWV[887] = "G\N{MUSIC SHARP SIGN} minor";
($note, $black, $mode) = $BWV[887] =~ /^([A-G])(.)\s+(\S+)/;
print "That's lookin' sharp!\n" if $black eq chr(9839);

###########################################################################
5:Pattern Matching/Character Classes/Classic Perl Character Class Shortcuts
###########################################################################

if ($var =~ /\D/) { warn "contains non-digit" }
if ($var =~ /[^\w\s.]/) { warn "contains non-(word, space, dot)" }

#######################################################
5:Pattern Matching/Character Classes/Unicode Properties
#######################################################

if ($var =~ /^\p{IsAlpha}+$/) { print "all alphabetic" }
if ($var =~ s/[\p{Zl}\p{Zp}]/\n/g) { print "fixed newline wannabes" }

--------------

perl -MConfig -le 'print $Config{privlib}'

################################################################################
5:Pattern Matching/Character Classes/Unicode Properties/Unicode block properties
################################################################################

print "It's Greek to me!\n" if chr(931) =~ /\p{InGreek}/;

##############################################################################################
5:Pattern Matching/Character Classes/Unicode Properties/Defining your own character properties
##############################################################################################

sub InKana {
return <<'END';
3040 309F
30A0 30FF
END
}

--------------

sub InKana {
return <<'END';
+utf8::InHiragana
+utf8::InKatakana
END
}

--------------

sub IsKana {
return <<'END';
+utf8::InHiragana
+utf8::InKatakana
-utf8::IsCn
END
}

--------------

sub IsNotKana {
return <<'END';
!utf8::InHiragana
-utf8::InKatakana
+utf8::IsCn
END
}

##################################################################
5:Pattern Matching/Character Classes/POSIX-Style Character Classes
##################################################################

42 =~ /^[:digit:]$/ # WRONG

--------------

42 =~ /^[[:digit:]]+$/

##############################
5:Pattern Matching/Quantifiers
##############################

"exasperate" =~ /e(.*)e/ # $1 now "xasperat"

--------------

"exasperate" =~ /e(.*?)e/ # $1 now "xasp"

--------------

"exasperate" =~ /.*e(.*?)e/ # $1 now "rat"

######################################################################
5:Pattern Matching/Positions/Beginnings: The C<\A> and C<^> Assertions
######################################################################

/\Abar/ # Matches "bar" and "barstool"
/^bar/ # Matches "bar" and "barstool"
/^bar/m # Matches "bar" and "barstool" and "sand\nbar"

--------------

s/^\s+//gm; # Trim leading whitespace on each line
$total++ while /^./mg; # Count nonblank lines

###########################################################################
5:Pattern Matching/Positions/Endings: The C<\z>, C<\Z>, and C<$> Assertions
###########################################################################

/bot\z/ # Matches "robot"
/bot\Z/ # Matches "robot" and "abbot\n"
/bot$/ # Matches "robot" and "abbot\n"
/bot$/m # Matches "robot" and "abbot\n" and "robot\nrules"

/^robot$/ # Matches "robot" and "robot\n"
/^robot$/m # Matches "robot" and "robot\n" and "this\nrobot\n"
/\Arobot\Z/ # Matches "robot" and "robot\n"
/\Arobot\z/ # Matches only "robot" -- but why didn't you use eq?

--------------

s/\s*$//gm; # Trim trailing whitespace on each line in paragraph

while (/^([^:]+):\s*(.*)/gm ) { # get mail header
$headers{$1} = $2;
}

#######################################################################
5:Pattern Matching/Positions/Boundaries: The C<\b> and C<\B> Assertions
#######################################################################

/\bis\b/ # matches "what it is" and "that is it"
/\Bis\B/ # matches "thistle" and "artist"
/\bis\B/ # matches "istanbul" and "so--isn't that butter?"
/\Bis\b/ # matches "confutatis" and "metropolis near you"

#################################################
5:Pattern Matching/Positions/Progressive Matching
#################################################

$burglar = "Bilbo Baggins";
while ($burglar =~ /b/gi) {
printf "Found a B at %d\n", pos($burglar)-1;
}

$burglar = "Bilbo Baggins";
while ($burglar =~ /b/gci) { # ADD /c
printf "Found a B at %d\n", pos($burglar)-1;
}
while ($burglar =~ /i/gi) {
printf "Found an I at %d\n", pos($burglar)-1;
}

####################################################################
5:Pattern Matching/Positions/Where You Left Off: The C<\G> Assertion
####################################################################

($recipe = <<'DISH') =~ s/^\s+//gm;
Preheat oven to 451 deg. fahrenheit.
Mix 1 ml. dilithium with 3 oz. NaCl and
stir in 4 anchovies. Glaze with 1 g.
mercury. Heat for 4 hours and let cool
for 3 seconds. Serves 10 aliens.
DISH

$recipe =~ /\d+ /g;
$recipe =~ /\G(\w+)/; # $1 is now "deg"
$recipe =~ /\d+ /g;
$recipe =~ /\G(\w+)/; # $1 is now "ml"
$recipe =~ /\d+ /g;
$recipe =~ /\G(\w+)/; # $1 is now "oz"

--------------

pos($recipe) = 0; # Just to be safe, reset \G to 0
while ( $recipe =~ /(\d+) /g ) {
my $amount = $1;
if ($recipe =~ / \G (\w{0,3}) \. \s+ (\w+) /x) { # abbrev. + word
print "$amount $1 of $2\n";
} else {
$recipe =~ / \G (\w+) /x; # just a word
print "$amount $1\n";
}
}

#####################################################
5:Pattern Matching/Capturing and Clustering/Capturing
#####################################################

/(\d)(\d)/ # Match two digits, capturing them into $1 and $2
/(\d+)/ # Match one or more digits, capturing them all into $1
/(\d)+/ # Match a digit one or more times, capturing the last into $1

--------------

/\b(\w+) \1\b/i

--------------

From: gnat@perl.com
To: camelot@oreilly.com
Date: Mon, 17 Jul 2000 09:00:00 -1000
Subject: Eye of the needle

--------------

while (<>) {
/^(.*?): (.*)$/; # Pre-colon text into $1, post-colon into $2
$fields{$1} = $2;
}

--------------

s/^(\S+) (\S+)/$2 $1/; # Swap first two words

--------------

/^((\w+) (\w+))$/

--------------

($first, $last) = /^(\w+) (\w+)$/;
($full, $first, $last) = /^((\w+) (\w+))$/;

--------------

%fields = /^(.*?): (.*)$/gm;

--------------

$_ = "Speak, friend, and enter.";
m[ (<.*?>) (.*?) (</.*?>) ]x; # A tag, then chars, then an end tag
print "prematch: $`\n"; # Speak,
print "match: $&\n"; # friend
print "postmatch: $'\n"; # , and enter.
print "lastmatch: $+\n"; # 

--------------

#!/usr/bin/perl
$alphabet = "abcdefghijklmnopqrstuvwxyz";
$alphabet =~ /(hi).*(stu)/;

print "The entire match began at $-[0] and ended at $+[0]\n";
print "The first match began at $-[1] and ended at $+[1]\n";
print "The second match began at $-[2] and ended at $+[2]\n";

--------------

/$e.g. .*?$/

######################################################
5:Pattern Matching/Capturing and Clustering/Clustering
######################################################

@fields = split(/\b(?:a|b|c)\b/)

--------------

@fields = split(/\b(a|b|c)\b/)

########################################################################
5:Pattern Matching/Capturing and Clustering/Cloistered Pattern Modifiers
########################################################################

/Harry (?i:s) Truman/

--------------

/Harry (?x: [A-Z] \.? )? Truman/

--------------

/Harry (?ix: [A-Z] \.? )? Truman/

--------------

/Harry (?x-i: [A-Z] \.? )? Truman/i

--------------

/(?i)foo/ # Equivalent to /foo/i
/foo((?-i)bar)/i # "bar" must be lower case
/foo((?x-i) bar)/ # Enables /x and disables /i for "bar"

##############################
5:Pattern Matching/Alternation
##############################

/Gandalf|Saruman|Radagast/

--------------

/prob|n|r|l|ate/ # Match prob, n, r, l, or ate
/pro(b|n|r|l)ate/ # Match probate, pronate, prorate, or prolate
/pro(?:b|n|r|l)ate/ # Match probate, pronate, prorate, or prolate

--------------

/(Sam|Samwise)/

--------------

"'Sam I am,' said Samwise" =~ /(Samwise|Sam)/; # $1 eq "Sam"

--------------

"'Sam I am,' said Samwise" =~ /.*(Samwise|Sam)/; # $1 eq "Samwise"

--------------

"'Sam I am,' said Samwise" =~ /(Samwise|Sam)$/; # $1 eq "Samwise"

--------------

#!/usr/bin/perl
while (<>) {
print if /^__DATA__|^__END__/;
}

--------------

/^cat|dog|cow$/

--------------

/^(cat|dog|cow)$/

--------------

/^cat$|^dog$|^cow$/

--------------

/com(pound|)/; # Matches "compound" or "com"
/com(pound(s|)|)/; # Matches "compounds", "compound", or "com"

--------------

/com(pound)?/; # Matches "compound" or "com"
/com(pound(s?))?/; # Matches "compounds", "compound", or "com"
/com(pounds?)?/; # Same, but doesn't use $2

##############################################################
5:Pattern Matching/Staying in Control/Letting Perl Do the Work
##############################################################

/Gandalf|Saruman|Radagast/

--------------

/Gandalf/ || /Saruman/ || /Radagast/

--------------

while (<CONF>) {
next if /^#/;
next if /^\s*(#|$)/;
chomp;
munchabunch($_);
}

--------------

warn "has nondigits" if /\D/;
warn "not a natural number" unless /^\d+$/; # rejects -3
warn "not an integer" unless /^-?\d+$/; # rejects +3
warn "not an integer" unless /^[+-]?\d+$/;
warn "not a decimal number" unless /^-?\d+\.?\d*$/; # rejects .2
warn "not a decimal number" unless /^-?(?:\d+(?:\.\d*)?|\.\d+)$/;
warn "not a C float"
unless /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;

############################################################
5:Pattern Matching/Staying in Control/Variable Interpolation
############################################################

if ($num =~ /^[-+]?\d+\.?\d*$/) { ... }

--------------

$sign = '[-+]?';
$digits = '\d+';
$decimal = '\.?';
$more_digits = '\d*';
$number = "$sign$digits$decimal$more_digits";
...
if ($num =~ /^$number$/o) { ... }

--------------

chomp($answer = <STDIN>);
if ("SEND" =~ /^\Q$answer/i) { print "Action is send\n" }
elsif ("STOP" =~ /^\Q$answer/i) { print "Action is stop\n" }
elsif ("ABORT" =~ /^\Q$answer/i) { print "Action is abort\n" }
elsif ("LIST" =~ /^\Q$answer/i) { print "Action is list\n" }
elsif ("EDIT" =~ /^\Q$answer/i) { print "Action is edit\n" }

####################################################################################
5:Pattern Matching/Staying in Control/Variable Interpolation/When backslashes happen
####################################################################################

($col1, $col2) = /(.*?) \t+ (.*?)/x;

--------------

$colsep = "\t+"; # (double quotes)
($col1, $col2) = /(.*?) $colsep (.*?)/x;

--------------

$var = '\U';
/${var}frodo/;

--------------

$hobbit = 'Frodo';
$var = '$hobbit'; # (single quotes)
/$var/; # means m'$hobbit', not m'Frodo'.

--------------

#!/usr/bin/perl
$pattern = shift;
while (<>) {
print if /$pattern/o;
}

--------------

% pgrep '\t\d' *.c

--------------

% pgrep '(?i)ring' LotR*.pod

##########################################################################################
5:Pattern Matching/Staying in Control/Variable Interpolation/The qr// quote regex operator
##########################################################################################

print if /$pattern/o;

--------------

foreach $item (@data) {
foreach $patstr (@patterns) {
if ($item =~ /$patstr/) { ... }
}
}

--------------

$regex = qr/my.STRING/is;
s/$regex/something else/;

--------------

s/my.STRING/something else/is;

--------------

@regexes = ();
foreach $patstr (@patterns) {
push @regexes, qr/$patstr/;
}

--------------

@regexes = map { qr/$patstr/ } @patterns;

--------------

foreach $item (@data) {
foreach $re (@regexes) {
if ($item =~ /$re/) { ... }
}
}

--------------

$regex = qr/$pattern/;
$string =~ /foo${regex}bar/; # interpolate into larger patterns

--------------

$re = qr/my.STRING/is;
print $re; # prints (?si-xm:my.STRING)

--------------

$re = qr/$pat/is; # might escape and eat you
$re = eval { qr/$pat/is } || warn ... # caught it in an outer cage

########################################################
5:Pattern Matching/Staying in Control/The Regex Compiler
########################################################

#!/usr/bin/perl
use re "debug";
"Smeagol" =~ /^Sm(.*)g[aeiou]l$/;

##########################################################################
5:Pattern Matching/Staying in Control/The Little Engine that /Could(n't)?/
##########################################################################

/x*y*/

--------------

$a = 'nobody';
$b = 'bodysnatcher';
if ("$a $b" =~ /^(\w+)(\w+) \2(\w+)$/) {
print "$2 overlaps in $1-$2-$3\n";
}

#######################################################
5:Pattern Matching/Fancy Patterns/Lookaround Assertions
#######################################################

$_ = "Paris in THE THE THE THE spring.";

# remove duplicate words (and triplicate (and quadruplicate...))
1 while s/\b(\w+) \1\b/$1/gi;

--------------

s/ \b(\w+) \s (?= \1\b ) //gxi;

--------------

s/ \b(\w+) \s (?= \1\b (?! '\w))//xgi;

--------------

s/ \b(\w+) \s (?= \1\b (?! '\w | \s particular))//gix;

--------------

s/ \b(\w+) \s (?= \1\b (?! '\w | \s particular | \s nation))//igx;

--------------

@thatthat = qw(particular nation);
local $" = '|';
s/ \b(\w+) \s (?= \1\b (?! '\w | \s (?: @thatthat )))//xig;

--------------

s/ \b(\w+) \s (?= \1\b (?! '\w | (?<= that) \s (?: @thatthat )))//ixg;

--------------

s/(?<!c)ei/ie/g

##############################################################
5:Pattern Matching/Fancy Patterns/Non-Backtracking Subpatterns
##############################################################

$_ = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab";
/a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*[b]/;

--------------

/(?>a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*)[b]/;

--------------

#!/usr/bin/perl -00p
while ( /( (.+) ( (?<=\\) \n .* )+ ) /gx) {
print "GOT $.: $1\n\n";
}

--------------

(.+(?:(?<=\\)\n.*)+)

--------------

((?>.+)(?:(?<=\\)\n.*)+)

##########################################################################
5:Pattern Matching/Fancy Patterns/Programmatic Patterns/Generated patterns
##########################################################################

#!/usr/bin/perl
$vowels = 'aeiouy';
$cons = 'cbdfghjklmnpqrstvwxzy';
%map = (C => $cons, V => $vowels); # init map for C and V

for $class ($vowels, $cons) { # now for each type
for (split //, $class) { # get each letter of that type
$map{$_} .= $class; # and map the letter back to the type
}
}

for $char (split //, shift) { # for each letter in template word
$pat .= "[$map{$char}]"; # add appropriate character class
}

$re = qr/^${pat}$/i; # compile the pattern
print "REGEX is $re\n"; # debugging output
@ARGV = ('/usr/dict/words') # pick a default dictionary
if -t && !@ARGV;

while (<>) { # and now blaze through the input
print if /$re/; # printing any line that matches
}

################################################################################
5:Pattern Matching/Fancy Patterns/Programmatic Patterns/Substitution evaluations
################################################################################

s/(\d+)/$1 * 2/; # Replaces "42" with "42 * 2"
s/(\d+)/$1 * 2/e; # Replaces "42" with "84"

--------------

$_ = "Preheat oven to 233C.\n";
s/\b(\d+\.?\d*)C\b/int($1 * 1.8 + 32) . "F"/e; # convert to 451F

--------------

% perl -pi -e 's/^(\d+)(?=:)/100 + $1/e' filename

--------------

s/(\$\w+)/$1/eeg; # Interpolate most scalars' values

--------------

$_ = "I have 4 + 19 dollars and 8/2 cents.\n";
s{ (
\d+ \s* # find an integer
[+*/-] # and an arithmetical operator
\s* \d+ # and another integer
)
}{ $1 }eegx; # then expand $1 and run that code
print; # "I have 23 dollars and 4 cents."

##################################################################################
5:Pattern Matching/Fancy Patterns/Programmatic Patterns/Match-time code evaluation
##################################################################################

"glyph" =~ /.+ (?{ print "hi" }) ./x; # Prints "hi" twice.

--------------

$_ = 'lothlorien';
m/ (?{ $i = 0 }) # Set $i to 0
(. (?{ $i++ }) )* # Update $i, even after backtracking
lori # Forces a backtrack
/x;

--------------

$_ = 'lothlorien';
m/ (?{ $i = 0 })
(. (?{ local $i = $i + 1; }) )* # Update $i, backtracking-safe.
lori
(?{ $result = $i }) # Copy to non-localized location.
/x;

--------------

"glyph" =~ /.+(?(?{ $foo{bar} gt "symbol" }).|signet)./;

--------------

"glyph" =~ m{
.+ # some anythings
(?(?{ # if
$foo{bar} gt "symbol" # this is true
})
. # match another anything
| # else
signet # match signet
)
. # and one more anything
}x;

--------------

/(.*?) (?{length($1) < 3 && warn}) $suffix/; # Error without use re 'eval'

--------------

/foo${pat}bar/

--------------

"abcdef" =~ / .+ (?{print "Matched so far: $&\n"}) bcdef $/x;

########################################################################################
5:Pattern Matching/Fancy Patterns/Programmatic Patterns/Match-time pattern interpolation
########################################################################################

/\w (??{ if ($threshold > 1) { "red" } else { "blue" } }) \d/x;

--------------

/^ (.+) .? (??{quotemeta reverse $1}) $/xi;

--------------

$text =~ /( $+ ) (.*?) (??{ '$' x length $1 })/x;

--------------

$np = qr{
$
(?:
(?> [^()]+ ) # Non-parens without backtracking
|
(??{ $np }) # Group with matching parens
)*
$
}x;

--------------

$funpat = qr/\w+$np/;
'myfunfun(1,(2*(3+4)),5)' =~ /^$funpat$/; # Matches!

#################################################################################
5:Pattern Matching/Fancy Patterns/Programmatic Patterns/Conditional interpolation
#################################################################################

#!/usr/bin/perl
$x = 'Perl is free.';
$y = 'ManagerWare costs $99.95.';

foreach ($x, $y) {
/^(\w+) (?:is|(costs)) (?(2)(\$\d+)|\w+)/; # Either (\$\d+) or \w+
if ($3) {
print "$1 costs money.\n"; # ManagerWare costs money.
} else {
print "$1 doesn't cost money.\n"; # Perl doesn't cost money.
}
}

--------------

/[ATGC]+(?(?<=AA)G|C)$/;

##############################################################
5:Pattern Matching/Fancy Patterns/Defining Your Own Assertions
##############################################################

use Tagger;
$_ = 'camel';
print "Tagged camel found" if /\tag\w+\tag/;

--------------

package Tagger;
use overload;

sub import { overload::constant 'qr' => \&convert }

sub convert {
my $re = shift;
$re =~ s/ \\tag /<.*?>/xg;
$re =~ s/ \\w /[A-Za-z]/xg;
return $re;
}

1;

--------------

$re = '\tag\w+\tag'; # This string begins with \t, a tab
print if /$re/; # Matches a tab, followed by an "a"...

--------------

$re = '\tag\w+\tag'; # This string begins with \t, a tab
$re = Tagger::convert $re; # expand \tag and \w
print if /$re/; # $re becomes <.*?>[A-Za-z]+<.*?>

#######################
6:Subroutines/Semantics
#######################

sub razzle {
print "Ok, you've been razzled.\n";
}

--------------

razzle();

###################################################
6:Subroutines/Semantics/Tricks with Parameter Lists
###################################################

sub maysetenv {
my ($key, $value) = @_;
$ENV{$key} = $value unless $ENV{$key};
}

--------------

sub max {
my $max = shift(@_);
for my $item (@_) {
$max = $item if $max < $item;
}
return $max;
}

$bestday = max($mon,$tue,$wed,$thu,$fri);

--------------

sub configuration {
my %options = @_;
print "Maximum verbosity.\n" if $options{VERBOSE} == 9;
}

configuration(PASSWORD => "xyzzy", VERBOSE => 9, SCORE => 0);

--------------

upcase_in($v1, $v2); # this changes $v1 and $v2
sub upcase_in {
for (@_) { tr/a-z/A-Z/ }
}

--------------

upcase_in("frederick");

--------------

($v3, $v4) = upcase($v1, $v2);
sub upcase {
my @parms = @_;
for (@parms) { tr/a-z/A-Z/ }
# Check whether we were called in list context.
return wantarray ? @parms : $parms[0];
}

--------------

@newlist = upcase(@list1, @list2);
@newlist = upcase( split /:/, $var );

--------------

(@a, @b) = upcase(@list1, @list2); # WRONG

#########################################
6:Subroutines/Semantics/Error Indications
#########################################

if ($something_went_awry) {
return if defined wantarray; # good, not void context.
die "Pay attention to my error, you danglesocket!!!\n";
}

######################################
6:Subroutines/Semantics/Scoping Issues
######################################

&foo(1,2,3); # pass three arguments
foo(1,2,3); # the same

foo(); # pass a null list
&foo(); # the same

&foo; # foo() gets current args, like foo(@_), but faster!
foo; # like foo() if sub foo predeclared, else bareword "foo"

--------------

# top of file
my $x = 10; # declare and initialize variable
sub bumpx { $x++ } # function can see outer lexical variable

--------------

{
my $counter = 0;
sub next_counter { return ++$counter }
sub prev_counter { return --$counter }
}

--------------

BEGIN {
my @scale = ('A' .. 'G');
my $note = -1;
sub next_pitch { return $scale[ ($note += 1) %= @scale ] };
}

################################
6:Subroutines/Passing References
################################

$total = sum ( \@a );

sub sum {
my ($aref) = @_;
my ($total) = 0;
foreach (@$aref) { $total += $_ }
return $total;
}

--------------

@tailings = popmany ( \@a, \@b, \@c, \@d );

sub popmany {
my @retlist = ();
for my $aref (@_) {
push @retlist, pop @$aref;
}
return @retlist;
}

--------------

@common = inter( \%foo, \%bar, \%joe );
sub inter {
my %seen;
for my $href (@_) {
while (my $k = each %$href ) {
$seen{$k}++;
}
}
return grep { $seen{$_} == @_ } keys %seen;
}

--------------

(@a, @b) = func(@c, @d);

--------------

(%a, %b) = func(%c, %d);

--------------

($aref, $bref) = func(\@c, \@d);
print "@$aref has more than @$bref\n";
sub func {
my ($cref, $dref) = @_;
if (@$cref > @$dref) {
return ($cref, $dref);
} else {
return ($dref, $cref);
}
}

########################
6:Subroutines/Prototypes
########################

sub mypush (\@@);

--------------

use Symbol 'qualify_to_ref';

sub foo (*) {
my $fh = qualify_to_ref(shift, caller);
...
}

--------------

mytime +2;

--------------

sub try (&$) {
my ($try, $catch) = @_;
eval { &$try };
if ($@) {
local $_ = $@;
&$catch;
}
}
sub catch (&) { $_[0] }

try {
die "phooey";
} # not the end of the function call!
catch {
/phooey/ and print "unphooey\n";
};

--------------

sub mygrep (&@) {
my $coderef = shift;
my @result;
foreach $_ (@_) {
push(@result, $_) if &$coderef;
}
return @result;
}

####################################################
6:Subroutines/Prototypes/Inlining Constant Functions
####################################################

sub pi () { 3.14159 } # Not exact, but close.
sub PI () { 4 * atan2(1, 1) } # As good as it gets

--------------

sub FLAG_FOO () { 1 << 8 }
sub FLAG_BAR () { 1 << 9 }
sub FLAG_MASK () { FLAG_FOO | FLAG_BAR }

sub OPT_GLARCH () { (0x1B58 & FLAG_MASK) == 0 }
sub GLARCH_VAL () {
if (OPT_GLARCH) { return 23 }
else { return 42 }
}

sub N () { int(GLARCH_VAL) / 3 }
BEGIN { # compiler runs this block at compile time
my $prod = 1; # persistent, private variable
for (1 .. N) { $prod *= $_ }
sub NFACT () { $prod }
}

--------------

sub not_inlined () {
return 23 || $$;
}

#############################################
6:Subroutines/Prototypes/Care with Prototypes
#############################################

sub func ($) {
my $n = shift;
print "you gave me $n\n";
}

--------------

func @foo; # counts @foo elements
func split /:/; # counts number of fields returned
func "a", "b", "c"; # passes "a" only, discards "b" and "c"
func("a", "b", "c"); # suddenly, a compiler error!

--------------

sub func (\$) {
my $nref = shift;
print "you gave me $$nref\n";
}

--------------

func @foo; # compiler error, saw @, want $
func split/:/; # compiler error, saw function, want $
func $s; # this one is ok -- got real $ symbol
func $a[3]; # and this one
func $h{stuff}[-1]; # or even this
func 2+5; # scalar expr still a compiler error
func ${ \(2+5) }; # ok, but is the cure worse than the disease?

##########################################################################
6:Subroutines/Subroutine Attributes/The C<locked> and C<method> Attributes
##########################################################################

# Only one thread is allowed into this function.
sub afunc : locked { ... }

# Only one thread is allowed into this function on a given object.
sub afunc : locked method { ... }

--------------

sub afunc : method { ... }

--------------

sub fnord (&\%) : switch(10,foo(7,3)) : expensive;
sub plugh () : Ugly('\(") :Bad;
sub xyzzy : _5x5 { ... }

--------------

sub fnord : switch(10,foo(); # ()-string not balanced
sub snoid : Ugly('('); # ()-string not balanced
sub xyzzy : 5x5; # "5x5" not a valid identifier
sub plugh : Y2::north; # "Y2::north" not a simple identifier
sub snurt : foo + bar; # "+" not a colon or space

###########################################################
6:Subroutines/Subroutine Attributes/The C<lvalue> attribute
###########################################################

my $val;
sub canmod : lvalue {
$val;
}
sub nomod {
$val;
}

canmod() = 5; # Assigns to $val.
nomod() = 5; # ERROR

--------------

canmod $x = 5; # assigns 5 to $x first!
canmod 42 = 5; # can't change a constant; compile-time error
canmod($x) = 5; # this is ok
canmod(42) = 5; # and so is this

--------------

canmod = 5;

--------------

$obj->canmod = 5;

--------------

data(2,3) = get_data(3,4);

--------------

(data(2,3)) = get_data(3,4);

--------------

(data(2),data(3)) = get_data(3,4);

#########
7:Formats
#########

$value =~ tr/\n\t\f/ /;

--------------

# a report on the /etc/passwd file
format STDOUT_TOP =
Passwd File
Name Login Office Uid Gid Home
------------------------------------------------------------------
.
format STDOUT =
@<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<<
$name, $login, $office,$uid,$gid, $home
.

# a report from a bug report form
format STDOUT_TOP =
Bug Reports
@<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>>
$system, $%, $date
------------------------------------------------------------------
.
format STDOUT =
Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$subject
Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$index, $description
Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$priority, $date, $description
From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$from, $description
Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$programmer, $description
~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$description
~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$description
~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$description
~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$description
~ ^<<<<<<<<<<<<<<<<<<<<<<<...
$description
.

###########################

7:Formats//Format Variables

###########################

select((select(OUTF),

$~ = "My_Other_Format",

$^ = "My_Top_Format"

)[0]);

--------------

$ofh = select(OUTF);

$~ = "My_Other_Format";

$^ = "My_Top_Format";

select($ofh);

--------------

use English;

$ofh = select(OUTF);

$FORMAT_NAME = "My_Other_Format";

$FORMAT_TOP_NAME = "My_Top_Format";

select($ofh);

--------------

use FileHandle;

OUTF->format_name("My_Other_Format");

OUTF->format_top_name("My_Top_Format");

--------------

format Ident =

@<<<<<<<<<<<<<<<

commify($n)

--------------

format Ident =

I have an @ here.

"@"

--------------

format Ident =

@||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

"Some text line"

--------------

$format = "format STDOUT = \n"

. '^' . '<' x $cols . "\n"

. '$entry' . "\n"

. "\t^" . "<" x ($cols-8) . "~~\n"

. '$entry' . "\n"

. ".\n";

print $format if $Debugging;

eval $format;

die $@ if $@;

--------------

format STDOUT =

^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

$entry

^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~

$entry

--------------

format =

^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~

$/ = "";

while (<>) {

s/\s*\n\s*/ /g;

write;

}

#########################################

7:Formats//Accessing Formatting Internals

#########################################

$str = formline <<'END', 1,2,3;

@<<< @||| @>>>

END

print "Wow, I just stored `$^A' in the accumulator!\n";

--------------

use Carp;

sub swrite {

croak "usage: swrite PICTURE ARGS" unless @_;

my $format = shift;

$^A = "";

formline($format, @_);

return $^A;

}

$string = swrite(<<'END', 1, 2, 3);

Check me out

@<<< @||| @>>>

END

print $string;

--------------

use FileHandle;

STDOUT->formline("^" . ("<" x 72) . "~~\n", $long_text);

############

8:References

############

@john = (47, "brown", 186);

@mary = (23, "hazel", 128);

@bill = (35, "blue", 157);

--------------

@vitals = ('john', 'mary', 'bill');

#######################################################

8:References/Creating References/The Backslash Operator

#######################################################

$scalarref = \$foo;

$constref = \186_282.42;

$arrayref = \@ARGV;

$hashref = \%ENV;

$coderef = \&handler;

$globref = \*STDOUT;

############################################################################

8:References/Creating References/Anonymous Data/The anonymous array composer

############################################################################

$arrayref = [1, 2, ['a', 'b', 'c', 'd']];

--------------

$table = [ [ "john", 47, "brown", 186],

[ "mary", 23, "hazel", 128],

[ "bill", 35, "blue", 157] ];

###########################################################################

8:References/Creating References/Anonymous Data/The anonymous hash composer

###########################################################################

$hashref = {

'Adam' => 'Eve',

'Clyde' => $bonnie,

'Antony' => 'Cleo' . 'patra',

};

--------------

$table = {

"john" => [ 47, "brown", 186 ],

"mary" => [ 23, "hazel", 128 ],

"bill" => [ 35, "blue", 157 ],

};

--------------

$table = {

"john" => { age => 47,

eyes => "brown",

weight => 186,

"mary" => { age => 23,

eyes => "hazel",

weight => 128,

"bill" => { age => 35,

eyes => "blue",

weight => 157,

};

--------------

sub hashem { { @_ } } # Silently WRONG -- returns @_.

sub hashem { +{ @_ } } # Ok.

sub hashem { return { @_ } } # Ok.

#################################################################################

8:References/Creating References/Anonymous Data/The anonymous subroutine composer

#################################################################################

$coderef = sub { print "Boink!\n" }; # Now &$coderef prints "Boink!"

####################################################

8:References/Creating References/Object Constructors

####################################################

$objref = Doggie::->new(Tail => 'short', Ears => 'long'); #1

$objref = new Doggie:: Tail => 'short', Ears => 'long'; #2

$objref = Doggie->new(Tail => 'short', Ears => 'long'); #3

$objref = new Doggie Tail => 'short', Ears => 'long'; #4

##################################################

8:References/Creating References/Handle References

##################################################

splutter(\*STDOUT);

sub splutter {

my $fh = shift;

print $fh "her um well a hmmm\n";

}

$rec = get_rec(\*STDIN);

sub get_rec {

my $fh = shift;

return scalar <$fh>;

}

--------------

for $file (@names) {

local *FH;

open(*FH, $file) || next;

$handle{$file} = *FH;

}

--------------

for $file (@names) {

my $fh;

open($fh, $file) || next;

$handle{$file} = $fh;

}

########################################################

8:References/Creating References/Symbol Table References

########################################################

$scalarref = *foo{SCALAR}; # Same as \$foo

$arrayref = *ARGV{ARRAY}; # Same as \@ARGV

$hashref = *ENV{HASH}; # Same as \%ENV

$coderef = *handler{CODE}; # Same as \&handler

$globref = *foo{GLOB}; # Same as \*foo

$ioref = *STDIN{IO}; # Er...

--------------

splutter(*STDOUT);

splutter(*STDOUT{IO});

sub splutter {

my $fh = shift;

print $fh "her um well a hmmm\n";

}

######################################################################

8:References/Using Hard References/Using a Variable as a Variable Name

######################################################################

$foo = "three humps";

$scalarref = \$foo; # $scalarref is now a reference to $foo

$camel_model = $$scalarref; # $camel_model is now "three humps"

--------------

$bar = $$scalarref;

push(@$arrayref, $filename);

$$arrayref[0] = "January"; # Set the first element of @$arrayref

@$arrayref[4..6] = qw/May June July/; # Set several elements of @$arrayref

%$hashref = (KEY => "RING", BIRD => "SING"); # Initialize whole hash

$$hashref{KEY} = "VALUE"; # Set one key/value pair

@$hashref{"KEY1","KEY2"} = ("VAL1","VAL2"); # Set several pairs

&$coderef(1,2,3);

print $handleref "output\n";

--------------

$refrefref = \\\"howdy";

print $$$$refrefref;

######################################################################

8:References/Using Hard References/Using a BLOCK as a Variable Name

######################################################################

$bar = ${$scalarref};

push(@{$arrayref}, $filename);

${$arrayref}[0] = "January";

@{$arrayref}[4..6] = qw/May June July/;

${$hashref}{"KEY"} = "VALUE";

@{$hashref}{"KEY1","KEY2"} = ("VAL1","VAL2");

&{$coderef}(1,2,3);

--------------

$refrefref = \\\"howdy";

print ${${${$refrefref}}};

--------------

&{ $dispatch{$index} }(1, 2, 3);

###########################################################

8:References/Using Hard References/Using the Arrow Operator

###########################################################

$ $arrayref [2] = "Dorian"; #1

${ $arrayref }[2] = "Dorian"; #2

$arrayref->[2] = "Dorian"; #3

$ $hashref {KEY} = "F#major"; #1

${ $hashref }{KEY} = "F#major"; #2

$hashref->{KEY} = "F#major"; #3

& $coderef (Presto => 192); #1

&{ $coderef }(Presto => 192); #2

$coderef->(Presto => 192); #3

--------------

print $array[3]->{"English"}->[0];

--------------

$array[3]->{"English"}->[0] = "January";

--------------

$dispatch{$index}(1, 2, 3);

$array[3]{"English"}[0] = "January";

--------------

$answer[$x][$y][$z] += 42;

--------------

$listref->[2][2] = "hello"; # Pretty clear

$$listref[2][2] = "hello"; # A bit confusing

--------------

$listref[2]->[$greeting] = "hello";

###############################################

8:References/Using Hard References/Pseudohashes

###############################################

$john = [ {age => 1, eyes => 2, weight => 3}, 47, "brown", 186 ];

--------------

$john->{weight} # Treats $john as a hashref

$john->[3] # Treats $john as an arrayref

--------------

$john->[0]{height} = 4; # height is to be element 4

$john->{height} = "tall"; # Or $john->[4] = "tall"

--------------

delete $john->[0]{height}; # Deletes from the underlying hash only

$john->{height}; # This now raises an exception

$john->[4]; # Still prints "tall"

--------------

use fields;

$ph = fields::phash(age => 47, eyes => "brown", weight => 186);

print $ph->{age};

--------------

use fields;

$ph= fields::phash([qw(age eyes brown)], [47]);

$ph->{eyes} = undef;

print exists $ph->{age}; # True, 'age' was set in declaration.

print exists $ph->{weight}; # False, 'weight' has not been used.

print exists $ph->{eyes}; # True, your 'eyes' have been touched.

--------------

print exists $ph->[0]{age}; # True, 'page' is a valid field

print exists $ph->[0]{name}; # False, 'name' can't be used

--------------

print delete $ph->{age}; # Removes and returns $ph->[1], 47

print exists $ph->{age}; # Now false

print exists $ph->[0]{age}; # True, 'age' key still usable

print delete $ph->[0]{age}; # Now 'age' key is gone

print $ph->{age}; # Run-time exception

###############################################################################

8:References/Using Hard References/Other Tricks You Can Do with Hard References

###############################################################################

@reflist = (\$s, \@a, \%h, \&f); # List of four references

@reflist = \($s, @a %h, &f); # Same thing

--------------

@reflist = \(@x); # Interpolate array, then get refs

@reflist = map { \$_ } @x; # Same thing

--------------

@reflist = \(@x, (@y)); # But only single aggregates expand

@reflist = (\@x, map { \$_ } @y); # Same thing

--------------

@envrefs = \@ENV{'HOME', 'TERM'}; # Backslashing a slice

@envrefs = \( $ENV{HOME}, $ENV{TERM} ); # Backslashing a list

@envrefs = ( \$ENV{HOME}, \$ENV{TERM} ); # A list of two references

--------------

@reflist = \fx();

@reflist = map { \$_ } fx(); # Same thing

@reflist = \( fx(), fy(), fz() );

@reflist = ( \fx(), \fy(), \fz() ); # Same thing

@reflist = map { \$_ } fx(), fy(), fz(); # Same thing

--------------

@reflist = \localtime(); # Ref to each of nine time elements

$lastref = \localtime(); # Ref to whether it's daylight savings time

--------------

$dateref = \scalar localtime(); # \"Sat Jul 16 11:42:18 2000"

--------------

sub sum {

my $arrayref = shift;

warn "Not an array reference" if ref($arrayref) ne "ARRAY";

return eval join("+", @$arrayref);

}

--------------

print "My sub returned @{[ mysub(1,2,3) ]} that time.\n";

--------------

print "We need @{ [$n + 5] } widgets!\n";

--------------

print "mysub returns @{ [scalar mysub(1,2,3)] } now.\n";

###########################################

8:References/Using Hard References/Closures

###########################################

{

my $critter = "camel";

$critterref = \$critter;

}

--------------

{

my $critter = "camel";

$critterref = sub { return $critter };

}

--------------

sub make_saying {

my $salute = shift;

my $newfunc = sub {

my $target = shift;

print "$salute, $target!\n";

};

return $newfunc; # Return a closure

}

$f = make_saying("Howdy"); # Create a closure

$g = make_saying("Greetings"); # Create another closure

# Time passes...

$f->("world");

$g->("earthlings");

--------------

sub get_method_ref {

my ($self, $methodname) = @_;

my $methref = sub {

# the @_ below is not the same as the one above!

return $self->$methodname(@_);

};

return $methref;

}

my $dog = new Doggie::

Name => "Lucky",

Legs => 3,

Tail => "clipped";

our $wagger = get_method_ref($dog, 'wag');

$wagger->("tail"); # Calls $dog->wag('tail').

##########################################################################

8:References/Using Hard References/Closures/Closures as function templates

##########################################################################

print "Be ", red("careful"), "with that ", green("light"), "!!!";

--------------

@colors = qw(red blue green yellow orange purple violet);

for my $name (@colors) {

no strict 'refs'; # Allow symbolic references

*$name = *{uc $name} = sub { "@_" };

}

--------------

*$name = sub ($) { "$_[0]" };

##############################################################

8:References/Using Hard References/Closures/Nested subroutines

##############################################################

sub outer {

my $x = $_[0] + 35;

local *inner = sub { return $x * 19 };

return $x + inner();

}

--------------

sub outer {

my $x = $_[0] + 35;

my $inner = sub { return $x * 19 };

return $x + $inner->();

}

################################

8:References/Symbolic References

################################

$name = "bam";

$$name = 1; # Sets $bam

$name->[0] = 4; # Sets the first element of @bam

$name->{X} = "Y"; # Sets the X element of %bam to Y

@$name = (); # Clears @bam

keys %$name; # Yields the keys of %bam

&$name; # Calls &bam

--------------

use strict 'refs';

--------------

no strict 'refs';

--------------

${identifier}; # Same as $identifier.

${"identifier"}; # Also $identifier, but a symbolic reference.

--------------

our $value = "global";

{

my $value = "private";

print "Inside, mine is ${value}, ";

print "but ours is ${'value'}.\n";

}

print "Outside, ${value} is again ${'value'}.\n";

##########################################

8:References/Braces, Brackets, and Quoting

##########################################

$push = "pop on ";

print "${push}over";

--------------

print ${push} . 'over';

--------------

print ${ push } . 'over';

--------------

$hash{ "aaa" }{ "bbb" }{ "ccc" }

--------------

$hash{ aaa }{ bbb }{ ccc }

--------------

$hash{aaa}{bbb}{ccc}

--------------

$hash{ shift }

--------------

$hash{ shift() }

$hash{ +shift }

$hash{ shift @_ }

#############################################################################

8:References/Braces, Brackets, and Quoting/References Don't Work as Hash Keys

#############################################################################

$x{ \$a } = $a;

($key, $value) = each %x;

print $$key; # WRONG

--------------

$r = \@a;

$x{ $r } = $r;

--------------

use Tie::RefHash;

tie my %h, 'Tie::RefHash';

%h = (

["this", "here"] => "at home",

["that", "there"] => "elsewhere",

);

while ( my($keyref, $value) = each %h ) {

print "@$keyref is $value\n";

}

#######################################################################################################

8:References/Braces, Brackets, and Quoting/Garbage Collection, Circular References, and Weak References

#######################################################################################################

{ # make $a and $b point to each other

my ($a, $b);

$a = \$b;

$b = \$a;

}

--------------

{ # make $a point to itself

my $a;

$a = \$a;

}

#################################################################################################################

9:Data Structures/A Brief Tutorial: Manipulating Arrays of Arrays/Creating and Accessing a Two-Dimensional Array

#################################################################################################################

# Assign a list of array references to an array.

@AoA = (

[ "fred", "barney" ],

[ "george", "jane", "elroy" ],

[ "homer", "marge", "bart" ],

);

print $AoA[2][1]; # prints "marge"

--------------

# Create an reference to an array of array references.

$ref_to_AoA = [

[ "fred", "barney", "pebbles", "bamm bamm", "dino", ],

[ "homer", "bart", "marge", "maggie", ],

[ "george", "jane", "elroy", "judy", ],

];

print $ref_to_AoA->[2][3]; # prints "judy"

--------------

$AoA[2][3]

$ref_to_AoA->[2][3]

--------------

$AoA[2]->[3]

$ref_to_AoA->[2]->[3]

--------------

$AoA[0][-2]

###################################################################################

9:Data Structures/A Brief Tutorial: Manipulating Arrays of Arrays/Growing Your Own

###################################################################################

while (<>) {

@tmp = split; # Split elements into an array.

push @AoA, [ @tmp ]; # Add an anonymous array reference to @AoA.

}

--------------

while (<>) {

push @AoA, [ split ];

}

--------------

while (<>) {

push @$ref_to_AoA, [ split ];

}

--------------

for $x (0 .. 9) { # For each row...

for $y (0 .. 9) { # For each column...

$AoA[$x][$y] = func($x, $y); # ...set that cell

}

for $x ( 0..9 ) { # For each row...

$ref_to_AoA->[$x][3] = func2($x); # ...set the fourth column

}

--------------

# Append new columns to an existing row.

push @{ $AoA[0] }, "wilma", "betty";

--------------

push $AoA[0], "wilma", "betty"; # WRONG!

######################################################################################

9:Data Structures/A Brief Tutorial: Manipulating Arrays of Arrays/Access and Printing

######################################################################################

print $AoA[3][2];

--------------

print @AoA; # WRONG

--------------

for $row ( @AoA ) {

print "@$row\n";

}

--------------

for $i ( 0 .. $#AoA ) {

print "row $i is: @{$AoA[$i]}\n";

}

--------------

for $i ( 0 .. $#AoA ) {

for $j ( 0 .. $#{$AoA[$i]} ) {

print "element $i $j is $AoA[$i][$j]\n";

}

--------------

for $i ( 0 .. $#AoA ) {

$row = $AoA[$i];

for $j ( 0 .. $#{$row} ) {

print "element $i $j is $row->[$j]\n";

}

#########################################################################

9:Data Structures/A Brief Tutorial: Manipulating Arrays of Arrays/Slices

#########################################################################

@part = ();

for ($y = 7; $y < 13; $y++) {

push @part, $AoA[4][$y];

}

--------------

@part = @{ $AoA[4] } [ 7..12 ];

--------------

@newAoA = ();

for ($startx = $x = 4; $x <= 8; $x++) {

for ($starty = $y = 7; $y <= 12; $y++) {

$newAoA[$x - $startx][$y - $starty] = $AoA[$x][$y];

}

--------------

for ($x = 4; $x <= 8; $x++) {

push @newAoA, [ @{ $AoA[$x] } [ 7..12 ] ];

}

##################################################################################

9:Data Structures/A Brief Tutorial: Manipulating Arrays of Arrays/Common Mistakes

##################################################################################

@AoA = ( [2, 3], [4, 5, 7], [0] );

print "@AoA";

--------------

print $AoA[1][2];

--------------

for $i (1..10) {

@array = somefunc($i);

$AoA[$i] = @array; # WRONG!

}

--------------

for $i (1..10) {

@array = somefunc($i);

$AoA[$i] = \@array; # WRONG AGAIN!

}

--------------

for $i (1..10) {

@array = somefunc($i);

$AoA[$i] = [ @array ]; # RIGHT!

}

--------------

for $i (1..10) {

@array = somefunc($i);

@{$AoA[$i]} = @array;

}

--------------

$AoA[3] = \@original_array;

--------------

@{$AoA[3]} = @array;

--------------

for $i (1..10) {

my @array = somefunc($i);

$AoA[$i] = \@array;

}

--------------

for $i (1..10) {

$AoA[$i] = [ somefunc($i) ];

}

--------------

$AoA[$i] = [ @array ]; # Safest, sometimes fastest

$AoA[$i] = \@array; # Fast but risky, depends on my-ness of array

@{ $AoA[$i] } = @array; # Too tricky for most uses

##################################################################

9:Data Structures/Hashes of Arrays/Composition of a Hash of Arrays

##################################################################

# We customarily omit quotes when the keys are identifiers.

%HoA = (

flintstones => [ "fred", "barney" ],

jetsons => [ "george", "jane", "elroy" ],

simpsons => [ "homer", "marge", "bart" ],

);

--------------

$HoA{teletubbies} = [ "tinky winky", "dipsy", "laa-laa", "po" ];

#################################################################

9:Data Structures/Hashes of Arrays/Generation of a Hash of Arrays

#################################################################

while ( <> ) {

next unless s/^(.*?):\s*//;

$HoA{$1} = [ split ];

}

while ( $line = <> ) {

($who, $rest) = split /:\s*/, $line, 2;

@fields = split ' ', $rest;

$HoA{$who} = [ @fields ];

}

--------------

for $group ( "simpsons", "jetsons", "flintstones" ) {

$HoA{$group} = [ get_family($group) ];

}

for $group ( "simpsons", "jetsons", "flintstones" ) {

@members = get_family($group);

$HoA{$group} = [ @members ];

}

--------------

push @{ $HoA{flintstones} }, "wilma", "pebbles";

##########################################################################

9:Data Structures/Hashes of Arrays/Access and Printing of a Hash of Arrays

##########################################################################

$HoA{flintstones}[0] = "Fred";

--------------

$HoA{simpsons}[1] =~ s/(\w)/\u$1/;

--------------

for $family ( keys %HoA ) {

print "$family: @{ $HoA{$family} }\n";

}

--------------

for $family ( keys %HoA ) {

print "$family: ";

for $i ( 0 .. $#{ $HoA{$family} } ) {

print " $i = $HoA{$family}[$i]";

}

print "\n";

}

--------------

for $family ( sort { @{$HoA{$b}} <=> @{$HoA{$a}} } keys %HoA ) {

print "$family: @{ $HoA{$family} }\n"

}

--------------

# Print the whole thing sorted by number of members and name.

for $family ( sort { @{$HoA{$b}} <=> @{$HoA{$a}} } keys %HoA ) {

print "$family: ", join(", ", sort @{ $HoA{$family} }), "\n";

}

####################################################################

9:Data Structures/Arrays of Hashes/Composition of an Array of Hashes

####################################################################

@AoH = (

{

husband => "barney",

wife => "betty",

son => "bamm bamm",

{

husband => "george",

wife => "jane",

son => "elroy",

{

husband => "homer",

wife => "marge",

son => "bart",

);

--------------

push @AoH, { husband => "fred", wife => "wilma", son => "junior" };

###################################################################

9:Data Structures/Arrays of Hashes/Generation of an Array of Hashes

###################################################################

while ( <> ) {

$rec = {};

for $field ( split ) {

($key, $value) = split /=/, $field;

$rec->{$key} = $value;

}

push @AoH, $rec;

}

while ( <> ) {

push @AoH, { split /[\s=]+/ };

}

--------------

while ( @fields = get_next_pair() ) {

push @AoH, { @fields };

}

while (<>) {

push @AoH, { get_next_pair($_) };

}

--------------

$AoH[0]{pet} = "dino";

$AoH[2]{pet} = "santa's little helper";

############################################################################

9:Data Structures/Arrays of Hashes/Access and Printing of an Array of Hashes

############################################################################

$AoH[0]{husband} = "fred";

--------------

$AoH[1]{husband} =~ s/(\w)/\u$1/;

--------------

for $href ( @AoH ) {

print "{ ";

for $role ( keys %$href ) {

print "$role=$href->{$role} ";

}

print "}\n";

}

--------------

for $i ( 0 .. $#AoH ) {

print "$i is { ";

for $role ( keys %{ $AoH[$i] } ) {

print "$role=$AoH[$i]{$role} ";

}

print "}\n";

}

##################################################################

9:Data Structures/Hashes of Hashes/Composition of a Hash of Hashes

##################################################################

%HoH = (

flintstones => {

husband => "fred",

pal => "barney",

jetsons => {

husband => "george",

wife => "jane",

"his boy" => "elroy", # Key quotes needed.

simpsons => {

husband => "homer",

wife => "marge",

kid => "bart",

);

--------------

$HoH{ mash } = {

captain => "pierce",

major => "burns",

corporal => "radar",

};

#################################################################

9:Data Structures/Hashes of Hashes/Generation of a Hash of Hashes

#################################################################

while ( <> ) {

next unless s/^(.*?):\s*//;

$who = $1;

for $field ( split ) {

($key, $value) = split /=/, $field;

$HoH{$who}{$key} = $value;

}

while ( <> ) {

next unless s/^(.*?):\s*//;

$who = $1;

$rec = {};

$HoH{$who} = $rec;

for $field ( split ) {

($key, $value) = split /=/, $field;

$rec->{$key} = $value;

}

--------------

for $group ( "simpsons", "jetsons", "flintstones" ) {

$HoH{$group} = { get_family($group) };

}

for $group ( "simpsons", "jetsons", "flintstones" ) {

@members = get_family($group);

$HoH{$group} = { @members };

}

sub hash_families {

my @ret;

for $group ( @_ ) {

push @ret, $group, { get_family($group) };

}

@ret;

}

%HoH = hash_families( "simpsons", "jetsons", "flintstones" );

--------------

%new_folks = (

wife => "wilma",

pet => "dino";

);

for $what (keys %new_folks) {

$HoH{flintstones}{$what} = $new_folks{$what};

}

##########################################################################

9:Data Structures/Hashes of Hashes/Access and Printing of a Hash of Hashes

##########################################################################

$HoH{flintstones}{wife} = "wilma";

--------------

$HoH{jetsons}{'his boy'} =~ s/(\w)/\u$1/;

--------------

for $family ( keys %HoH ) {

print "$family: ";

for $role ( keys %{ $HoH{$family} } ) {

print "$role=$HoH{$family}{$role} ";

}

print "\n";

}

--------------

while ( ($family, $roles) = each %HoH ) {

print "$family: ";

while ( ($role, $person) = each %$roles ) {

print "$role=$person ";

}

print "\n";

}

--------------

for $family ( sort keys %HoH ) {

print "$family: ";

for $role ( sort keys %{ $HoH{$family} } ) {

print "$role=$HoH{$family}{$role} ";

}

print "\n";

}

--------------

for $family ( sort { keys %{$HoH{$a}} <=> keys %{$HoH{$b}} } keys %HoH ) {

print "$family: ";

for $role ( sort keys %{ $HoH{$family} } ) {

print "$role=$HoH{$family}{$role} ";

}

print "\n";

}

--------------

$i = 0;

for ( qw(husband wife son daughter pal pet) ) { $rank{$_} = ++$i }

for $family ( sort { keys %{$HoH{$a}} <=> keys %{$HoH{$b}} } keys %HoH ) {

print "$family: ";

for $role ( sort { $rank{$a} <=> $rank{$b} } keys %{ $HoH{$family} } ) {

print "$role=$HoH{$family}{$role} ";

}

print "\n";

}

#####################################

9:Data Structures/Hashes of Functions

#####################################

if ($cmd =~ /^exit$/i) { exit }

elsif ($cmd =~ /^help$/i) { show_help() }

elsif ($cmd =~ /^watch$/i) { $watch = 1 }

elsif ($cmd =~ /^mail$/i) { mail_msg($msg) }

elsif ($cmd =~ /^edit$/i) { $edited++; editmsg($msg); }

elsif ($cmd =~ /^delete$/i) { confirm_kill() }

else {

warn "Unknown command: `$cmd'; Try `help' next time\n";

}

--------------

%HoF = ( # Compose a hash of functions

exit => sub { exit },

help => \&show_help,

watch => sub { $watch = 1 },

mail => sub { mail_msg($msg) },

edit => sub { $edited++; editmsg($msg); },

delete => \&confirm_kill,

);

if ($HoF{lc $cmd}) { $HoF{lc $cmd}->() } # Call function

else { warn "Unknown command: `$cmd'; Try `help' next time\n" }

####################################################################################################

9:Data Structures/More Elaborate Records/Composition, Access, and Printing of More Elaborate Records

####################################################################################################

$rec = {

TEXT => $string,

SEQUENCE => [ @old_values ],

LOOKUP => { %some_table },

THATCODE => \&some_function,

THISCODE => sub { $_[0] ** $_[1] },

HANDLE => \*STDOUT,

};

--------------

print $rec->{TEXT};

--------------

print $rec->{SEQUENCE}[0];

$last = pop @{ $rec->{SEQUENCE} };

print $rec->{LOOKUP}{"key"};

($first_k, $first_v) = each %{ $rec->{LOOKUP} };

--------------

$that_answer = $rec->{THATCODE}->($arg1, $arg2);

$this_answer = $rec->{THISCODE}->($arg1, $arg2);

--------------

print { $rec->{HANDLE} } "a string\n";

--------------

use FileHandle;

$rec->{HANDLE}->autoflush(1);

$rec->{HANDLE}->print("a string\n");

#########################################################################################################

9:Data Structures/More Elaborate Records/Composition, Access, and Printing of Even More Elaborate Records

#########################################################################################################

%TV = (

flintstones => {

series => "flintstones",

nights => [ "monday", "thursday", "friday" ],

members => [

{ name => "fred", role => "husband", age => 36, },

{ name => "wilma", role => "wife", age => 31, },

{ name => "pebbles", role => "kid", age => 4, },

jetsons => {

series => "jetsons",

nights => [ "wednesday", "saturday" ],

members => [

{ name => "george", role => "husband", age => 41, },

{ name => "jane", role => "wife", age => 39, },

{ name => "elroy", role => "kid", age => 9, },

simpsons => {

series => "simpsons",

nights => [ "monday" ],

members => [

{ name => "homer", role => "husband", age => 34, },

{ name => "marge", role => "wife", age => 37, },

{ name => "bart", role => "kid", age => 11, },

);

################################################################################

9:Data Structures/More Elaborate Records/Generation of a Hash of Complex Records

################################################################################

$rec = {};

$rec->{series} = "flintstones";

$rec->{nights} = [ find_days() ];

--------------

@members = ();

while (<>) {

%fields = split /[\s=]+/;

push @members, { %fields };

}

$rec->{members} = [ @members ];

--------------

$TV{ $rec->{series} } = $rec;

--------------

for $family (keys %TV) {

my $rec = $TV{$family}; # temporary pointer

@kids = ();

for $person ( @{$rec->{members}} ) {

if ($person->{role} =~ /kid|son|daughter/) {

push @kids, $person;

}

# $rec and $TV{$family} point to same data!

$rec->{kids} = [ @kids ];

}

--------------

$TV{simpsons}{kids}[0]{age}++;

--------------

print $TV{simpsons}{members}[2]{age};

--------------

for $family ( keys %TV ) {

print "the $family";

print " is on ", join (" and ", @{ $TV{$family}{nights} }), "\n";

print "its members are:\n";

for $who ( @{ $TV{$family}{members} } ) {

print " $who->{name} ($who->{role}), age $who->{age}\n";

}

print "children: ";

print join (", ", map { $_->{name} } @{ $TV{$family}{kids} } );

print "\n\n";

}

########################################

9:Data Structures/Saving Data Structures

########################################

use Data::Dumper;

$Data::Dumper::Purity = 1; # since %TV is self-referential

open (FILE, "> tvinfo.perldata") or die "can't open tvinfo: $!";

print FILE Data::Dumper->Dump([\%TV], ['*TV']);

close FILE or die "can't close tvinfo: $!";

--------------

open (FILE, "< tvinfo.perldata") or die "can't open tvinfo: $!";

undef $/; # read in file all at once

eval <FILE>; # recreate %TV

die "can't recreate tv data from tvinfo.perldata: $@" if $@;

close FILE or die "can't close tvinfo: $!";

print $TV{simpsons}{members}[2]{age};

--------------

do "tvinfo.perldata" or die "can't recreate tvinfo: $! $@";

print $TV{simpsons}{members}[2]{age};

###########

10:Packages

###########

$SIG{QUIT} = "Pkg::quit_catcher"; # fully qualified handler name

$SIG{QUIT} = "quit_catcher"; # implies "main::quit_catcher"

$SIG{QUIT} = *quit_catcher; # forces current package's sub

$SIG{QUIT} = \&quit_catcher; # forces current package's sub

$SIG{QUIT} = sub { print "Caught SIGQUIT\n" }; # anonymous sub

#########################

10:Packages/Symbol Tables

#########################

*sym = *main::variable;

*sym = $main::{"variable"};

--------------

foreach $symname (sort keys %main::) {

local *sym = $main::{$symname};

print "\$$symname is defined\n" if defined $sym;

print "\@$symname is nonnull\n" if @sym;

print "\%$symname is nonnull\n" if %sym;

}

--------------

$!@#$% = 0; # WRONG, syntax error.

${'!@#$%'} = 1; # Ok, though unqualified.

${'main::!@#$%'} = 2; # Can qualify within the string.

print ${ $main::{'!@#$%'} } # Ok, prints 2!

--------------

*dick = *richard;

--------------

*dick = \$richard;

--------------

*SomePack::dick = \&OtherPack::richard;

--------------

*units = populate() ; # Assign \%newhash to the typeglob

print $units{kg}; # Prints 70; no dereferencing needed!

sub populate {

my %newhash = (km => 10, kg => 70);

return \%newhash;

}

--------------

%units = (miles => 6, stones => 11);

fillerup( \%units ); # Pass in a reference

print $units{quarts}; # Prints 4

sub fillerup {

local *hashsym = shift; # Assign \%units to the typeglob

$hashsym{quarts} = 4; # Affects %units; no dereferencing needed!

}

--------------

*PI = \3.14159265358979;

--------------

use constant PI => 3.14159;

--------------

*PI = sub () { 3.14159 };

--------------

*sym = *oldvar;

*sym = \*oldvar; # auto-dereference

*sym = *{"oldvar"}; # explicit symbol table lookup

*sym = "oldvar"; # implicit symbol table lookup

--------------

*sym = \$frodo;

*sym = \@sam;

*sym = \%merry;

*sym = \&pippin;

--------------

*pkg::sym{SCALAR} # same as \$pkg::sym

*pkg::sym{ARRAY} # same as \@pkg::sym

*pkg::sym{HASH} # same as \%pkg::sym

*pkg::sym{CODE} # same as \&pkg::sym

*pkg::sym{GLOB} # same as \*pkg::sym

*pkg::sym{IO} # internal file/dir handle, no direct equivalent

*pkg::sym{NAME} # "sym" (not a reference)

*pkg::sym{PACKAGE} # "pkg" (not a reference)

--------------

sub identify_typeglob {

my $glob = shift;

print 'You gave me ', *{$glob}{PACKAGE}, '::', *{$glob}{NAME}, "\n";

}

identify_typeglob(*foo);

identify_typeglob(*bar::glarch);

#######################

10:Packages/Autoloading

#######################

sub AUTOLOAD {

our $AUTOLOAD;

warn "Attempt to call $AUTOLOAD failed.\n";

}

blarg(10); # our $AUTOLOAD will be set to main::blarg

print "Still alive!\n";

--------------

sub AUTOLOAD {

our $AUTOLOAD;

return "I see $AUTOLOAD(@_)\n";

}

print blarg(20); # prints: I see main::blarg(20)

--------------

sub AUTOLOAD {

my $name = our $AUTOLOAD;

*$AUTOLOAD = sub { print "I see $name(@_)\n" };

goto &$AUTOLOAD; # Restart the new routine.

}

blarg(30); # prints: I see main::blarg(30)

glarb(40); # prints: I see main::glarb(40)

blarg(50); # prints: I see main::blarg(50)

--------------

sub AUTOLOAD {

my $program = our $AUTOLOAD;

$program =~ s/.*:://; # trim package name

system($program, @_);

}

--------------

date();

who('am', 'i');

ls('-l');

echo("Abadugabudabuda...");

--------------

sub date (;$$); # Allow zero to two arguments.

sub who (;$$$$); # Allow zero to four args.

sub ls; # Allow any number of args.

sub echo ($@); # Allow at least one arg.

date;

who "am", "i";

ls "-l";

echo "That's all, folks!";

########################

11:Modules/Using Modules

########################

use Fred; # If Fred.pm has @EXPORT = qw(flintstone)

flintstone(); # ...this calls Fred::flintstone().

###########################

11:Modules/Creating Modules

###########################

package Bestiary;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT = qw(camel); # Symbols to be exported by default

our @EXPORT_OK = qw($weight); # Symbols to be exported on request

our $VERSION = 1.00; # Version number

### Include your variables and functions here

sub camel { print "One-hump dromedary" }

$weight = 1024;

###########################################################

11:Modules/Creating Modules/Module Privacy and the Exporter

###########################################################

require Exporter;

our @ISA = ("Exporter");

--------------

our @EXPORT = qw($camel %wolf ram); # Export by default

our @EXPORT_OK = qw(leopard @llama $emu); # Export by request

our %EXPORT_TAGS = ( # Export as group

camelids => [qw($camel @llama)],

critters => [qw(ram $camel %wolf)],

);

--------------

use Bestiary; # Import @EXPORT symbols

use Bestiary (); # Import nothing

use Bestiary qw(ram @llama); # Import the ram function and @llama array

use Bestiary qw(:camelids); # Import $camel and @llama

use Bestiary qw(:DEFAULT); # Import @EXPORT symbols

use Bestiary qw(/am/); # Import $camel, @llama, and ram

use Bestiary qw(/^\$/); # Import all scalars

use Bestiary qw(:critters !ram); # Import the critters, but exclude ram

use Bestiary qw(:critters !:camelids);

# Import critters, but no camelids

--------------

BEGIN {

require Bestiary;

import Bestiary LIST;

}

##########################################################################################################

11:Modules/Creating Modules/Module Privacy and the Exporter/Exporting without using Export's import method

##########################################################################################################

package Bestiary;

@ISA = qw(Exporter);

@EXPORT_OK = qw ($zoo);

sub import {

$Bestiary::zoo = "menagerie";

}

--------------

sub import {

$Bestiary::zoo = "menagerie";

Bestiary->export_to_level(1, @_);

}

############################################################################

11:Modules/Creating Modules/Module Privacy and the Exporter/Version checking

############################################################################

use Bestiary 3.14; # The Bestiary must be version 3.14 or later

use Bestiary v1.0.4; # The Bestiary must be version 1.0.4 or later

####################################################################################

11:Modules/Creating Modules/Module Privacy and the Exporter/Managing unknown symbols

####################################################################################

sub export_fail {

my $class = shift;

carp "Sorry, these symbols are unavailable: @_";

return @_;

}

##########################################################################################

11:Modules/Creating Modules/Module Privacy and the Exporter/Tag handling utility functions

##########################################################################################

%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);

Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT

Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK

########################################

11:Modules/Overriding Built-in Functions

########################################

use subs qw(chdir chroot chmod chown);

chdir $somewhere;

sub chdir { ... }

--------------

*CORE::GLOBAL::glob = sub {

my $pat = shift;

my @got;

local *D;

if (opendir D, '.') {

@got = grep /$pat/, readdir D;

closedir D;

}

return @got;

}

package Whatever;

print <^[a-z_]+\.pm\$>; # show all pragmas in the current directory

#######################################################################

12:Objects/Method Invocation/Method Invocation Using the Arrow Operator

#######################################################################

$mage = Wizard->summon("Gandalf"); # class method

$mage->speak("friend"); # instance method

--------------

Wizard->summon("Gandalf")->speak("friend");

--------------

$method = "summon";

$mage = Wizard->$method("Gandalf"); # Invoke Wizard->summon

$travel = $companion eq "Shadowfax" ? "ride" : "walk";

$mage->$travel("seven leagues"); # Invoke $mage->ride or $mage->walk

#####################################################################

12:Objects/Method Invocation/Method Invocation Using Indirect Objects

#####################################################################

$mage = summon Wizard "Gandalf";

$nemesis = summon Balrog home => "Moria", weapon => "whip";

move $nemesis "bridge";

speak $mage "You cannot pass";

break $staff; # safer to use: break $staff ();

--------------

print STDERR "help!!!\n";

--------------

speak { summon Wizard "Gandalf" } "friend";

###################################################################

12:Objects/Method Invocation/Syntactic Snafus with Indirect Objects

###################################################################

enchant $sword ($pips + 2) * $cost;

--------------

($sword->enchant($pips + 2)) * $cost;

--------------

name $sword $oldname || "Glamdring"; # can't use "or" here!

--------------

$sword->name($oldname || "Glamdring");

--------------

speak $mage "friend" && enter(); # should've been "and" here!

--------------

$mage->speak("friend" && enter());

--------------

enter() if $mage->speak("friend");

$mage->speak("friend") && enter();

speak $mage "friend" and enter();

--------------

move $party->{LEADER}; # probably wrong!

move $riders[$i]; # probably wrong!

--------------

$party->move->{LEADER};

$riders->move([$i]);

--------------

$party->{LEADER}->move;

$riders[$i]->move;

###################################################

12:Objects/Method Invocation/Package-Quoted Classes

###################################################

$obj = new ElvenRing; # could be new("ElvenRing")

# or even new(ElvenRing())

$obj = ElvenRing->new; # could be ElvenRing()->new()

$obj = new ElvenRing::; # always "ElvenRing"->new()

$obj = ElvenRing::->new; # always "ElvenRing"->new()

--------------

$obj = new ElvenRing::

name => "Narya",

owner => "Gandalf",

domain => "fire",

stone => "ruby";

--------------

use ElvenRing;

require ElvenRing;

##############################

12:Objects/Object Construction

##############################

$obj = { }; # Get reference to anonymous hash.

bless($obj); # Bless hash into current package.

bless($obj, "Critter"); # Bless hash into class Critter.

--------------

package Critter;

sub spawn { bless {}; }

--------------

package Critter;

sub spawn {

my $self = {}; # Reference to an empty anonymous hash

bless $self, "Critter"; # Make that hash a Critter object

return $self; # Return the freshly generated Critter

}

--------------

$pet = Critter->spawn;

#######################################################

12:Objects/Object Construction/Inheritable Constructors

#######################################################

--------------

sub spawn {

my $class = shift; # Store the package name

my $self = { };

bless($self, $class); # Bless the reference into that package

return $self;

}

--------------

$vermin = Critter->spawn;

$shelob = Spider->spawn;

--------------

$type = "Spider";

$shelob = $type->spawn; # same as "Spider"->spawn

--------------

sub spawn {

my $invocant = shift;

my $class = ref($invocant) || $invocant; # Object or class name

my $self = { };

bless($self, $class);

return $self;

}

###########################################

12:Objects/Object Construction/Initializers

###########################################

$steed = Horse->new(name => "Shadowfax", color => "white");

--------------

sub new {

my $invocant = shift;

my $class = ref($invocant) || $invocant;

my $self = { @_ }; # Remaining args become attributes

bless($self, $class); # Bestow objecthood

return $self;

}

--------------

sub new {

my $invocant = shift;

my $class = ref($invocant) || $invocant;

my $self = {

color => "bay",

legs => 4,

owner => undef,

@_, # Override previous attributes

};

return bless $self, $class;

}

$ed = Horse->new; # A 4-legged bay horse

$stallion = Horse->new(color => "black"); # A 4-legged black horse

--------------

$steed = Horse->new(color => "dun");

$foal = $steed->clone(owner => "EquuGen Guild, Ltd.");

sub clone {

my $model = shift;

my $self = $model->new(%$model, @_);

return $self; # Previously blessed by ->new

}

############################

12:Objects/Class Inheritance

############################

package Horse;

our @ISA = "Critter";

--------------

$steed->move(10);

########################################################

12:Objects/Class Inheritance/Inheritance through C<@ISA>

########################################################

package Mule;

our @ISA = ("Horse", "Donkey");

--------------

package Mule;

use base ("Horse", "Donkey"); # declare superclasses

--------------

package Mule;

BEGIN {

our @ISA = ("Horse", "Donkey");

require Horse;

require Donkey;

}

#########################################################

12:Objects/Class Inheritance/Accessing Overridden Methods

#########################################################

$stallion = Horse->new(gender => "male");

$molly = Mule->new(gender => "female");

$colt = $molly->breed($stallion);

--------------

$colt = Horse::breed($molly, $stallion);

--------------

$colt = $molly->Horse::breed($stallion);

--------------

package Mule;

our @ISA = qw(Horse Donkey);

sub kick {

my $self = shift;

print "The mule kicks!\n";

$self->SUPER::kick(@_);

}

--------------

sub speak {

my $self = shift;

print "The mule speaks!\n";

$self->Donkey::speak(@_);

}

--------------

package Bird;

use Dragonfly;

sub Dragonfly::divebomb { shift->SUPER::divebomb(@_) }

--------------

package Bird;

use Dragonfly;

{

package Dragonfly;

sub divebomb { shift->SUPER::divebomb(@_) }

}

###################################################################

12:Objects/Class Inheritance/UNIVERSAL: The Ultimate Ancestor Class

###################################################################

use FileHandle;

if (FileHandle->isa("Exporter")) {

print "FileHandle is an Exporter.\n";

}

$fh = FileHandle->new();

if ($fh->isa("IO::Handle")) {

print "\$fh is some sort of IOish object.\n";

}

if ($fh->isa("GLOB")) {

print "\$fh is really a GLOB.\n";

}

--------------

if ($invocant->can("copy")) {

print "Our invocant can copy.\n";

}

--------------

$obj->snarl if $obj->can("snarl");

--------------

sub snarl {

my $self = shift;

print "Snarling: @_\n";

my %seen;

for my $parent (@ISA) {

if (my $code = $parent->can("snarl")) {

$self->$code(@_) unless $seen{$code}++;

}

--------------

use Thread 1.0; # calls Thread->VERSION(1.0)

print "Running version ", Thread->VERSION, " of Thread.\n";

--------------

use Data::Dumper;

use Carp;

sub UNIVERSAL::copy {

my $self = shift;

if (ref $self) {

return eval Dumper($self); # no CODE refs

} else {

confess "UNIVERSAL::copy can't copy class $self";

}

###############################################

12:Objects/Class Inheritance/Method Autoloading

###############################################

sub AUTOLOAD {

return if our $AUTOLOAD =~ /::DESTROY$/;

...

}

--------------

if ($obj->can("methname") || $obj->can("AUTOLOAD")) {

$obj->methname();

}

--------------

package Goblin;

sub kick;

sub bite;

sub scratch;

--------------

package Goblin;

use subs qw(kick bite scratch);

############################################

12:Objects/Class Inheritance/Private Methods

############################################

# declare private method

my $secret_door = sub {

my $self = shift;

....

};

--------------

sub knock {

my $self = shift;

if ($self->{knocked}++ > 5) {

$self->$secret_door();

}

###############################

12:Objects/Instance Destructors

###############################

package MailNotify;

sub DESTROY {

my $self = shift;

my $fh = $self->{mailhandle};

my $id = $self->{name};

print $fh "\n$id is signing off at " . localtime() . "\n";

close $fh; # close pipe to mailer

}

--------------

sub DESTROY {

my $self = shift;

# check for an overridden destructor...

$self->SUPER::DESTROY if $self->can("SUPER::DESTROY");

# now do your own thing before or after

}

#################################

12:Objects/Managing Instance Data

#################################

sub get_name {

my $self = shift;

return $self->{name};

}

sub set_name {

my $self = shift;

$self->{name} = shift;

}

--------------

$him = Person->new();

$him->set_name("Frodo");

$him->set_name( ucfirst($him->get_name) );

--------------

sub name {

my $self = shift;

if (@_) { $self->{name} = shift }

return $self->{name};

}

--------------

$him = Person->new();

$him->name("Frodo");

$him->name( ucfirst($him->name) );

--------------

sub name {

my $self = shift;

my $field = __PACKAGE__ . "::name";

if (@_) { $self->{$field} = shift }

return $self->{$field};

}

#######################################################################

12:Objects/Managing Instance Data/Field Declarations with C<use fields>

#######################################################################

sub new {

my $invocant = shift;

my $class = ref($invocant) || $invocant;

return bless [], $class;

}

--------------

sub name {

my $self = shift;

if (@_) { $self->[0] = shift }

return $self->[0];

}

sub race {

my $self = shift;

if (@_) { $self->[1] = shift }

return $self->[1];

}

sub aliases {

my $self = shift;

if (@_) { $self->[2] = shift }

return $self->[2];

}

--------------

package Person;

use fields qw(name race aliases);

--------------

package Person;

use fields qw(name race aliases);

sub new {

my $type = shift;

my Person $self = fields::new(ref $type || $type);

$self->{name} = "unnamed";

$self->{race} = "unknown;

$self->{aliases} = [];

return $self;

}

sub name {

my Person $self = shift;

$self->{name} = shift if @_;

return $self->{name};

}

sub race {

my Person $self = shift;

$self->{race} = shift if @_;

return $self->{race};

}

sub aliases {

my Person $self = shift;

$self->{aliases} = shift if @_;

return $self->{aliases};

}

--------------

package Wizard;

use base "Person";

use fields qw(staff color sphere);

--------------

my Wizard $mage = fields::new("Wizard");

--------------

$mage->name("Gandalf");

$mage->color("Grey");

--------------

$mage->{name} = "Gandalf";

$mage->{color} = "Grey";

##########################################################################

12:Objects/Managing Instance Data/Generating Classes with C<Class::Struct>

##########################################################################

package Person;

use Class::Struct;

struct Person => { # create a definition for a "Person"

name => '$', # name field is a scalar

race => '$', # race field is also a scalar

aliases => '@', # but aliases field is an array ref

};

--------------

use Person;

my $mage = Person->new();

$mage->name("Gandalf");

$mage->race("Istar");

$mage->aliases( ["Mithrandir", "Olorin", "Incanus"] );

#######################################################################

12:Objects/Managing Instance Data/Generating Accessors with Autoloading

#######################################################################

use Person;

$him = Person->new;

$him->name("Aragorn");

$him->race("Man");

$him->aliases( ["Strider", "Estel", "Elessar"] );

printf "%s is of the race of %s.\n", $him->name, $him->race;

print "His aliases are: ", join(", ", @{$him->aliases}), ".\n";

--------------

package Person;

use Carp;

my %fields = (

"Person::name" => "unnamed",

"Person::race" => "unknown",

"Person::aliases" => [],

);

# The next declaration guarantees we get our own autoloader.

use subs qw(name race aliases);

sub new {

my $invocant = shift;

my $class = ref($invocant) || $invocant;

my $self = { %fields, @_ }; # clone like Class::Struct

bless $self, $class;

return $self;

}

sub AUTOLOAD {

my $self = shift;

# only handle instance methods, not class methods

croak "$self not an object" unless ref($invocant);

my $name = our $AUTOLOAD;

return if $name =~ /::DESTROY$/;

unless (exists $self->{$name}) {

croak "Can't access `$name' field in $self";

}

if (@_) { return $self->{$name} = shift }

else { return $self->{$name} }

}

####################################################################

12:Objects/Managing Instance Data/Generating Accessors with Closures

####################################################################

package Person;

sub new {

my $invocant = shift;

my $self = bless({}, ref $invocant || $invocant);

$self->init();

return $self;

}

sub init {

my $self = shift;

$self->name("unnamed");

$self->race("unknown");

$self->aliases([]);

}

for my $field (qw(name race aliases)) {

my $slot = __PACKAGE__ . "::$field";

no strict "refs"; # So symbolic ref to typeglob works.

*$field = sub {

my $self = shift;

$self->{$slot} = shift if @_;

return $self->{$slot};

};

}

####################################################################

12:Objects/Managing Instance Data/Using Closures for Private Objects

####################################################################

package Person;

sub new {

my $invocant = shift;

my $class = ref($invocant) || $invocant;

my $data = {

NAME => "unnamed",

RACE => "unknown",

ALIASES => [],

};

my $self = sub {

my $field = shift;

#############################

### ACCESS CHECKS GO HERE ###

#############################

if (@_) { $data->{$field} = shift }

return $data->{$field};

};

bless($self, $class);

return $self;

}

# generate method names

for my $field (qw(name race aliases)) {

no strict "refs"; # for access to the symbol table

*$field = sub {

my $self = shift;

return $self->(uc $field, @_);

};

}

--------------

use Carp;

local $Carp::CarpLevel = 1; # Keeps croak messages short

my ($cpack, $cfile) = caller();

--------------

croak "No valid field `$field' in object"

unless exists $data->{$field};

--------------

carp "Unmediated access denied to foreign file"

unless $cfile eq __FILE__;

--------------

carp "Unmediated access denied to foreign package ${cpack}::"

unless $cpack eq __PACKAGE__;

--------------

carp "Unmediated access denied to unfriendly class ${cpack}::"

unless $cpack->isa(__PACKAGE__);

############################################

12:Objects/Managing Instance Data/New Tricks

############################################

package Critter;

sub new {

my $class = shift;

my $self = { pups => 0, @_ }; # Override default.

bless $self, $class;

}

sub pups : lvalue { # We'll assign to pups() later.

my $self = shift;

$self->{pups};

}

package main;

$varmint = Critter->new(pups => 4);

$varmint->pups *= 2; # Assign to $varmint->pups!

$varmint->pups =~ s/(.)/$1$1/; # Modify $varmint->pups in place!

print $varmint->pups; # Now we have 88 pups.

--------------

sub pups : locked method {

...

}

##############################

12:Objects/Managing Class Data

##############################

Critter->population() # Access via class name

$gollum->population() # Access via instance

--------------

package Critter;

our $Population = 0;

sub population { return $Population; }

sub DESTROY { $Population-- }

sub spawn {

my $invocant = shift;

my $class = ref($invocant) || $invocant;

$Population++;

return bless { name => shift || "anon" }, $class;

}

sub name {

my $self = shift;

$self->{name} = shift if @_;

return $self->{name};

}

--------------

our $Debugging = 0; # class datum

sub debug {

shift; # intentionally ignore invocant

$Debugging = shift if @_;

return $Debugging;

}

--------------

{

my $Debugging = 0; # lexically scoped class datum

sub debug {

shift; # intentionally ignore invocant

$Debugging = shift if @_;

return $Debugging;

}

--------------

sub debug {

my $invocant = shift;

my $class = ref($invocant) || $invocant;

my $varname = $class . "::Debugging";

no strict "refs"; # to access package data symbolically

$$varname = shift if @_;

return $$varname;

}

##############

13:Overloading

##############

print $object->as_string;

$new_object = $subject->add($object);

--------------

print $object;

$new_object = $subject + $object;

#####################################

13:Overloading/The C<overload> Pragma

#####################################

package MyClass;

use overload '+' => \&myadd, # coderef

'<' => "less_than"; # named method

'abs' => sub { return @_ }, # anonymous subroutine

################################

13:Overloading/Overload Handlers

################################

package ClipByte;

use overload '+' => \&clip_add,

'-' => \&clip_sub;

sub new {

my $class = shift;

my $value = shift;

return bless \$value => $class;

}

sub clip_add {

my ($x, $y) = @_;

my ($value) = ref($x) ? $$x : $x;

$value += ref($y) ? $$y : $y;

$value = 255 if $value > 255;

$value = 0 if $value < 0;

return bless \$value => ref($x);

}

sub clip_sub {

my ($x, $y, $swap) = @_;

my ($value) = (ref $x) ? $$x : $x;

$value -= (ref $y) ? $$y : $y;

if ($swap) { $value = -$value }

$value = 255 if $value > 255;

$value = 0 if $value < 0;

return bless \$value => ref($x);

}

package main;

$byte1 = ClipByte->new(200);

$byte2 = ClipByte->new(100);

$byte3 = $byte1 + $byte2; # 255

$byte4 = $byte1 - $byte2; # 100

$byte5 = 150 - $byte2; # 50

#####################################

13:Overloading/Overloadable Operators

#####################################

package Person;

use overload q("") => \&as_string;

sub new {

my $class = shift;

return bless { @_ } => $class;

}

sub as_string {

my $self = shift;

my ($key, $value, $result);

while (($key, $value) = each %$self) {

$result .= "$key => $value\n";

}

return $result;

}

$obj = Person->new(height => 72, weight => 165, eyes => "brown");

print $obj;

--------------

package ShiftString;

use overload

'>>' => \&right_shift,

'""' => sub { ${ $_[0] } };

sub new {

my $class = shift;

my $value = shift;

return bless \$value => $class;

}

sub right_shift {

my ($x, $y) = @_;

my $value = $$x;

substr($value, -$y) = "";

return bless \$value => ref($x);

}

$camel = ShiftString->new("Camel");

$ram = $camel >> 2;

print $ram; # Cam

--------------

package MagicDec;

use overload

q(--) => \&decrement,

q("") => sub { ${ $_[0] } };

sub new {

my $class = shift;

my $value = shift;

bless \$value => $class;

}

sub decrement {

my @string = reverse split(//, ${ $_[0] } );

my $i;

for ($i = 0; $i < @string; $i++ ) {

last unless $string[$i] =~ /a/i;

$string[$i] = chr( ord($string[$i]) + 25 );

}

$string[$i] = chr( ord($string[$i]) - 1 );

my $result = join('', reverse @string);

$_[0] = bless \$result => ref($_[0]);

}

package main;

for $normal (qw/perl NZ Pa/) {

$magic = MagicDec->new($normal);

$magic--;

print "$normal goes to $magic\n";

}

--------------

package LuckyDraw;

use overload

'<>' => sub {

my $self = shift;

return splice @$self, rand @$self, 1;

};

sub new {

my $class = shift;

return bless [@_] => $class;

}

package main;

$lotto = new LuckyDraw 1 .. 51;

for (qw(1st 2nd 3rd 4th 5th 6th)) {

$lucky_number = <$lotto>;

print "The $_ lucky number is: $lucky_number.\n";

}

$lucky_number = <$lotto>;

print "\nAnd the bonus number is: $lucky_number.\n";

--------------

package PsychoHash;

use overload '%{}' => \&as_hash;

sub as_hash {

my ($x) = shift;

return { @$x };

}

sub new {

my $class = shift;

return bless [ @_ ] => $class;

}

$critter = new PsychoHash( height => 72, weight => 365, type => "camel" );

print $critter->{weight}; # prints 365

--------------

use overload '+' => sub { bless [ \$_[0], \$_[1] ] };

##########################################

13:Overloading/The Copy Constructor (C<=>)

##########################################

$copy = $scalar_ref;

++$$copy; # changes $$scalar_ref

--------------

$copy = $scalar_ref;

$copy = $copy + 1;

--------------

$copy = $scalar_ref;

...

++$copy;

--------------

$copy = $scalar_ref;

...

$copy = $copy->clone(undef, "");

$copy->incr(undef, "");

####################################

13:Overloading/Overloading Constants

####################################

sub import { overload::constant ( integer => \&integer_handler,

float => \&float_handler,

binary => \&oct_and_hex_handler,

q => \&string_handler,

qr => \&regex_handler ) }

--------------

$year = cube(12) + 1;

$pi = 3.14159265358979;

--------------

package DigitDoubler; # A module to be placed in DigitDoubler.pm

use overload;

sub import { overload::constant ( integer => \&integer_handler,

float => \&float_handler ) }

sub integer_handler {

my ($orig, $interp, $context) = @_;

return $interp * 2; # double all constant integers

}

--------------

use DigitDoubler;

$trouble = 123; # trouble is now 246

###################################

13:Overloading/Run-time Overloading

###################################

eval " use overload '+' => \&my_add ";

--------------

eval " no overload '+', '--', '<=' ";

###############################

14:Tied Variables/Tying Scalars

###############################

#!/usr/bin/perl

package Centsible;

sub TIESCALAR { bless \my $self, shift }

sub STORE { ${ $_[0] } = $_[1] } # do the default thing

sub FETCH { sprintf "%.02f", ${ my $self = shift } } # round value

package main;

tie $bucks, "Centsible";

$bucks = 45.00;

$bucks *= 1.0715; # tax

$bucks *= 1.0715; # and double tax!

print "That will be $bucks, please.\n";

####################################################

14:Tied Variables/Tying Scalars/Scalar Tying Methods

####################################################

use ScalarFile; # load ScalarFile.pm

tie $camel, "ScalarFile", "/tmp/camel.lot";

--------------

$dromedary = $camel;

--------------

$dromedary = (tied $camel)->FETCH():

--------------

$clot = tie $camel, "ScalarFile", "/tmp/camel.lot";

$dromedary = $camel; # through the implicit interface

$dromedary = $clot->FETCH(); # same thing, but explicitly

--------------

package ScalarFile;

use Carp; # Propagates error messages nicely.

use strict; # Enforce some discipline on ourselves.

use warnings; # Turn on lexically scoped warnings.

use warnings::register; # Allow user to say "use warnings 'ScalarFile'".

my $count = 0; # Internal count of tied ScalarFiles.

--------------

sub TIESCALAR { # in ScalarFile.pm

my $class = shift;

my $filename = shift;

$count++; # A file-scoped lexical, private to class.

return bless \$filename, $class;

}

--------------

sub TIESCALAR { bless \$_[1], $_[0] } # WRONG, could refer to global.

--------------

sub TIESCALAR { # in ScalarFile.pm

my $class = shift;

my $filename = shift;

my $fh;

if (open $fh, "<", $filename or

open $fh, ">", $filename)

{

close $fh;

$count++;

return bless \$filename, $class;

}

carp "Can't tie $filename: $!" if warnings::enabled();

return;

}

--------------

tie ($string, "ScalarFile", "camel.lot") or die;

--------------

sub FETCH {

my $self = shift;

confess "I am not a class method" unless ref $self;

return unless open my $fh, $$self;

read($fh, my $value, -s $fh); # NB: don't use -s on pipes!

return $value;

}

--------------

tie($string, "ScalarFile", "camel.lot");

print $string;

--------------

sub STORE {

my($self,$value) = @_;

ref $self or confess "not a class method";

open my $fh, ">", $$self or croak "can't clobber $$self: $!";

syswrite($fh, $value) == length $value

or croak "can't write to $$self: $!";

close $fh or croak "can't close $$self: $!";

return $value;

}

--------------

tie($string, "ScalarFile", "camel.lot");

$string = "Here is the first line of camel.lot\n";

$string .= "And here is another line, automatically appended.\n";

--------------

sub DESTROY {

my $self = shift;

confess "wrong type" unless ref $self;

$count--;

}

--------------

sub count {

# my $invocant = shift;

$count;

}

--------------

if (ScalarFile->count) {

warn "Still some tied ScalarFiles sitting around somewhere...\n";

}

Ok-Guru

Search This Blog

Friday, June 12, 2020

PERL cheat sheet

Perl Cheat Sheet

Operators and Loops

Matching and Regular Expressions

1 comment:

About Me