Advanced Perl


OVERVIEW

These lectures examine the application of Perl to tasks commonly encountered by programmers.

As an interpreted language, Perl has features not normally found in compiled languages. We will focus on two of these features:

  1. Execution of expressions on the fly
  2. Associative arrays

EXPRESSIONS IN THE SUBSTITUTION FUNCTION

With the substitute function, we have seen extensive use of patterns in the first position. For example, 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)/e
will 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;
	}

THE EVAL FUNCTION

The 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 $_;
	}

ASSOCIATIVE ARRAYS

EXAMPLE: CREATING A CALL TREE

In large C programs, it is often useful to understand the basic structure of the program before trying to grasp the details. Studying the call tree can help here. The call tree has a node for each C function. The node for function F has child G if F calls G one or more times. For example, shown below are the files 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);
	}
}

 




Previous Section Back to Index Next Section