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

Tuesday, April 17, 2012

Looping through list in SQL

Wednesday, April 11, 2012

TRANSACTION and Error Handling

About Me