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.

@//

@foreach var [condition]
@end

@FOREACH attr_list ($className eq "Test")

@if @elsif @else @end

@openfile filename 
              [options]

@perl

@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()).

#!/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);
}