From 164d7fe0d2ba1079fa0325c4c74304906d694a40 Mon Sep 17 00:00:00 2001 From: kokalj Date: Wed, 12 Mar 2008 14:14:58 +0000 Subject: [PATCH] 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 --- dev-tools/helpdoc | 26 +++ dev-tools/helpdoc.d/auxil.tcl | 44 ++++ dev-tools/helpdoc.d/helpdoc.tcl | 174 +++++++++++++++ dev-tools/helpdoc.d/outputs.tcl | 237 ++++++++++++++++++++ dev-tools/helpdoc.d/parseTags.tcl | 203 +++++++++++++++++ dev-tools/helpdoc.d/readSchema.tcl | 345 +++++++++++++++++++++++++++++ dev-tools/helpdoc.d/tclIndex | 68 ++++++ 7 files changed, 1097 insertions(+) create mode 100755 dev-tools/helpdoc create mode 100644 dev-tools/helpdoc.d/auxil.tcl create mode 100644 dev-tools/helpdoc.d/helpdoc.tcl create mode 100644 dev-tools/helpdoc.d/outputs.tcl create mode 100644 dev-tools/helpdoc.d/parseTags.tcl create mode 100644 dev-tools/helpdoc.d/readSchema.tcl create mode 100644 dev-tools/helpdoc.d/tclIndex diff --git a/dev-tools/helpdoc b/dev-tools/helpdoc new file mode 100755 index 000000000..6f3e64e4d --- /dev/null +++ b/dev-tools/helpdoc @@ -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 diff --git a/dev-tools/helpdoc.d/auxil.tcl b/dev-tools/helpdoc.d/auxil.tcl new file mode 100644 index 000000000..33096d61e --- /dev/null +++ b/dev-tools/helpdoc.d/auxil.tcl @@ -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 +} + + diff --git a/dev-tools/helpdoc.d/helpdoc.tcl b/dev-tools/helpdoc.d/helpdoc.tcl new file mode 100644 index 000000000..f705814e3 --- /dev/null +++ b/dev-tools/helpdoc.d/helpdoc.tcl @@ -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) {} + puts $fid(xml) {} + puts $fid(xml) { + } + + #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 + } + } +} diff --git a/dev-tools/helpdoc.d/outputs.tcl b/dev-tools/helpdoc.d/outputs.tcl new file mode 100644 index 000000000..97c8694c4 --- /dev/null +++ b/dev-tools/helpdoc.d/outputs.tcl @@ -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]" +} + + +# +# 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 +} diff --git a/dev-tools/helpdoc.d/parseTags.tcl b/dev-tools/helpdoc.d/parseTags.tcl new file mode 100644 index 000000000..b9c864aa8 --- /dev/null +++ b/dev-tools/helpdoc.d/parseTags.tcl @@ -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" + } +} + diff --git a/dev-tools/helpdoc.d/readSchema.tcl b/dev-tools/helpdoc.d/readSchema.tcl new file mode 100644 index 000000000..4c6005929 --- /dev/null +++ b/dev-tools/helpdoc.d/readSchema.tcl @@ -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" + } +} diff --git a/dev-tools/helpdoc.d/tclIndex b/dev-tools/helpdoc.d/tclIndex new file mode 100644 index 000000000..8dd365dfd --- /dev/null +++ b/dev-tools/helpdoc.d/tclIndex @@ -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]]