1proc ::helpdoc::attrsToOpts_ {attrList} { 2 # PURPOSE 3 # Tranform attribute list to option list, i.e.: 4 # {name ident type} --> {-name -ident -type} 5 6 set optList {} 7 foreach attr $attrList { 8 lappend optList -$attr 9 } 10 return $optList 11} 12 13 14proc ::helpdoc::optVal2AttrVal_ {optValList} { 15 # PURPOSE 16 # Tranform option-value pairs to attribute value pairs, i.e.: 17 # {-option1 value1 -option2 value2} --> {option1="value1" option2="value2"} 18 19 set result "" 20 foreach {opt val} $optValList { 21 set attr [string trimleft $opt -] 22 append result "$attr=\"$val\" " 23 } 24 return $result 25} 26 27 28proc ::helpdoc::checkIdent_ {ident} { 29 # PURPOSE 30 # Check if $ident is valid ident: it should not start with -, and 31 # should be one word only, starting with an alphabetical 32 # character" 33 34 set ident [string trim $ident] 35 set tag [tag -3] 36 if { [regexp {^-} $ident] } { 37 ::tclu::abort "expecting ident for tag \"$tag\", but got an option $ident" 38 } 39 40 if { [llength $ident] > 1 } { 41 ::tclu::abort "expecting ident for tag \"$tag\" (ident should be a single word), but got a text: $ident" 42 } 43 44 if { ! [regexp {^[a-zA-Z_]} $ident] } { 45 ::tclu::abort "not a proper ident, $ident, for tag \"$tag\", ident start with a-z, or A-Z, or _" 46 } 47} 48 49proc ::helpdoc::rootnameTag_ {args} { 50 variable tree 51 variable stack 52 variable state 53 variable elemArr 54 55 set tag [tag -2] 56 set code [lindex $args end] 57 set tree [::struct::tree] 58 set node [$tree rootname] 59 60 $tree set $node tag $tag 61 62 parseTagMsg_; puts "" 63 64 # do tag uses ident ? 65 66 #puts "tag=$tag" 67 #puts "array(IDENT,*): [array names elemArr IDENT,*]\n" 68 #puts "array(ATTRLIST,*): [array names elemArr ATTRLIST,*]\n" 69 70 if { [info exists elemArr(IDENT,$tag)] } { 71 # add name="string" to attribute list 72 set ident [lindex $args 0] 73 checkIdent_ $ident 74 set attr "name=\"$ident\" " 75 set args [lrange $args 1 end] 76 } 77 78 # do tag use attributes ? 79 80 if { [info exists elemArr(ATTRLIST,$tag)] } { 81 append attr [optVal2AttrVal_ [::tclu::extractArgs \ 82 [attrsToOpts_ $elemArr(ATTRLIST,$tag)] args]] 83 if { [llength $args] != 1 } { 84 # wrong attributes have been specified 85 ::tclu::abort "wrong attributes for the \"$tag\" specified, must be one of: [join $elemArr(ATTRLIST,$tag) ,]" 86 } 87 } 88 89 # store attributes into the tree ... 90 91 if { [info exists attr] } { 92 $tree set $node attributes $attr 93 } 94 95 # proceed further 96 97 $stack push [$tree rootname] 98 namespace eval tag $code 99 $stack pop 100 101 puts {[OK] - parsing finished} 102} 103 104 105proc ::helpdoc::elementTag_ {args} { 106 variable tree 107 variable stack 108 variable state 109 variable elemArr 110 111 set tag [tag -2] 112 113 if { $tree == "" } { 114 # an element tag has been specified before rootelement 115 ::tclu::abort "an element \"$tag\" specified before the rootelement \"$state(rootElem)\"" 116 } 117 118 set node [$tree insert [$stack peek] end] 119 set code [lindex $args end] 120 121 122 $tree set $node tag $tag 123 124 #puts "tag=$tag" 125 #puts "array(TEXT,*): [array names elemArr TEXT,*]\n" 126 #puts "array(IDENT,*): [array names elemArr IDENT,*]\n" 127 #puts "array(ATTRLIST,*): [array names elemArr ATTRLIST,*]\n" 128 129 # do tag uses ident ? 130 131 if { [info exists elemArr(IDENT,$tag)] } { 132 # add name="string" to attribute list 133 set name [lindex $args 0] 134 parseTagMsg_ $name; 135 136 checkIdent_ $name 137 set attr "name=\"$name\" " 138 set args [lrange $args 1 end] 139 if { $args == "" } { set code "" } 140 } else { 141 parseTagMsg_; 142 } 143 144 # do tag use attributes ? 145 146 if { [info exists elemArr(ATTRLIST,$tag)] } { 147 if { [llength $args] > 1 } { 148 # this is quick-and-dirty, but we need to do more cheking on order, optionality, .... 149 append attr [optVal2AttrVal_ [::tclu::extractArgs \ 150 [attrsToOpts_ $elemArr(ATTRLIST,$tag)] args]] 151 if { [llength $args] != 1 } { 152 # wrong attributes have been specified 153 ::tclu::abort "wrong attributes for the \"$tag\" specified, must be one of: [join $elemArr(ATTRLIST,$tag) ,]" 154 } 155 } 156 } 157 158 # TODO: checks on order, optionality, ... 159 160 # store attributes into the tree ... 161 162 if { [info exists attr] } { 163 $tree set $node attributes $attr 164 } 165 166 # we have a leaf or a complex-element ? 167 168 if { [info exists elemArr(WORD,$tag)] || [info exists elemArr(STRING,$tag)] || 169 [info exists elemArr(TEXT,$tag)] || [info exists elemArr(CLIST,$tag)] || [info exists elemArr(PLIST,$tag)] } { 170 171 # we have a simple-element (leaf) 172 $tree set $node text [lindex $args 0] 173 #parseTagMsg_; puts ok 174 puts ok 175 176 } else { 177 # we have a complex element 178 puts ""; # (needed for nice print-out) 179 180 # proceed further 181 182 $stack push $node 183 namespace eval tag $code 184 $stack pop 185 186 parseTagMsgOK_; 187 } 188} 189 190 191proc ::helpdoc::parseTagMsg_ {{name {}}} { 192 variable tree 193 194 set indent [uplevel 1 {indent [$tree depth $node]}] 195 set tag [string toupper [tag -3]] 196 puts -nonewline "${indent}parsing $tag $name ... " 197} 198 199proc ::helpdoc::parseTagMsgOK_ {{name {}}} { 200 variable tree 201 set indent [uplevel 1 {indent [$tree depth $node]}] 202 set tag [string toupper [tag -3]] 203 204 if { $name == "" } { 205 puts "${indent}\[OK\] - parsing $tag completed" 206 } else { 207 puts "${indent}\[OK\] - parsing $tag $name completed" 208 } 209} 210 211