| 1 | # This program is under CECILL_B licence. See footer for details. |
|---|
| 2 | |
|---|
| 3 | |
|---|
| 4 | ################################################################ |
|---|
| 5 | # This function analyses a parsed tree to |
|---|
| 6 | # - Fill attributes of nodes from a directory |
|---|
| 7 | # - Be sure keywords are well-formed |
|---|
| 8 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 9 | proc analyseModelTree {itree nodes_to_skip solvers_to_add} { |
|---|
| 10 | global nodesToDelete libraryPath dataPath solverOrder |
|---|
| 11 | upvar $itree tree |
|---|
| 12 | # analyseModelNode tree "root" |
|---|
| 13 | |
|---|
| 14 | |
|---|
| 15 | # delete nodes if requested |
|---|
| 16 | foreach solver_to_add $solvers_to_add { |
|---|
| 17 | set solver [lindex $solver_to_add 0] |
|---|
| 18 | set order [lindex $solver_to_add 1] |
|---|
| 19 | |
|---|
| 20 | puts "## GRAFTING SOLVER $solver" |
|---|
| 21 | |
|---|
| 22 | set solverOrder($solver) $order |
|---|
| 23 | |
|---|
| 24 | set modelPath_add [file normalize [file join $libraryPath $solver XML]] |
|---|
| 25 | |
|---|
| 26 | OpenTeaXML2tree XMLtree_add $modelPath_add $dataPath |
|---|
| 27 | |
|---|
| 28 | # not necessary apparently, to be checked thoroughly if problems arise |
|---|
| 29 | #analyseModelTree XMLtree_add $nodes_to_skip "" |
|---|
| 30 | |
|---|
| 31 | dTree_copyBranch XMLtree_add "root $solver" tree "root" |
|---|
| 32 | } |
|---|
| 33 | |
|---|
| 34 | |
|---|
| 35 | |
|---|
| 36 | # Perform all inclusions |
|---|
| 37 | set nodesToDelete "" |
|---|
| 38 | # Analyse each child |
|---|
| 39 | set childrenList [dTree_getChildren $tree "root"] |
|---|
| 40 | |
|---|
| 41 | foreach child $childrenList { |
|---|
| 42 | set childNode "root $child" |
|---|
| 43 | performInclusionForNode tree $childNode |
|---|
| 44 | } |
|---|
| 45 | set nodesToDelete [lsort -unique $nodesToDelete] |
|---|
| 46 | foreach address $nodesToDelete { |
|---|
| 47 | puts "Pruning branch $address" |
|---|
| 48 | dTree_rmBranch tree $address |
|---|
| 49 | } |
|---|
| 50 | |
|---|
| 51 | # delete nodes if requested |
|---|
| 52 | foreach node_to_skip $nodes_to_skip { |
|---|
| 53 | set resultsAddress [dTree_searchNode $tree $node_to_skip] |
|---|
| 54 | foreach address $resultsAddress { |
|---|
| 55 | dTree_rmBranch tree $address |
|---|
| 56 | } |
|---|
| 57 | } |
|---|
| 58 | |
|---|
| 59 | |
|---|
| 60 | |
|---|
| 61 | # Analyse every node |
|---|
| 62 | set nodesToDelete "" |
|---|
| 63 | # Analyse each child |
|---|
| 64 | set childrenList [dTree_getChildren $tree "root"] |
|---|
| 65 | foreach child $childrenList { |
|---|
| 66 | set childNode "root $child" |
|---|
| 67 | analyseModelNode tree $childNode |
|---|
| 68 | } |
|---|
| 69 | set nodesToDelete [lsort -unique $nodesToDelete] |
|---|
| 70 | foreach address $nodesToDelete { |
|---|
| 71 | dTree_rmBranch tree $address |
|---|
| 72 | } |
|---|
| 73 | } |
|---|
| 74 | |
|---|
| 75 | |
|---|
| 76 | proc performInclusionForNode {itree node} { |
|---|
| 77 | upvar $itree tree |
|---|
| 78 | global nodesToDelete |
|---|
| 79 | |
|---|
| 80 | # NodeType |
|---|
| 81 | if {[catch {set nodeType [dTree_getAttribute $tree "$node" nodeType]} ]} { |
|---|
| 82 | popup_error "no nodeType detected for the node $node. Please check your XML file system" strict |
|---|
| 83 | } |
|---|
| 84 | |
|---|
| 85 | #################################### |
|---|
| 86 | # Except "DATA" directory |
|---|
| 87 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 88 | if {$node == "root DATA"} { |
|---|
| 89 | return 0 |
|---|
| 90 | } |
|---|
| 91 | |
|---|
| 92 | #################################### |
|---|
| 93 | # Perform inclusions when detecting "include" |
|---|
| 94 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 95 | if {$nodeType == "include"} { |
|---|
| 96 | # Be sure address is written |
|---|
| 97 | if {[catch {set addrInclude [dTree_getAttribute $tree "$node" "address"]}]} { |
|---|
| 98 | popup_error "No attribute -address- found in node : $node \n Please, be sure it is well written " strict |
|---|
| 99 | } |
|---|
| 100 | set resultsAddress [dTree_searchNode $tree $addrInclude] |
|---|
| 101 | set resultsCount [llength $resultsAddress] |
|---|
| 102 | if {$resultsCount == 0 } {popup_error "$addrInclude not found while reading node : $node\nPlease, be sure it well written" strict} |
|---|
| 103 | if {$resultsCount > 1} { |
|---|
| 104 | set resultsAddress [list [ lindex $resultsAddress 0]] |
|---|
| 105 | } |
|---|
| 106 | puts "Grafting branch $resultsAddress in [lrange $node end-2 end-1]" |
|---|
| 107 | |
|---|
| 108 | # We are now sure the address is unique |
|---|
| 109 | set includeAddress [lindex $resultsAddress 0] |
|---|
| 110 | |
|---|
| 111 | # Delete the include node |
|---|
| 112 | dTree_rmBranch tree "$node" |
|---|
| 113 | |
|---|
| 114 | |
|---|
| 115 | dTree_copyBranch tree "$includeAddress" tree "[lrange $node 0 end-1]" |
|---|
| 116 | lappend nodesToDelete "$includeAddress" |
|---|
| 117 | return |
|---|
| 118 | } |
|---|
| 119 | |
|---|
| 120 | #################################### |
|---|
| 121 | # Analyse each child for inclusion |
|---|
| 122 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 123 | set childrenList [dTree_getChildren $tree $node] |
|---|
| 124 | foreach child $childrenList { |
|---|
| 125 | set childNode "$node $child" |
|---|
| 126 | if {[dTree_nodeExists $tree $childNode]} { |
|---|
| 127 | performInclusionForNode tree $childNode |
|---|
| 128 | } |
|---|
| 129 | } |
|---|
| 130 | } |
|---|
| 131 | |
|---|
| 132 | |
|---|
| 133 | |
|---|
| 134 | |
|---|
| 135 | |
|---|
| 136 | |
|---|
| 137 | |
|---|
| 138 | ################################################################ |
|---|
| 139 | # Recursive part of the analyseModelTree function |
|---|
| 140 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 141 | proc analyseModelNode {itree node} { |
|---|
| 142 | upvar $itree tree |
|---|
| 143 | global nodesToDelete additionalWidgets |
|---|
| 144 | |
|---|
| 145 | |
|---|
| 146 | |
|---|
| 147 | |
|---|
| 148 | |
|---|
| 149 | # NodeType |
|---|
| 150 | if {[catch {set nodeType [dTree_getAttribute $tree "$node" nodeType]} ]} { |
|---|
| 151 | popup_error "no nodeType detected for the node $node. Please check your XML file system" strict |
|---|
| 152 | } |
|---|
| 153 | #################################### |
|---|
| 154 | # Except "DATA" directory |
|---|
| 155 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 156 | if {$node == "root DATA"} { |
|---|
| 157 | return 0 |
|---|
| 158 | } |
|---|
| 159 | |
|---|
| 160 | |
|---|
| 161 | |
|---|
| 162 | |
|---|
| 163 | #################################### |
|---|
| 164 | # Add item node in the multiple |
|---|
| 165 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 166 | if {$nodeType == "multiple"} { |
|---|
| 167 | set multipleChildren [dTree_getChildren $tree $node] |
|---|
| 168 | dTree_addNode tree $node "item" |
|---|
| 169 | dTree_setAttribute tree "$node item" "nodeType" "item" |
|---|
| 170 | dTree_setAttribute tree "$node item" "name" "item" |
|---|
| 171 | dTree_setAttribute tree "$node item" "nodeType" "item" |
|---|
| 172 | foreach child $multipleChildren { |
|---|
| 173 | dTree_moveBranch tree "$node $child" tree "$node item" |
|---|
| 174 | } |
|---|
| 175 | |
|---|
| 176 | } |
|---|
| 177 | |
|---|
| 178 | |
|---|
| 179 | |
|---|
| 180 | set childrenList [dTree_getChildren $tree $node] |
|---|
| 181 | #################################### |
|---|
| 182 | # Fill attributes of directory nodes |
|---|
| 183 | # Move docu nodes to attribute of the father |
|---|
| 184 | # Include "include" |
|---|
| 185 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 186 | foreach child $childrenList { |
|---|
| 187 | # get name of the child if it exists |
|---|
| 188 | |
|---|
| 189 | if {![catch {set childName [dTree_getAttribute $tree "$node $child" name]}]} { |
|---|
| 190 | if {$childName == "folderParameters"} { |
|---|
| 191 | # If child's name is 'folderParameters' ... |
|---|
| 192 | |
|---|
| 193 | # ... Attributes from the child are stored ... |
|---|
| 194 | set childAttributes [dTree_getAttributes $tree "$node $child"] |
|---|
| 195 | |
|---|
| 196 | # ... into the father! |
|---|
| 197 | foreach attribute $childAttributes { |
|---|
| 198 | if {[lindex $attribute 0] != "name"} { |
|---|
| 199 | dTree_setAttribute tree "$node" [lindex $attribute 0] [lindex $attribute 1] |
|---|
| 200 | } |
|---|
| 201 | } |
|---|
| 202 | |
|---|
| 203 | # Delete the child (love this one ...) |
|---|
| 204 | dTree_rmNode tree "$node $child" |
|---|
| 205 | |
|---|
| 206 | } |
|---|
| 207 | } |
|---|
| 208 | |
|---|
| 209 | if {$child == "docu"} { |
|---|
| 210 | dTree_setAttribute tree "$node" "docu" "[dTree_getAttribute $tree "$node docu" XMLContent]" |
|---|
| 211 | dTree_rmNode tree "$node docu" |
|---|
| 212 | } |
|---|
| 213 | |
|---|
| 214 | if {$child == "desc"} { |
|---|
| 215 | dTree_setAttribute tree "$node" "desc" "[dTree_getAttribute $tree "$node desc" XMLContent]" |
|---|
| 216 | dTree_rmNode tree "$node desc" |
|---|
| 217 | } |
|---|
| 218 | |
|---|
| 219 | |
|---|
| 220 | |
|---|
| 221 | } |
|---|
| 222 | |
|---|
| 223 | |
|---|
| 224 | #################################### |
|---|
| 225 | # Analyse elements of the node |
|---|
| 226 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 227 | |
|---|
| 228 | # A analyser : |
|---|
| 229 | # -Validit du nodeType |
|---|
| 230 | # -Prsence des attributs en fonction du nodeType |
|---|
| 231 | # -Default correspond un des enfants |
|---|
| 232 | # - Place dans l'arbre |
|---|
| 233 | |
|---|
| 234 | |
|---|
| 235 | # NodeType |
|---|
| 236 | if {[catch {set nodeType [dTree_getAttribute $tree "$node" nodeType]} ]} { |
|---|
| 237 | popup_error "no nodeType detected for the node $node. Please check your XML file system" |
|---|
| 238 | } |
|---|
| 239 | set possibleNodeTypes "docu status solver tab comment comparator graph glance timeline viewer model xor action info param choice option multiple item" |
|---|
| 240 | |
|---|
| 241 | foreach widget $additionalWidgets { |
|---|
| 242 | lappend possibleNodeTypes $widget |
|---|
| 243 | } |
|---|
| 244 | |
|---|
| 245 | |
|---|
| 246 | if {[lsearch $possibleNodeTypes $nodeType] < 0} { |
|---|
| 247 | popup_error "$nodeType is not a valid nodeType for the node $node.\nIt has to be one of the following :\n$possibleNodeTypes" strict |
|---|
| 248 | } |
|---|
| 249 | |
|---|
| 250 | # Check attributes and depending on the nodeType |
|---|
| 251 | # quite loose for the moment. |
|---|
| 252 | |
|---|
| 253 | set checkName 1 |
|---|
| 254 | set checkValue 0 |
|---|
| 255 | |
|---|
| 256 | |
|---|
| 257 | if {$nodeType ni $possibleNodeTypes} { |
|---|
| 258 | error "You got to add the nodeType you invented in the switch in the tree analyser (where this message is emitted from)" |
|---|
| 259 | } |
|---|
| 260 | |
|---|
| 261 | switch $nodeType { |
|---|
| 262 | "docu" { |
|---|
| 263 | set checkName 0 |
|---|
| 264 | } |
|---|
| 265 | "status" { |
|---|
| 266 | set mandatoryArgs "name" |
|---|
| 267 | set optionalArgs "msgtrue msgfalse msgunknown default" |
|---|
| 268 | } |
|---|
| 269 | "solver" { |
|---|
| 270 | set mandatoryArgs "name title" |
|---|
| 271 | set optionalArgs "size" |
|---|
| 272 | } |
|---|
| 273 | "comment" { |
|---|
| 274 | set mandatoryArgs "name title" |
|---|
| 275 | } |
|---|
| 276 | "comparator" { |
|---|
| 277 | set mandatoryArgs "name title folder require" |
|---|
| 278 | } |
|---|
| 279 | "graph" { |
|---|
| 280 | set mandatoryArgs "name title" |
|---|
| 281 | } |
|---|
| 282 | "glance" { |
|---|
| 283 | set mandatoryArgs "name title" |
|---|
| 284 | } |
|---|
| 285 | "timeline" { |
|---|
| 286 | set mandatoryArgs "name title" |
|---|
| 287 | } |
|---|
| 288 | "tab" { |
|---|
| 289 | set mandatoryArgs "name title" |
|---|
| 290 | set optionalArgs "script existif custombutton" |
|---|
| 291 | } |
|---|
| 292 | "model" { |
|---|
| 293 | set mandatoryArgs "name title" |
|---|
| 294 | set optionalArgs "existif layout" |
|---|
| 295 | } |
|---|
| 296 | "xor" { |
|---|
| 297 | if {![catch {set defaultTemp [dTree_getAttribute $tree "$node" default]} ]} { |
|---|
| 298 | set children [dTree_getAttribute $tree "$node" children] |
|---|
| 299 | if {[lsearch $children $defaultTemp] < 0} { |
|---|
| 300 | popup_error "In $node,\nThe 'default' attribute you specified can't be identified among the options : $children" strict |
|---|
| 301 | } |
|---|
| 302 | } |
|---|
| 303 | set optionalArgs "groups" |
|---|
| 304 | } |
|---|
| 305 | "param" { |
|---|
| 306 | set mandatoryArgs "name title type" |
|---|
| 307 | set optionalArgs "existif require fixed default filter ratio labels headings controls selection" |
|---|
| 308 | |
|---|
| 309 | } |
|---|
| 310 | "option" { |
|---|
| 311 | set checkName 0 |
|---|
| 312 | set checkValue 1 |
|---|
| 313 | } |
|---|
| 314 | "multiple" { |
|---|
| 315 | set mandatoryArgs "size" |
|---|
| 316 | |
|---|
| 317 | } |
|---|
| 318 | "include" { |
|---|
| 319 | set checkName 0 |
|---|
| 320 | # But normally, the case is treated above |
|---|
| 321 | } |
|---|
| 322 | default { |
|---|
| 323 | |
|---|
| 324 | } |
|---|
| 325 | } |
|---|
| 326 | |
|---|
| 327 | # name presence |
|---|
| 328 | if {$checkName == 1 && [catch {set nameTemp [dTree_getAttribute $tree "$node" name]} ]} { |
|---|
| 329 | popup_error "no name detected for the node\n $node\n Please check your XML file system" strict |
|---|
| 330 | } |
|---|
| 331 | |
|---|
| 332 | # value presence |
|---|
| 333 | if {$checkValue == 1 && [catch {set valueTemp [dTree_getAttribute $tree "$node" value]} ]} { |
|---|
| 334 | popup_error "no value detected for the node\n $node\n Please check your XML file system" strict |
|---|
| 335 | } |
|---|
| 336 | |
|---|
| 337 | # title presence, if not, copy name |
|---|
| 338 | if {[catch {set titleTemp [dTree_getAttribute $tree "$node" title]} ]} { |
|---|
| 339 | if {$checkName} { |
|---|
| 340 | dTree_setAttribute tree "$node" title [dTree_getAttribute $tree "$node" name] |
|---|
| 341 | } |
|---|
| 342 | } |
|---|
| 343 | |
|---|
| 344 | #################################### |
|---|
| 345 | # Analyse each child |
|---|
| 346 | #ÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐÐ |
|---|
| 347 | set childrenList [dTree_getChildren $tree $node] |
|---|
| 348 | foreach child $childrenList { |
|---|
| 349 | set first_char [string index $child 0] |
|---|
| 350 | if {[string map {";" ""} $child ] != $child} { |
|---|
| 351 | popup_error "Semicolons (character ;) are not allowed for the node \n $node + $child \nPlease check your XML file system" strict |
|---|
| 352 | } |
|---|
| 353 | if {[string map {" " ""} $child ] != $child} { |
|---|
| 354 | popup_error "Spaces are not allowed for the node \n $node + $child \nPlease check your XML file system" strict |
|---|
| 355 | } |
|---|
| 356 | # firstchar rule |
|---|
| 357 | |
|---|
| 358 | if {[string tolower $first_char] != $first_char} { |
|---|
| 359 | popup_error "Ill formed node : uppercase letters are not allowed at the begginning of the node \n $node + $child \n Please check your XML file system" strict |
|---|
| 360 | } |
|---|
| 361 | set forbidden_chars [list "." "_" ":" "?" "!"] |
|---|
| 362 | if {$first_char in $forbidden_chars} { |
|---|
| 363 | popup_error "Ill formed node : nodes names cannot start with punctuation marks \n $node + $child \n Please check your XML file system" strict |
|---|
| 364 | } |
|---|
| 365 | |
|---|
| 366 | |
|---|
| 367 | |
|---|
| 368 | |
|---|
| 369 | |
|---|
| 370 | set childNode "$node $child" |
|---|
| 371 | if {[dTree_nodeExists $tree $childNode]} { |
|---|
| 372 | analyseModelNode tree $childNode |
|---|
| 373 | } |
|---|
| 374 | } |
|---|
| 375 | } |
|---|
| 376 | |
|---|
| 377 | |
|---|
| 378 | # Copyright CERFACS 2014 |
|---|
| 379 | # |
|---|
| 380 | # antoine.dauptain@cerfacs.fr |
|---|
| 381 | # |
|---|
| 382 | # This software is a computer program whose purpose is to ensure technology |
|---|
| 383 | # transfer between academia and industry. |
|---|
| 384 | # |
|---|
| 385 | # This software is governed by the CeCILL-B license under French law and |
|---|
| 386 | # abiding by the rules of distribution of free software. You can use, |
|---|
| 387 | # modify and/ or redistribute the software under the terms of the CeCILL-B |
|---|
| 388 | # license as circulated by CEA, CNRS and INRIA at the following URL |
|---|
| 389 | # "http://www.cecill.info". |
|---|
| 390 | # |
|---|
| 391 | # As a counterpart to the access to the source code and rights to copy, |
|---|
| 392 | # modify and redistribute granted by the license, users are provided only |
|---|
| 393 | # with a limited warranty and the software's author, the holder of the |
|---|
| 394 | # economic rights, and the successive licensors have only limited |
|---|
| 395 | # liability. |
|---|
| 396 | # |
|---|
| 397 | # In this respect, the user's attention is drawn to the risks associated |
|---|
| 398 | # with loading, using, modifying and/or developing or reproducing the |
|---|
| 399 | # software by the user in light of its specific status of free software, |
|---|
| 400 | # that may mean that it is complicated to manipulate, and that also |
|---|
| 401 | # therefore means that it is reserved for developers and experienced |
|---|
| 402 | # professionals having in-depth computer knowledge. Users are therefore |
|---|
| 403 | # encouraged to load and test the software's suitability as regards their |
|---|
| 404 | # requirements in conditions enabling the security of their systems and/or |
|---|
| 405 | # data to be ensured and, more generally, to use and operate it in the |
|---|
| 406 | # same conditions as regards security. |
|---|
| 407 | # |
|---|
| 408 | # The fact that you are presently reading this means that you have had |
|---|
| 409 | # knowledge of the CeCILL-B license and that you accept its terms. |
|---|
