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