#-----------------------------
while ($string =~ s//t+/' ' x (length(___FCKpd___7amp;) * 8 - length(
#-----------------------------
$string = '/n'; # two characters, / and an n
$string = 'Jon /'Maddog/' Orwant'; # literal single quotes
#-----------------------------
$string = "/n"; # a "newline" character
$string = "Jon /"Maddog/" Orwant"; # literal double quotes
#-----------------------------
$string = q/Jon 'Maddog' Orwant/; # literal single quotes
#-----------------------------
$string = q[Jon 'Maddog' Orwant]; # literal single quotes
$string = q{Jon 'Maddog' Orwant}; # literal single quotes
$string = q(Jon 'Maddog' Orwant); # literal single quotes
$string = q<Jon 'Maddog' Orwant>; # literal single quotes
#-----------------------------
$a = <<"EOF";
This is a multiline here document
terminated by EOF on a line by itself
EOF
#-----------------------------
|
#-----------------------------
$value = substr($string, $offset, $count);
$value = substr($string, $offset);
substr($string, $offset, $count) = $newstring;
substr($string, $offset) = $newtail;
#-----------------------------
# get a 5-byte string, skip 3, then grab 2 8-byte strings, then the rest
($leading, $s1, $s2, $trailing) =
unpack("A5 x3 A8 A8 A*", $data);
# split at five byte boundaries
@fivers = unpack("A5" x (length($string)/5), $string);
# chop string into individual characters
@chars = unpack("A1" x length($string), $string);
#-----------------------------
$string = "This is what you have";
# +012345678901234567890 Indexing forwards (left to right)
# 109876543210987654321- Indexing backwards (right to left)
# note that 0 means 10 or 20, etc. above
$first = substr($string, 0, 1); # "T"
$start = substr($string, 5, 2); # "is"
$rest = substr($string, 13); # "you have"
$last = substr($string, -1); # "e"
$end = substr($string, -4); # "have"
$piece = substr($string, -8, 3); # "you"
#-----------------------------
$string = "This is what you have";
print $string;
#This is what you have
substr($string, 5, 2) = "wasn't"; # change "is" to "wasn't"
#This wasn't what you have
substr($string, -12) = "ondrous";# replace last 12 characters
#This wasn't wondrous
substr($string, 0, 1) = ""; # delete first character
#his wasn't wondrous
substr($string, -10) = ""; # delete last 10 characters
#his wasn'
#-----------------------------
# you can test substrings with =~
if (substr($string, -10) =~ /pattern/) {
print "Pattern matches in last 10 characters/n";
}
# substitute "at" for "is", restricted to first five characters
substr($string, 0, 5) =~ s/is/at/g;
#-----------------------------
# exchange the first and last letters in a string
$a = "make a hat";
(substr($a,0,1), substr($a,-1)) = (substr($a,-1), substr($a,0,1));
print $a;
# take a ham
#-----------------------------
# extract column with unpack
$a = "To be or not to be";
$b = unpack("x6 A6", $a); # skip 6, grab 6
print $b;
# or not
($b, $c) = unpack("x6 A2 X5 A2", $a); # forward 6, grab 2; backward 5, grab 2
print "$b/n$c/n";
# or
#
# be
#-----------------------------
sub cut2fmt {
my(@positions) = @_;
my $template = '';
my $lastpos = 1;
foreach $place (@positions) {
$template .= "A" . ($place - $lastpos) . " ";
$lastpos = $place;
}
$template .= "A*";
return $template;
}
$fmt = cut2fmt(8, 14, 20, 26, 30);
print "$fmt/n";
# A7 A6 A6 A6 A4 A*
#-----------------------------
|
#-----------------------------
# use $b if $b is true, else $c
$a = $b || $c;
# set $x to $y unless $x is already true
$x ||= $y
#-----------------------------
# use $b if $b is defined, else $c
$a = defined($b) ? $b : $c;
#-----------------------------
$foo = $bar || "DEFAULT VALUE";
#-----------------------------
$dir = shift(@ARGV) || "/tmp";
#-----------------------------
$dir = $ARGV[0] || "/tmp";
#-----------------------------
$dir = defined($ARGV[0]) ? shift(@ARGV) : "/tmp";
#-----------------------------
$dir = @ARGV ? $ARGV[0] : "/tmp";
#-----------------------------
$count{ $shell || "/bin/sh" }++;
#-----------------------------
# find the user name on Unix systems
$user = $ENV{USER}
|| $ENV{LOGNAME}
|| getlogin()
|| (getpwuid(___FCKpd___2lt;))[0]
|| "Unknown uid number ___FCKpd___2lt;";
#-----------------------------
$starting_point ||= "Greenwich";
#-----------------------------
@a = @b unless @a; # copy only if empty
@a = @b ? @b : @c; # assign @b if nonempty, else @c
#-----------------------------
|
#-----------------------------
($VAR1, $VAR2) = ($VAR2, $VAR1);
#-----------------------------
$temp = $a;
$a = $b;
$b = $temp;
#-----------------------------
$a = "alpha";
$b = "omega";
($a, $b) = ($b, $a); # the first shall be last -- and versa vice
#-----------------------------
($alpha, $beta, $production) = qw(January March August);
# move beta to alpha,
# move production to beta,
# move alpha to production
($alpha, $beta, $production) = ($beta, $production, $alpha);
#-----------------------------
|
#-----------------------------
$num = ord($char);
$char = chr($num);
#-----------------------------
$char = sprintf("%c", $num); # slower than chr($num)
printf("Number %d is character %c/n", $num, $num);
Number 101 is character e
#-----------------------------
@ASCII = unpack("C*", $string);
$STRING = pack("C*", @ascii);
#-----------------------------
$ascii_value = ord("e"); # now 101
$character = chr(101); # now "e"
#-----------------------------
printf("Number %d is character %c/n", 101, 101);
#-----------------------------
@ascii_character_numbers = unpack("C*", "sample");
print "@ascii_character_numbers/n";
115 97 109 112 108 101
$word = pack("C*", @ascii_character_numbers);
$word = pack("C*", 115, 97, 109, 112, 108, 101); # same
print "$word/n";
sample
#-----------------------------
$hal = "HAL";
@ascii = unpack("C*", $hal);
foreach $val (@ascii) {
$val++; # add one to each ASCII value
}
$ibm = pack("C*", @ascii);
print "$ibm/n"; # prints "IBM"
#-----------------------------
|
#-----------------------------
@array = split(//, $string);
@array = unpack("C*", $string);
#-----------------------------
while (/(.)/g) { # . is never a newline here
# do something with $1
}
#-----------------------------
%seen = ();
$string = "an apple a day";
foreach $byte (split //, $string) {
$seen{$byte}++;
}
print "unique chars are: ", sort(keys %seen), "/n";
unique chars are: adelnpy
#-----------------------------
%seen = ();
$string = "an apple a day";
while ($string =~ /(.)/g) {
$seen{$1}++;
}
print "unique chars are: ", sort(keys %seen), "/n";
unique chars are: adelnpy
#-----------------------------
$sum = 0;
foreach $ascval (unpack("C*", $string)) {
$sum += $ascval;
}
print "sum is $sum/n";
# prints "1248" if $string was "an apple a day"
#-----------------------------
$sum = unpack("%32C*", $string);
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# sum - compute 16-bit checksum of all input files
$checksum = 0;
while (<>) { $checksum += unpack("%16C*", $_) }
$checksum %= (2 ** 16) - 1;
print "$checksum/n";
#-----------------------------
#% perl sum /etc/termcap
#1510
#-----------------------------
#% sum --sysv /etc/termcap
#1510 851 /etc/termcap
#-----------------------------
# download the following standalone program
#!/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);
}
}
#-----------------------------
|
#-----------------------------
$revbytes = reverse($string);
#-----------------------------
$revwords = join(" ", reverse split(" ", $string));
#-----------------------------
$gnirts = reverse($string); # reverse letters in $string
@sdrow = reverse(@words); # reverse elements in @words
$confused = reverse(@words); # reverse letters in join("", @words)
#-----------------------------
# reverse word order
$string = 'Yoda said, "can you see this?"';
@allwords = split(" ", $string);
$revwords = join(" ", reverse @allwords);
print $revwords, "/n";
this?" see you "can said, Yoda
#-----------------------------
$revwords = join(" ", reverse split(" ", $string));
#-----------------------------
$revwords = join("", reverse split(/(/s+)/, $string));
#-----------------------------
$word = "reviver";
$is_palindrome = ($word eq reverse($word));
#-----------------------------
#% perl -nle 'print if $_ eq reverse && length > 5' /usr/dict/words
#deedeed
#
#degged
#
#deified
#
#denned
#
#hallah
#
#kakkak
#
#murdrum
#
#redder
#
#repaper
#
#retter
#
#reviver
#
#rotator
#
#sooloos
#
#tebbet
#
#terret
#
#tut-tut
#-----------------------------
|
) % 8)/e) {
# spin in empty loop until substitution finally fails
}
#-----------------------------
use Text::Tabs;
@expanded_lines = expand(@lines_with_tabs);
@tabulated_lines = unexpand(@lines_without_tabs);
#-----------------------------
while (<>) {
1 while s//t+/' ' x (length(___FCKpd___7amp;) * 8 - length(
#-----------------------------
$string = '/n'; # two characters, / and an n
$string = 'Jon /'Maddog/' Orwant'; # literal single quotes
#-----------------------------
$string = "/n"; # a "newline" character
$string = "Jon /"Maddog/" Orwant"; # literal double quotes
#-----------------------------
$string = q/Jon 'Maddog' Orwant/; # literal single quotes
#-----------------------------
$string = q[Jon 'Maddog' Orwant]; # literal single quotes
$string = q{Jon 'Maddog' Orwant}; # literal single quotes
$string = q(Jon 'Maddog' Orwant); # literal single quotes
$string = q<Jon 'Maddog' Orwant>; # literal single quotes
#-----------------------------
$a = <<"EOF";
This is a multiline here document
terminated by EOF on a line by itself
EOF
#-----------------------------
|
#-----------------------------
$value = substr($string, $offset, $count);
$value = substr($string, $offset);
substr($string, $offset, $count) = $newstring;
substr($string, $offset) = $newtail;
#-----------------------------
# get a 5-byte string, skip 3, then grab 2 8-byte strings, then the rest
($leading, $s1, $s2, $trailing) =
unpack("A5 x3 A8 A8 A*", $data);
# split at five byte boundaries
@fivers = unpack("A5" x (length($string)/5), $string);
# chop string into individual characters
@chars = unpack("A1" x length($string), $string);
#-----------------------------
$string = "This is what you have";
# +012345678901234567890 Indexing forwards (left to right)
# 109876543210987654321- Indexing backwards (right to left)
# note that 0 means 10 or 20, etc. above
$first = substr($string, 0, 1); # "T"
$start = substr($string, 5, 2); # "is"
$rest = substr($string, 13); # "you have"
$last = substr($string, -1); # "e"
$end = substr($string, -4); # "have"
$piece = substr($string, -8, 3); # "you"
#-----------------------------
$string = "This is what you have";
print $string;
#This is what you have
substr($string, 5, 2) = "wasn't"; # change "is" to "wasn't"
#This wasn't what you have
substr($string, -12) = "ondrous";# replace last 12 characters
#This wasn't wondrous
substr($string, 0, 1) = ""; # delete first character
#his wasn't wondrous
substr($string, -10) = ""; # delete last 10 characters
#his wasn'
#-----------------------------
# you can test substrings with =~
if (substr($string, -10) =~ /pattern/) {
print "Pattern matches in last 10 characters/n";
}
# substitute "at" for "is", restricted to first five characters
substr($string, 0, 5) =~ s/is/at/g;
#-----------------------------
# exchange the first and last letters in a string
$a = "make a hat";
(substr($a,0,1), substr($a,-1)) = (substr($a,-1), substr($a,0,1));
print $a;
# take a ham
#-----------------------------
# extract column with unpack
$a = "To be or not to be";
$b = unpack("x6 A6", $a); # skip 6, grab 6
print $b;
# or not
($b, $c) = unpack("x6 A2 X5 A2", $a); # forward 6, grab 2; backward 5, grab 2
print "$b/n$c/n";
# or
#
# be
#-----------------------------
sub cut2fmt {
my(@positions) = @_;
my $template = '';
my $lastpos = 1;
foreach $place (@positions) {
$template .= "A" . ($place - $lastpos) . " ";
$lastpos = $place;
}
$template .= "A*";
return $template;
}
$fmt = cut2fmt(8, 14, 20, 26, 30);
print "$fmt/n";
# A7 A6 A6 A6 A4 A*
#-----------------------------
|
#-----------------------------
# use $b if $b is true, else $c
$a = $b || $c;
# set $x to $y unless $x is already true
$x ||= $y
#-----------------------------
# use $b if $b is defined, else $c
$a = defined($b) ? $b : $c;
#-----------------------------
$foo = $bar || "DEFAULT VALUE";
#-----------------------------
$dir = shift(@ARGV) || "/tmp";
#-----------------------------
$dir = $ARGV[0] || "/tmp";
#-----------------------------
$dir = defined($ARGV[0]) ? shift(@ARGV) : "/tmp";
#-----------------------------
$dir = @ARGV ? $ARGV[0] : "/tmp";
#-----------------------------
$count{ $shell || "/bin/sh" }++;
#-----------------------------
# find the user name on Unix systems
$user = $ENV{USER}
|| $ENV{LOGNAME}
|| getlogin()
|| (getpwuid(___FCKpd___2lt;))[0]
|| "Unknown uid number ___FCKpd___2lt;";
#-----------------------------
$starting_point ||= "Greenwich";
#-----------------------------
@a = @b unless @a; # copy only if empty
@a = @b ? @b : @c; # assign @b if nonempty, else @c
#-----------------------------
|
#-----------------------------
($VAR1, $VAR2) = ($VAR2, $VAR1);
#-----------------------------
$temp = $a;
$a = $b;
$b = $temp;
#-----------------------------
$a = "alpha";
$b = "omega";
($a, $b) = ($b, $a); # the first shall be last -- and versa vice
#-----------------------------
($alpha, $beta, $production) = qw(January March August);
# move beta to alpha,
# move production to beta,
# move alpha to production
($alpha, $beta, $production) = ($beta, $production, $alpha);
#-----------------------------
|
#-----------------------------
$num = ord($char);
$char = chr($num);
#-----------------------------
$char = sprintf("%c", $num); # slower than chr($num)
printf("Number %d is character %c/n", $num, $num);
Number 101 is character e
#-----------------------------
@ASCII = unpack("C*", $string);
$STRING = pack("C*", @ascii);
#-----------------------------
$ascii_value = ord("e"); # now 101
$character = chr(101); # now "e"
#-----------------------------
printf("Number %d is character %c/n", 101, 101);
#-----------------------------
@ascii_character_numbers = unpack("C*", "sample");
print "@ascii_character_numbers/n";
115 97 109 112 108 101
$word = pack("C*", @ascii_character_numbers);
$word = pack("C*", 115, 97, 109, 112, 108, 101); # same
print "$word/n";
sample
#-----------------------------
$hal = "HAL";
@ascii = unpack("C*", $hal);
foreach $val (@ascii) {
$val++; # add one to each ASCII value
}
$ibm = pack("C*", @ascii);
print "$ibm/n"; # prints "IBM"
#-----------------------------
|
#-----------------------------
@array = split(//, $string);
@array = unpack("C*", $string);
#-----------------------------
while (/(.)/g) { # . is never a newline here
# do something with $1
}
#-----------------------------
%seen = ();
$string = "an apple a day";
foreach $byte (split //, $string) {
$seen{$byte}++;
}
print "unique chars are: ", sort(keys %seen), "/n";
unique chars are: adelnpy
#-----------------------------
%seen = ();
$string = "an apple a day";
while ($string =~ /(.)/g) {
$seen{$1}++;
}
print "unique chars are: ", sort(keys %seen), "/n";
unique chars are: adelnpy
#-----------------------------
$sum = 0;
foreach $ascval (unpack("C*", $string)) {
$sum += $ascval;
}
print "sum is $sum/n";
# prints "1248" if $string was "an apple a day"
#-----------------------------
$sum = unpack("%32C*", $string);
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# sum - compute 16-bit checksum of all input files
$checksum = 0;
while (<>) { $checksum += unpack("%16C*", $_) }
$checksum %= (2 ** 16) - 1;
print "$checksum/n";
#-----------------------------
#% perl sum /etc/termcap
#1510
#-----------------------------
#% sum --sysv /etc/termcap
#1510 851 /etc/termcap
#-----------------------------
# download the following standalone program
#!/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);
}
}
#-----------------------------
|
#-----------------------------
$revbytes = reverse($string);
#-----------------------------
$revwords = join(" ", reverse split(" ", $string));
#-----------------------------
$gnirts = reverse($string); # reverse letters in $string
@sdrow = reverse(@words); # reverse elements in @words
$confused = reverse(@words); # reverse letters in join("", @words)
#-----------------------------
# reverse word order
$string = 'Yoda said, "can you see this?"';
@allwords = split(" ", $string);
$revwords = join(" ", reverse @allwords);
print $revwords, "/n";
this?" see you "can said, Yoda
#-----------------------------
$revwords = join(" ", reverse split(" ", $string));
#-----------------------------
$revwords = join("", reverse split(/(/s+)/, $string));
#-----------------------------
$word = "reviver";
$is_palindrome = ($word eq reverse($word));
#-----------------------------
#% perl -nle 'print if $_ eq reverse && length > 5' /usr/dict/words
#deedeed
#
#degged
#
#deified
#
#denned
#
#hallah
#
#kakkak
#
#murdrum
#
#redder
#
#repaper
#
#retter
#
#reviver
#
#rotator
#
#sooloos
#
#tebbet
#
#terret
#
#tut-tut
#-----------------------------
|
) % 8)/e;
print;
}
#-----------------------------
use Text::Tabs;
$tabstop = 4;
while (<>) { print expand($_) }
#-----------------------------
use Text::Tabs;
while (<>) { print unexpand($_) }
#-----------------------------
|
#-----------------------------
#You owe $debt to me.
#-----------------------------
$text =~ s//$(/w+)/${$1}/g;
#-----------------------------
$text =~ s/(/$/w+)/$1/gee;
#-----------------------------
use vars qw($rows $cols);
no strict 'refs'; # for ${$1}/g below
my $text;
($rows, $cols) = (24, 80);
$text = q(I am $rows high and $cols long); # like single quotes!
$text =~ s//$(/w+)/${$1}/g;
print $text;
I am 24 high and 80 long
#-----------------------------
$text = "I am 17 years old";
$text =~ s/(/d+)/2 * $1/eg;
#-----------------------------
2 * 17
#-----------------------------
$text = 'I am $AGE years old'; # note single quotes
$text =~ s/(/$/w+)/$1/eg; # WRONG
#-----------------------------
'$AGE'
#-----------------------------
$text =~ s/(/$/w+)/$1/eeg; # finds my() variables
#-----------------------------
# expand variables in $text, but put an error message in
# if the variable isn't defined
$text =~ s{
/$ # find a literal dollar sign
(/w+) # find a "word" and store it in $1
}{
no strict 'refs'; # for $1 below
if (defined ${$1}) {
${$1}; # expand global variables only
} else {
"[NO VARIABLE: /$1]"; # error msg
}
}egx;
#-----------------------------
|
#-----------------------------
use locale; # needed in 5.004 or above
$big = uc($little); # "bo peep" -> "BO PEEP"
$little = lc($big); # "JOHN" -> "john"
$big = "/U$little"; # "bo peep" -> "BO PEEP"
$little = "/L$big"; # "JOHN" -> "john"
#-----------------------------
$big = "/u$little"; # "bo" -> "Bo"
$little = "/l$big"; # "BoPeep" -> "boPeep"
#-----------------------------
use locale; # needed in 5.004 or above
$beast = "dromedary";
# capitalize various parts of $beast
$capit = ucfirst($beast); # Dromedary
$capit = "/u/L$beast"; # (same)
$capall = uc($beast); # DROMEDARY
$capall = "/U$beast"; # (same)
$caprest = lcfirst(uc($beast)); # dROMEDARY
$caprest = "/l/U$beast"; # (same)
#-----------------------------
# capitalize each word's first character, downcase the rest
$text = "thIS is a loNG liNE";
$text =~ s/(/w+)//u/L$1/g;
print $text;
This Is A Long Line
#-----------------------------
if (uc($a) eq uc($b)) {
print "a and b are the same/n";
}
#-----------------------------
# download the following standalone program
#!/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;
#% randcap < genesis | head -9
#boOk 01 genesis
#
#
#001:001 in the BEginning goD created the heaven and tHe earTh.
#
#
#
#001:002 and the earth wAS without ForM, aND void; AnD darkneSS was
#
# upon The Face of the dEEp. and the spIrit of GOd movEd upOn
#
# tHe face of the Waters.
#
#
#001:003 and god Said, let there be ligHt: and therE wAs LigHt.
#-----------------------------
sub randcase {
rand(100) < 20 ? ("/040" ^ $_[0]) : $_[0];
}
#-----------------------------
$string &= "/177" x length($string);
#-----------------------------
|
#-----------------------------
$answer = $var1 . func() . $var2; # scalar only
#-----------------------------
$answer = "STRING @{[ LIST EXPR ]} MORE STRING";
$answer = "STRING ${/( SCALAR EXPR )} MORE STRING";
#-----------------------------
$phrase = "I have " . ($n + 1) . " guanacos.";
$phrase = "I have ${/($n + 1)} guanacos.";
#-----------------------------
print "I have ", $n + 1, " guanacos./n";
#-----------------------------
some_func("What you want is @{[ split /:/, $rec ]} items");
#-----------------------------
die "Couldn't send mail" unless send_mail(<<"EOTEXT", $target);
To: $naughty
From: Your Bank
Cc: @{ get_manager_list($naughty) }
Date: @{[ do { my $now = `date`; chomp $now; $now } ]} (today)
Dear $naughty,
Today, you bounced check number @{[ 500 + int rand(100) ]} to us.
Your account is now closed.
Sincerely,
the management
EOTEXT
#-----------------------------
|
#-----------------------------
# all in one
($var = <<HERE_TARGET) =~ s/^/s+//gm;
your text
goes here
HERE_TARGET
# or with two steps
$var = <<HERE_TARGET;
your text
goes here
HERE_TARGET
$var =~ s/^/s+//gm;
#-----------------------------
($definition = <<'FINIS') =~ s/^/s+//gm;
The five varieties of camelids
are the familiar camel, his friends
the llama and the alpaca, and the
rather less well-known guanaco
and vicu馻.
FINIS
#-----------------------------
sub fix {
my $string = shift;
$string =~ s/^/s+//gm;
return $string;
}
print fix(<<"END");
My stuff goes here
END
# With function predeclaration, you can omit the parens:
print fix <<"END";
My stuff goes here
END
#-----------------------------
($quote = <<' FINIS') =~ s/^/s+//gm;
...we will have peace, when you and all your works have
perished--and the works of your dark master to whom you would
deliver us. You are a liar, Saruman, and a corrupter of mens
hearts. --Theoden in /usr/src/perl/taint.c
FINIS
$quote =~ s//s+--//n--/; #move attribution to line of its own
#-----------------------------
if ($REMEMBER_THE_MAIN) {
$perl_main_C = dequote<<' MAIN_INTERPRETER_LOOP';
@@@ int
@@@ runops() {
@@@ SAVEI32(runlevel);
@@@ runlevel++;
@@@ while ( op = (*op->op_ppaddr)() ) ;
@@@ TAINT_NOT;
@@@ return 0;
@@@ }
MAIN_INTERPRETER_LOOP
# add more code here if you want
}
#-----------------------------
sub dequote;
$poem = dequote<<EVER_ON_AND_ON;
Now far ahead the Road has gone,
And I must follow, if I can,
Pursuing it with eager feet,
Until it joins some larger way
Where many paths and errands meet.
And whither then? I cannot say.
--Bilbo in /usr/src/perl/pp_ctl.c
EVER_ON_AND_ON
print "Here's your poem:/n/n$poem/n";
#-----------------------------
#Here's your poem:
#
#Now far ahead the Road has gone,
#
# And I must follow, if I can,
#
#Pursuing it with eager feet,
#
# Until it joins some larger way
#
#Where many paths and errands meet.
#
# And whither then? I cannot say.
#
# --Bilbo in /usr/src/perl/pp_ctl.c
#-----------------------------
sub dequote {
local $_ = shift;
my ($white, $leader); # common whitespace and common leading string
if (/^/s*(?:([^/w/s]+)(/s*).*/n)(?:/s*/1/2?.*/n)+$/) {
($white, $leader) = ($2, quotemeta($1));
} else {
($white, $leader) = (/^(/s+)/, '');
}
s/^/s*?$leader(?:$white)?//gm;
return $_;
}
#-----------------------------
if (m{
^ # start of line
/s * # 0 or more whitespace chars
(?: # begin first non-remembered grouping
( # begin save buffer $1
[^/w/s] # one byte neither space nor word
+ # 1 or more of such
) # end save buffer $1
( /s* ) # put 0 or more white in buffer $2
.* /n # match through the end of first line
) # end of first grouping
(?: # begin second non-remembered grouping
/s * # 0 or more whitespace chars
/1 # whatever string is destined for $1
/2 ? # what'll be in $2, but optionally
.* /n # match through the end of the line
) + # now repeat that group idea 1 or more
$ # until the end of the line
}x
)
{
($white, $leader) = ($2, quotemeta($1));
} else {
($white, $leader) = (/^(/s+)/, '');
}
s{
^ # start of each line (due to /m)
/s * # any amount of leading whitespace
? # but minimally matched
$leader # our quoted, saved per-line leader
(?: # begin unremembered grouping
$white # the same amount
) ? # optionalize in case EOL after leader
}{}xgm;
#-----------------------------
|
#-----------------------------
use Text::Wrap;
@OUTPUT = wrap($LEADTAB, $NEXTTAB, @PARA);
#-----------------------------
# download the following standalone program
#!/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";
#-----------------------------
01234567890123456789
Folding and
splicing is the
work of an
editor, not a
mere collection
of silicon and
mobile electrons!
#-----------------------------
# merge multiple lines into one, then wrap one long line
use Text::Wrap;
undef $/;
print wrap('', '', split(//s*/n/s*/, <>));
#-----------------------------
use Text::Wrap qw(&wrap $columns);
use Term::ReadKey qw(GetTerminalSize);
($columns) = GetTerminalSize();
($/, $/) = ('', "/n/n"); # read by paragraph, output 2 newlines
while (<>) { # grab a full paragraph
s//s*/n/s*/ /g; # convert intervening newlines to spaces
print wrap('', '', $_); # and format
}
#-----------------------------
|
#-----------------------------
# backslash
$var =~ s/([CHARLIST])///$1/g;
# double
$var =~ s/([CHARLIST])/$1$1/g;
#-----------------------------
$string =~ s/%/%%/g;
#-----------------------------
$string = q(Mom said, "Don't do that."); #'
$string =~ s/(['"])///$1/g;
#-----------------------------
$string = q(Mom said, "Don't do that.");
$string =~ s/(['"])/$1$1/g;
#-----------------------------
$string =~ s/([^A-Z])///$1/g;
#-----------------------------
$string = "this /Qis a test!/E";
$string = "this is// a// test//!";
$string = "this " . quotemeta("is a test!");
#-----------------------------
|
#-----------------------------
$string =~ s/^/s+//;
$string =~ s//s+$//;
#-----------------------------
$string = trim($string);
@many = trim(@many);
sub trim {
my @out = @_;
for (@out) {
s/^/s+//;
s//s+$//;
}
return wantarray ? @out : $out[0];
}
#-----------------------------
# print what's typed, but surrounded by >< symbols
while(<STDIN>) {
chomp;
print ">$_</n";
}
#-----------------------------
|
#-----------------------------
sub parse_csv {
my $text = shift; # record containing comma-separated values
my @new = ();
push(@new, ) while $text =~ m{
# the first part groups the phrase inside the quotes.
# see explanation of this pattern in MRE
"([^/"//]*(?://.[^/"//]*)*)",?
| ([^,]+),?
| ,
}gx;
push(@new, undef) if substr($text, -1,1) eq ',';
return @new; # list of values that were comma-separated
}
#-----------------------------
use
Text::ParseWords;
sub parse_csv {
return quoteword(",",0, $_[0]);
}
#-----------------------------
$line = q<XYZZY,"","O'Reilly, Inc","Wall, Larry","a /"glug/" bit,",5,
"Error, Core Dumped">;
@fields = parse_csv($line);
for ($i = 0; $i < @fields; $i++) {
print "$i : $fields[$i]/n";
}
#0 : XYZZY
#
#1 :
#
#2 : O'Reilly, Inc
#
#3 : Wall, Larry
#
#4 : a /"glug/" bit,
#
#5 : 5
#
#6 : Error, Core Dumped
#-----------------------------
|
#-----------------------------
use Text::Soundex;
$CODE = soundex($STRING);
@CODES = soundex(@LIST);
#-----------------------------
use Text::Soundex;
use User::pwent;
print "Lookup user: ";
chomp($user = <STDIN>);
exit unless defined $user;
$name_code = soundex($user);
while ($uent = getpwent()) {
($firstname, $lastname) = $uent->gecos =~ /(/w+)[^,]*/b(/w+)/;
if ($name_code eq soundex($uent->name) ||
$name_code eq soundex($lastname) ||
$name_code eq soundex($firstname) )
{
printf "%s: %s %s/n", $uent->name, $firstname, $lastname;
}
}
#-----------------------------
|
#-----------------------------
# download the following standalone program
#!/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
#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
#-----------------------------
# download the following standalone program
#!/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
#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
#-----------------------------
# very fast, but whitespace collapse
while (<>) {
for (split) {
print $change{$_} || $_, " ";
}
print "/n";
}
#-----------------------------
my $pid = open(STDOUT, "|-");
die "cannot fork: $!" unless defined $pid;
unless ($pid) { # child
while (<STDIN>) {
s/ $//;
print;
}
exit;
}
#-----------------------------
|
#-----------------------------
#% psgrep '/sh/b/'
#-----------------------------
#% psgrep 'command =~ /sh$/'
#-----------------------------
#% psgrep 'uid < 10'
#-----------------------------
#% psgrep 'command =~ /^-/' 'tty ne "?"'
#-----------------------------
#% psgrep 'tty =~ /^[p-t]/'
#-----------------------------
#% psgrep 'uid && tty eq "?"'
#-----------------------------
#% psgrep 'size > 10 * 2**10' 'uid != 0'
#-----------------------------
# FLAGS UID PID PPID PRI NI SIZE RSS WCHAN STA TTY TIME COMMAND
#
# 0 101 9751 1 0 0 14932 9652 do_select S p1 0:25 netscape
#
#100000 101 9752 9751 0 0 10636 812 do_select S p1 0:00 (dns helper)
#-----------------------------
# download the following standalone program
#!/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
# 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
#-----------------------------
eval "sub is_desirable { uid < 10 } " . 1;
#-----------------------------
#% psgrep 'no strict "vars";
# BEGIN { $id = getpwnam("nobody") }
# uid == $id '
#-----------------------------
sub id() { $_->{ID} }
sub title() { $_->{TITLE} }
sub executive() { title =~ /(?:vice-)?president/i }
# user search criteria go in the grep clause
@slowburners = grep { id < 10 && !executive } @employees;
|
|
|
918
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
