Commit b50e21f6 authored by O'Reilly Media, Inc.'s avatar O'Reilly Media, Inc.
Browse files

Initial commit

parents
9780596003135
\ No newline at end of file
## Example files for the title:
# Perl Cookbook 2nd Edition, by Tom Christiansen
[![Perl Cookbook 2nd Edition, by Tom Christiansen](http://akamaicovers.oreilly.com/images/9780596003135/cat.gif)](https://www.safaribooksonline.com/library/view/title/0596003137//)
The following applies to example files from material published by O’Reilly Media, Inc. Content from other publishers may include different rules of usage. Please refer to any additional usage rights explained in the actual example files or refer to the publisher’s website.
O'Reilly books are here to help you get your job done. In general, you may use the code in O'Reilly books in your programs and documentation. You do not need to contact us for permission unless you're reproducing a significant portion of the code. For example, writing a program that uses several chunks of code from our books does not require permission. Answering a question by citing our books and quoting example code does not require permission. On the other hand, selling or distributing a CD-ROM of examples from O'Reilly books does require permission. Incorporating a significant amount of example code from our books into your product's documentation does require permission.
We appreciate, but do not require, attribution. An attribution usually includes the title, author, publisher, and ISBN.
If you think your use of code examples falls outside fair use or the permission given here, feel free to contact us at <permissions@oreilly.com>.
Please note that the examples are not production code and have not been carefully testing. They are provided "as-is" and come with no warranty of any kind.
This diff is collapsed.
#!/usr/bin/perl -w
# fixstyle - switch first set of <DATA> strings to second set
# usage: $0 [-v] [files ...]
use strict;
my $verbose = (@ARGV && $ARGV[0] eq '-v' && shift);
if (@ARGV) {
$^I = ".orig"; # preserve old files
} else {
warn "$0: Reading from stdin\n" if -t STDIN;
}
my $code = "while (<>) {\n";
# read in config, build up code to eval
while (<DATA>) {
chomp;
my ($in, $out) = split /\s*=>\s*/;
next unless $in && $out;
$code .= "s{\\Q$in\\E}{$out}g";
$code .= "&& printf STDERR qq($in => $out at \$ARGV line \$.\\n)"
if $verbose;
$code .= ";\n";
}
$code .= "print;\n}\n";
eval "{ $code } 1" || die;
__END__
analysed => analyzed
built-in => builtin
chastized => chastised
commandline => command-line
de-allocate => deallocate
dropin => drop-in
hardcode => hard-code
meta-data => metadata
multicharacter => multi-character
multiway => multi-way
non-empty => nonempty
non-profit => nonprofit
non-trappable => nontrappable
pre-define => predefine
preextend => pre-extend
re-compiling => recompiling
reenter => re-enter
turnkey => turn-key
#!/usr/bin/perl -w
# fixstyle2 - like fixstyle but faster for many many matches
use strict;
my $verbose = (@ARGV && $ARGV[0] eq '-v' && shift);
my %change = ();
while (<DATA>) {
chomp;
my ($in, $out) = split /\s*=>\s*/;
next unless $in && $out;
$change{$in} = $out;
}
if (@ARGV) {
$^I = ".orig";
} else {
warn "$0: Reading from stdin\n" if -t STDIN;
}
while (<>) {
my $i = 0;
s/^(\s+)// && print $1; # emit leading whitespace
for (split /(\s+)/, $_, -1) { # preserve trailing whitespace
print( ($i++ & 1) ? $_ : ($change{$_} || $_));
}
}
__END__
analysed => analyzed
built-in => builtin
chastized => chastised
commandline => command-line
de-allocate => deallocate
dropin => drop-in
hardcode => hard-code
meta-data => metadata
multicharacter => multi-character
multiway => multi-way
non-empty => nonempty
non-profit => nonprofit
non-trappable => nontrappable
pre-define => predefine
preextend => pre-extend
re-compiling => recompiling
reenter => re-enter
turnkey => turn-key
#!/usr/bin/perl -w
# psgrep - print selected lines of ps output by
# compiling user queries into code
use strict;
# each field from the PS header
my @fieldnames = qw(FLAGS UID PID PPID PRI NICE SIZE
RSS WCHAN STAT TTY TIME COMMAND);
# determine the unpack format needed (hard-coded for Linux ps)
my $fmt = cut2fmt(8, 14, 20, 26, 30, 34, 41, 47, 59, 63, 67, 72);
my %fields; # where the data will store
die <<Thanatos unless @ARGV;
usage: $0 criterion ...
Each criterion is a Perl expression involving:
@fieldnames
All criteria must be met for a line to be printed.
Thanatos
# Create function aliases for uid, size, UID, SIZE, etc.
# Empty parens on closure args needed for void prototyping.
for my $name (@fieldnames) {
no strict 'refs';
*$name = *{lc $name} = sub () { $fields{$name} };
}
my $code = "sub is_desirable { " . join(" and ", @ARGV) . " } ";
unless (eval $code.1) {
die "Error in code: $@\n\t$code\n";
}
open(PS, "ps wwaxl |") || die "cannot fork: $!";
print scalar <PS>; # emit header line
while (<PS>) {
@fields{@fieldnames} = trim(unpack($fmt, $_));
print if is_desirable(); # line matches their criteria
}
close(PS) || die "ps failed!";
# convert cut positions to unpack format
sub cut2fmt {
my(@positions) = @_;
my $template = '';
my $lastpos = 1;
for my $place (@positions) {
$template .= "A" . ($place - $lastpos) . " ";
$lastpos = $place;
}
$template .= "A*";
return $template;
}
sub trim {
my @strings = @_;
for (@strings) {
s/^\s+//;
s/\s+$//;
}
return wantarray ? @strings : $strings[0];
}
# the following was used to determine column cut points.
# sample input data follows
#123456789012345678901234567890123456789012345678901234567890123456789012345
# 1 2 3 4 5 6 7
# Positioning:
# 8 14 20 26 30 34 41 47 59 63 67 72
# | | | | | | | | | | | |
__END__
FLAGS UID PID PPID PRI NI SIZE RSS WCHAN STA TTY TIME COMMAND
100 0 1 0 0 0 760 432 do_select S ? 0:02 init
140 0 187 1 0 0 784 452 do_select S ? 0:02 syslogd
100100 101 428 1 0 0 1436 944 do_exit S 1 0:00 /bin/login
100140 99 30217 402 0 0 1552 1008 posix_lock_ S ? 0:00 httpd
0 101 593 428 0 0 1780 1260 copy_thread S 1 0:00 -tcsh
100000 101 30639 9562 17 0 924 496 R p1 0:00 ps axl
0 101 25145 9563 0 0 2964 2360 idetape_rea S p2 0:06 trn
100100 0 10116 9564 0 0 1412 928 setup_frame T p3 0:00 ssh -C www
100100 0 26560 26554 0 0 1076 572 setup_frame T p2 0:00 less
100000 101 19058 9562 0 0 1396 900 setup_frame T p1 0:02 nvi /tmp/a
#!/usr/bin/perl -p
# randcap: filter to randomly capitalize 20% of the letters
# call to srand() is unnecessary in 5.004
BEGIN { srand(time() ^ ($$ + ($$ << 15))) }
sub randcase { rand(100) < 20 ? "\u$_[0]" : "\l$_[0]" }
s/(\w)/randcase($1)/ge;
#!/usr/bin/perl
# slowcat - emulate a s l o w line printer
# usage: slowcat [-DELAY] [files ...]
$DELAY = ($ARGV[0] =~ /^-([.\d]+)/) ? (shift, $1) : 1;
$| = 1;
while (<>) {
for (split(//)) {
print;
select(undef,undef,undef, 0.005 * $DELAY);
}
}
#!/usr/bin/perl -w
# wrapdemo - show how Text::Wrap works
@input = ("Folding and splicing is the work of an editor,",
"not a mere collection of silicon",
"and",
"mobile electrons!");
use Text::Wrap qw($columns &wrap);
$columns = 20;
print "0123456789" x 2, "\n";
print wrap(" ", " ", @input), "\n";
#!/usr/bin/perl
# bigfact - calculate prime factors
use strict;
use integer;
use vars qw{ $opt_b $opt_d };
use Getopt::Std;
@ARGV && getopts('bd') or die "usage: $0 [-b] number ...";
load_biglib() if $opt_b;
ARG: foreach my $orig ( @ARGV ) {
my ($n, $root, %factors, $factor);
$n = $opt_b ? Math::BigInt->new($orig) : $orig;
if ($n + 0 ne $n) { # don't use -w for this
printf STDERR "bignum: %s would become %s\n", $n, $n+0 if $opt_d;
load_biglib();
$n = Math::BigInt->new($orig);
}
printf "%-10s ", $n;
# Here $sqi will be the square of $i. We will take advantage
# of the fact that ($i + 1) ** 2 == $i ** 2 + 2 * $i + 1.
for (my ($i, $sqi) = (2, 4); $sqi <= $n; $sqi += 2 * $i ++ + 1) {
while ($n % $i == 0) {
$n /= $i;
print STDERR "<$i>" if $opt_d;
$factors {$i} ++;
}
}
if ($n != 1 && $n != $orig) { $factors{$n}++ }
if (! %factors) {
print "PRIME\n";
next ARG;
}
for $factor ( sort { $a <=> $b } keys %factors ) {
print "$factor";
if ($factors{$factor} > 1) {
print "**$factors{$factor}";
}
print " ";
}
print "\n";
}
# this simulates a use, but at run time
sub load_biglib {
require Math::BigInt;
Math::BigInt->import(); #immaterial?
}
if ($string =~ /PATTERN/) {
# is a number
} else {
# is not
}
----------------------------
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+))?$/;
----------------------------
sub getnum {
use POSIX qw(strtod);
my $str = shift;
$str =~ s/^\s+//;
$str =~ s/\s+$//;
$! = 0;
my($num, $unparsed) = strtod($str);
if (($str eq '') || ($unparsed != 0) || $!) {
return;
} else {
return $num;
}
}
sub is_numeric { defined scalar &getnum }
----------------------------
# equal(NUM1, NUM2, ACCURACY) : returns true if NUM1 and NUM2 are
# equal to ACCURACY number of decimal places
sub equal {
my ($A, $B, $dp) = @_;
return sprintf("%.${dp}g", $A) eq sprintf("%.${dp}g", $B);
}
----------------------------
$wage = 536; # $5.36/hour
$week = 40 * $wage; # $214.40
printf("One week's wage is: \$%.2f\n", $week/100);
One week's wage is: $214.40
----------------------------
$rounded = sprintf("%FORMATf", $unrounded);
---------------------------
$a = 0.255;
$b = sprintf("%.2f", $a);
print "Unrounded: $a\nRounded: $b\n";
printf "Unrounded: $a\nRounded: %.2f\n", $a;
Unrounded: 0.255
Rounded: 0.26
Unrounded: 0.255
Rounded: 0.26
---------------------------
use POSIX;
print "number\tint\tfloor\tceil\n";
@a = ( 3.3 , 3.5 , 3.7, -3.3 );
foreach (@a) {
printf( "% .1f\t% .1f\t% .1f\t% .1f\n",
$_, int($_), floor($_), ceil($_) );
}
number int floor ceil
3.3 3.0 3.0 4.0
3.5 3.0 3.0 4.0
3.7 3.0 3.0 4.0
-3.3 -3.0 -4.0 -3.0
---------------------------
sub dec2bin {
my $str = unpack("B32", pack("N", shift));
$str =~ s/^0+(?=\d)//; # otherwise you'll get leading zeros
return $str;
}
---------------------------
sub bin2dec {
return unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
}
---------------------------
$num = bin2dec('0110110'); # $num is 54
$binstr = dec2bin(54); # $binstr is 110110
foreach ($X .. $Y) {
# $_ is set to every integer from X to Y, inclusive
}
foreach $i ($X .. $Y) {
# $i is set to every integer from X to Y, inclusive
}
for ($i = $X; $i <= $Y; $i++) {
# $i is set to every integer from X to Y, inclusive
}
for ($i = $X; $i <= $Y; $i += 7) {
# $i is set to every integer from X to Y, stepsize = 7
}
-----------------------------
print "Infancy is: ";
foreach (0 .. 2) {
print "$_ ";
}
print "\n";
print "Toddling is: ";
foreach $i (3 .. 4) {
print "$i ";
}
print "\n";
print "Childhood is: ";
for ($i = 5; $i <= 12; $i++) {
print "$i ";
}
print "\n";
Infancy is: 0 1 2
Toddling is: 3 4
Childhood is: 5 6 7 8 9 10 11 12
-----------------------------
use Roman;
$roman = roman($arabic); # convert to roman numerals
$arabic = arabic($roman) if isroman($roman); # convert from roman numerals
-----------------------------
use Roman;
$roman_fifteen = roman(15); # "xv"
print "Roman for fifteen is $roman_fifteen\n";
$arabic_fifteen = arabic($roman_fifteen);
print "Converted back, $roman_fifteen is $arabic_fifteen\n";
Roman for fifteen is xv
Converted back, xv is 15
-----------------------------
$random = int( rand( $Y-$X+1 ) ) + $X;
-----------------------------
$random = int( rand(51)) + 25;
print "$random\n";
-----------------------------
$elt = $array[ rand @array ];
-----------------------------
@chars = ( "A" .. "Z", "a" .. "z", 0 .. 9, qw(% ! @ $ % ^ & *) );
$password = join("", @chars[ map { rand @chars } ( 1 .. 8 ) ]);
-----------------------------
srand EXPR;
-----------------------------
use Math::TrulyRandom;
$random = truly_random_value();
use Math::Random;
$random = random_uniform();
-----------------------------
sub gaussian_rand {
my ($u1, $u2); # uniformly distributed random numbers
my $w; # variance, then a weight
my ($g1, $g2); # gaussian-distributed numbers
do {
$u1 = 2 * rand() - 1;
$u2 = 2 * rand() - 1;
$w = $u1*$u1 + $u2*$u2;
} while ( $w >= 1 );
$w = sqrt( (-2 * log($w)) / $w );
$g2 = $u1 * $w;
$g1 = $u2 * $w;
# return both if wanted, else just one
return wantarray ? ($g1, $g2) : $g1;
}
-----------------------------
# weight_to_dist: takes a hash mapping key to weight and returns
# a hash mapping key to probability
sub weight_to_dist {
my %weights = @_;
my %dist = ();
my $total = 0;
my ($key, $weight);
local $_;
foreach (values %weights) {
$total += $_;
}
while ( ($key, $weight) = each %weights ) {
$dist{$key} = $weight/$total;
}
return %dist;
}
# weighted_rand: takes a hash mapping key to probability, and
# returns the corresponding element
sub weighted_rand {
my %dist = @_;
my ($key, $weight);
while (1) { # to avoid floating point inaccuracies
my $rand = rand;
while ( ($key, $weight) = each %dist ) {
return $key if ($rand -= $weight) < 0;
}
}
}
-----------------------------
# gaussian_rand as above
$mean = 25;
$sdev = 2;
$salary = gaussian_rand() * $sdev + $mean;
printf("You have been hired at \$%.2f\n", $salary);
-----------------------------
BEGIN {
use constant PI => 3.14159265358979;
sub deg2rad {
my $degrees = shift;
return ($degrees / 180) * PI;
}
sub rad2deg {
my $radians = shift;
return ($radians / PI) * 180;
}
}
-----------------------------
$radians = deg2rad($degrees);
$degrees = rad2deg($radians);
-----------------------------
# deg2rad and rad2deg defined either as above or from Math::Trig
sub degree_sine {
my $degrees = shift;
my $radians = deg2rad($degrees);
my $result = sin($radians);
return $result;
}
-----------------------------
sub tan {
my $theta = shift;
return sin($theta)/cos($theta);
}
-----------------------------
use POSIX;
$y = acos(3.7);
-----------------------------
use Math::Trig;
$y = acos(3.7);
-----------------------------
eval {
$y = tan($pi/2);
} or return undef;
-----------------------------
$log_e = log(VALUE);
-----------------------------
use POSIX qw(log10);
$log_10 = log10(VALUE);
-----------------------------
sub log_base {
my ($base, $value) = @_;
return log($value)/log($base);
}
-----------------------------
# log_base defined as above
$answer = log_base(10, 10_000);
print "log10(10,000) = $answer\n";
log10(10,000) = 4
-----------------------------
use Math::Complex;
printf "log2(1024) = %lf\n", logn(1024, 2); # watch out for argument order!
log2(1024) = 10.000000
---------------------------
use PDL;
# $a and $b are both pdl objects
$c = $a * $b;
---------------------------
sub mmult {
my ($m1,$m2) = @_;
my ($m1rows,$m1cols) = matdim($m1);
my ($m2rows,$m2cols) = matdim($m2);
unless ($m1cols == $m2rows) { # raise exception
die "IndexError: matrices don't match: $m1cols != $m2rows";
}
my $result = [];
my ($i, $j, $k);
for $i (range($m1rows)) {
for $j (range($m2cols)) {
for $k (range($m1cols)) {
$result->[$i][$j] += $m1->[$i][$k] * $m2->[$k][$j];
}
}
}
return $result;
}
sub range { 0 .. ($_[0] - 1) }
sub veclen {
my $ary_ref = $_[0];
my $type = ref $ary_ref;
if ($type ne "ARRAY") { die "$type is bad array ref for $ary_ref" }
return scalar(@$ary_ref);
}
sub matdim {
my $matrix = $_[0];
my $rows = veclen($matrix);
my $cols = veclen($matrix->[0]);
return ($rows, $cols);
}
----------------------------
$a = pdl [
[ 3, 2, 3 ],
[ 5, 9, 8 ],
];
$b = pdl [
[ 4, 7 ],
[ 9, 3 ],
[ 8, 1 ],
];
$c = $a x $b; # x overload
----------------------------
# $c = $a * $b manually
$c_real = ( $a_real * $b_real ) - ( $a_imaginary * $b_imaginary );
$c_imaginary = ( $a_real * $b_imaginary ) + ( $b_real * $a_imaginary );
----------------------------
# $c = $a * $b using Math::Complex
use Math::Complex;
$c = $a * $b;
----------------------------
$a_real = 3; $a_imaginary = 5; # 3 + 5i;
$b_real = 2; $b_imaginary = -2; # 2 - 2i;
$c_real = ( $a_real * $b_real ) - ( $a_imaginary * $b_imaginary );
$c_imaginary = ( $a_real * $b_imaginary ) + ( $b_real * $a_imaginary );
print "c = ${c_real}+${c_imaginary}i\n";