Advanced Perl Programming

Advanced Perl ProgrammingSearch this book
Previous: 17.3 Jeeves OverviewChapter 17
Template-Driven Code Generation
Next: 17.5 Sample Specification Parser
 

17.4 Jeeves Implementation

In the following pages, we implement all the components of the Jeeves framework. You may find it helpful to run jeeves for a sample problem and have a copy of the output handy.

17.4.1 AST Module

The AST module is a very simple library, so we will look at only a few of the more interesting procedures below.

An AST node is a container of properties, so a hash table suits the job perfectly. Each node is given a name for ease of debugging:

package Ast;
use strict;
sub new {
    my ($pkg, $name) = @_;
    bless {'ast_node_name' => $name}, $pkg;
}

new, add_prop, and add_prop_list are used by all specification parsers to create AST objects:

sub add_prop {
    my ($node, $prop_name, $prop_value) = @_;
    $node->{$prop_name} = $prop_value;
}
sub add_prop_list {
    my ($node, $prop_name, $node_ref) = @_;
    if (! exists $node->{$prop_name}) {
        $node->{$prop_name} = [];
    }
    push (@{$node->{$prop_name}}, $node_ref);
}

add_prop simply adds a name-value pair to the AST object. add_prop_list creates a list-valued property. The property value is an anonymous array that contains references to other AST nodes. You can have your own list-valued properties, but you should never use them as an argument to @foreach because it assumes that the elements of that list are AST nodes.

my @saved_values_stack;
sub visit {
    no strict 'refs';
    my $node = shift;
    package main;
    my ($var, $val, $old_val, %saved_values);
    while (($var,$val) = each %{$node}) {
        if (defined ($old_val = $$var)) {
           $saved_values{$var} = $old_val;
        }
        $$var = $val;
    }
    push (@saved_values_stack, \%saved_values);
}

The visit and bye methods are used by the intermediate Perl file. $node is the node being visited, so %$node is the corresponding hash table. $var is a property name such as class_name, so to check whether a variable such as $class_name already exists, we use symbolic references: if defined($$var). All such variables that existed before are squirreled away into a hash table (%saved_values), which is then pushed into a stack. This stack represents collections of such saved values.

sub bye {
    my $rh_saved_values = pop(@saved_values_stack);
    no strict 'refs';
    package main;
    my ($var,$val);
    while (($var,$val) = each %$rh_saved_values) {
        $$var = $val;
    }
}

bye() simply pops this stack and restores the global variables to their former values. Incidentally, since use strict doesn't encourage symbolic references, we have to explicitly turn it off for a short while with no strict 'refs'.

17.4.2 Template Parser

The template parser supports the directives in Table 17.1.


Table 17.1: Directives Recognized by Jeeves

Directive

Description

@//

Comment. This line is not output

@foreach var [condition]
@end

This loops through each element of var (it is assumed that var is an array) and executes the body if the (optional) condition is true. Conditions are simply pieces of embedded Perl code and can be used like this:

@FOREACH attr_list ($className eq "Test")
@if @elsif @else @end

Translates directly to Perl's if statement.

@openfile filename 
              [options]

All statements following this line are simply sent to this file until another @OPENFILE is encountered. Options are:

-append: open the file in append mode

-no_overwrite: do not overwrite the file if it already exists

-only_if_different: overwrites the file only if it is different. Useful in a make environment, where you don't want to unnecessarily touch files.

@perl

For embedding Perl code, provided as an escape to a higher power.

@perl $user_name = $ENV{USER};
@perl print $user_name;

The following template parser code simply translates all template directives to corresponding pieces of Perl code in the intermediate files. Explanations follow each subroutine definition.

package TemplateParser;
use strict;
sub parse {
    # Args : template file, intermediate perl file
    my ($pkg,$template_file, $inter_file) = @_;
    unless (open (T, $template_file)) {
        warn "$template_file : $@";
        return 1;
    }
    open (I, "> $inter_file") || 
        die "Error opening intermediate file $inter_file : $@";
    
    emit_opening_stmts($template_file);
    my $line;
    while (defined($line = <T>)) {
        if ($line !~ /^\s*\@/) { # Is it a command?
            emit_text($line);
            next;
        } 
        if ($line =~ /^\s*\@OPENFILE\s*(.*)\s*$/i) {
            emit_open_file ($1);
        } elsif ($line =~ /^\s*\@FOREACH\s*(\w*)\s*(.*)\s*/i) {
            emit_loop_begin ($1,$2);
        } elsif ($line =~ /^\s*\@END/i) {
            emit_loop_end();
        } elsif ($line =~ /^\s*\@PERL(.*)/i) {
            emit_perl("$1\n");
        };
    }
    emit_closing_stmts();
    
    close(I);
    return 0;
}

TemplateParser::parse is called by the driver, with the name of the template file. For every line in the template, it checks to see whether that line is a command or ordinary text and calls the appropriate "emit" routine. All emitted code is shown in italics.

sub emit_opening_stmts {
    my $template_file = shift;
    emit("# Created automatically from $template_file");
    emit(<<'_EOC_');
use Ast;
use JeevesUtil;

$tmp_file = "jeeves.tmp";
sub open_file;
if (! (defined ($ROOT) && $ROOT)) {
    die "ROOT not defined \n";
}

$file = "> -";   # Assumes STDOUT, unless @OPENFILE changes it.
open (F, $file) || die $@;
$code = "";
$ROOT->visit();
_EOC_
}

All pieces of code that go into the intermediate file (emitted) are shown in italics. Perl's "here document" feature is used extensively because we can use quotes and newlines without restrictions. emit_opening_statement visits the syntax tree's root node (the driver makes it available as a global variable called $ROOT). By default, all output from the intermediate file is to standard output until it comes across an @openfile directive.

sub emit_open_file {
    my $file = shift;
    my $no_overwrite      = ($file =~ s/-no_overwrite//gi) ? 1 : 0;
    my $append            = ($file =~ s/-append//gi) ? 1 : 0;
    my $only_if_different = ($file =~ s/-only_if_different//gi) ? 1 : 0;
    $file =~ s/\s*//g;
    emit (<<"_EOC_");
# Line $.
open_file(\"$file\", $no_overwrite, $only_if_different, $append);
_EOC_
}

emit_open_file contains the translation for @openfile and simply emits a call to the utility function open_file (discussed later).

sub emit_loop_begin {
    my $l_name = shift; # Name of the list variable
    my $condition = shift;
    my $l_name_i = $l_name . "_i";
emit (<<"_EOC_");
# Line $.
foreach \$$l_name_i (\@\${$l_name}) {
    \$$l_name_i->visit ();
_EOC_
    if ($condition) {
        emit ("next if (! ($condition));\n");
    }
}
sub emit_loop_end {
    emit(<<"_EOC_");
#Line $.
    Ast->bye();
}
_EOC_
}

We saw earlier the code generated for a @foreach directive. Note how we manufacture the iterator name and protect certain expressions from getting interpolated. This code can be better understood by looking at the sample output.

sub emit {
    print I $_[0];
}
sub emit_perl {
    emit($_[0]);
}
sub emit_text {
    my $text = $_[0];
    chomp $text;
    # Escape quotes in the text
    $text =~ s/"/\\"/g;
    $text =~ s/'/\\'/g;
    emit(<<"_EOC_");
output("$text\\n");
_EOC_
}

sub emit_closing_stmts {
    emit(<<'_EOC_');
Ast::bye();
close(F);
unlink ($tmp_file);
sub open_file {
    my ($a_file, $a_nooverwrite, $a_only_if_different, $a_append) = @_;

    #First deal with the file previously opened
    close (F);
    if ($only_if_different) {
        if (JeevesUtil::compare ($orig_file, $curr_file) != 0) {
            rename ($curr_file, $orig_file) || 
            die "Error renaming $curr_file  to $orig_file";
        }
    }
    #Now for the new file ...
    $curr_file = $orig_file = $a_file;
    $only_if_different = ($a_only_if_different && (-f $curr_file)) 
                         ? 1 : 0;
    $no_overwrite = ($a_nooverwrite && (-f $curr_file))  ? 1 : 0;
    $mode =  ($a_append) ? ">>" : ">";
    if ($only_if_different) {
        unlink ($tmp_file);
        $curr_file = $tmp_file;
    }
    if (! $no_overwrite) {
        open (F, "$mode $curr_file") || die "could not open $curr_file";
    }
}

sub output {
    print F @_ (! $no_overwrite);
}
1;
_EOC_
}

The open_file and output routines are present in all intermediate code files (for no particular reason - they might as well have been put in the JeevesUtil package). open_file closes the previously opened file. If you say, @openfile foo -only_if_different, the intermediate file dumps the template output into a temporary file, and when it is done, it compares this temporary file to the contents of foo, and overwrites it only if it is different.

17.4.3 Jeeves Driver

The jeeves script is merely a driver that first calls the template parser to produce the intermediate file, then calls the input parser (its parse() method, actually) to produce the syntax tree, and finally evals the intermediate file. The template file is recompiled only if it is newer than the intermediate file.

Example 17.3 gives the code for jeeves, minus the uninteresting stuff (such as process_args()).

Example 17.3: Jeeves

#!/opt/bin/perl
# process_args initializes the following global variables:
#   $spec_file     - Name of the input specification (emp.om)
#   $template_file - Name of the template file (oo.tpl)
#   $inter_file    - name of the intermediate file 
#                        (defaults to "${template_file}.pl"
process_args();  
#-------------------------------------------------------------------------
# Parse the template file
#-------------------------------------------------------------------------
# Use "require" to allow process_args() to set @INC first
require 'TemplateParser.pm';
my $compile_template = 1;
if ((-e $inter_file) &&
    (-M $inter_file) >= (-M $template_file)) {
        $compile_template = 0; # Don't compile if inter-file is newer.
}
if ($compile_template) {
    if (TemplateParser->parse ($template_file, $inter_file) == 0) {
        print STDERR ("Translated $template_file to $inter_file\n")
           if $verbose;
    } else {
        die "Could not parse template file - exiting\n";
    }
}
#-------------------------------------------------------------------------
# Parse the input specification file
#-------------------------------------------------------------------------
require "${spec_parser}.pm"; $spec_parser->import;
$ROOT = $spec_parser->parse($spec_file);
print STDERR ("Parsed $spec_file\n") if $verbose;
$ROOT->print() if $debugging;
#-------------------------------------------------------------------------
# Eval the intermediate Perl file
#-------------------------------------------------------------------------
require "$inter_file";
die "$@\n" if $@;
exit(0);


#-------------------------------------------------------------------------
sub Usage {
    print STDERR <<"_EOT_";

Usage: jeeves <options> <specification file>
 where options are: 
 -t <template file>            : Name of the template file. 
                                 Default : "./jeeves.template"
                                 Default template directory = ".", which
                                 can be modified by setenv-ing
                                 "JEEVESTEMPLATEDIR"
 -q                            : Quiet Mode
 -d                            : Set a debugging trace. This is NOT quiet!
 -s <specification parser>     : Parser module that can parse the input
                                 specification file
                                 Default : "oo_schema"
[-ti <intermediate perl file>] : jeeves translates the template file to
                               : perl code. Default : "<template>.pl"
-D var[=value]                 : Define variables on the command line 

The command line can be specified in the envt. variable "JEEVESOPTIONS".

The pathname to all Jeeves modules can be set in the envt. variable 
    "JEEVESLIBDIR" (colon-separated);
_EOT_
    exit(1);
}


Previous: 17.3 Jeeves OverviewAdvanced Perl ProgrammingNext: 17.5 Sample Specification Parser
17.3 Jeeves OverviewBook Index17.5 Sample Specification Parser