OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [tools/] [tixverify.tcl] - Blame information for rev 1782

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
#! /bin/sh
2 
# the next line restarts using tclsh7.5 \
3 
exec tclsh7.5 "$0" "$@"
4 
 
5 
#
6 
# tixverify.tcl
7 
#
8 
#       Parses some files in the Tix distribution (.tcl scripts, Makefile.in,
9 
#       etc) and detect potential errors.
10 
#
11 
#
12 
 
13 
#----------------------------------------------------------------------
14 
#                        AUX ROUTINES
15 
#----------------------------------------------------------------------
16 
 
17 
proc Usage {} {
18 
    global info
19 
 
20 
    puts "Usage: \[test ... --\] files ..."
21 
    puts "available tests:"
22 
    set maxLen 0
23 
    foreach name [lsort [array names info]] {
24 
        if {$maxLen < [string length $name]} {
25 
            set maxLen [string length $name]
26 
        }
27 
    }
28 
    foreach name [lsort [array names info]] {
29 
        puts "  [format %-$maxLen\s $name] : $info($name)"
30 
    }
31 
}
32 
 
33 
proc ReadFile {file} {
34 
    set data {}
35 
    set fd [open $file {RDONLY}]
36 
    while {![eof $fd]} {
37 
        append data [gets $fd]\n
38 
    }
39 
    close $fd
40 
    return $data
41 
}
42 
 
43 
# returns a list of all the procedures in the $file
44 
#
45 
#
46 
proc ProcParser {file} {
47 
    global procs
48 
    set procs {}
49 
 
50 
    set interp [interp create]
51 
 
52 
    foreach cmd [$interp eval info commands] {
53 
        if {$cmd == "rename"} {
54 
            continue
55 
        }
56 
        if {$cmd == "proc"} {
57 
            continue
58 
        }
59 
        if {$cmd == "unknown"} {
60 
            continue
61 
        }
62 
        if {$cmd == "source"} {
63 
            continue
64 
        }
65 
        if {$cmd == "info"} {
66 
            continue
67 
        }
68 
        if {$cmd == "set"} {
69 
            continue
70 
        }
71 
        $interp eval [list rename $cmd {}]
72 
    }
73 
 
74 
    $interp eval rename source __source
75 
    $interp eval rename info   __info
76 
    $interp eval rename rename __rename
77 
    $interp alias unknown unknown_sub
78 
    $interp alias proc proc_sub
79 
 
80 
    proc unknown_sub {args} {
81 
        #puts "Ignoring toplevel command $args"
82 
    }
83 
 
84 
    proc proc_sub {name arg body} {
85 
        global procs
86 
        lappend procs [list $name $arg $body]
87 
    }
88 
 
89 
    $interp eval __source $file
90 
    interp delete $interp
91 
 
92 
    return $procs
93 
}
94 
 
95 
#----------------------------------------------------------------------
96 
#                      THE TESTS
97 
#----------------------------------------------------------------------
98 
 
99 
#----------------------------------------------------------------------
100 
#
101 
set info(make) "the .o targets in the Makefiles"
102 
 
103 
proc Verify:make {files} {
104 
    # $files is not used
105 
    #
106 
    set list {}
107 
    set list_s {}
108 
    set appPWD [pwd]
109 
    set dir [file dirname [info script]]
110 
    cd $dir
111 
    cd ..
112 
    set dir [pwd]
113 
    cd $appPWD
114 
    puts "checking the makefiles $dir/*/Makefile.in"
115 
    foreach file [glob $dir/*/Makefile.in] {
116 
        set data [ReadFile $file]
117 
        if [regexp {tixClass[.]o} $data] {
118 
            lappend list $file
119 
 
120 
            foreach line [split $data \n] {
121 
                if [regexp {tix[A-z]*[.]o} $line target] {
122 
                    regsub _s $target "" target
123 
                    set targets($target) 1
124 
                }
125 
            }
126 
        }
127 
        if [regexp {tixClass_s[.]o} $data] {
128 
            lappend list_s $file
129 
        }
130 
    }
131 
 
132 
    foreach file $list {
133 
        set data [ReadFile $file]
134 
        set filename "$file:\n"
135 
        foreach target [lsort [array names targets]] {
136 
            if {![regexp $target $data]} {
137 
                puts -nonewline $filename
138 
                puts \t$target
139 
                set filename ""
140 
            }
141 
        }
142 
        if {[lsearch $list_s $file] != -1} {
143 
            foreach target [lsort [array names targets]] {
144 
                if {$target == "tixAppInit.o"} {
145 
                    continue
146 
                }
147 
                regsub {[.]o} $target _s.o target
148 
                if {![regexp $target $data]} {
149 
                    puts -nonewline $filename
150 
                    puts \t$target
151 
                    set filename ""
152 
                }
153 
            }
154 
        }
155 
    }
156 
}
157 
 
158 
#----------------------------------------------------------------------
159 
#
160 
set info(strcmp)  "ungarded string comparisons"
161 
 
162 
proc Verify:strcmp {files} {
163 
    catch {
164 
        set lines ""
165 
        set lines [eval exec egrep -n [list {if.*[!=]=.*[^x]\$}] $files]
166 
    }
167 
 
168 
    foreach line [split $lines \n] {
169 
        if [regexp {[x]\$} $line] {
170 
            continue
171 
        }
172 
        puts $line
173 
    }
174 
}
175 
 
176 
#----------------------------------------------------------------------
177 
#
178 
set info(strcmp1) "improperly guarded string comparisons"
179 
 
180 
proc Verify:strcmp1 {files} {
181 
    catch {
182 
        set lines ""
183 
        set lines [eval exec egrep -n [list {if.*[!=]=.*[x]\$}] $files]
184 
    }
185 
 
186 
    foreach line [split $lines \n] {
187 
       if ![regexp {[\"]x[^\"]*[\"][ ]*[!=]=[ ]*[\"]x[^\"]*[\"]} $line stuff] {
188 
            puts $line
189 
            continue
190 
        }
191 
    }
192 
}
193 
 
194 
#----------------------------------------------------------------------
195 
#
196 
set info(bool) "unverified boolean options (missing tixVerifyBoolean)"
197 
 
198 
proc Verify:bool {files} {
199 
    set boolOpts {
200 
        -disablecallback
201 
        -dropdown
202 
        -editable
203 
        -fancy
204 
        -history
205 
        -prunehistory
206 
        -disablecallback
207 
        -showhidden
208 
        -takefocus
209 
        -allowzero
210 
        -radio
211 
        -dynamicgeometry
212 
        -ignoreinvoke
213 
    }
214 
 
215 
    puts "checking the following options: \{$boolOpts\}"
216 
 
217 
    set rexp ""
218 
    set prefix ""
219 
 
220 
    foreach opt $boolOpts {
221 
        append rexp "$prefix\(\{$opt\[\ \].*\[^n\]\}\)"
222 
        set prefix "|"
223 
    }
224 
 
225 
    catch {
226 
        puts [eval exec egrep -n [list $rexp] $files]
227 
    }
228 
}
229 
 
230 
#----------------------------------------------------------------------
231 
#
232 
set info(classname) "misspelled class name"
233 
 
234 
proc Verify:classname {files} {
235 
    foreach file $files {
236 
        set data [exec cat $file]
237 
        if [regexp "(tixWidgetClass|tixClass)\[^\{\]*\{" $data def] {
238 
            regsub (tixWidgetClass|tixClass) $def "" def
239 
            regsub \{ $def "" def
240 
            set def [string trim $def]
241 
 
242 
            set inFile "in file $file:\n"
243 
 
244 
            foreach line [split $data \n] {
245 
                if {[regexp "^proc.*:" $line] && ![regexp $def: $line]} {
246 
                    puts -nonewline $inFile
247 
                    puts "    $line"
248 
                    set inFile ""
249 
                }
250 
            }
251 
        }
252 
    }
253 
}
254 
 
255 
#----------------------------------------------------------------------
256 
#
257 
set info(chain)  "improperly chained methods"
258 
 
259 
proc Verify:chain {files} {
260 
    set baseClass(InitWidgetRec)   tixPrimitive
261 
    set baseClass(ConstructWidget) tixPrimitive
262 
    set baseClass(SetBindings)     tixPrimitive
263 
    set baseClass(Destructor)      tixPrimitive
264 
    set mustChain [array names baseClass]
265 
 
266 
    foreach file $files {
267 
        foreach proc [ProcParser $file] {
268 
            set name [lindex $proc 0]
269 
            set args [lindex $proc 1]
270 
            set body [lindex $proc 2]
271 
 
272 
            set class  [lindex [split $name :] 0]
273 
            set method [lindex [split $name :] 1]
274 
 
275 
            foreach p $mustChain {
276 
                if {$baseClass($p) == $class} {
277 
                    continue
278 
                }
279 
                if [regexp :$p $name] {
280 
                    if {![string match "*tixChainMethod \$w $p*" $body]} {
281 
                        puts $name
282 
                    }
283 
                }
284 
            }
285 
        }
286 
    }
287 
}
288 
 
289 
#----------------------------------------------------------------------
290 
#       Main program
291 
#----------------------------------------------------------------------
292 
if {$argv == {}} {
293 
    Usage
294 
    exit 0
295 
}
296 
 
297 
set idx [lsearch $argv "--"]
298 
if {$idx > 0 } {
299 
    set tests [lrange $argv 0 [expr $idx-1]]
300 
} else {
301 
    set tests [lsort [array names info]]
302 
}
303 
 
304 
if {$idx != -1} {
305 
    set files [lrange $argv [expr $idx+1] end]
306 
} else {
307 
    set files $argv
308 
}
309 
 
310 
 
311 
foreach test $tests {
312 
    if {![info exists info($test)]} {
313 
        puts "Error: \"$test\" is not a test"
314 
        Usage
315 
        exit 1
316 
    }
317 
}
318 
 
319 
foreach test $tests {
320 
    puts "Executing test \"$test\": Checking $info($test)"
321 
    Verify:$test $files
322 
    puts --------OK-----------
323 
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.