#-----------------------------
$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($<))[0]
|| "Unknown uid number $<";
#-----------------------------
$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
#-----------------------------
|
#-----------------------------
while ($string =~ s/\t+/' ' x (length($&) * 8 - length($`) % 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($&) * 8 - length($`) % 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ņa.
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; #----------------------------- |