As an interpreted language, Perl has features not normally found in compiled languages. We will focus on two of these features:
s/[0-9]+/X/
will replace the leftmost integer with "X".
However, complex expressions may appear in the second position
as well, with the e option of the substitute function.
For example, the following code
s/([0-9]+)/"X" x length($1)/ewill replace
"abc123def" with "abcXXXdef".
Suppose that you have a lot of code that is indented on multiples
of eight columns with tabs ("\t"),
and you would prefer indentation on multiples of four columns.
The retab program provides this service:
# Usage: retab < infile > outfile
$indent = 4;
while (<STDIN>) {
s#^(\t+)#' ' x (length($1) * 8)#e;
s#^( *)#' ' x (length($1) * $indent / 8)#e;
s#^(( {8})*)#"\t" x (length($1) / 8)#e;
print;
}
e option of the substitute function
allows evaluation on the fly in string substitution.
The eval function provides a more general
form of expression evaluation.
Any string can be evaluated as a Perl program.
The string can be read from a file or generated on the fly.
Consider the following "hello world" program:
$program = 'print "Hello world\n";'; eval $program;The
rename program uses eval
to solve a common programmer's problem.
Suppose that you have a large number of files
that you wish to rename in a uniform way.
For example, you wish to change the .c suffix
to .cpp.
The rename program can do this and
many other renaming tasks, in just a few lines of Perl:
# Usage: rename perlExpression [files]
# extract perlExpression from @ARGV[0]
($op = shift) || die "Usage: rename perlExpression [files]\n";
for (@ARGV) {
$oldName = $_;
eval $op;
die $@ if $@;
rename($oldName,$_) unless $oldName eq $_;
}
## use an associative array named %age
$age{"jane"} = 26;
$age{"bill"} = "21";
$age{"fido"} = 3;
print $age{"bill"}, "\n";
$age{"fido"} += 1;
As with ordinary arrays, the prefix becomes $
when accessing an element (a scalar value).keys() function returns a list of all the keys.
E.g.
@K = keys(%age);
foreach (@K) {
print "Age of ", $_, " is ", $age{$_}, "\n";
}
value() function returns a list of all the values.
E.g.
@V = values(%age);
foreach (@V) {
print "Age: ", $_, "\n";
}
each() function returns a key-value pair,
one at a time. For example:
while( ($k, $v) = each(%age) ) {
print "Age of ", $k, " is ", $v, "\n";
}
defined() function can be used to determine whether
an associative array contains a given key. For example:
if (defined($age{$k})) {
print "$k is present\n";
}
@ageArray = %age;
## ageArray[0] = "jane", ageArray[1] = 26
## ageArray[2] = "bill", ageArray[3] = 21
## ageArray[4] = "fido", ageArray[5] = 4
%colour = ("house", "white",
"sky", "blue", "grass", "green");
## colour{"house"} equals "white", etc.
delete()
function. For example:
delete $colour{"house"};
removes the "house"-"white" pair from the
%colour array. for( $i = 0; $i < 10; $i++ ) {
for( $j = 0; $j < 10; $j++ ) {
$Table{$i,$j} = $i * $j;
}
}
builds a multiplication table named %Table.
In actual fact, an element $Table{4,3}
is implemented as a key-value pair where the key is
the string "4;3".
x.c and y.c and their call tree.
------------------------------
x.c
------------------------------
int main()
{
int i;
g();
for (i = 0; i < 5; i++)
h();
g();
}
------------------------------
y.c
------------------------------
void h()
{
printf("h called\n");
i();
}
void i()
{
}
------------------------------
call tree
------------------------------
main
g
h
printf
i
The Perl program shown below generates a call tree from a list of
C source files.
Phase I extracts the call tree and stores it in an
associative array. Most of the work is done by getFunction.
Phase II displays the call tree, with most of the work
done by the recursive function printTree.
#!/public/bin/perl
#***** Phase I: extract the call tree
%noiseWords = ("if",0,"for",0,"return",0,"sizeof",0,"switch",0,"while",0,);
# (id,level) getFunction
# id: the identifier of the next function found
# level: nesting level at which id was found
sub getFunction
{
local($id);
while (1) {
# search for next {, } or \w
while (1) {
if ($buf eq "") { $buf = ; }
if ($buf eq "") { return ("",0); }
$buf =~ /[^{}\w]*/;
if (($buf = $') ne "") { last; }
}
if ($buf =~/^{/) {
$level++; $buf = $';
} elsif ($buf =~/^}/) {
$level--; $buf = $';
} elsif ($buf =~ /^(\w+)/) {
$id = $1; $buf = $';
if ($buf =~ /^\s*\(/) {
if (!(defined($noiseWords{$id}))) {
return ($id,$level);
}
}
}
}
}
open(SRCFILES,"cat @ARGV |") || die;
$buf = "";
$level = 0;
($id,$level) = &getFunction();
while ($id ne "") {
if ($level == 0) {
$caller = $id;
} else {
if (!defined($callTree{$caller})) {
$callTree{$caller} = " " . $id . " ";
} elsif (!($callTree{$caller} =~ /\s+$id\s+/)) {
$callTree{$caller} .= $id . " ";
}
}
($id,$level) = &getFunction();
}
#***** Phase II: print the call tree
# void printTree(root,level)
# print the call tree rooted at r, indented level*4 spaces
sub printTree
{
local ($root,$level) = @_;
print ' ' x $level, "$root\n";
foreach (split(" ",$callTree{$root})) {
&printTree($_,$level+4);
}
}
# concatenate all value ids into a single blank-delimited string
$allValues = join("",values(%callTree));
foreach (keys(%callTree)) {
if (!($allValues =~ / +$_ +/)) {
&printTree($_,0);
}
}