source: branches/1.7/builder/scripts/templates.tcl @ 6226

Last change on this file since 6226 was 3177, checked in by mmc, 12 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.

File size: 15.2 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: templates
3#
4#  This file contains routines to parse language definition files in
5#  the "templates" directory.  This defines all of the programming
6#  languages that the Builder can build main programs for.  Each
7#  language is specified as follows:
8#
9#    language NAME {
10#        main { ...template... }
11#        input pattern { script }
12#        output pattern { script }
13#    }
14#
15# ======================================================================
16#  AUTHOR:  Michael McLennan, Purdue University
17#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
18#
19#  See the file "license.terms" for information on usage and
20#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
21# ======================================================================
22package require Itcl
23package require RapptureBuilder
24
25namespace eval RapptureBuilder::templates {
26    #
27    # Set up a safe interpreter for loading language defn files...
28    #
29    variable tmplParser [interp create -safe]
30    foreach cmd [$tmplParser eval {info commands}] {
31        $tmplParser hide $cmd
32    }
33    $tmplParser alias language RapptureBuilder::templates::parse_language
34    $tmplParser alias unknown RapptureBuilder::templates::parse_tmpl_unknown
35    proc ::RapptureBuilder::templates::parse_tmpl_unknown {args} {
36        error "bad command \"[lindex $args 0]\": should be language"
37    }
38
39    #
40    # Set up a safe interpreter for loading the language definition...
41    #
42    variable langParser [interp create -safe]
43    foreach cmd [$langParser eval {info commands}] {
44        $langParser hide $cmd
45    }
46    $langParser alias extension RapptureBuilder::templates::parse_template extension
47    $langParser alias command RapptureBuilder::templates::parse_template command
48    $langParser alias makefile RapptureBuilder::templates::parse_template makefile
49
50    $langParser alias main RapptureBuilder::templates::parse_template main
51    $langParser alias input RapptureBuilder::templates::parse_pattern input
52    $langParser alias output RapptureBuilder::templates::parse_pattern output
53
54    $langParser alias unknown RapptureBuilder::templates::parse_lang_unknown
55    proc ::RapptureBuilder::templates::parse_lang_unknown {args} {
56        error "bad option \"[lindex $args 0]\": should be main, input, output"
57    }
58
59    # this variable will hold LangDef object as it is being built
60    variable currLangDef ""
61}
62
63# ----------------------------------------------------------------------
64# USAGE: RapptureBuilder::templates::init
65#
66# Called at the beginning of the Rappture builder to initialize the
67# template language system.  Loads all languages in the "templates"
68# directory within the builder to define all known languages.  After
69# this, the main program can be built by calling templates::generate.
70# ----------------------------------------------------------------------
71proc RapptureBuilder::templates::init {} {
72    # load supporting type definitions
73    set dir [file join $RapptureBuilder::library scripts templates]
74    foreach fname [glob [file join $dir *.tl]] {
75        RapptureBuilder::templates::load $fname
76    }
77
78    # if anyone tries to load again, do nothing
79    proc ::RapptureBuilder::templates::init {} { # already loaded }
80}
81
82# ----------------------------------------------------------------------
83# USAGE: RapptureBuilder::templates::load <fileName>
84#
85# Used internally to load language definition files when this package
86# is first initialized by the builder.  Processes the <fileName>
87# within the template parser.  As a side-effect of executing this
88# file, a new template language is defined.
89# ----------------------------------------------------------------------
90proc RapptureBuilder::templates::load {fname} {
91    variable tmplParser
92    variable langDefs
93
94    set fid [open $fname r]
95    set info [read $fid]
96    close $fid
97
98    if {[catch {$tmplParser eval $info} err] != 0} {
99        error $err "$err\n    (while loading object definition from file \"$fname\")"
100    }
101}
102
103# ----------------------------------------------------------------------
104# USAGE: RapptureBuilder::templates::languages
105#
106# Returns a list of languages with templates loaded by the "init"
107# procedure.  These names can be passed in to "generate" to generate
108# code for these languages.
109# ----------------------------------------------------------------------
110proc RapptureBuilder::templates::languages {} {
111    variable langDefs
112    return [array names langDefs]
113}
114
115# ----------------------------------------------------------------------
116# USAGE: RapptureBuilder::templates::generate <what> \
117#           ?-language name? ?-xmlobj obj? ?-macros <string-map>?
118#
119# Builds a string of generated information starting with <what> as
120# the main template.  This string may contain other @@NAME@@ fields,
121# which are substituted recursively until all substitutions have
122# been made.  The -language option specifies which language template
123# should be used.  The -xmlobj option gives data for the @@NAME@@
124# substitutions.
125#
126# Returns the generated string with all possible substitutions.
127# ----------------------------------------------------------------------
128proc RapptureBuilder::templates::generate {what args} {
129    variable langDefs
130
131    Rappture::getopts args params {
132        value -language ""
133        value -xmlobj ""
134        value -macros ""
135    }
136    if {[llength $args] > 0} {
137        error "wrong # args: should be \"generate what ?-language name? ?-xmlobj obj?\""
138    }
139    if {$params(-language) eq ""} {
140        error "must specify a language for the code to be generated"
141    }
142
143    set lang $params(-language)
144    if {![info exists langDefs($lang)]} {
145        error "bad -language \"$lang\": should be one of [join [lsort [array names langDefs]] {, }]"
146    }
147
148    set info [$langDefs($lang) template $what]
149    if {$info eq ""} {
150        error "no such template \"$what\""
151    }
152
153    set xmlobj $params(-xmlobj)
154
155    # produce the @@INPUTS@@ section...
156    set inputs ""
157    if {$xmlobj ne ""} {
158        foreach path [Rappture::entities -as path $xmlobj input] {
159            append inputs [$langDefs($lang) generate $xmlobj $path -code]
160        }
161    }
162
163    # produce the @@OUTPUTS@@ section...
164    set outputs ""
165    if {$xmlobj ne ""} {
166        foreach path [Rappture::entities -as path $xmlobj output] {
167            append outputs [$langDefs($lang) generate $xmlobj $path -code]
168        }
169    }
170
171    # produce the @@DECLARATIONS@@ section...
172    set decls ""
173    if {$xmlobj ne ""} {
174        foreach path [Rappture::entities -as path $xmlobj input] {
175            append decls [$langDefs($lang) generate $xmlobj $path -decl]
176        }
177        foreach path [Rappture::entities -as path $xmlobj output] {
178            append decls [$langDefs($lang) generate $xmlobj $path -decl]
179        }
180    }
181
182    # handle the @@INPUTS@@ / @@OUTPUTS@@ / @@DECLARATIONS@@ specially
183    # preserve the indent at the beginning of each line
184    foreach {macro var} {
185        @@INPUTS@@ inputs
186        @@OUTPUTS@@ outputs
187        @@DECLARATIONS@@ decls
188    } {
189        set re [format {(?:^|\n)([ \t]*)%s} $macro]
190        while {[regexp -indices $re $info match indent]} {
191            set code [set $var]
192            foreach {m0 m1} $match break
193            foreach {i0 i1} $indent break
194            if {$i1-$i0 > 0} {
195                set indent [string range $info $i0 $i1]
196                set newcode ""
197                foreach line [split $code \n] {
198                    append newcode $indent $line "\n"
199                }
200                set code [string trimright $newcode \n]
201            }
202            if {[string index $info $m0] eq "\n"} { set code "\n$code" }
203            set info [string replace $info $m0 $m1 $code]
204        }
205    }
206
207    # make substitutions for any remaining macros
208    set info [string map $params(-macros) $info]
209
210    # return the generated code
211    return $info
212}
213
214# ----------------------------------------------------------------------
215# PARSER:  RapptureBuilder::templates::parse_language
216#
217# Used internally to parse the definition of a language file:
218#
219#   language NAME {
220#       main { ...body of code... }
221#       inputs { template }
222#       outputs { template }
223#   }
224#
225# Builds an object in currLangDef and then registers the completed
226# object in the langDefs array.  This defines a known language that
227# can be used to generate a template.
228# ----------------------------------------------------------------------
229proc RapptureBuilder::templates::parse_language {name body} {
230    variable currLangDef
231    variable langDefs
232    variable langParser
233
234    set currLangDef [RapptureBuilder::templates::LangDef ::#auto $name]
235
236    if {[catch {$langParser eval $body} err] != 0} {
237        itcl::delete object $currLangDef
238        set currLangDef ""
239        error $err "\n    (while loading language definition for \"$name\")"
240    }
241
242    set langDefs($name) $currLangDef
243    set currLangDef ""
244}
245
246# ----------------------------------------------------------------------
247# PARSER:  RapptureBuilder::templates::parse_template <what> <body>
248#
249# Used internally to add the definition of program templates to the
250# current language definition:
251#
252#   main { ...template... }
253#
254# ----------------------------------------------------------------------
255proc RapptureBuilder::templates::parse_template {what body} {
256    variable currLangDef
257    $currLangDef template $what $body
258}
259
260# ----------------------------------------------------------------------
261# PARSER:  RapptureBuilder::templates::parse_pattern <which> <pattern> <script>
262#
263# Used internally to add the definition of how to input/output
264# specific objects to the current language definition:
265#
266#   input number {...script...}
267#   output * {...script...}
268#
269# Each script is executed in a context that has commands and built-in
270# variables for various bits of the current object:
271#   [attr get name] ... returns the value of attribute name
272#   $path ............. path for current object
273#   $id ............... id (name at end of path) for current object
274# ----------------------------------------------------------------------
275proc RapptureBuilder::templates::parse_pattern {which pattern body} {
276    variable currLangDef
277    $currLangDef handler $which:$pattern $body
278}
279
280
281# ----------------------------------------------------------------------
282#  CLASS: LangDef
283# ----------------------------------------------------------------------
284itcl::class RapptureBuilder::templates::LangDef {
285    constructor {name args} {
286        set _lang $name
287        eval configure $args
288    }
289
290    # used to query the name of this language
291    public method language {} {
292        return $_lang
293    }
294
295    # used to register/query a template with a specific name
296    public method template {what args} {
297        if {[llength $args] == 0} {
298            if {[info exists _frag2txt($what)]} {
299                return $_frag2txt($what)
300            }
301            return ""
302        } elseif {[llength $args] != 1} {
303            error "wrong # args: should be \"template what ?text?\""
304        }
305        set _frag2txt($what) [lindex $args 0]
306    }
307
308    # used to register a script that processes an input/output element
309    public method handler {pattern body} {
310        set i [lsearch -exact $_patterns $pattern]
311        if {$i < 0} { lappend _patterns $pattern }
312        set _pat2code($pattern) $body
313    }
314
315    # used to generate the output for a specific Rappture object in this lang
316    public method generate {xmlobj path {what "-code"}} {
317        variable genParser
318        variable genOutput ""
319        variable genDecls ""
320        variable genXmlobj $xmlobj
321        variable genPath $path
322
323        set which [lindex [split $path .] 0]
324        set type [$xmlobj element -as type $path]
325        set elem $which:$type
326
327        set code ""
328        foreach pat $_patterns {
329            if {[string match $pat $elem]} {
330                set code $_pat2code($pat)
331                break
332            }
333        }
334        if {$code eq ""} {
335            error "can't find production code for $elem"
336        }
337
338        $genParser eval [list set path $path]
339        $genParser eval [list set type $type]
340        $genParser eval [list set id [$xmlobj element -as id $path]]
341        $genParser eval $code
342
343        switch -- $what {
344            -code   { return $genOutput }
345            -decl   { return $genDecls }
346            default { error "bad option \"$what\": should be -code, -decl" }
347        }
348    }
349
350    private variable _lang ""     ;# name of this language
351    private variable _frag2txt    ;# maps fragment name => template text
352    private variable _patterns "" ;# order of patterns for _pat2code
353    private variable _pat2code    ;# maps glob pattern => script to gen output
354
355    #
356    # Set up a safe interpreter for the "generate" method...
357    #
358    private common genParser [interp create -safe]
359    $genParser alias code RapptureBuilder::templates::LangDef::cmd_code
360    $genParser alias decl RapptureBuilder::templates::LangDef::cmd_decl
361    $genParser alias attr RapptureBuilder::templates::LangDef::cmd_attr
362
363    private common genOutput ""  ;# gathers code output from genParser
364    private common genDecls ""   ;# gathers declarations from genParser
365    private common genXmlobj ""  ;# Rappture tool spec
366    private common genPath ""    ;# current path in the genXmlobj data
367
368    # like the std "puts" command, but adds output to the generated code
369    proc cmd_code {args} {
370        set nl "\n"
371        while {[llength $args] > 1} {
372            set opt [lindex $args 0]
373            set args [lrange $args 1 end]
374            if {$opt eq "-nonewline"} {
375                set nl ""
376            } else {
377                error "bad option \"$opt\": should be -nonewline"
378            }
379        }
380        if {[llength $args] != 1} {
381            error "wrong # args: should be \"puts ?-nonewline? string\""
382        }
383        append genOutput [lindex $args 0] $nl
384    }
385
386    # like the std "puts" command, but adds output to code declarations
387    proc cmd_decl {args} {
388        set nl "\n"
389        while {[llength $args] > 1} {
390            set opt [lindex $args 0]
391            set args [lrange $args 1 end]
392            if {$opt eq "-nonewline"} {
393                set nl ""
394            } else {
395                error "bad option \"$opt\": should be -nonewline"
396            }
397        }
398        if {[llength $args] != 1} {
399            error "wrong # args: should be \"puts ?-nonewline? string\""
400        }
401        append genDecls [lindex $args 0] $nl
402    }
403
404    # used to query attribute info for the current object
405    proc cmd_attr {option name} {
406        set type [$genXmlobj element -as type $genPath]
407        set ainfo [Rappture::objects::get $type -attributes]
408        if {$ainfo eq ""} {
409            error "don't know how to generate code for type \"$type\""
410        }
411
412        set found 0
413        foreach rec $ainfo {
414            if {[lindex $rec 0] eq $name} {
415                set found 1
416                break
417            }
418        }
419        if {!$found} {
420            error "bad attribute name \"$name\" for type \"$type\""
421        }
422
423        switch -- $option {
424            get {
425                array set attr [lrange $rec 1 end]
426                return [$genXmlobj get $genPath.$attr(-path)]
427            }
428            info {
429                return $rec
430            }
431            default {
432                error "bad option \"$option\": should be get, info"
433            }
434        }
435    }
436}
Note: See TracBrowser for help on using the repository browser.