#####################################
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 = ) {
($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") # 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 = ; # input the number
print STDOUT "The number is $number.\n"; # print the number
--------------
chop($number = ); # input number and remove newline
--------------
$number = ; # 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 = );
##########################################################
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 = ;
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 = ;
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 = ) {
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 = ) {
if ($line =~ /http:/) {
print $line;
}
}
--------------
while () {
print if /http:/;
}
--------------
while () {
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 < 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($_ = )) { print $_; } # the longest way
while ($_ = ) { print; } # explicitly to $_
while () { print; } # the short way
for (;;) { print; } # while loop in disguise
print $_ while defined($_ = ); # long statement modifier
print while $_ = ; # explicitly to $_
print while ; # short statement modifier
--------------
while ( && ) { ... } # WRONG: discards both inputs
if () { print; } # WRONG: prints old value of $_
if ($_ = ) { print; } # suboptimal: doesn't test defined
if (defined($_ = )) { print; } # best
--------------
while (local $_ = ) { print; } # use local $_
--------------
while (my $line = ) { print $line; } # now private
--------------
$one_line = ; # Get first line.
@all_lines = ; # 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 () {
... # 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, ";
############################################################
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) = ; # list context
--------------
$file = ; # 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 = ;
...
} 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 = 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 = ) =~ /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 = ) {
$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(); ; 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 () {
last LINE if /^$/; # exit when done with mail header
...
}
--------------
LINE: while () {
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 = )) {
chomp($line);
if ($line =~ s/\\$//) {
$line .= ;
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) = ;
my @array = ;
--------------
my $foo = ;
--------------
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 $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
##############################################################################################
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 $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);
s{larva}{pupa};
s[pupa]/imago/;
--------------
s (egg) ;
s {larva} {pupa};
s [pupa] /imago/;
--------------
"hot cross buns" =~ /cross/;
print "Matched: <$`> $& <$'>\n"; # Matched: cross < buns>
print "Left: <$`>\n"; # Left:
print "Match: <$&>\n"; # Match:
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 () {
$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 () {
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 = );
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/(?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 and C 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 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 ; # 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;
1;
###########################################################
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
