Initial commit

parents
Showing with 3795 additions and 0 deletions
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.
#!/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?
}
#!/usr/bin/perl
# hopdelta - feed mail header, produce lines
# showing delay at each hop.
use strict;
use Date::Manip qw (ParseDate UnixDate);
# print header; this should really use format/write due to
# printf complexities
printf "%-20.20s %-20.20s %-20.20s %s\n",
"Sender", "Recipient", "Time", "Delta";
$/ = ''; # paragraph mode
$_ = <>; # read header
s/\n\s+/ /g; # join continuation lines
# calculate when and where this started
my($start_from) = /^From.*\@([^\s>]*)/m;
my($start_date) = /^Date:\s+(.*)/m;
my $then = getdate($start_date);
printf "%-20.20s %-20.20s %s\n", 'Start', $start_from, fmtdate($then);
my $prevfrom = $start_from;
# now process the headers lines from the bottom up
for (reverse split(/\n/)) {
my ($delta, $now, $from, $by, $when);
next unless /^Received:/;
s/\bon (.*?) (id.*)/; $1/s; # qmail header, I think
unless (($when) = /;\s+(.*)$/) { # where the date falls
warn "bad received line: $_";
next;
}
($from) = /from\s+(\S+)/;
($from) = /\((.*?)\)/ unless $from; # some put it here
$from =~ s/\)$//; # someone was too greedy
($by) = /by\s+(\S+\.\S+)/; # who sent it on this hop
# now random mungings to get their string parsable
for ($when) {
s/ (for|via) .*$//;
s/([+-]\d\d\d\d) \(\S+\)/$1/;
s/id \S+;\s*//;
}
next unless $now = getdate($when); # convert to Epoch
$delta = $now - $then;
printf "%-20.20s %-20.20s %s ", $from, $by, fmtdate($now);
$prevfrom = $by;
puttime($delta);
$then = $now;
}
exit;
# convert random date strings into Epoch seconds
sub getdate {
my $string = shift;
$string =~ s/\s+\(.*\)\s*$//; # remove nonstd tz
my $date = ParseDate($string);
my $epoch_secs = UnixDate($date,"%s");
return $epoch_secs;
}
# convert Epoch seconds into a particular date string
sub fmtdate {
my $epoch = shift;
my($sec,$min,$hour,$mday,$mon,$year) = localtime($epoch);
return sprintf "%02d:%02d:%02d %04d/%02d/%02d",
$hour, $min, $sec,
$year + 1900, $mon + 1, $mday,
}
# take seconds and print in pleasant-to-read format
sub puttime {
my($seconds) = shift;
my($days, $hours, $minutes);
$days = pull_count($seconds, 24 * 60 * 60);
$hours = pull_count($seconds, 60 * 60);
$minutes = pull_count($seconds, 60);
put_field('s', $seconds);
put_field('m', $minutes);
put_field('h', $hours);
put_field('d', $days);
print "\n";
}
# usage: $count = pull_count(seconds, amount)
# remove from seconds the amount quantity, altering caller's version.
# return the integral number of those amounts so removed.
sub pull_count {
my($answer) = int($_[0] / $_[1]);
$_[0] -= $answer * $_[1];
return $answer;
}
# usage: put_field(char, number)
# output number field in 3-place decimal format, with trailing char
# suppress output unless char is 's' for seconds
sub put_field {
my ($char, $number) = @_;
printf " %3d%s", $number, $char if $number || $char eq 's';
}
#!/usr/bin/perl -w
# commify_series - show proper comma insertion in list output
@lists = (
[ 'just one thing' ],
[ qw(Mutt Jeff) ],
[ qw(Peter Paul Mary) ],
[ 'To our parents', 'Mother Theresa', 'God' ],
[ 'pastrami', 'ham and cheese', 'peanut butter and jelly', 'tuna' ],
[ 'recycle tired, old phrases', 'ponder big, happy thoughts' ],
[ 'recycle tired, old phrases',
'ponder big, happy thoughts',
'sleep and dream peacefully' ],
);
foreach $aref (@lists) {
print "The list is: " . commify_series(@$aref) . ".\n";
}
sub commify_series {
my $sepchar = grep(/,/ => @_) ? ";" : ",";
(@_ == 0) ? '' :
(@_ == 1) ? $_[0] :
(@_ == 2) ? join(" and ", @_) :
join("$sepchar ", @_[0 .. ($#_-1)], "and $_[-1]");
}
#!/usr/bin/perl -w
# mjd_permute: permute each word of input
use strict;
while (<>) {
my @data = split;
my $num_permutations = factorial(scalar @data);
for (my $i=0; $i < $num_permutations; $i++) {
my @permutation = @data[n2perm($i, $#data)];
print "@permutation\n";
}
}
# Utility function: factorial with memorizing
BEGIN {
my @fact = (1);
sub factorial($) {
my $n = shift;
return $fact[$n] if defined $fact[$n];
$fact[$n] = $n * factorial($n - 1);
}
}
# n2pat($N, $len) : produce the $N-th pattern of length $len
sub n2pat {
my $i = 1;
my $N = shift;
my $len = shift;
my @pat;
while ($i <= $len + 1) { # Should really be just while ($N) { ...
push @pat, $N % $i;
$N = int($N/$i);
$i++;
}
return @pat;
}
# pat2perm(@pat) : turn pattern returned by n2pat() into
# permutation of integers. XXX: splice is already O(N)
sub pat2perm {
my @pat = @_;
my @source = (0 .. $#pat);
my @perm;
push @perm, splice(@source, (pop @pat), 1) while @pat;
return @perm;
}
# n2perm($N, $len) : generate the Nth permutation of S objects
sub n2perm {
pat2perm(n2pat(@_));
}
#!/usr/bin/perl -n
# tsc_permute: permute each word of input
permute([split], []);
sub permute {
my @items = @{ $_[0] };
my @perms = @{ $_[1] };
unless (@items) {
print "@perms\n";
} else {
my(@newitems,@newperms,$i);
foreach $i (0 .. $#items) {
@newitems = @items;
@newperms = @perms;
unshift(@newperms, splice(@newitems, $i, 1));
permute([@newitems], [@newperms]);
}
}
}
#!/usr/bin/perl -w
# words - gather lines, present in columns
use strict;
my ($item, $cols, $rows, $maxlen);
my ($xpixel, $ypixel, $mask, @data);
getwinsize();
# first gather up every line of input,
# remembering the longest line length seen
$maxlen = 1;
while (<>) {
my $mylen;
s/\s+$//;
$maxlen = $mylen if (($mylen = length) > $maxlen);
push(@data, $_);
}
$maxlen += 1; # to make extra space
# determine boundaries of screen
$cols = int($cols / $maxlen) || 1;
$rows = int(($#data+$cols) / $cols);
# pre-create mask for faster computation
$mask = sprintf("%%-%ds ", $maxlen-1);
# subroutine to check whether at last item on line
sub EOL { ($item+1) % $cols == 0 }
# now process each item, picking out proper piece for this position
for ($item = 0; $item < $rows * $cols; $item++) {
my $target = ($item % $cols) * $rows + int($item/$cols);
my $piece = sprintf($mask, $target < @data ? $data[$target] : "");
$piece =~ s/\s+$// if EOL(); # don't blank-pad to EOL
print $piece;
print "\n" if EOL();
}
# finish up if needed
print "\n" if EOL();
# not portable -- linux only
sub getwinsize {
my $winsize = "\0" x 8;
my $TIOCGWINSZ = 0x40087468;
if (ioctl(STDOUT, $TIOCGWINSZ, $winsize)) {
($rows, $cols, $xpixel, $ypixel) = unpack('S4', $winsize);
} else {
$cols = 80;
}
}
#!/usr/bin/perl
# countfrom - count number of messages from each sender
$filename = $ARGV[0] || "-";
open(FILE, "<$filename") or die "Can't open $filename : $!";
while(<FILE>) {
if (/^From: (.*)/) { $from{$1}++ }
}
foreach $person (sort keys %from) {
print "$person: $from{$person}\n";
}
#!/usr/bin/perl -w
# dutree - print sorted indented rendition of du output
use strict;
my %Dirsize;
my %Kids;
getdots(my $topdir = input());
output($topdir);
# run du, read in input, save sizes and kids
# return last directory (file?) read
sub input {
my($size, $name, $parent);
@ARGV = ("du @ARGV |"); # prep the arguments
while (<>) { # magic open is our friend
($size, $name) = split;
$Dirsize{$name} = $size;
($parent = $name) =~ s#/[^/]+$##; # dirname
push @{ $Kids{$parent} }, $name unless eof;
}
return $name;
}
# figure out how much is taken up in each directory
# that isn't stored in subdirectories. add a new
# fake kid called "." containing that much.
sub getdots {
my $root = $_[0];
my($size, $cursize);
$size = $cursize = $Dirsize{$root};
if ($Kids{$root}) {
for my $kid (@{ $Kids{$root} }) {
$cursize -= $Dirsize{$kid};
getdots($kid);
}
}
if ($size != $cursize) {
my $dot = "$root/.";
$Dirsize{$dot} = $cursize;
push @{ $Kids{$root} }, $dot;
}
}
# recursively output everything,
# passing padding and number width in as well
# on recursive calls
sub output {
my($root, $prefix, $width) = (shift, shift || '', shift || 0);
my $path;
($path = $root) =~ s#.*/##; # basename
my $size = $Dirsize{$root};
my $line = sprintf("%${width}d %s", $size, $path);
print $prefix, $line, "\n";
for ($prefix .= $line) { # build up more output
s/\d /| /;
s/[^|]/ /g;
}
if ($Kids{$root}) { # not a bachelor node
my @Kids = @{ $Kids{$root} };
@Kids = sort { $Dirsize{$b} <=> $Dirsize{$a} } @Kids;
$Dirsize{$Kids[0]} =~ /(\d+)/;
my $width = length $1;
for my $kid (@Kids) { output($kid, $prefix, $width) }
}
}
#!/usr/bin/perl
# dutree_orig: the old version pre-perl5 (early 90s)
@lines = `du @ARGV`;
chop(@lines);
&input($top = pop @lines);
&output($top);
exit;
sub input {
local($root, *kid, $him) = @_[0,0];
while (@lines && &childof($root, $lines[$#lines])) {
&input($him = pop(@lines));
push(@kid, $him);
i}
if (@kid) {
local($mysize) = ($root =~ /^(\d+)/);
for (@kid) { $mysize -= (/^(\d+)/)[0]; }
push(@kid, "$mysize .") if $size != $mysize;
}
@kid = &sizesort(*kid);
}
sub output {
local($root, *kid, $prefix) = @_[0,0,1];
local($size, $path) = split(' ', $root);
$path =~ s!.*/!!;
$line = sprintf("%${width}d %s", $size, $path);
print $prefix, $line, "\n";
$prefix .= $line;
$prefix =~ s/\d /| /;
$prefix =~ s/[^|]/ /g;
local($width) = $kid[0] =~ /(\d+)/ && length("$1");
for (@kid) { &output($_, $prefix); };
}
sub sizesort {
local(*list, @index) = shift;
sub bynum { $index[$b] <=> $index[$a]; }
for (@list) { push(@index, /(\d+)/); }
@list[sort bynum 0..$#list];
}
sub childof {
local(@pair) = @_;
for (@pair) { s/^\d+\s+//g; s/$/\//; }
index($pair[1], $pair[0]) >= 0;
}
#!/usr/bin/perl -w
# foodfind - find match for food or color
$given = shift @ARGV or die "usage: foodfind food_or_color\n";
%color = (
"Apple" => "red",
"Banana" => "yellow",
"Lemon" => "yellow",
"Carrot" => "orange"
);
%food = reverse %color;
if (exists $color{$given}) {
print "$given is a food with color $color{$given}.\n";
}
if (exists $food{$given}) {
print "$food{$given} is a food with color $given.\n";
}
#!/usr/bin/perl
# grepauth - print lines that mention both Tom and Nat
$multimatch = build_match_all(q/Tom/, q/Nat/);
while (<>) {
print if &$multimatch;
}
exit;
sub build_match_any { build_match_func('||', @_) }
sub build_match_all { build_match_func('&&', @_) }
sub build_match_func {
my $condition = shift;
my @pattern = @_; # must be lexical variable, not dynamic one
my $expr = join $condition => map { "m/\$pattern[$_]/o" } (0..$#pattern);
my $match_func = eval "sub { local \$_ = shift if \@_; $expr }";
die if $@; # propagate $@; this shouldn't happen!
return $match_func;
}
#!/usr/bin/perl
# headerfy: change certain chapter headers to html
$/ = '';
while ( <> ) { # fetch a paragraph
s{
\A # start of record
( # capture in $1
Chapter # text string
\s+ # mandatory whitespace
\d+ # decimal number
\s* # optional whitespace
: # a real colon
. * # anything not a newline till end of line
)
}{<H1>$1</H1>}gx;
print;
}
#!/usr/bin/perl
# killtags - very bad html tag killer
undef $/; # each read is whole file
while (<>) { # get one whole file at a time
s/<.*?>//gs; # strip tags (terribly)
print; # print file to STDOUT
}
#!/usr/bin/perl -w
# localeg - demonstrate locale effects
use locale;
use POSIX 'locale_h';
$name = "andreas k\xF6nig";
@locale{qw(German English)} = qw(de_DE.ISO_8859-1 us-ascii);
setlocale(LC_CTYPE, $locale{English})
or die "Invalid locale $locale{English}";
@english_names = ();
while ($name =~ /\b(\w+)\b/g) {
push(@english_names, ucfirst($1));
}
setlocale(LC_CTYPE, $locale{German})
or die "Invalid locale $locale{German}";
@german_names = ();
while ($name =~ /\b(\w+)\b/g) {
push(@german_names, ucfirst($1));
}
print "English names: @english_names\n";
print "German names: @german_names\n";
#!/usr/bin/perl
# minigrep - trivial grep
$pat = shift;
while (<>) {
print if /$pat/o;
}
#!/usr/bin/perl
# paragrep - trivial paragraph grepper
die "usage: $0 pat [files]\n" unless @ARGV;
$/ = '';
$pat = shift;
eval { "" =~ /$pat/; 1 } or die "$0: Bad pattern $pat: $@\n";
while (<>) {
print "$ARGV $.: $_" if /$pat/o;
}
# popgrep1 - grep for abbreviations of places that say "pop"
# version 1: slow but obvious way
@popstates = qw(CO ON MI WI MN);
LINE: while (defined($line = <>)) {
for $state (@popstates) {
if ($line =~ /\b$state\b/) {
print; next LINE;
}
}
}
#!/usr/bin/perl
# popgrep2 - grep for abbreviations of places that say "pop"
# version 2: eval strings; fast but hard to quote
@popstates = qw(CO ON MI WI MN);
$code = 'while (defined($line = <>)) {';
for $state (@popstates) {
$code .= "\tif (\$line =~ /\\b$state\\b/) { print \$line; next; }\n";
}
$code .= '}';
print "CODE IS\n----\n$code\n----\n" if 0; # turn on to debug
eval $code;
die if $@;
#!/usr/bin/perl
# popgrep3 - grep for abbreviations of places that say "pop"
# version 3: use build_match_func algorithm
@popstates = qw(CO ON MI WI MN);
$expr = join('||', map { "m/\\b\$popstates[$_]\\b/o" } 0..$#popstates);
$match_any = eval "sub { $expr }";
die if $@;
while (<>) {
print if &$match_any;
}
#!/usr/bin/perl
# popgrep4 - grep for abbreviations of places that say "pop"
# version 4: use Regexp module
use Regexp;
@popstates = qw(CO ON MI WI MN);
@poppats = map { Regexp->new( '\b' . $_ . '\b') } @popstates;
while (defined($line = <>)) {
for $patobj (@poppats) {
print $line if $patobj->match($line);
}
}
#!/usr/bin/perl
# prime_pattern -- find prime factors of argument using pattern matching
for ($N = ('o' x shift); $N =~ /^(oo+?)\1+$/; $N =~ s/$1/o/g) {
print length($1), " ";
}
print length ($N), "\n";
#!/usr/bin/perl -p
# resname - change all "foo.bar.com" style names in the input stream
# into "foo.bar.com [204.148.40.9]" (or whatever) instead
use Socket; # load inet_addr
s{ #
( # capture the hostname in $1
(?: # these parens for grouping only
(?! [-_] ) # lookahead for neither underscore nor dash
[\w-] + # hostname component
\. # and the domain dot
) + # now repeat that whole thing a bunch of times
</