1# -*- tcl -*-
2# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
3##
4# ###
5
6package require  sak::animate
7package require  sak::feedback
8package require  sak::color
9
10getpackage textutil::repeat textutil/repeat.tcl
11getpackage doctools         doctools/doctools.tcl
12
13namespace eval ::sak::validate::syntax {
14    namespace import ::textutil::repeat::blank
15    namespace import ::sak::color::*
16    namespace import ::sak::feedback::!
17    namespace import ::sak::feedback::>>
18    namespace import ::sak::feedback::+=
19    namespace import ::sak::feedback::=
20    namespace import ::sak::feedback::=|
21    namespace import ::sak::feedback::log
22    namespace import ::sak::feedback::summary
23    rename summary sum
24}
25
26# ###
27
28proc ::sak::validate::syntax {modules mode stem} {
29    syntax::run $modules $mode $stem
30    syntax::summary
31    return
32}
33
34proc ::sak::validate::syntax::run {modules mode stem} {
35    sak::feedback::init $mode $stem
36    sak::feedback::first log  "\[ Syntax \] ======================================================"
37    sak::feedback::first unc  "\[ Syntax \] ======================================================"
38    sak::feedback::first fail "\[ Syntax \] ======================================================"
39    sak::feedback::first warn "\[ Syntax \] ======================================================"
40    sak::feedback::first miss "\[ Syntax \] ======================================================"
41    sak::feedback::first none "\[ Syntax \] ======================================================"
42
43    # Preprocessing of module names to allow better formatting of the
44    # progress output, i.e. vertically aligned columns
45
46    # Per module we can distinguish the following levels of
47    # syntactic completeness and validity.
48
49    # Rule completeness
50    # - No package has pcx rules
51    # - Some, but not all packages have pcx rules
52    # - All packages have pcx rules
53    #
54    # Validity. Not of the pcx rules, but of the files in the
55    # packages.
56    # - Package has errors and warnings
57    # - Package has errors, but no warnings.
58    # - Package has no errors, but warnings.
59    # - Package has neither errors nor warnings.
60
61    # Progress report per module: Modules and packages it is working on.
62    # Summary at module level:
63    # - Number of packages, number of packages with pcx rules
64    # - Number of errors, number of warnings.
65
66    # Full log:
67    # - Lists packages without pcx rules.
68    # - Lists packages with errors/warnings.
69    # - Lists the exact errors/warnings per package, and location.
70
71    # Global preparation: Pull information about all packages and the
72    # modules they belong to.
73
74    Setup
75    Count $modules
76    MapPackages
77
78    InitCounters
79    foreach m $modules {
80	# Skip tcllibc shared library, not a module.
81	if {[string equal $m tcllibc]} continue
82
83	InitModuleCounters
84	!
85	log "@@ Module $m"
86	Head $m
87
88	# Per module: Find all syntax definition (pcx) files inside
89	# and process them. Further find all the Tcl files and process
90	# them as well. We get errors, warnings, and determine the
91	# package(s) they may belong to.
92
93	# Per package: Have they pcx files claiming them? After that,
94	# are pcx files left over (i.e. without a package)?
95
96	ProcessAllPCX     $m
97	ProcessPackages   $m
98	ProcessUnclaimed
99	ProcessTclSources $m
100	ModuleSummary
101    }
102
103    Shutdown
104    return
105}
106
107proc ::sak::validate::syntax::summary {} {
108    Summary
109    return
110}
111
112# ###
113
114proc ::sak::validate::syntax::ProcessAllPCX {m} {
115    !claims
116    foreach f [glob -nocomplain [file join [At $m] *.pcx]] {
117	ProcessOnePCX $f
118    }
119    return
120}
121
122proc ::sak::validate::syntax::ProcessOnePCX {f} {
123    =file $f
124
125    if {[catch {
126	Scan [get_input $f]
127    } msg]} {
128	+e $msg
129    } else {
130        +claim $msg
131    }
132
133    return
134}
135
136proc ::sak::validate::syntax::ProcessPackages {m} {
137    !used
138    if {![HasPackages $m]} return
139
140    foreach p [ThePackages $m] {
141	+pkg $p
142	if {[claimants $p]} {
143	    +pcx $p
144	} else {
145	    nopcx $p
146	}
147    }
148    return
149}
150
151proc ::sak::validate::syntax::ProcessUnclaimed {} {
152    variable claims
153    if {![array size claims]} return
154    foreach p [lsort -dict [array names claims]] {
155	foreach fx $claims($p) { +u $fx }
156    }
157    return
158}
159
160proc ::sak::validate::syntax::ProcessTclSources {m} {
161    variable tclchecker
162    if {![llength $tclchecker]} return
163
164    foreach t [modtclfiles $m] {
165	# Ignore TeX files.
166	if {[string equal [file extension $t] .tex]} continue
167
168	=file $t
169	set cmd [Command $t]
170	if {[catch {Close [Process [open |$cmd r+]]} msg]} {
171	    if {[string match {*child process exited abnormally*} $msg]} continue
172	    +e $msg
173	}
174    }
175    return
176}
177
178###
179
180proc ::sak::validate::syntax::Setup {} {
181    variable ip [interp create]
182
183    # Make it mostly empty (We keep the 'set' command).
184
185    foreach n [interp eval $ip [list ::namespace children ::]] {
186	if {[string equal $n ::tcl]} continue
187	interp eval $ip [list namespace delete $n]
188    }
189    foreach c [interp eval $ip [list ::info commands]] {
190	if {[string equal $c set]}       continue
191	if {[string equal $c if]}        continue
192	if {[string equal $c rename]}    continue
193	if {[string equal $c namespace]} continue
194	interp eval $ip [list ::rename $c {}]
195    }
196
197    interp eval $ip [list ::namespace delete ::tcl]
198    interp eval $ip [list ::rename namespace {}]
199    interp eval $ip [list ::rename rename    {}]
200
201    foreach m {
202	pcx::register unknown
203    } {
204	interp alias $ip $m {} ::sak::validate::syntax::PCX/[string map {:: _} $m] $ip
205    }
206    return
207}
208
209proc ::sak::validate::syntax::Shutdown {} {
210    variable ip
211    interp delete $ip
212    return
213}
214
215proc ::sak::validate::syntax::Scan {data} {
216    variable ip
217    variable pcxpackage
218    while {1} {
219	if {[catch {
220	    $ip eval $data
221	} msg]} {
222	    if {[string match {can't read "*": no such variable} $msg]} {
223		regexp  {can't read "(.*)": no such variable} $msg -> var
224		log "@@ + variable \"$var\""
225		$ip eval [list set $var {}]
226		continue
227	    }
228	    return -code error $msg
229	}
230	break
231    }
232    return $pcxpackage
233}
234
235proc ::sak::validate::syntax::PCX/pcx_register {ip pkg} {
236    variable pcxpackage $pkg
237    return
238}
239
240proc ::sak::validate::syntax::PCX/unknown {ip args} {
241    return 0
242}
243
244###
245
246proc ::sak::validate::syntax::Process {pipe} {
247    variable current
248    set dst log
249    while {1} {
250	if {[eof  $pipe]} break
251	if {[gets $pipe line] < 0} break
252
253	set tline [string trim $line]
254	if {[string equal $tline ""]} continue
255
256	if {[string match scanning:* $tline]} {
257	    log $line
258	    continue
259	}
260	if {[string match checking:* $tline]} {
261	    log $line
262	    continue
263	}
264	if {[regexp {^([^:]*):(\d+) \(([^)]*)\) (.*)$} $tline -> path at code detail]} {
265	    = "$current $at $code"
266	    set dst code,$code
267	    if {[IsError $code]} {
268		+e $line
269	    } else {
270		+w $line
271	    }
272	}
273	log $line $dst
274    }
275    return $pipe
276}
277
278proc ::sak::validate::syntax::IsError {code} {
279    variable codetype
280    variable codec
281    if {[info exists codec($code)]} {
282	return $codec($code)
283    }
284
285    foreach {p t} $codetype {
286	if {![string match $p $code]} continue
287	set codec($code) $t
288	return $t
289    }
290
291    # We assume that codetype contains a default * pattern as the last
292    # entry, capturing all unknown codes.
293    +e INTERNAL
294    exit
295}
296
297proc ::sak::validate::syntax::Command {t} {
298    # Unix. Construction of the pipe to run the tclchecker against a
299    # single tcl file.
300
301    set     cmd [Driver]
302    lappend cmd $t
303
304    #lappend cmd >@ stdout 2>@ stderr
305    #puts <<$cmd>>
306
307    return $cmd
308}
309
310proc ::sak::validate::syntax::Close {pipe} {
311    close $pipe
312    return
313}
314
315proc ::sak::validate::syntax::Driver {} {
316    variable tclchecker
317    set cmd $tclchecker
318
319    # Make all syntax definition files we may have available to the
320    # checker for higher accuracy of its output.
321    foreach m [modules] { lappend cmd -pcx [At $m] }
322
323    # Memoize
324    proc ::sak::validate::syntax::Driver {} [list return $cmd]
325    return $cmd
326}
327
328###
329
330proc ::sak::validate::syntax::=file {f} {
331    variable current [file tail $f]
332    = "$current ..."
333    return
334}
335
336###
337
338proc ::sak::validate::syntax::!claims {} {
339    variable    claims
340    array unset claims *
341    return
342}
343
344proc ::sak::validate::syntax::+claim {pkg} {
345    variable current
346    variable claims
347    lappend  claims($pkg) $current
348    return
349}
350
351proc ::sak::validate::syntax::claimants {pkg} {
352    variable claims
353    expr { [info exists claims($pkg)] && [llength $claims($pkg)] }
354}
355
356
357###
358
359proc ::sak::validate::syntax::!used {} {
360    variable    used
361    array unset used *
362    return
363}
364
365proc ::sak::validate::syntax::+use {pkg} {
366    variable used
367    variable claims
368    foreach fx $claims($pkg) { set used($fx) . }
369    unset claims($pkg)
370    return
371}
372
373###
374
375proc ::sak::validate::syntax::MapPackages {} {
376    variable    pkg
377    array unset pkg *
378
379    !
380    += Package
381    foreach {pname pdata} [ipackages] {
382	= "$pname ..."
383	foreach {pver pmodule} $pdata break
384	lappend pkg($pmodule) $pname
385    }
386    !
387    =| {Packages mapped ...}
388    return
389}
390
391proc ::sak::validate::syntax::HasPackages {m} {
392    variable pkg
393    expr { [info exists pkg($m)] && [llength $pkg($m)] }
394}
395
396proc ::sak::validate::syntax::ThePackages {m} {
397    variable pkg
398    return [lsort -dict $pkg($m)]
399}
400
401###
402
403proc ::sak::validate::syntax::+pkg {pkg} {
404    variable mtotal ; incr mtotal
405    variable total  ; incr total
406    return
407}
408
409proc ::sak::validate::syntax::+pcx {pkg} {
410    variable mhavepcx ; incr mhavepcx
411    variable havepcx  ; incr havepcx
412    = "$pkg Ok"
413    +use $pkg
414    return
415}
416
417proc ::sak::validate::syntax::nopcx {pkg} {
418    = "$pkg Bad"
419    log "@@ WARN  No syntax definition: $pkg"
420    return
421}
422
423###
424
425proc ::sak::validate::syntax::+w {msg} {
426    variable mwarnings ; incr mwarnings
427    variable warnings  ; incr warnings
428    variable current
429    foreach {a b c} [split $msg \n] break
430    log "@@ WARN  $current: [Trim $a] [Trim $b] [Trim $c]"
431    return
432}
433
434proc ::sak::validate::syntax::+e {msg} {
435    variable merrors ; incr merrors
436    variable errors  ; incr errors
437    variable current
438    log "@@ ERROR $current $msg"
439    return
440}
441
442proc ::sak::validate::syntax::+u {f} {
443    variable used
444    if {[info exists used($f)]} return
445    variable munclaimed ; incr munclaimed
446    variable unclaimed  ; incr unclaimed
447    set used($f) .
448    log "@@ WARN  Unclaimed syntax definition file: $f"
449    return
450}
451
452###
453
454proc ::sak::validate::syntax::Count {modules} {
455    variable maxml 0
456    !
457    foreach m [linsert $modules 0 Module] {
458	= "M $m"
459	set l [string length $m]
460	if {$l > $maxml} {set maxml $l}
461    }
462    =| "Validate syntax (code, and API definitions) ..."
463    return
464}
465
466proc ::sak::validate::syntax::Head {m} {
467    variable maxml
468    += ${m}[blank [expr {$maxml - [string length $m]}]]
469    return
470}
471
472###
473
474proc ::sak::validate::syntax::InitModuleCounters {} {
475    variable mtotal     0
476    variable mhavepcx   0
477    variable munclaimed 0
478    variable merrors    0
479    variable mwarnings  0
480    return
481}
482
483proc ::sak::validate::syntax::ModuleSummary {} {
484    variable mtotal
485    variable mhavepcx
486    variable munclaimed
487    variable merrors
488    variable mwarnings
489    variable tclchecker
490
491    set complete [F $mhavepcx]/[F $mtotal]
492    set not      "! [F [expr {$mtotal - $mhavepcx}]]"
493    set err      "E [F $merrors]"
494    set warn     "W [F $mwarnings]"
495    set unc      "U [F $munclaimed]"
496
497    if {$munclaimed} {
498	set unc [=cya $unc]
499	>> unc
500    }
501    if {!$mhavepcx && $mtotal} {
502	set complete [=red $complete]
503	set not      [=red $not]
504	>> none
505    } elseif {$mhavepcx < $mtotal} {
506	set complete [=yel $complete]
507	set not      [=yel $not]
508	>> miss
509    }
510    if {[llength $tclchecker]} {
511	if {$merrors} {
512	    set err  " [=red $err]"
513	    set warn " [=yel $warn]"
514	    >> fail
515	} elseif {$mwarnings} {
516	    set err " $err"
517	    set warn " [=yel $warn]"
518	    >> warn
519	} else {
520	    set err  " $err"
521	    set warn " $warn"
522	}
523    } else {
524	set err  ""
525	set warn ""
526    }
527
528    =| "~~ $complete $not $unc$err$warn"
529    return
530}
531
532###
533
534proc ::sak::validate::syntax::InitCounters {} {
535    variable total     0
536    variable havepcx   0
537    variable unclaimed 0
538    variable errors    0
539    variable warnings  0
540    return
541}
542
543proc ::sak::validate::syntax::Summary {} {
544    variable total
545    variable havepcx
546    variable unclaimed
547    variable errors
548    variable warnings
549    variable tclchecker
550
551    set tot   [F $total]
552    set doc   [F $havepcx]
553    set udc   [F [expr {$total - $havepcx}]]
554
555    set unc   [F $unclaimed]
556    set per   [format %6.2f [expr {$havepcx*100./$total}]]
557    set uper  [format %6.2f [expr {($total - $havepcx)*100./$total}]]
558    set err   [F $errors]
559    set wrn   [F $warnings]
560
561    if {$errors}    { set err [=red $err] }
562    if {$warnings}  { set wrn [=yel $wrn] }
563    if {$unclaimed} { set unc [=cya $unc] }
564
565    if {!$havepcx && $total} {
566	set doc [=red $doc]
567	set udc [=red $udc]
568    } elseif {$havepcx < $total} {
569	set doc [=yel $doc]
570	set udc [=yel $udc]
571    }
572
573    if {[llength $tclchecker]} {
574	set sfx " ($tclchecker)"
575    } else {
576	set sfx " ([=cya {No tclchecker available}])"
577    }
578
579    sum ""
580    sum "Syntax statistics$sfx"
581    sum "#Packages:     $tot"
582    sum "#Syntax def:   $doc (${per}%)"
583    sum "#No syntax:    $udc (${uper}%)"
584    sum "#Unclaimed:    $unc"
585    if {[llength $tclchecker]} {
586	sum "#Errors:       $err"
587	sum "#Warnings:     $wrn"
588    }
589    return
590}
591
592###
593
594proc ::sak::validate::syntax::F {n} { format %6d $n }
595
596proc ::sak::validate::syntax::Trim {text} {
597    regsub {^[^:]*:} $text {} text
598    return [string trim $text]
599}
600
601###
602
603proc ::sak::validate::syntax::At {m} {
604    global distribution
605    return [file join $distribution modules $m]
606}
607
608# ###
609
610namespace eval ::sak::validate::syntax {
611    # Max length of module names and patchlevel information.
612    variable maxml 0
613
614    # Counters across all modules
615    variable total     0 ; # Number of packages overall.
616    variable havepcx   0 ; # Number of packages with syntax definition (pcx) files.
617    variable unclaimed 0 ; # Number of PCX files not claimed by a specific package.
618    variable errors    0 ; # Number of errors found in all code.
619    variable warnings  0 ; # Number of warnings found in all code.
620
621    # Same counters, per module.
622    variable mtotal     0
623    variable mhavepcx   0
624    variable munclaimed 0
625    variable merrors    0
626    variable mwarnings  0
627
628    # Name of currently processed syntax definition or code file
629    variable current ""
630
631    # Map from packages to files claiming to define the syntax of their API.
632    variable  claims
633    array set claims {}
634
635    # Set of files taken by packages, as array
636    variable  used
637    array set used {}
638
639    # Map from modules to packages contained in them
640    variable  pkg
641    array set pkg {}
642
643    # Transient storage used while collecting packages per syntax definition.
644    variable pcxpackage {}
645    variable ip         {}
646
647    # Location of the tclchecker used to perform syntactic validation.
648    variable tclchecker [auto_execok tclchecker]
649
650    # Patterns for separation of errors from warnings
651    variable codetype {
652	warn*        0
653	nonPort*     0
654	pkgUnchecked 0
655	pkgVConflict 0
656	*            1
657    }
658    variable codec ; array  set codec {}
659}
660
661##
662# ###
663
664package provide sak::validate::syntax 1.0
665