mirror of https://gitlab.com/QEF/q-e.git
Adding "helpdoc" utility, which is used to tranform the INPUT_*.def files
into INPUT_*.html and other formats. The idea is to enhance/replace the plain ascii descriptions of input file syntax (i.e. INPUT_* files) with more structured/descriptive format yielding an enhanced documentation + better input syntax definition + possibility for semi-automatic upgrade of the PWgui to any future input syntax additions. git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@4736 c92efa57-630b-4861-b058-cf58834340f0
This commit is contained in:
kokalj
parent
fb07aef1ba
commit
164d7fe0d2
|
|
@ -0,0 +1,26 @@
|
|||
#!/bin/sh
|
||||
# the next line restarts using tclsh \
|
||||
exec tclsh "$0" "$@"
|
||||
|
||||
source [file join [file dirname [info script]] helpdoc.d helpdoc.tcl]
|
||||
|
||||
#
|
||||
# MAIN
|
||||
#
|
||||
|
||||
if { $argc < 1 } {
|
||||
puts stderr "\nUsage: $argv0 file1.def ?file2.def? ...\n"
|
||||
exit 1
|
||||
}
|
||||
|
||||
# custom ROBODOC program
|
||||
#set ::helpdoc::robodoc /path/to/robodoc
|
||||
|
||||
|
||||
# custom XSLTPROC program
|
||||
#set ::helpdoc::xsltproc /path/to/xsltproc
|
||||
|
||||
|
||||
# MAKE-IT-ALL
|
||||
|
||||
::helpdoc::process $argv
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
proc ::helpdoc::tag {{level -2}} {
|
||||
# PURPOSE
|
||||
# Return the name of the calling proc, which is used as the name
|
||||
# of tag.
|
||||
return [namespace tail [lindex [info level $level] 0]]
|
||||
}
|
||||
|
||||
|
||||
proc helpdoc::indent {depth {extraDepth 0}} {
|
||||
variable indentNum
|
||||
return [::textutil::blank [expr ($depth + $extraDepth) * $indentNum]]
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::getFromTree {tree node key} {
|
||||
if { [$tree keyexists $node $key] } {
|
||||
return [$tree get $node $key]
|
||||
}
|
||||
return ""
|
||||
}
|
||||
|
||||
|
||||
|
||||
proc ::helpdoc::formatString {string {depth 0} {extraIndent 0}} {
|
||||
variable indentNum
|
||||
set indent [::textutil::blank [expr $depth * $indentNum + $extraIndent]]
|
||||
return [::textutil::indent \
|
||||
[::textutil::undent \
|
||||
[::textutil::untabify [::textutil::trimEmptyHeading $string]]] \
|
||||
$indent]
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::trimEmpty {text} {
|
||||
# PURPOSE
|
||||
# Trim empty lines (this is not equal to [string trim], because the
|
||||
# beginning and ending indenation would be lost with the latter.
|
||||
|
||||
regsub -- "^(\[ \t\]*\n)*" $text {} text
|
||||
regsub -- "(\[ \t\n\])*$" $text {} text
|
||||
return $text
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,174 @@
|
|||
set dir [file dirname [info script]]
|
||||
lappend auto_path $dir [file join $dir .. .. GUI Guib lib]
|
||||
|
||||
package require tclu 0.9
|
||||
package require struct::tree 2.1
|
||||
package require struct::stack 1.3
|
||||
package require textutil
|
||||
|
||||
namespace eval ::helpdoc {
|
||||
variable dir [file dirname [info script]]
|
||||
|
||||
# schema-related variables
|
||||
|
||||
variable attrArr; # stores all about attributes
|
||||
variable elemArr; # stores all about elements
|
||||
variable defineArr; # stores all about define's
|
||||
|
||||
variable elemList ""
|
||||
variable itemList ""
|
||||
|
||||
variable state
|
||||
array set state {
|
||||
depth 0
|
||||
rootVisited 0
|
||||
rootElem ""
|
||||
}
|
||||
|
||||
variable stackArr
|
||||
array set stackArr [subst {
|
||||
repetition [::struct::stack]
|
||||
optional [::struct::stack]
|
||||
interleave [::struct::stack]
|
||||
currentElem [::struct::stack]
|
||||
}]
|
||||
|
||||
$stackArr(repetition) push 1; # decimal-digit | + | * | ? (meaning integer-number of times, one-or-more, zero-or-more, zero-or-one)
|
||||
$stackArr(optional) push 0
|
||||
$stackArr(interleave) push 0
|
||||
$stackArr(currentElem) push ""
|
||||
|
||||
# stack & tree for parsing input definitions
|
||||
|
||||
variable tree ""
|
||||
variable stack [::struct::stack]
|
||||
|
||||
# output-related
|
||||
|
||||
variable indentNum 3
|
||||
variable txtDepth 0
|
||||
variable fid
|
||||
variable head
|
||||
variable rbd_var
|
||||
variable rbd_stack
|
||||
variable rbd_info
|
||||
variable robodoc [auto_execok robodoc]
|
||||
variable xsltproc [auto_execok xsltproc]
|
||||
}
|
||||
|
||||
namespace eval ::helpdoc::tag {}
|
||||
namespace eval ::helpdoc::schema {}
|
||||
source [file join $::helpdoc::dir readSchema.tcl]
|
||||
|
||||
proc ::helpdoc::openOutputs {file} {
|
||||
variable fid
|
||||
variable head
|
||||
|
||||
set head [file rootname $file]
|
||||
|
||||
set fid(xml) [open $head.xml w]
|
||||
# currently disabled formats
|
||||
#set fid(txt) [open $head.txt w]
|
||||
#set fid(rbd) [open $head.rbd w]
|
||||
|
||||
puts $fid(xml) {<?xml version="1.0" encoding="ISO-8859-1"?>}
|
||||
puts $fid(xml) {<?xml-stylesheet type="text/xsl" href="input_xx.xsl"?>}
|
||||
puts $fid(xml) {<!-- FILE AUTOMATICALLY CREATED: DO NOT EDIT, CHANGES WILL BE LOST -->
|
||||
}
|
||||
|
||||
#puts $fid(txt) "*** FILE AUTOMATICALLY CREATED: DO NOT EDIT, CHANGES WILL BE LOST ***\n"
|
||||
|
||||
#puts $fid(rbd) "# *** FILE AUTOMATICALLY CREATED: DO NOT EDIT, CHANGES WILL BE LOST ***\n"
|
||||
}
|
||||
|
||||
proc ::helpdoc::writeOutputs {} {
|
||||
variable tree
|
||||
variable head
|
||||
variable fid
|
||||
variable robodoc
|
||||
variable xsltproc
|
||||
variable rbd_info
|
||||
|
||||
#$tree destroy
|
||||
|
||||
puts ""
|
||||
foreach fmt [array names fid] {
|
||||
puts "File $head.$fmt has been written."
|
||||
close $fid($fmt)
|
||||
}
|
||||
|
||||
# run XSLTPROC
|
||||
|
||||
if { $xsltproc != "" } {
|
||||
catch [list exec $xsltproc $head.xml > $head.html]
|
||||
puts "File $head.html has been written."
|
||||
}
|
||||
|
||||
# run ROBODOC
|
||||
|
||||
if { 0 } {
|
||||
# currently disbabled
|
||||
|
||||
if { $robodoc != "" } {
|
||||
if { ! [file isdirectory $head.d] } {
|
||||
file mkdir $head.d
|
||||
} else {
|
||||
foreach file [glob -nocomplain $head.d/*.html] {
|
||||
file delete $file
|
||||
}
|
||||
}
|
||||
if { ! [file isdirectory $head.robodoc] } {
|
||||
file mkdir $head.robodoc
|
||||
}
|
||||
|
||||
file copy -force $head.rbd $head.robodoc/
|
||||
|
||||
catch {exec $robodoc --doc $head.d/ --src $head.robodoc/ --documenttitle "Description of $rbd_info(program) input file"}
|
||||
|
||||
if { [file exists $head.d/toc_index.html] } {
|
||||
file copy -force $head.d/toc_index.html $head.d/index.html
|
||||
puts "File $head.d/index.html has been written."
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::readSchema {} {
|
||||
puts "\n***\n*** Parsing the helpdoc.schema\n***\n"
|
||||
namespace eval schema { ::source helpdoc.schema }
|
||||
|
||||
puts "\n\n***\n*** Assigning ref's\n***\n"
|
||||
assignRefs_
|
||||
|
||||
puts "\n\n***\n*** Creating tags commands\n***\n"
|
||||
createTagCmds_
|
||||
}
|
||||
|
||||
proc ::helpdoc::process {fileList} {
|
||||
variable tree
|
||||
|
||||
# first read the schema (and load tag's commands)
|
||||
readSchema
|
||||
|
||||
#puts "tag commands: [info procs ::helpdoc::tag::*]"
|
||||
|
||||
foreach file $fileList {
|
||||
|
||||
if { [file exists $file] } {
|
||||
|
||||
openOutputs $file
|
||||
|
||||
puts "\n\n***\n*** Parsing definition file: $file\n***\n"
|
||||
namespace eval tag [list source $file]
|
||||
|
||||
$tree walkproc root -order both print
|
||||
writeOutputs
|
||||
|
||||
$tree destroy
|
||||
} else {
|
||||
puts stderr "file [file join [pwd] $file] does not exists : aborting ..."
|
||||
exit 1
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,237 @@
|
|||
#
|
||||
# XML
|
||||
#
|
||||
proc ::helpdoc::xml_escape_chr {content} {
|
||||
# replace xml special characters by escape-characters
|
||||
foreach {chr escChr} {
|
||||
& {\&}
|
||||
< {\<}
|
||||
> {\>}
|
||||
} {
|
||||
regsub -all -- $chr $content $escChr content
|
||||
}
|
||||
regsub -all -- ' $content {\'} content
|
||||
regsub -all -- \" $content {\"} content
|
||||
|
||||
return $content
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::xml_tag_enter {tag attr content depth} {
|
||||
variable fid
|
||||
|
||||
set indent [indent $depth]
|
||||
|
||||
set sep ""
|
||||
if { $content != "" } {
|
||||
if { [llength [split $content \n]] > 1 } {
|
||||
set content [trimEmpty $content]
|
||||
set sep \n
|
||||
} else {
|
||||
set sep " "
|
||||
}
|
||||
}
|
||||
|
||||
set content [formatString [xml_escape_chr $content]]
|
||||
|
||||
if { $attr != "" } {
|
||||
puts $fid(xml) "${indent}<$tag ${attr}>${sep}${content}"
|
||||
} else {
|
||||
puts $fid(xml) "${indent}<$tag>${sep}${content}"
|
||||
}
|
||||
}
|
||||
|
||||
proc ::helpdoc::xml_tag_leave {tag attr content depth} {
|
||||
variable fid
|
||||
puts $fid(xml) "[indent $depth]</$tag>"
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# TXT
|
||||
#
|
||||
proc ::helpdoc::attr2array_ {arrayVar attributes} {
|
||||
upvar $arrayVar attr
|
||||
|
||||
foreach {name value} [::textutil::splitx $attributes "=\"|\"\[ \n\r\\t\]|\"$"] {
|
||||
if { $name != "" } {
|
||||
set attr($name) [string trim $value =]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::txt_tag_enter {tag attr content depth} {
|
||||
variable txtDepth
|
||||
variable indentNum
|
||||
variable fid
|
||||
|
||||
set indent [indent $txtDepth]
|
||||
set content [formatString [trimEmpty $content]]
|
||||
|
||||
attr2array_ arr $attr
|
||||
|
||||
switch -exact $tag {
|
||||
namelist {
|
||||
incr txtDepth
|
||||
puts $fid(txt) "${indent}========================================================================\n"
|
||||
puts $fid(txt) "${indent}[string toupper $tag] &$arr(name)"
|
||||
}
|
||||
text {
|
||||
puts $fid(txt) [formatString $content $txtDepth]
|
||||
}
|
||||
var {
|
||||
# if arr(type) does not exists, then var was called from vargroup
|
||||
if { [info exists arr(type)] } {
|
||||
puts $fid(txt) ${indent}[format "%-15s %s" $arr(name) [string toupper $arr(type)]]
|
||||
}
|
||||
}
|
||||
info {
|
||||
puts $fid(txt) [formatString $content $txtDepth [expr 15 + 1]]
|
||||
}
|
||||
status {
|
||||
set content "[::tclu::labelMsg {( Status} $content] )"
|
||||
puts $fid(txt) [formatString $content $txtDepth [expr 15 + 1]]
|
||||
#puts $fid(txt) ${indent}[format "%15s %s" {} "( Status: $content )"]
|
||||
}
|
||||
label {
|
||||
puts $fid(txt) "${indent}!"
|
||||
puts $fid(txt) ${indent}[::tclu::labelMsg "${indent}! :::" [formatString $content]]
|
||||
puts $fid(txt) "${indent}!\n"
|
||||
}
|
||||
}
|
||||
if { $tag == "default" } {
|
||||
set content "[::tclu::labelMsg {( Default} $content] )"
|
||||
puts $fid(txt) [formatString $content $txtDepth [expr 15 + 1]]
|
||||
#puts $fid(txt) ${indent}[format "%15s %s" {} "( Default: $content )"]
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::txt_tag_leave {tag attr content depth} {
|
||||
variable fid
|
||||
variable txtDepth
|
||||
switch -exact $tag {
|
||||
namelist {
|
||||
incr txtDepth -1
|
||||
set indent [indent $txtDepth]
|
||||
puts $fid(txt) "${indent}END OF NAMELIST\n"
|
||||
}
|
||||
group - text {
|
||||
puts $fid(txt) ""
|
||||
}
|
||||
var {
|
||||
puts $fid(txt) "\n"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Robodoc
|
||||
#
|
||||
proc ::helpdoc::rbd_tag_enter {tag attr content depth} {
|
||||
variable fid
|
||||
variable rbd_var
|
||||
variable rbd_stack
|
||||
variable rbd_info
|
||||
|
||||
set content [formatString [trimEmpty $content]]
|
||||
|
||||
attr2array_ arr $attr
|
||||
|
||||
switch -exact $tag {
|
||||
input_description {
|
||||
set rbd_stack [::struct::stack]
|
||||
|
||||
set module {}
|
||||
set rbd_info(program) unknown
|
||||
if { [info exists arr(distribution)] } { set module $arr(distribution) }
|
||||
if { [info exists arr(package)] } { set module $arr(package) }
|
||||
if { [info exists arr(program)] } {
|
||||
set module $module/$arr(program)
|
||||
set rbd_info(program) $arr(program)
|
||||
}
|
||||
if { $module == "" } { set module /input }
|
||||
|
||||
set current_module [lindex [split $module /] end]
|
||||
$rbd_stack push $current_module
|
||||
|
||||
puts $fid(rbd) [formatString [subst {
|
||||
#****h* $module
|
||||
# DESCRIPTION
|
||||
# Description of the input syntax for program ...
|
||||
#******
|
||||
}]]\n
|
||||
}
|
||||
namelist {
|
||||
set module "[$rbd_stack peek]/$arr(name)"
|
||||
$rbd_stack push $arr(name)
|
||||
|
||||
puts $fid(rbd) [formatString [subst {
|
||||
#****n* $module
|
||||
# DESCRIPTION
|
||||
# Description of the $arr(name) namelist.
|
||||
#******
|
||||
}]]\n
|
||||
}
|
||||
var {
|
||||
set name $arr(name)
|
||||
regsub -all -- , $name + name
|
||||
set rbd_var "#****v* [$rbd_stack peek]/$name\n"
|
||||
append rbd_var "# NAME\n"
|
||||
append rbd_var "# $arr(name)\n"
|
||||
}
|
||||
info {
|
||||
append rbd_var "# DESCRIPTION\n[::textutil::indent $content {# }]"
|
||||
}
|
||||
status {
|
||||
append rbd_var "# STATUS\n[::textutil::indent $content {# }]\n"
|
||||
}
|
||||
}
|
||||
if { $tag == "default" } {
|
||||
append rbd_var "# DEFAULT\n[::textutil::indent $content {# }]\n"
|
||||
}
|
||||
}
|
||||
|
||||
proc ::helpdoc::rbd_tag_leave {tag attr content depth} {
|
||||
variable fid
|
||||
variable rbd_var
|
||||
variable rbd_stack
|
||||
switch -exact $tag {
|
||||
namelist {
|
||||
puts $fid(rbd) "\n\# *** END of NAMELIST\n"
|
||||
$rbd_stack pop
|
||||
}
|
||||
var {
|
||||
puts $fid(rbd) $rbd_var
|
||||
puts $fid(rbd) "#******\n"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::print {tree node action} {
|
||||
variable fid
|
||||
|
||||
set depth [$tree depth $node]
|
||||
|
||||
set tag [$tree get $node tag]
|
||||
set attributes [getFromTree $tree $node attributes]
|
||||
set content [getFromTree $tree $node text]
|
||||
|
||||
|
||||
# XML
|
||||
|
||||
xml_tag_${action} $tag $attributes $content $depth
|
||||
|
||||
# currently disabled:
|
||||
|
||||
# TXT
|
||||
|
||||
#txt_tag_${action} $tag $attributes $content [expr $depth - 1]
|
||||
|
||||
# robodoc
|
||||
|
||||
#rbd_tag_${action} $tag $attributes $content $depth
|
||||
}
|
||||
|
|
@ -0,0 +1,203 @@
|
|||
proc ::helpdoc::attrsToOpts_ {attrList} {
|
||||
# PURPOSE
|
||||
# Tranform attribute list to option list, i.e.:
|
||||
# {name ident type} --> {-name -ident -type}
|
||||
|
||||
set optList {}
|
||||
foreach attr $attrList {
|
||||
lappend optList -$attr
|
||||
}
|
||||
return $optList
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::optVal2AttrVal_ {optValList} {
|
||||
# PURPOSE
|
||||
# Tranform option-value pairs to attribute value pairs, i.e.:
|
||||
# {-option1 value1 -option2 value2} --> {option1="value1" option2="value2"}
|
||||
|
||||
set result ""
|
||||
foreach {opt val} $optValList {
|
||||
set attr [string trimleft $opt -]
|
||||
append result " $attr=\"$val\""
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::checkIdent_ {ident} {
|
||||
# PURPOSE
|
||||
# Check if $ident is valid ident: it should not start with -, and
|
||||
# should be one word only, starting with an alphabetical
|
||||
# character"
|
||||
|
||||
set ident [string trim $ident]
|
||||
set tag [tag -3]
|
||||
if { [regexp {^-} $ident] } {
|
||||
::tclu::abort "expecting ident for tag \"$tag\", but got an option $ident"
|
||||
}
|
||||
|
||||
if { [llength $ident] > 1 } {
|
||||
::tclu::abort "expecting ident for tag \"$tag\" (ident should be a single word), but got a text: $ident"
|
||||
}
|
||||
|
||||
if { ! [regexp {^[a-zA-Z_]} $ident] } {
|
||||
::tclu::abort "not a proper ident, $ident, for tag \"$tag\", ident start with a-z, or A-Z, or _"
|
||||
}
|
||||
}
|
||||
|
||||
proc ::helpdoc::rootnameTag_ {args} {
|
||||
variable tree
|
||||
variable stack
|
||||
variable state
|
||||
variable elemArr
|
||||
|
||||
set tag [tag -2]
|
||||
set code [lindex $args end]
|
||||
set tree [::struct::tree]
|
||||
set node [$tree rootname]
|
||||
|
||||
$tree set $node tag $tag
|
||||
|
||||
parseTagMsg_; puts ""
|
||||
|
||||
# do tag uses ident ?
|
||||
|
||||
#puts "tag=$tag"
|
||||
#puts "array(IDENT,*): [array names elemArr IDENT,*]\n"
|
||||
#puts "array(ATTRLIST,*): [array names elemArr ATTRLIST,*]\n"
|
||||
|
||||
if { [info exists elemArr(IDENT,$tag)] } {
|
||||
# add name="string" to attribute list
|
||||
set ident [lindex $args 0]
|
||||
checkIdent_ $ident
|
||||
set attr "name=\"$ident\""
|
||||
set args [lrange $args 1 end]
|
||||
}
|
||||
|
||||
# do tag use attributes ?
|
||||
|
||||
if { [info exists elemArr(ATTRLIST,$tag)] } {
|
||||
append attr [optVal2AttrVal_ [::tclu::extractArgs \
|
||||
[attrsToOpts_ $elemArr(ATTRLIST,$tag)] args]]
|
||||
if { [llength $args] != 1 } {
|
||||
# wrong attributes have been specified
|
||||
::tclu::abort "wrong attributes for the \"$tag\" specified, must be one of: [join $elemArr(ATTRLIST,$tag) ,]"
|
||||
}
|
||||
}
|
||||
|
||||
# store attributes into the tree ...
|
||||
|
||||
if { [info exists attr] } {
|
||||
$tree set $node attributes $attr
|
||||
}
|
||||
|
||||
# proceed further
|
||||
|
||||
$stack push [$tree rootname]
|
||||
namespace eval tag $code
|
||||
$stack pop
|
||||
|
||||
puts {[OK] - parsing finished}
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::elementTag_ {args} {
|
||||
variable tree
|
||||
variable stack
|
||||
variable state
|
||||
variable elemArr
|
||||
|
||||
if { $tree == "" } {
|
||||
# an element tag has been specified before rootelement
|
||||
::tclu::abort "an element \"$tag\" specified before the rootelement \"$state(rootElem)\""
|
||||
}
|
||||
|
||||
set tag [tag -2]
|
||||
set node [$tree insert [$stack peek] end]
|
||||
set code [lindex $args end]
|
||||
|
||||
|
||||
$tree set $node tag $tag
|
||||
|
||||
#puts "tag=$tag"
|
||||
#puts "array(TEXT,*): [array names elemArr TEXT,*]\n"
|
||||
#puts "array(IDENT,*): [array names elemArr IDENT,*]\n"
|
||||
#puts "array(ATTRLIST,*): [array names elemArr ATTRLIST,*]\n"
|
||||
|
||||
if { [info exists elemArr(TEXT,$tag)] || [info exists elemArr(STRING,$tag)] } {
|
||||
# we have a simple-element (leaf)
|
||||
$tree set $node text [lindex $args 0]
|
||||
parseTagMsg_; puts ok
|
||||
|
||||
} else {
|
||||
# we have a complex-element
|
||||
|
||||
# do tag uses ident ?
|
||||
|
||||
if { [info exists elemArr(IDENT,$tag)] } {
|
||||
# add name="string" to attribute list
|
||||
set name [lindex $args 0]
|
||||
parseTagMsg_ $name; puts ""
|
||||
|
||||
checkIdent_ $name
|
||||
set attr "name=\"$name\""
|
||||
set args [lrange $args 1 end]
|
||||
if { $args == "" } { set code "" }
|
||||
} else {
|
||||
parseTagMsg_; puts ""
|
||||
}
|
||||
|
||||
# do tag use attributes ?
|
||||
|
||||
if { [info exists elemArr(ATTRLIST,$tag)] } {
|
||||
if { [llength $args] > 1 } {
|
||||
# this is quick-and-dirty, but we need to do more cheking on order, optionality, ....
|
||||
append attr [optVal2AttrVal_ [::tclu::extractArgs \
|
||||
[attrsToOpts_ $elemArr(ATTRLIST,$tag)] args]]
|
||||
if { [llength $args] != 1 } {
|
||||
# wrong attributes have been specified
|
||||
::tclu::abort "wrong attributes for the \"$tag\" specified, must be one of: [join $elemArr(ATTRLIST,$tag) ,]"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# TODO: checks on order, optionality, ...
|
||||
|
||||
# store attributes into the tree ...
|
||||
|
||||
if { [info exists attr] } {
|
||||
$tree set $node attributes $attr
|
||||
}
|
||||
|
||||
# proceed further
|
||||
|
||||
$stack push $node
|
||||
namespace eval tag $code
|
||||
$stack pop
|
||||
|
||||
parseTagMsgOK_;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::parseTagMsg_ {{name {}}} {
|
||||
variable tree
|
||||
|
||||
set indent [uplevel 1 {indent [$tree depth $node]}]
|
||||
set tag [string toupper [tag -3]]
|
||||
puts -nonewline "${indent}parsing $tag $name ... "
|
||||
}
|
||||
|
||||
proc ::helpdoc::parseTagMsgOK_ {{name {}}} {
|
||||
variable tree
|
||||
set indent [uplevel 1 {indent [$tree depth $node]}]
|
||||
set tag [string toupper [tag -3]]
|
||||
|
||||
if { $name == "" } {
|
||||
puts "${indent}\[OK\] - parsing $tag completed"
|
||||
} else {
|
||||
puts "${indent}\[OK\] - parsing $tag $name completed"
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,345 @@
|
|||
|
||||
namespace eval ::helpdoc::schema {
|
||||
|
||||
# here is the definition of Tcl-commands that are used in schema
|
||||
|
||||
proc rootelement {name code} { uplevel 1 [list ::helpdoc::rootelement $name $code] }
|
||||
proc element {name code} { uplevel 1 [list ::helpdoc::element $name $code] }
|
||||
proc attribute {name code} { uplevel 1 [list ::helpdoc::attribute $name $code] }
|
||||
proc define {name code} { uplevel 1 [list ::helpdoc::define $name $code] }
|
||||
proc text {} { uplevel 1 [list ::helpdoc::text] }
|
||||
proc string {} { uplevel 1 [list ::helpdoc::String] }
|
||||
proc ref {name} { uplevel 1 [list ::helpdoc::ref $name] }
|
||||
proc ident {} { uplevel 1 [list ::helpdoc::ident] }
|
||||
proc optional {code} { uplevel 1 [list ::helpdoc::optional $code] }
|
||||
proc interleave {code} { uplevel 1 [list ::helpdoc::interleave $code] }
|
||||
proc choice {code} { uplevel 1 [list ::helpdoc::choice $code] }
|
||||
proc ancestorElements {} { uplevel 1 [list ::helpdoc::ancestorElements] }
|
||||
proc ? {code} { uplevel 1 [list ::helpdoc::? $code] }
|
||||
proc * {code} { uplevel 1 [list ::helpdoc::* $code] }
|
||||
proc + {code} { uplevel 1 [list ::helpdoc::+ $code] }
|
||||
}
|
||||
|
||||
# actual implementation of commands ...
|
||||
|
||||
proc ::helpdoc::rootelement {name code} {
|
||||
variable elemList
|
||||
variable itemList
|
||||
variable stackArr
|
||||
variable state
|
||||
|
||||
parseMsg_ $name; puts ""
|
||||
incr state(depth)
|
||||
|
||||
if { $state(rootVisited) } {
|
||||
::tclu::abort "more than one rootelement; there can be only one !"
|
||||
}
|
||||
set state(rootVisited) 1
|
||||
set state(rootElem) $name
|
||||
|
||||
lappend elemList $name
|
||||
lappend itemList $name
|
||||
|
||||
|
||||
$stackArr(currentElem) push $name
|
||||
#eval $code
|
||||
namespace eval schema $code
|
||||
$stackArr(currentElem) pop
|
||||
|
||||
incr state(depth) -1
|
||||
parseMsgOK_ $name
|
||||
}
|
||||
|
||||
proc ::helpdoc::element {name code} {
|
||||
variable elemList
|
||||
variable itemList
|
||||
variable state
|
||||
variable stackArr
|
||||
variable elemArr
|
||||
|
||||
parseMsg_ $name; puts ""
|
||||
incr state(depth)
|
||||
|
||||
# check that $name does not exists
|
||||
if { [::tclu::lpresent $elemList $name] } {
|
||||
::tclu::abort "element \"$name\" already defined"
|
||||
}
|
||||
lappend elemList $name
|
||||
lappend itemList $name
|
||||
|
||||
$stackArr(optional) push 0
|
||||
$stackArr(interleave) push 0
|
||||
|
||||
set parentElem [$stackArr(currentElem) peek]
|
||||
|
||||
lappend elemArr(ELEMLIST,$parentElem) $name
|
||||
lappend elemArr(OPTIONAL,$parentElem,$name) [$stackArr(optional) peek]
|
||||
lappend elemArr(INTERLEAVE,$parentElem,$name) [$stackArr(interleave) peek]
|
||||
lappend elemArr(REPETITION,$parentElem,$name) [$stackArr(repetition) peek]
|
||||
|
||||
$stackArr(currentElem) push $name
|
||||
#eval $code
|
||||
namespace eval schema $code
|
||||
$stackArr(currentElem) pop
|
||||
|
||||
$stackArr(optional) pop
|
||||
$stackArr(interleave) pop
|
||||
|
||||
incr state(depth) -1
|
||||
parseMsgOK_ $name
|
||||
}
|
||||
|
||||
proc ::helpdoc::attribute {name code} {
|
||||
# so far we assume attributes have arbitrary values (which means
|
||||
# we ignore code)
|
||||
|
||||
variable itemList
|
||||
variable stackArr
|
||||
variable elemArr
|
||||
|
||||
parseMsg_ $name
|
||||
|
||||
set currentElem [$stackArr(currentElem) peek]
|
||||
|
||||
lappend itemList $name
|
||||
lappend elemArr(ATTRLIST,$currentElem) $name
|
||||
lappend attrArr(OPTIONAL,$currentElem) [$stackArr(optional) peek]
|
||||
|
||||
puts ok
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::define {name code} {
|
||||
variable defineArr
|
||||
variable itemList
|
||||
|
||||
parseMsg_ $name;
|
||||
|
||||
lappend itemList $name
|
||||
set defineArr($name) $code
|
||||
|
||||
puts ok
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::text {} {
|
||||
# BEWARE: so far can be called only from element (because
|
||||
# attribute does not yet support ...)
|
||||
variable stackArr
|
||||
variable elemArr
|
||||
set currentElem [$stackArr(currentElem) peek]
|
||||
set elemArr(TEXT,$currentElem) 1
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::String {} {
|
||||
# BEWARE: so far can be called only from element (because
|
||||
# attribute does not yet support ...)
|
||||
variable stackArr
|
||||
variable elemArr
|
||||
set currentElem [$stackArr(currentElem) peek]
|
||||
set elemArr(STRING,$currentElem) 1
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::ref {name} {
|
||||
variable stackArr
|
||||
variable elemArr
|
||||
variable defineArr
|
||||
|
||||
parseMsg_ $name;
|
||||
|
||||
if { [info exists defineArr($name)] } {
|
||||
puts ""
|
||||
# the ref points to define, evaluate it
|
||||
#eval $defineArr($name)
|
||||
namespace eval schema $defineArr($name)
|
||||
parseMsgOK_;
|
||||
return
|
||||
}
|
||||
|
||||
set currentElem [$stackArr(currentElem) peek]
|
||||
|
||||
if { $currentElem != "" } {
|
||||
lappend elemArr(REFLIST,$currentElem) $name
|
||||
|
||||
lappend elemArr(OPTIONAL,$currentElem,$name) [$stackArr(optional) peek]
|
||||
lappend elemArr(INTERLEAVE,$currentElem,$name) [$stackArr(interleave) peek]
|
||||
lappend elemArr(REPETITION,$currentElem,$name) [$stackArr(repetition) peek]
|
||||
} else {
|
||||
::tclu::abort "can't use \"ref\" outside element definition"
|
||||
}
|
||||
|
||||
puts ok
|
||||
}
|
||||
|
||||
proc ::helpdoc::ident {} {
|
||||
variable stackArr
|
||||
variable elemArr
|
||||
|
||||
set currentElem [$stackArr(currentElem) peek]
|
||||
|
||||
if { $currentElem != "" } {
|
||||
set elemArr(IDENT,$currentElem) 1
|
||||
} else {
|
||||
::tclu::abort "can't use \"ident\" outside element definition"
|
||||
}
|
||||
}
|
||||
|
||||
proc ::helpdoc::optional {code} {
|
||||
variable stackArr
|
||||
variable state
|
||||
|
||||
parseMsg_; puts ""
|
||||
incr state(depth)
|
||||
|
||||
$stackArr(optional) push 1
|
||||
# eval $code
|
||||
namespace eval schema $code
|
||||
$stackArr(optional) pop
|
||||
|
||||
incr state(depth) -1
|
||||
parseMsgOK_
|
||||
}
|
||||
|
||||
proc ::helpdoc::interleave {code} {
|
||||
variable stackArr
|
||||
variable state
|
||||
|
||||
parseMsg_; puts ""
|
||||
incr state(depth)
|
||||
|
||||
$stackArr(interleave) push 1
|
||||
# eval $code
|
||||
namespace eval schema $code
|
||||
$stackArr(interleave) pop
|
||||
|
||||
incr state(depth) -1
|
||||
parseMsgOK_
|
||||
}
|
||||
|
||||
proc ::helpdoc::choice {code} {
|
||||
variable stackArr
|
||||
variable state
|
||||
|
||||
# TODO: implement the CHOICE; so far this proc is dummy
|
||||
parseMsg_; puts ""
|
||||
incr state(depth)
|
||||
|
||||
#eval $code
|
||||
namespace eval schema $code
|
||||
|
||||
incr state(depth) -1
|
||||
parseMsgOK_
|
||||
}
|
||||
|
||||
proc ::helpdoc::ancestorElements {} {
|
||||
parseMsg_
|
||||
# DO nothing (this means no validation for correctness will be done)
|
||||
puts ok
|
||||
}
|
||||
|
||||
proc ::helpdoc::? {code} {
|
||||
repetition_ $code
|
||||
}
|
||||
proc ::helpdoc::* {code} {
|
||||
repetition_ $code
|
||||
}
|
||||
proc ::helpdoc::+ {code} {
|
||||
repetition_ $code
|
||||
}
|
||||
proc ::helpdoc::repetition_ {code} {
|
||||
variable stackArr
|
||||
variable state
|
||||
|
||||
set type [tag -2]
|
||||
uplevel 1 "parseMsg_; puts {}"
|
||||
incr state(depth)
|
||||
|
||||
$stackArr(repetition) push $type
|
||||
#eval $code
|
||||
namespace eval schema $code
|
||||
$stackArr(repetition) pop
|
||||
|
||||
incr state(depth) -1
|
||||
uplevel 1 "parseMsgOK_"
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::assignRefs_ {} {
|
||||
variable elemList
|
||||
variable elemArr
|
||||
|
||||
foreach elem $elemList {
|
||||
if { [info exists elemArr(REFLIST,$elem)] } {
|
||||
# we have a ref
|
||||
puts -nonewline " $elem --> "
|
||||
foreach ref $elemArr(REFLIST,$elem) {
|
||||
# check if ref points to "define"
|
||||
lappend elemArr(ELEMLIST,$elem) $ref
|
||||
|
||||
puts -nonewline "$ref "
|
||||
|
||||
# check that $ref exists
|
||||
if { ! [::tclu::lpresent $elemList $ref] } {
|
||||
puts ""
|
||||
::tclu::abort "the \"$ref\" element has not been defined, yet it is referenced"
|
||||
}
|
||||
}
|
||||
puts ""
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc ::helpdoc::createTagCmds_ {} {
|
||||
variable state
|
||||
variable elemList
|
||||
|
||||
if { $state(rootElem) == {} } {
|
||||
::tclu::abort "rootelement was not defined"
|
||||
}
|
||||
|
||||
# create the rootelement cmd
|
||||
puts " creating $state(rootElem) cmd ... ok"
|
||||
proc ::helpdoc::tag::$state(rootElem) {args} {
|
||||
eval ::helpdoc::rootnameTag_ $args
|
||||
}
|
||||
|
||||
# create all elements cmds
|
||||
|
||||
foreach elem $elemList {
|
||||
if { $elem != $state(rootElem) } {
|
||||
puts -nonewline " creating $elem cmd ... "
|
||||
proc ::helpdoc::tag::$elem {args} {
|
||||
eval ::helpdoc::elementTag_ $args
|
||||
}
|
||||
puts ok
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# for the time being ...
|
||||
proc helpdoc::parseMsg_ {{name {}}} {
|
||||
variable state
|
||||
|
||||
set indent [::textutil::blank [expr (1+$state(depth)) * 3]]
|
||||
|
||||
set tag [string toupper [tag -2]]
|
||||
puts -nonewline "${indent}parsing $tag $name ... "
|
||||
}
|
||||
|
||||
proc helpdoc::parseMsgOK_ {{name {}}} {
|
||||
variable state
|
||||
|
||||
set indent [::textutil::blank [expr (1+$state(depth)) * 3]]
|
||||
|
||||
set tag [string toupper [tag -2]]
|
||||
|
||||
if { $name == "" } {
|
||||
puts "${indent}OK - parsing $tag completed"
|
||||
} else {
|
||||
puts "${indent}OK - parsing $tag $name completed"
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
# Tcl autoload index file, version 2.0
|
||||
# This file is generated by the "auto_mkindex" command
|
||||
# and sourced to set up indexing information for one or
|
||||
# more commands. Typically each line is a command that
|
||||
# sets an element in the auto_index array, where the
|
||||
# element name is the name of a command and the value is
|
||||
# a script that loads the command.
|
||||
|
||||
set auto_index(::helpdoc::schema::rootelement) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::element) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::attribute) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::define) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::text) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::string) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::ref) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::ident) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::optional) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::interleave) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::choice) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::ancestorElements) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::?) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::*) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::schema::+) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::rootelement) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::element) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::attribute) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::define) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::text) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::String) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::ref) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::ident) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::optional) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::interleave) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::choice) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::ancestorElements) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::?) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::*) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::+) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::repetition_) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::assignRefs_) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::createTagCmds_) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::parseMsg_) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::parseMsgOK_) [list source [file join $dir readSchema.tcl]]
|
||||
set auto_index(::helpdoc::openOutputs) [list source [file join $dir helpdoc.tcl]]
|
||||
set auto_index(::helpdoc::writeOutputs) [list source [file join $dir helpdoc.tcl]]
|
||||
set auto_index(::helpdoc::readSchema) [list source [file join $dir helpdoc.tcl]]
|
||||
set auto_index(::helpdoc::process) [list source [file join $dir helpdoc.tcl]]
|
||||
set auto_index(::helpdoc::tag) [list source [file join $dir auxil.tcl]]
|
||||
set auto_index(::helpdoc::indent) [list source [file join $dir auxil.tcl]]
|
||||
set auto_index(::helpdoc::getFromTree) [list source [file join $dir auxil.tcl]]
|
||||
set auto_index(::helpdoc::formatString) [list source [file join $dir auxil.tcl]]
|
||||
set auto_index(::helpdoc::trimEmpty) [list source [file join $dir auxil.tcl]]
|
||||
set auto_index(::helpdoc::attrsToOpts_) [list source [file join $dir parseTags.tcl]]
|
||||
set auto_index(::helpdoc::optVal2AttrVal_) [list source [file join $dir parseTags.tcl]]
|
||||
set auto_index(::helpdoc::checkIdent_) [list source [file join $dir parseTags.tcl]]
|
||||
set auto_index(::helpdoc::rootnameTag_) [list source [file join $dir parseTags.tcl]]
|
||||
set auto_index(::helpdoc::elementTag_) [list source [file join $dir parseTags.tcl]]
|
||||
set auto_index(::helpdoc::parseTagMsg_) [list source [file join $dir parseTags.tcl]]
|
||||
set auto_index(::helpdoc::parseTagMsgOK_) [list source [file join $dir parseTags.tcl]]
|
||||
set auto_index(::helpdoc::xml_escape_chr) [list source [file join $dir outputs.tcl]]
|
||||
set auto_index(::helpdoc::xml_tag_enter) [list source [file join $dir outputs.tcl]]
|
||||
set auto_index(::helpdoc::xml_tag_leave) [list source [file join $dir outputs.tcl]]
|
||||
set auto_index(::helpdoc::attr2array_) [list source [file join $dir outputs.tcl]]
|
||||
set auto_index(::helpdoc::txt_tag_enter) [list source [file join $dir outputs.tcl]]
|
||||
set auto_index(::helpdoc::txt_tag_leave) [list source [file join $dir outputs.tcl]]
|
||||
set auto_index(::helpdoc::rbd_tag_enter) [list source [file join $dir outputs.tcl]]
|
||||
set auto_index(::helpdoc::rbd_tag_leave) [list source [file join $dir outputs.tcl]]
|
||||
set auto_index(::helpdoc::print) [list source [file join $dir outputs.tcl]]
|
||||
Loading…
Reference in New Issue