source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/util/oasisgui/opentea/XMLparser.tcl

Last change on this file was 4775, checked in by aclsce, 5 years ago
  • Imported oasis3-mct from Cerfacs svn server (not suppotred anymore).

The version has been extracted from ​https://oasis3mct.cerfacs.fr/svn/branches/OASIS3-MCT_2.0_branch/oasis3-mct@1818
File size: 19.5 KB
Line 
1#  This program is under CECILL_B licence. See footer for details.
2
3proc XMLnewNode {command attributes icurrentNodes itree} {
4    upvar $icurrentNodes currentNodes
5    upvar $itree tree
6   if {[llength $attributes] == 0} { # No attributes, name is then the command name
7        set name $command
8   } elseif {[llength $attributes] == 2} { # If only one attribute, name is the value whatever it is
9        set name [lindex $attributes 1]
10   } else { # Searches for node name in the attributes and node value for option command
11        set name [lindex $attributes [expr [lsearch -nocase $attributes name]+1]]
12   }
13   
14    if {$command == "include"} {set name "[join $name "_"]_include" }
15    if {$command == "option"} {set name [lindex $attributes [expr [lsearch -nocase $attributes value]+1]]} 
16    if {$name == ""} {error 0 "No name in the node #$currentNodes $command# with attributes : $attributes"}
17   
18    # Build the key of the node
19    set key "root"
20    foreach item $currentNodes {
21        lappend key [lindex $item 1]
22    }
23   
24    # Check uniqueness of the name
25    if {[dTree_nodeExists $tree "$key $name"]} {error 0 "The node $key $name already exists"}
26    dTree_addNode tree $key $name 
27   
28    # Updates the path in tree
29    lappend currentNodes [list $command $name]
30    lappend key $name
31   
32    #Adds the attributes
33    dTree_setAttribute tree $key "nodeType" $command
34    foreach {attr value} $attributes {
35        dTree_setAttribute tree $key $attr $value
36    }
37}
38
39proc modelNewNode {command attributes icurrentNodes itree} {
40    upvar $icurrentNodes currentNodes
41    upvar $itree tree
42    set name $command
43   
44    if {$name == ""} {error 0 "No name in the node #$currentNodes $command# with attributes : $attributes"}
45   
46    # Build the key of the node
47    set key "root"
48    foreach item $currentNodes {
49        lappend key [lindex $item 1]
50    }
51   
52    # Check uniqueness of the name
53    if {[dTree_nodeExists $tree "$key $name"]} {error 0 "The node $key $name already exists"}
54       
55    dTree_addNode tree $key $name
56    # Updates the path in tree
57    lappend currentNodes [list $command $name]
58    lappend key $name
59   
60    #Adds the attributes
61   
62    foreach {attr value} $attributes {
63        dTree_setAttribute tree $key $attr $value
64    }
65}
66
67proc XMLendNode {command icurrentNodes itree} {
68    upvar $icurrentNodes currentNodes
69    upvar $itree tree
70   
71    # Controls that the end tag is correct
72    set currentNode [lindex $currentNodes end 0]
73    if {$currentNode != $command} {
74        error 0 "end tag unexpected : expected $currentNode but detected $command, current nodes : $currentNodes"
75    }
76    set currentNodes [lrange $currentNodes 0 end-1]
77}
78
79proc modelEndNode {command icurrentNodes itree} {
80    upvar $icurrentNodes currentNodes
81    upvar $itree tree
82   
83    # Controls that the end tag is correct
84    set currentNode [lindex $currentNodes end 0]
85    if {$currentNode != $command} {
86        error 0 "end tag unexpected : expected $currentNode but detected $command, current nodes : $currentNodes"
87    }
88    set currentNodes [lrange $currentNodes 0 end-1]
89}
90
91proc XMLaddContent {line icurrentNodes itree} {
92    upvar $icurrentNodes currentNodes
93    upvar $itree tree
94    set line [string trim $line]
95    if { $line == ""} {return 0}
96
97    # Build the key of the node
98    set key "root"
99    foreach item $currentNodes {
100        lappend key [lindex $item 1]
101    }
102    #lappend key
103   
104
105    # If no existing content, creates the XMLContent node
106    if {![dict exists $tree $key "XMLContent"]} {
107        dTree_setAttribute tree $key "XMLContent" "$line"
108    } else {
109        dTree_setAttribute tree $key "XMLContent" "[dTree_getAttribute tree $key XMLContent] $line"
110    }
111   
112   
113}
114
115proc analyseTag {contentTag itree icurrentNodes fileType} {
116   
117    upvar $itree tree
118    upvar $icurrentNodes currentNodes
119   
120    set tagType "begin"
121   
122    #Clean content
123    set contentTag [string trim $contentTag]
124    if {$contentTag == ""} {
125        error "Error : one tag seems to be empty"
126    }
127    # Extract tag name and test if slash is present to detect type of tag
128    set tagName [lindex [split $contentTag " "] 0]
129    if {$tagName!=[string trimleft $tagName "/"]} {
130        set tagName [string trimleft $tagName "/"]
131        set tagType "end"
132    }
133   
134    if {$tagName!=[string trimright $tagName "/"]} {
135        set tagName [string trimright $tagName "/"]
136        set tagType "simple"
137    }
138   
139   
140    # Extract rawAttributes
141    set rawAttributes [join [lrange [split $contentTag " "] 1 end] " "]
142    set rawLine $rawAttributes
143    if {$rawAttributes!=[string trimright $rawAttributes "/"]} {
144        set rawAttributes [string trimright $rawAttributes "/"]
145        set tagType "simple"
146    }
147
148   
149    # The easiest way to split attributes and take into account the possibility not to quote one word long attribute
150    # is to split list of attributes using "=". The result is a list of couple : value(n) attrName(n+1) except for
151    # the first one and the last one
152
153    set rawAttributes [split $rawAttributes "="]
154    set attributes ""
155    set dummy 1
156    foreach element $rawAttributes {  # Parsing rawAttributes to get a proper list
157        set element [string trim $element]
158       
159        set length1 [llength [split $element {"}]]
160           
161        #" This comment purpose is to correct syntaxic coloration with eclipse
162           
163        set length2 [llength [split $element " "]]
164        if {$length1 == 1} { # No quote in element
165            if {$length2 == 1} { # First param or last value
166                if {$dummy == 1 || $dummy == [llength $rawAttributes]} {
167                    lappend attributes [string trim $element]
168                } else {
169                    error "Error during parsing XML : attributes seem not to be well-formed in tag : $tagName \n The parser doesn't understand ...$element..."
170                }
171            }
172            if {$length2 == 2} { # is |value(n) param(n+1)|
173                set value [string trim [lindex $element 0]]
174                set param [string trim [lindex $element end]]
175                lappend attributes $value
176                lappend attributes $param
177               
178            }
179            if {$length2 > 2} { # Problem in parsing
180                warning "During parsing XML : attributes seem not to be well-formed in tag : $tagName near ...$element... \n It seems that one value for an attribute contains a white space but no quotes to surround it \n The parser has tried to continue but that could lead to errors or unexpected results"
181                if {$dummy == [llength $rawAttributes]} {
182                    set value [string trim $element]
183                    lappend attributes $value
184                } elseif {$dummy == 1} {
185                    error "Error during parsing XML : attributes seem not to be well-formed in tag : $tagName near $element..."
186                } else {
187                    set value [string trim [lrange $element 0 end-1]]
188                    set param [string trim [lindex $element end]]
189                    lappend attributes $value
190                    lappend attributes $param
191                }
192            }
193        } elseif {$length1 == 3} { # Two quotes in element
194            set element [string trim $element]
195            if {[lindex [split $element {}] 0] == {"}} { # element begins with a quote
196                if {[lindex [split $element {}] end] == {"} && $dummy == [llength $rawAttributes]} { # element finish with a quote and it's the final element
197                    set value [string trim [lindex [split $element {"}] 1]]
198                    lappend attributes $value
199                } elseif { $dummy > 1 && $dummy < [llength $rawAttributes]} { # element is made of two elements, the first one surrounded by quotes
200                    set element [split $element {"}]
201                    #" this comment is present to avoid editors to detect unexistant strings
202                    set value [string trim [lindex $element 1]]
203                    set param [string trim [lindex $element 2]]
204                    lappend attributes $value
205                    lappend attributes $param
206                } else {
207                    error "Error : During parsing XML : attributes seem not to be well-formed in tag : $tagName . It may be misplaced quotes in ...$element..."
208                }
209            } else {
210                error "Error : During parsing XML : attributes seem not to be well-formed in tag : $tagName near ...$element... \n It may be caused by misplaced quotes"
211            }
212           
213           
214        } else {
215            # It appears there are equals in the arguments, rawArgument needs to be parsed by a more specific and more restrictive parser
216            AnalyseStrictRawArguments
217            break
218            #error "Error with quotes in tag : $tagName near ...$element..."
219        }
220        incr dummy
221    }
222   
223    if {$fileType == "folderParameters"} {
224        set attributes_temp $attributes
225        set attributes ""
226        foreach {key value} $attributes_temp {
227            if {$key != "name"} {
228                lappend attributes $key
229                lappend attributes $value
230            }
231        }
232        lappend attributes "name"
233        lappend attributes "folderParameters"
234        set fileType "XMLtree"
235    }
236   
237    if {$fileType == "XMLtree"} {
238        # Act on the tree depending on tag type
239        switch $tagType {
240            simple {
241                XMLnewNode $tagName $attributes currentNodes tree
242                XMLendNode $tagName currentNodes tree
243            }
244           
245            begin {
246                XMLnewNode $tagName $attributes currentNodes tree
247            }
248           
249            end {
250                XMLendNode $tagName currentNodes tree
251            }
252        }
253    }
254   
255    if {$fileType == "DStree"} {
256        switch $tagType {
257            simple {
258                modelNewNode $tagName $attributes currentNodes tree
259                modelEndNode $tagName currentNodes tree
260            }
261           
262            begin {
263                modelNewNode $tagName $attributes currentNodes tree
264            }
265           
266            end {
267                modelEndNode $tagName currentNodes tree
268            }
269        }
270    }
271}
272
273proc AnalyseStrictRawArguments {} {
274    uplevel 1 {
275        set attributes ""
276        set rawAttributes [split $rawLine {"}]
277           
278        if {[llength $rawAttributes] % 2 == 0} {error "The parser was unable to retrieve the structure of [join $rawAttributes {"}] "} 
279           
280       
281        for {set i 0} {$i < [expr [llength $rawAttributes]-2 ]} {incr i ; incr i} {
282            set rawArg [lindex $rawAttributes $i]
283            set value [lindex $rawAttributes [expr $i + 1]]
284           
285            set rawArg [string trim $rawArg]
286            set arg [string trimright $rawArg "="]
287            if {$arg == $rawArg} {error "Equal missing in XML file near $rawArg"}
288            set arg [string trim $arg]
289            set value [string trim $value]
290           
291            lappend attributes $arg
292            lappend attributes $value
293        }
294           
295    }
296}
297
298
299
300proc parseFile {fileName itree startNode fileType} {
301    # This function reads an OpenTeaXML file whose format is fileType and insert it into tree under the node startNode
302    # Please note that startNode has to be a list of 2-elements lists {node type (eg. model, param, etc))  and node name }
303   
304    upvar $itree tree
305    set currentNodes $startNode
306   
307    # Read XML file
308    set filePointer [open [file join $fileName]]
309    set XMLfile [read $filePointer]
310    close $filePointer
311   
312    # Remove comments
313    regsub -all {<!--.*?-->} $XMLfile {} XMLfile
314   
315    # Remove xml info
316    regsub -all {<\?.*?\?>} $XMLfile {} XMLfile   
317   
318    # include XML files if any
319    #set inclusion [lsearch -glob $XMLfile  "#!include"]
320    #puts "position $inclusion "
321    #set fileInclude [ lindex $XMLfile $inclusion+1]
322    #set filePointer [open [file join $fileInclude ]]
323    #set XMLfileInclude [read $filePointer]
324    #close $filePointer
325    ##set XMLfile [lrange $XMLfile 0 end]
326    #set XMLfile [lreplace $XMLfile $inclusion $inclusion+1  [join $XMLfileInclude] ]
327    #puts "xxx"
328    #puts "$XMLfile"
329    #exit
330   
331    # Explode XMLfile
332    set XMLfile [split $XMLfile ""]
333   
334    # Initialize some dummy variables
335    set previousChar ""
336   
337    # Initialize states
338    set tagState "out"
339    set valueState "out"
340   
341    # Initialize buffers
342    set tagBuffer ""
343    set contentBuffer ""
344   
345    # states descriptors
346    #   - tagState
347    #       "out"   : waiting for smthg to happen
348    #       "in"    : insideTag
349    #   - valueState
350    #       "out"   : out of a string
351    #       "in"    : in a string, special char are automatically escaped
352   
353    foreach char $XMLfile {
354        switch $tagState {
355            "out" {
356                if {$char=="<" && $previousChar!="\\"} { # Entering a tag
357                    set tagState "in"
358                    set tagBuffer ""
359                    XMLaddContent $contentBuffer currentNodes tree
360                    set contentBuffer ""
361                } else { # Still out a tag
362                    if {$char == " " && $previousChar == " "} {
363                        # don't store character
364                    } elseif {$char == "\t"} {
365                        # don't store character et keep the previousChar
366                        set char $previousChar
367                    } elseif {$previousChar != "\\" && $char == "\\"} {
368                        # don't store
369                    } elseif {$char == "\n" && $previousChar != "\n"} {
370                        #don't store
371                        append contentBuffer " "
372                    } else {
373                        append contentBuffer $char
374                    }
375                }
376            }
377            "in" {
378                if {$char==">" && $previousChar!="\\" && $valueState=="out"} { # Leaving a tag
379                    set tagState "out"
380                    # Tag is now well-known, it is send to a special procedure
381                    analyseTag $tagBuffer tree currentNodes $fileType
382                } else { # Still in a tag
383                    append tagBuffer $char
384                }
385            }
386           
387        }
388       
389        switch $valueState {
390            "out" {
391                if {$char=="\"" && $previousChar!="\\"} { # Entering a tag
392                    set valueState "in"
393                }
394            }
395            "in" {
396                if {$char=="\"" && $previousChar!="\\"} {
397                    set valueState "out"
398                }
399                }
400           
401        }
402        set previousChar $char
403    }
404   
405    # At the end currentNodes has to be equal to startNode, otherwise, it means that end tags are missing in the XML file
406    if {$currentNodes != $startNode} {
407        set msg_err "Error in the XML file $fileName : closing tag is missing for node $currentNodes "
408        popup_error $msg_err strict
409    }
410   
411    # At the end of the file, valueState has to be equal to out. If not, that means a tag isn't closed properly
412    if {$valueState == "in"} {
413        set msg_err "Error : in the file $fileName, a tag is not properly closed (Normally, this one : [lindex [split $tagBuffer { }] 0])"
414        popup_error $msg_err strict
415    }
416}
417
418
419proc dir2tree {modelPath startNode itree} {
420    # This function create a subtree of the path "modelPath" and add it to the tree itree under the node startNode
421    # Please note that the node has to be a list of the ancestors (without "root")
422    upvar $itree tree
423    set currentPath [file join $modelPath [join $startNode [file separator]]]
424    set files [lsort [glob -nocomplain -tails -directory $currentPath *]]
425   
426    foreach fileid $files {
427        # fileid is a directory
428        if {[lindex [split $fileid ""] 0] == "."} {
429            continue
430        }
431        if {[file isdirectory [file join $currentPath $fileid]]} {
432            if { [glob -nocomplain -tails -directory [file join $currentPath $fileid] *.xml] == "" && [glob -nocomplain -directory [file join $currentPath $fileid] -type d *] == "" } {
433                continue
434            }
435            set currentNode [concat $startNode $fileid]
436            # Adds this directory to the tree
437            dTree_addNode tree [concat "root" $startNode] $fileid
438            dTree_setAttribute tree [concat "root" $startNode $fileid] nodeType "folder"
439            dTree_setAttribute tree [concat "root" $startNode $fileid] name "$fileid"           
440           
441            # reads the directory
442            dir2tree $modelPath $currentNode tree
443           
444        } else {
445            if {[file extension [file join $currentPath $fileid]] == ".xml" } {
446                # fileid is a XML file
447                set startNodeXML ""
448           
449                # Translates the format of the node from dir2tree format to file2tree format
450                foreach value $startNode {
451                    lappend startNodeXML [list "directory" $value]
452                }
453               
454                if {[file tail [file join $currentPath $fileid]] == "folderParameters.xml"} {
455                    parseFile [file join $currentPath $fileid] tree $startNodeXML "folderParameters"
456                } else {
457                    if {[lindex [lindex $startNodeXML end] end] == "DATA" && "1"=="0"} {
458                        parseFile [file join $currentPath $fileid] tree $startNodeXML "DStree"                       
459                    } else {
460                        parseFile [file join $currentPath $fileid] tree $startNodeXML "XMLtree"
461                    }
462                }
463            }
464        }
465    }
466   
467}
468
469
470proc OpenTeaXML2tree {itree modelPath dataPath} {
471    upvar $itree tree
472    dTree_init tree
473
474    # check if modelPath exists
475    if {![file isdirectory $modelPath]} {
476        error "The folder containing the XML files cannot be found. Should be : $modelPath"
477    }
478
479    # add solver directory
480    dir2tree $modelPath "" tree
481                           
482    # add DATA node
483    dTree_addNode tree "root" DATA
484    dTree_setAttribute tree "root DATA" nodeType "folder"
485    dir2tree [file join $dataPath] DATA tree
486}
487
488
489
490
491#  Copyright CERFACS 2014
492#   
493#  antoine.dauptain@cerfacs.fr
494#   
495#  This software is a computer program whose purpose is to ensure technology
496#  transfer between academia and industry.
497#   
498#  This software is governed by the CeCILL-B license under French law and
499#  abiding by the rules of distribution of free software.  You can  use,
500#  modify and/ or redistribute the software under the terms of the CeCILL-B
501#  license as circulated by CEA, CNRS and INRIA at the following URL
502#  "http://www.cecill.info".
503#   
504#  As a counterpart to the access to the source code and  rights to copy,
505#  modify and redistribute granted by the license, users are provided only
506#  with a limited warranty  and the software's author,  the holder of the
507#  economic rights,  and the successive licensors  have only  limited
508#  liability.
509#   
510#  In this respect, the user's attention is drawn to the risks associated
511#  with loading,  using,  modifying and/or developing or reproducing the
512#  software by the user in light of its specific status of free software,
513#  that may mean  that it is complicated to manipulate,  and  that  also
514#  therefore means  that it is reserved for developers  and  experienced
515#  professionals having in-depth computer knowledge. Users are therefore
516#  encouraged to load and test the software's suitability as regards their
517#  requirements in conditions enabling the security of their systems and/or
518#  data to be ensured and,  more generally, to use and operate it in the
519#  same conditions as regards security.
520#   
521#  The fact that you are presently reading this means that you have had
522#  knowledge of the CeCILL-B license and that you accept its terms.
Note: See TracBrowser for help on using the repository browser.