1#!/bin/sh 2# -*- tcl -*- \ 3exec tclsh "$0" ${1+"$@"} 4 5# -------------------------------------------------------------- 6# Perform various checks and operations on the distribution. 7# SAK = Swiss Army Knife. 8 9set distribution [file dirname [info script]] 10set auto_path [linsert $auto_path 0 [file join $distribution modules]] 11 12set critcldefault {} 13set critclnotes {} 14set dist_excluded {} 15 16proc package_name {text} {global package_name ; set package_name $text} 17proc package_version {text} {global package_version ; set package_version $text} 18proc dist_exclude {path} {global dist_excluded ; lappend dist_excluded $path} 19proc critcl {name files} { 20 global critclmodules 21 set critclmodules($name) $files 22 return 23} 24proc critcl_main {name files} { 25 global critcldefault 26 set critcldefault $name 27 critcl $name $files 28 return 29} 30proc critcl_notes {text} { 31 global critclnotes 32 set critclnotes [string map {{\n } \n} $text] 33 return 34} 35 36source [file join $distribution support installation version.tcl] ; # Get version information. 37 38set package_nv ${package_name}-${package_version} 39 40catch {eval file delete -force [glob [file rootname [info script]].tmp.*]} 41 42# -------------------------------------------------------------- 43# SAK internal debugging support. 44 45# Configuration, change as needed 46set debug 0 47 48if {$debug} { 49 proc sakdebug {script} {uplevel 1 $script ; return} 50} else { 51 proc sakdebug {args} {} 52} 53 54# -------------------------------------------------------------- 55# Internal helper to load packages straight out of the local directory 56# tree. Not something from an installation, possibly incompatible. 57 58proc getpackage {package tclmodule} { 59 global distribution 60 if {[catch {package present $package}]} { 61 set src [file join \ 62 $distribution modules \ 63 $tclmodule] 64 if {[file exists $src]} { 65 uplevel #0 [list source $src] 66 } else { 67 # Fallback 68 package require $package 69 } 70 } 71} 72 73# -------------------------------------------------------------- 74 75proc tclfiles {} { 76 global distribution 77 getpackage fileutil fileutil/fileutil.tcl 78 set fl [fileutil::findByPattern $distribution -glob *.tcl] 79 # Remove files under SCCS. They are repository, not sources to check. 80 set tmp {} 81 foreach f $fl { 82 if {[string match *SCCS* $f]} continue 83 lappend tmp $f 84 } 85 proc tclfiles {} [list return $tmp] 86 return $tmp 87} 88 89proc modtclfiles {modules} { 90 global mfiles guide 91 load_modinfo 92 set mfiles [list] 93 foreach m $modules { 94 eval $guide($m,pkg) $m __dummy__ 95 } 96 return $mfiles 97} 98 99proc modules {} { 100 global distribution 101 set fl [list] 102 foreach f [glob -nocomplain [file join $distribution modules *]] { 103 if {![file isdirectory $f]} {continue} 104 if {[string match CVS [file tail $f]]} {continue} 105 106 if {![file exists [file join $f pkgIndex.tcl]]} {continue} 107 108 lappend fl [file tail $f] 109 } 110 set fl [lsort $fl] 111 proc modules {} [list return $fl] 112 return $fl 113} 114 115proc modules_mod {m} { 116 return [expr {[lsearch -exact [modules] $m] >= 0}] 117} 118 119proc dealias {modules} { 120 set _ {} 121 foreach m $modules { 122 if {[file exists $m]} { 123 set m [file tail $m] 124 } 125 lappend _ $m 126 } 127 return $_ 128} 129 130proc load_modinfo {} { 131 global distribution modules guide 132 source [file join $distribution support installation modules.tcl] ; # Get list of installed modules. 133 source [file join $distribution support installation actions.tcl] ; # Get installer support code. 134 proc load_modinfo {} {} 135 return 136} 137 138proc imodules {} {global modules ; load_modinfo ; return $modules} 139 140proc imodules_mod {m} { 141 global modules 142 load_modinfo 143 return [expr {[lsearch -exact $modules $m] > 0}] 144} 145 146# Result: dict (package name --> list of package versions). 147 148proc loadpkglist {fname} { 149 set f [open $fname r] 150 foreach line [split [read $f] \n] { 151 set line [string trim $line] 152 if {[string match @* $line]} continue 153 if {$line == {}} continue 154 foreach {n v} $line break 155 lappend p($n) $v 156 set p($n) [lsort -uniq -dict $p($n)] 157 } 158 close $f 159 return [array get p] 160} 161 162# Result: dict (package name => list of (list of package versions, module)). 163 164proc ipackages {args} { 165 # Determine indexed packages (ifneeded, pkgIndex.tcl) 166 167 global distribution 168 169 if {[llength $args] == 0} {set args [modules]} 170 171 array set p {} 172 foreach m $args { 173 set f [open [file join $distribution modules $m pkgIndex.tcl] r] 174 foreach line [split [read $f] \n] { 175 if { [regexp {#} $line]} {continue} 176 if {![regexp {ifneeded} $line]} {continue} 177 regsub {^.*ifneeded } $line {} line 178 regsub {([0-9]) \[.*$} $line {\1} line 179 180 foreach {n v} $line break 181 set v [string trimright $v \\] 182 183 if {![info exists p($n)]} { 184 set p($n) [list $v $m] 185 } else { 186 # We have multiple versions of the same package. We 187 # remember all versions. 188 189 foreach {vlist mx} $p($n) break 190 lappend vlist $v 191 set p($n) [list [lsort -uniq -dict $vlist] $mx] 192 } 193 } 194 close $f 195 } 196 return [array get p] 197} 198 199 200# Result: dict (package name --> list of package versions). 201 202proc ppackages {args} { 203 # Determine provided packages (provide, *.tcl - pkgIndex.tcl) 204 # We cache results for a bit of speed, some stuff uses this 205 # multiple times for the same arguments. 206 207 global ppcache 208 if {[info exists ppcache($args)]} { 209 return $ppcache($args) 210 } 211 212 global p pf currentfile 213 array set p {} 214 215 if {[llength $args] == 0} { 216 set files [tclfiles] 217 } else { 218 set files [modtclfiles $args] 219 } 220 221 getpackage fileutil fileutil/fileutil.tcl 222 set capout [fileutil::tempfile] ; set capcout [open $capout w] 223 set caperr [fileutil::tempfile] ; set capcerr [open $caperr w] 224 225 array set notprovided {} 226 227 foreach f $files { 228 # We ignore package indices and all files not in a module. 229 230 if {[string equal pkgIndex.tcl [file tail $f]]} {continue} 231 if {![regexp modules $f]} {continue} 232 233 # We use two methods to extract the version information from a 234 # module and its packages. First we do a static scan for 235 # appropriate statements. If that did not work out we try to 236 # execute the script in a modified interpreter which lets us 237 # pick up dynamically generated version data (like stored in 238 # variables). If the second method fails as well we give up. 239 240 # Method I. Static scan. 241 242 # We do heuristic scanning of the code to locate suitable 243 # package provide statements. 244 245 set fh [open $f r] 246 247 set currentfile [eval file join [lrange [file split $f] end-1 end]] 248 249 set ok -1 250 foreach line [split [read $fh] \n] { 251 if {[regexp "\#\\s*@sak\\s+notprovided\\s+(\[^\\s\]+)" $line -> nppname]} { 252 sakdebug {puts stderr "PRAGMA notprovided = $nppname"} 253 set notprovided($nppname) . 254 } 255 256 regsub "\#.*$" $line {} line 257 if {![regexp {provide} $line]} {continue} 258 if {![regexp {package} $line]} {continue} 259 260 # Now a stronger check for the actual command 261 if {![regexp {package[ ][ ]*provide} $line]} {continue} 262 263 set xline $line 264 regsub {^.*provide } $line {} line 265 regsub {\].*$} $line {\1} line 266 267 sakdebug {puts stderr __$f\ _________$line} 268 269 #foreach {n v} $line break 270 if {[catch { 271 set n [lindex $line 0] 272 set v [lindex $line 1] 273 } err]} { 274 sakdebug {puts stderr "Line: $line of file $f threw $err"} 275 continue 276 } 277 278 # HACK ... 279 # Module 'page', package 'page::gen::peg::cpkg'. 280 # Has a provide statement inside a template codeblock. 281 # Name is placeholder @@. Ignore this specific name. 282 # Better would be to use general static Tcl parsing 283 # to find that the string is a variable value. 284 285 if {[string equal $n @@]} continue 286 287 if {[regexp {^[0-9]+(\.[0-9]+)*$} $v]} { 288 lappend p($n) $v 289 set p($n) [lsort -uniq -dict $p($n)] 290 set pf($n,$v) $currentfile 291 set ok 1 292 293 # We continue the scan. The file may provide several 294 # versions of the same package, or multiple packages. 295 continue 296 } 297 298 # 'package provide foo' are tests. Ignore. 299 if {$v == ""} continue 300 301 # We do not set the state to bad if we found ok provide 302 # statements before, only if nothing was found before. 303 if {$ok < 0} { 304 set ok 0 305 306 # No good version found on the current line. We scan 307 # further through the file and hope for more luck. 308 309 sakdebug {puts stderr @_$f\ _________$xline\t<$n>\t($v)} 310 } 311 } 312 close $fh 313 314 # Method II. Restricted Execution. 315 # We now try to run the code through a safe interpreter 316 # and hope for better luck regarding package information. 317 318 if {$ok == -1} {sakdebug {puts stderr $f\ IGNORE}} 319 if {$ok == 0} { 320 sakdebug {puts -nonewline stderr $f\ EVAL} 321 322 # Source the code into a sub-interpreter. The sub 323 # interpreter overloads 'package provide' so that the 324 # information about new packages goes directly to us. We 325 # also make sure that the sub interpreter doesn't kill us, 326 # and will not get stuck early by trying to load other 327 # files, or when creating procedures in namespaces which 328 # do not exist due to us disabling most of the package 329 # management. 330 331 set fh [open $f r] 332 333 set ip [interp create] 334 335 # Kill control structures. Namespace is required, but we 336 # skip everything related to loading of packages, 337 # i.e. 'command import'. 338 339 $ip eval { 340 rename ::if ::_if_ 341 rename ::namespace ::_namespace_ 342 343 proc ::if {args} {} 344 proc ::namespace {cmd args} { 345 #puts stderr "_nscmd_ $cmd" 346 ::_if_ {[string equal $cmd import]} return 347 #puts stderr "_nsdo_ $cmd $args" 348 return [uplevel 1 [linsert $args 0 ::_namespace_ $cmd]] 349 } 350 } 351 352 # Kill more package stuff, and ensure that unknown 353 # commands are neither loaded nor abort execution. We also 354 # stop anything trying to kill the application at large. 355 356 interp alias $ip package {} xPackage 357 interp alias $ip source {} xNULL 358 interp alias $ip unknown {} xNULL 359 interp alias $ip proc {} xNULL 360 interp alias $ip exit {} xNULL 361 362 # From here on no redefinitions anymore, proc == xNULL !! 363 364 $ip eval {close stdout} ; interp share {} $capcout $ip 365 $ip eval {close stderr} ; interp share {} $capcerr $ip 366 367 if {[catch {$ip eval [read $fh]} msg]} { 368 sakdebug {puts stderr "ERROR in $currentfile:\n$::errorInfo\n"} 369 } 370 371 sakdebug {puts stderr ""} 372 373 close $fh 374 interp delete $ip 375 } 376 } 377 378 close $capcout ; file delete $capout 379 close $capcerr ; file delete $caperr 380 381 # Process the accumulated pragma information, remove all the 382 # packages which exist but not really, in terms of indexing. 383 384 foreach n [array names notprovided] { 385 catch { unset p($n) } 386 array unset pf $n,* 387 } 388 389 set pp [array get p] 390 unset p 391 392 set ppcache($args) $pp 393 return $pp 394} 395 396proc xNULL {args} {} 397proc xPackage {cmd args} { 398 if {[string equal $cmd provide]} { 399 global p pf currentfile 400 foreach {n v} $args break 401 402 # No version specified, this is an inquiry, we ignore these. 403 if {$v == {}} {return} 404 405 sakdebug {puts stderr \tOK\ $n\ =\ $v} 406 407 lappend p($n) $v 408 set p($n) [lsort -uniq -dict $p($n)] 409 set pf($n,$v) $currentfile 410 } 411 return 412} 413 414proc sep {} {puts ~~~~~~~~~~~~~~~~~~~~~~~~} 415 416proc gd-cleanup {} { 417 global package_nv 418 419 puts {Cleaning up...} 420 421 set fl [glob -nocomplain ${package_nv}*] 422 foreach f $fl { 423 puts " Deleting $f ..." 424 catch {file delete -force $f} 425 } 426 return 427} 428 429proc gd-gen-archives {} { 430 global package_name package_nv 431 432 puts {Generating archives...} 433 434 set tar [auto_execok tar] 435 if {$tar != {}} { 436 puts " Gzipped tarball (${package_nv}.tar.gz)..." 437 catch { 438 exec $tar cf - ${package_nv} | gzip --best > ${package_nv}.tar.gz 439 } 440 441 set bzip [auto_execok bzip2] 442 if {$bzip != {}} { 443 puts " Bzipped tarball (${package_nv}.tar.bz2)..." 444 exec tar cf - ${package_nv} | bzip2 > ${package_nv}.tar.bz2 445 } 446 447 set xz [auto_execok xz] 448 if {$xz != {}} { 449 puts " Xzipped tarball (${package_nv}.tar.xz)..." 450 exec tar cf - ${package_nv} | xz > ${package_nv}.tar.xz 451 } 452 } 453 454 set zip [auto_execok zip] 455 if {$zip != {}} { 456 puts " Zip archive (${package_nv}.zip)..." 457 catch { 458 exec $zip -r ${package_nv}.zip ${package_nv} 459 } 460 } 461 462 set sdx [auto_execok sdx] 463 if {$sdx != {}} { 464 file copy -force [file join ${package_nv} support installation main.tcl] \ 465 [file join ${package_nv} main.tcl] 466 file rename ${package_nv} ${package_name}.vfs 467 468 puts " Starkit (${package_nv}.kit)..." 469 exec sdx wrap ${package_name} 470 file rename ${package_name} ${package_nv}.kit 471 472 if {![file exists tclkit]} { 473 puts " No tclkit present in current working directory, no starpack." 474 } else { 475 puts " Starpack (${package_nv}.exe)..." 476 exec sdx wrap ${package_name} -runtime tclkit 477 file rename ${package_name} ${package_nv}.exe 478 } 479 480 file rename ${package_name}.vfs ${package_nv} 481 } 482 483 puts { Keeping directory for other archive types} 484 485 ## Keep the directory for 'sdx' - kit/pack 486 return 487} 488 489proc xcopyfile {src dest} { 490 # dest can be dir or file 491 global mfiles 492 lappend mfiles $src 493 return 494} 495 496proc xcopy {src dest recurse {pattern *}} { 497 if {[string equal $pattern *] || !$recurse} { 498 foreach file [glob [file join $src $pattern]] { 499 set base [file tail $file] 500 set sub [file join $dest $base] 501 if {0 == [string compare CVS $base]} {continue} 502 if {[file isdirectory $file]} then { 503 if {$recurse} { 504 xcopy $file $sub $recurse $pattern 505 } 506 } else { 507 xcopyfile $file $sub 508 } 509 } 510 } else { 511 foreach file [glob [file join $src *]] { 512 set base [file tail $file] 513 set sub [file join $dest $base] 514 if {[string equal CVS $base]} {continue} 515 if {[file isdirectory $file]} then { 516 if {$recurse} { 517 xcopy $file $sub $recurse $pattern 518 } 519 } else { 520 if {![string match $pattern $base]} {continue} 521 xcopyfile $file $sub 522 } 523 } 524 } 525} 526 527proc xxcopy {src dest recurse {pattern *}} { 528 global package_name 529 530 file mkdir $dest 531 foreach file [glob -nocomplain [file join $src $pattern]] { 532 set base [file tail $file] 533 set sub [file join $dest $base] 534 535 # Exclude CVS, SCCS, ... automatically, and possibly the temp 536 # hierarchy itself too. 537 538 if {0 == [string compare CVS $base]} {continue} 539 if {0 == [string compare SCCS $base]} {continue} 540 if {0 == [string compare BitKeeper $base]} {continue} 541 if {[string match ${package_name}-* $base]} {continue} 542 if {[string match *~ $base]} {continue} 543 544 if {[file isdirectory $file]} then { 545 if {$recurse} { 546 file mkdir $sub 547 xxcopy $file $sub $recurse $pattern 548 } 549 } else { 550 puts -nonewline stdout . ; flush stdout 551 file copy -force $file $sub 552 } 553 } 554} 555 556proc gd-assemble {} { 557 global package_nv distribution dist_excluded 558 559 puts "Assembling distribution in directory '${package_nv}'" 560 561 xxcopy $distribution ${package_nv} 1 562 563 foreach f $dist_excluded { 564 file delete -force [file join $package_nv $f] 565 } 566 puts "" 567 return 568} 569 570proc normalize-version {v} { 571 # Strip everything after the first non-version character, and any 572 # trailing dots left behind by that, to avoid the insertion of bad 573 # version numbers into the generated .tap file. 574 575 regsub {[^0-9.].*$} $v {} v 576 return [string trimright $v .] 577} 578 579proc gd-gen-tap {} { 580 getpackage textutil textutil/textutil.tcl 581 getpackage fileutil fileutil/fileutil.tcl 582 583 global package_name package_version distribution tcl_platform 584 585 set pname [textutil::cap $package_name] 586 587 set modules [imodules] 588 array set pd [getpdesc] 589 set lines [list] 590 # Header 591 lappend lines {format {TclDevKit Project File}} 592 lappend lines {fmtver 2.0} 593 lappend lines {fmttool {TclDevKit TclApp PackageDefinition} 2.5} 594 lappend lines {} 595 lappend lines "## Saved at : [clock format [clock seconds]]" 596 lappend lines "## By : $tcl_platform(user)" 597 lappend lines {##} 598 lappend lines "## Generated by \"[file tail [info script]] tap\"" 599 lappend lines "## of $package_name $package_version" 600 lappend lines {} 601 lappend lines {########} 602 lappend lines {#####} 603 lappend lines {###} 604 lappend lines {##} 605 lappend lines {#} 606 607 # Bundle definition 608 lappend lines {} 609 lappend lines {# ###############} 610 lappend lines {# Complete bundle} 611 lappend lines {} 612 lappend lines [list Package [list $package_name [normalize-version $package_version]]] 613 lappend lines "Base @TAP_DIR@" 614 lappend lines "Platform *" 615 lappend lines "Desc \{$pname: Bundle of all packages\}" 616 lappend lines "Path pkgIndex.tcl" 617 lappend lines "Path [join $modules "\nPath "]" 618 619 set strip [llength [file split $distribution]] 620 incr strip 2 621 622 foreach m $modules { 623 # File set of module ... 624 625 lappend lines {} 626 lappend lines "# #########[::textutil::strRepeat {#} [string length $m]]" ; # {} 627 lappend lines "# Module \"$m\"" 628 set n 0 629 foreach {p vlist} [ppackages $m] { 630 foreach v $vlist { 631 lappend lines "# \[[format %1d [incr n]]\] | \"$p\" ($v)" 632 } 633 } 634 if {$n > 1} { 635 # Multiple packages (*). We create one hidden package to 636 # contain all the files and then have all the true 637 # packages in the module refer to it. 638 # 639 # (*) This can also be one package for which we have 640 # several versions. Or a combination thereof. 641 642 array set _ {} 643 foreach {p vlist} [ppackages $m] { 644 catch {set _([lindex $pd($p) 0]) .} 645 } 646 set desc [string trim [join [array names _] ", "] " \n\t\r,"] 647 if {$desc == ""} {set desc "$pname module"} 648 unset _ 649 650 lappend lines "# -------+" 651 lappend lines {} 652 lappend lines [list Package [list __$m 0.0]] 653 lappend lines "Platform *" 654 lappend lines "Desc \{$desc\}" 655 lappend lines Hidden 656 lappend lines "Base @TAP_DIR@/$m" 657 658 foreach f [lsort -dict [modtclfiles $m]] { 659 lappend lines "Path [fileutil::stripN $f $strip]" 660 } 661 662 # Packages in the module ... 663 foreach {p vlist} [ppackages $m] { 664 # NO DANGER. As we are listing only the packages P for 665 # the module any other version of P in a different 666 # module is _not_ listed here. 667 668 set desc "" 669 catch {set desc [string trim [lindex $pd($p) 1]]} 670 if {$desc == ""} {set desc "$pname package"} 671 672 foreach v $vlist { 673 lappend lines {} 674 lappend lines [list Package [list $p [normalize-version $v]]] 675 lappend lines "See [list __$m]" 676 lappend lines "Platform *" 677 lappend lines "Desc \{$desc\}" 678 } 679 } 680 } else { 681 # A single package in the module. And only one version of 682 # it as well. Otherwise we are in the multi-pkg branch. 683 684 foreach {p vlist} [ppackages $m] break 685 set desc "" 686 catch {set desc [string trim [lindex $pd($p) 1]]} 687 if {$desc == ""} {set desc "$pname package"} 688 689 set v [lindex $vlist 0] 690 691 lappend lines "# -------+" 692 lappend lines {} 693 lappend lines [list Package [list $p [normalize-version $v]]] 694 lappend lines "Platform *" 695 lappend lines "Desc \{$desc\}" 696 lappend lines "Base @TAP_DIR@/$m" 697 698 foreach f [lsort -dict [modtclfiles $m]] { 699 lappend lines "Path [fileutil::stripN $f $strip]" 700 } 701 } 702 lappend lines {} 703 lappend lines {#} 704 lappend lines "# #########[::textutil::strRepeat {#} [string length $m]]" 705 } 706 707 lappend lines {} 708 lappend lines {#} 709 lappend lines {##} 710 lappend lines {###} 711 lappend lines {#####} 712 lappend lines {########} 713 714 # Write definition 715 set f [open [file join $distribution ${package_name}.tap] w] 716 puts $f [join $lines \n] 717 close $f 718 return 719} 720 721proc getpdesc {} { 722 global argv ; if {![checkmod]} return 723 724 package require sak::doc 725 sak::doc::Gen desc l $argv 726 727 array set _ {} 728 foreach file [glob -nocomplain doc/desc/*.l] { 729 set f [open $file r] 730 foreach l [split [read $f] \n] { 731 foreach {p sd d} $l break 732 set _($p) [list $sd $d] 733 } 734 close $f 735 } 736 file delete -force doc/desc 737 738 return [array get _] 739} 740 741proc gd-gen-rpmspec {} { 742 global package_version package_name distribution 743 744 set in [file join $distribution support releases package_rpm.txt] 745 set out [file join $distribution ${package_name}.spec] 746 747 write_out $out [string map \ 748 [list \ 749 @PACKAGE_VERSION@ $package_version \ 750 @PACKAGE_NAME@ $package_name] \ 751 [get_input $in]] 752 return 753} 754 755proc gd-gen-yml {} { 756 # YAML is the format used for the FreePAN archive network. 757 # http://freepan.org/ 758 759 global package_version package_name distribution 760 761 set in [file join $distribution support releases package_yml.txt] 762 set out [file join $distribution ${package_name}.yml] 763 764 write_out $out [string map \ 765 [list \ 766 @PACKAGE_VERSION@ $package_version \ 767 @PACKAGE_NAME@ $package_name] \ 768 [get_input $in]] 769 return 770} 771 772proc docfiles {} { 773 global distribution 774 775 getpackage fileutil fileutil/fileutil.tcl 776 777 set res [list] 778 foreach f [fileutil::findByPattern $distribution -glob *.man] { 779 # Remove files under SCCS. They are repository, not sources to check. 780 if {[string match *SCCS* $f]} continue 781 lappend res [file rootname [file tail $f]].n 782 } 783 proc docfiles {} [list return $res] 784 return $res 785} 786 787proc gd-tip55 {} { 788 global package_version package_name distribution contributors 789 contributors 790 791 set in [file join $distribution support releases package_tip55.txt] 792 set out [file join $distribution DESCRIPTION.txt] 793 794 set md [string map \ 795 [list \ 796 @PACKAGE_VERSION@ $package_version \ 797 @PACKAGE_NAME@ $package_name] \ 798 [get_input $in]] 799 800 foreach person [lsort [array names contributors]] { 801 set mail $contributors($person) 802 regsub {@} $mail " at " mail 803 regsub -all {\.} $mail " dot " mail 804 append md "Contributor: $person <$mail>\n" 805 } 806 807 write_out $out $md 808 return 809} 810 811# Fill the global array of contributors to the bundle by processing 812# the ChangeLog entries. 813# 814proc contributors {} { 815 global distribution contributors 816 if {![info exists contributors] || [array size contributors] == 0} { 817 get_contributors [file join $distribution ChangeLog] 818 819 foreach f [glob -nocomplain [file join $distribution modules *]] { 820 if {![file isdirectory $f]} {continue} 821 if {[string match CVS [file tail $f]]} {continue} 822 if {![file exists [file join $f ChangeLog]]} {continue} 823 get_contributors [file join $f ChangeLog] 824 } 825 } 826} 827 828proc get_contributors {changelog} { 829 global contributors 830 set f [open $changelog r] 831 while {![eof $f]} { 832 gets $f line 833 if {[regexp {^[\d-]+\s+(.*?)<(.*?)>} $line r name mail]} { 834 set name [string trim $name] 835 if {![info exists names($name)]} { 836 set contributors($name) $mail 837 } 838 } 839 } 840 close $f 841} 842 843proc validate_imodules_cmp {imvar dmvar} { 844 upvar $imvar im $dmvar dm 845 846 foreach m [lsort [array names im]] { 847 if {![info exists dm($m)]} { 848 puts " Installed, does not exist: $m" 849 } 850 } 851 foreach m [lsort [array names dm]] { 852 if {![info exists im($m)]} { 853 puts " Missing in installer: $m" 854 } 855 } 856 return 857} 858 859proc validate_imodules {} { 860 foreach m [imodules] {set im($m) .} 861 foreach m [modules] {set dm($m) .} 862 863 validate_imodules_cmp im dm 864 return 865} 866 867proc validate_imodules_mod {m} { 868 array set im {} 869 array set dm {} 870 if {[imodules_mod $m]} {set im($m) .} 871 if {[modules_mod $m]} {set dm($m) .} 872 873 validate_imodules_cmp im dm 874 return 875} 876proc validate_versions_cmp {ipvar ppvar} { 877 global pf 878 getpackage struct::set struct/sets.tcl 879 880 upvar $ipvar ip $ppvar pp 881 set maxl 0 882 foreach name [array names ip] {if {[string length $name] > $maxl} {set maxl [string length $name]}} 883 foreach name [array names pp] {if {[string length $name] > $maxl} {set maxl [string length $name]}} 884 885 foreach p [lsort [array names ip]] { 886 if {![info exists pp($p)]} { 887 puts " Indexed, no provider: $p" 888 } 889 } 890 foreach p [lsort [array names pp]] { 891 if {![info exists ip($p)]} { 892 foreach k [array names pf $p,*] { 893 puts " Provided, not indexed: [format "%-*s | %s" $maxl $p $pf($k)]" 894 } 895 } 896 } 897 foreach p [lsort [array names ip]] { 898 if {![info exists pp($p)]} continue 899 if {[struct::set equal $pp($p) $ip($p)]} continue 900 901 # Compute intersection and set differences. 902 foreach {__ pmi imp} [struct::set intersect3 $pp($p) $ip($p)] break 903 904 puts " Index/provided versions differ: [format "%-*s | %8s | %8s" $maxl $p $imp $pmi]" 905 } 906} 907 908proc validate_versions {} { 909 foreach {p vm} [ipackages] {set ip($p) [lindex $vm 0]} 910 foreach {p vlist} [ppackages] {set pp($p) $vlist} 911 912 validate_versions_cmp ip pp 913 return 914} 915 916proc validate_versions_mod {m} { 917 foreach {p vm} [ipackages $m] {set ip($p) [lindex $vm 0]} 918 foreach {p vlist} [ppackages $m] {set pp($p) $vlist} 919 920 validate_versions_cmp ip pp 921 return 922} 923 924proc validate_testsuite_mod {m} { 925 global distribution 926 if {[llength [glob -nocomplain [file join $distribution modules $m *.test]]] == 0} { 927 puts " Without testsuite : $m" 928 } 929 return 930} 931 932proc bench_mod {mlist paths interp flags norm format verbose output coll rep} { 933 global distribution env tcl_platform 934 935 getpackage logger logger/logger.tcl 936 getpackage bench bench/bench.tcl 937 938 ::logger::setlevel $verbose 939 940 set pattern tclsh* 941 if {$interp != {}} { 942 set pattern [file tail $interp] 943 set paths [list [file dirname $interp]] 944 } elseif {![llength $paths]} { 945 # Using the environment PATH is not a good default for 946 # SAK. Use the interpreter running SAK as the default. 947 if 0 { 948 set paths [split $env(PATH) \ 949 [expr {($tcl_platform(platform) == "windows") ? ";" : ":"}]] 950 } 951 set interp [info nameofexecutable] 952 set pattern [file tail $interp] 953 set paths [list [file dirname $interp]] 954 } 955 956 set interps [bench::versions \ 957 [bench::locate $pattern $paths]] 958 959 if {![llength $interps]} { 960 puts "No interpreters found" 961 return 962 } 963 964 if {[llength $flags]} { 965 set cmd [linsert $flags 0 bench::run] 966 } else { 967 set cmd [list bench::run] 968 } 969 970 array set DATA {} 971 972 foreach m $mlist { 973 set files [glob -nocomplain [file join $distribution modules $m *.bench]] 974 if {![llength $files]} { 975 bench::log::warn "No benchmark files found for module \"$m\"" 976 continue 977 } 978 979 for {set i 0} {$i <= $rep} {incr i} { 980 if {$i} { puts "Repeat $i" } 981 982 set run $cmd 983 lappend run $interps $files 984 array set tmp [eval $run] 985 986 # Merge new set of data into the previous run, if any. 987 foreach key [array names tmp] { 988 set val $tmp($key) 989 if {![info exists DATA($key)]} { 990 set DATA($key) $val 991 continue 992 } elseif {[string is double -strict $val]} { 993 # Call user-request collation type 994 set DATA($key) [collate_$coll $DATA($key) $val $i] 995 } 996 } 997 unset tmp 998 } 999 } 1000 1001 _bench_write $output [array get DATA] $norm $format 1002 return 1003} 1004 1005proc collate_min {cur new runs} { 1006 # Minimum 1007 return [expr {$cur > $new ? $new : $cur}] 1008} 1009proc collate_avg {cur new runs} { 1010 # Average 1011 return [expr {($cur * $runs + $new)/($runs+1)}] 1012} 1013proc collate_max {cur new runs} { 1014 # Maximum 1015 return [expr {$cur < $new ? $new : $cur}] 1016} 1017 1018if 0 {proc bench_all {flags norm format verbose output} { 1019 bench_mod [modules] $flags $norm $format $verbose $output ? ? 1020 return 1021}} 1022 1023proc _bench_write {output data norm format} { 1024 if {$norm != {}} { 1025 getpackage logger logger/logger.tcl 1026 getpackage bench bench/bench.tcl 1027 1028 set data [bench::norm $data $norm] 1029 } 1030 1031 set data [bench::out::$format $data] 1032 1033 if {$output == {}} { 1034 puts $data 1035 } else { 1036 set output [open $output w] 1037 puts $output "# -*- tcl -*- bench/$format" 1038 puts $output $data 1039 close $output 1040 } 1041} 1042 1043proc validate_testsuites {} { 1044 foreach m [modules] { 1045 validate_testsuite_mod $m 1046 } 1047 return 1048} 1049 1050proc validate_pkgIndex_mod {m} { 1051 global distribution 1052 if {[llength [glob -nocomplain [file join $distribution modules $m pkgIndex.tcl]]] == 0} { 1053 puts " Without package index : $m" 1054 } 1055 return 1056} 1057 1058proc validate_pkgIndex {} { 1059 global distribution 1060 foreach m [modules] { 1061 validate_pkgIndex_mod $m 1062 } 1063 return 1064} 1065 1066proc validate_doc_existence_mod {m} { 1067 global distribution 1068 if {[llength [glob -nocomplain [file join $distribution modules $m {*.[13n]}]]] == 0} { 1069 if {[llength [glob -nocomplain [file join $distribution modules $m {*.man}]]] == 0} { 1070 puts " Without * any ** manpages : $m" 1071 } 1072 } elseif {[llength [glob -nocomplain [file join $distribution modules $m {*.man}]]] == 0} { 1073 puts " Without doctools manpages : $m" 1074 } else { 1075 foreach f [glob -nocomplain [file join $distribution modules $m {*.[13n]}]] { 1076 if {![file exists [file rootname $f].man]} { 1077 puts " no .man equivalent : $f" 1078 } 1079 } 1080 } 1081 return 1082} 1083 1084proc validate_doc_existence {} { 1085 global distribution 1086 foreach m [modules] { 1087 validate_doc_existence_mod $m 1088 } 1089 return 1090} 1091 1092 1093proc validate_doc_markup_mod {m} { 1094 package require sak::doc 1095 sak::doc::Gen null null [list $m] 1096 return 1097} 1098 1099proc validate_doc_markup {} { 1100 package require sak::doc 1101 sak::doc::Gen null null [modules] 1102 return 1103} 1104 1105proc run-frink {args} { 1106 global distribution 1107 1108 set tmp [file rootname [info script]].tmp.[pid] 1109 1110 if {[llength $args] == 0} { 1111 set files [tclfiles] 1112 } else { 1113 set files [lsort -dict [modtclfiles $args]] 1114 } 1115 1116 foreach f $files { 1117 puts "FRINK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" 1118 puts "$f..." 1119 puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" 1120 1121 catch {exec frink 2> $tmp -HJ $f} 1122 set data [get_input $tmp] 1123 if {[string length $data] > 0} { 1124 puts $data 1125 } 1126 } 1127 catch {file delete -force $tmp} 1128 return 1129} 1130 1131proc run-procheck {args} { 1132 global distribution 1133 1134 if {[llength $args] == 0} { 1135 set files [tclfiles] 1136 } else { 1137 set files [lsort -dict [modtclfiles $args]] 1138 } 1139 1140 foreach f $files { 1141 puts "PROCHECK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" 1142 puts "$f ..." 1143 puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" 1144 1145 catch {exec procheck >@ stdout $f} 1146 } 1147 return 1148} 1149 1150proc run-tclchecker {args} { 1151 global distribution 1152 1153 if {[llength $args] == 0} { 1154 set files [tclfiles] 1155 } else { 1156 set files [lsort -dict [modtclfiles $args]] 1157 } 1158 1159 foreach f $files { 1160 puts "TCLCHECKER ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" 1161 puts "$f ..." 1162 puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" 1163 1164 catch {exec tclchecker >@ stdout $f} 1165 } 1166 return 1167} 1168 1169proc run-nagelfar {args} { 1170 global distribution 1171 1172 if {[llength $args] == 0} { 1173 set files [tclfiles] 1174 } else { 1175 set files [lsort -dict [modtclfiles $args]] 1176 } 1177 1178 foreach f $files { 1179 puts "NAGELFAR ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" 1180 puts "$f ..." 1181 puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" 1182 1183 catch {exec nagelfar >@ stdout $f} 1184 } 1185 return 1186} 1187 1188 1189proc get_input {f} {return [read [set if [open $f r]]][close $if]} 1190 1191proc write_out {f text} { 1192 catch {file delete -force $f} 1193 puts -nonewline [set of [open $f w]] $text 1194 close $of 1195} 1196 1197proc location_PACKAGES {} { 1198 global distribution 1199 return [file join $distribution support releases PACKAGES] 1200} 1201 1202proc gd-gen-packages {} { 1203 global package_version distribution 1204 1205 set P [location_PACKAGES] 1206 file copy -force $P $P.LAST 1207 set f [open $P w] 1208 puts $f "@@ RELEASE $package_version" 1209 puts $f "" 1210 1211 array set packages {} 1212 foreach {p vm} [ipackages] { 1213 set packages($p) [lindex $vm 0] 1214 } 1215 1216 nparray packages $f 1217 close $f 1218} 1219 1220# -------------------------------------------------------------- 1221# Handle modules using docstrip 1222 1223proc docstripUser {m} { 1224 global distribution 1225 1226 set mdir [file join $distribution modules $m] 1227 1228 if {[llength [glob -nocomplain -dir $mdir *.stitch]]} {return 1} 1229 return 0 1230} 1231 1232proc docstripRegen {m} { 1233 global distribution 1234 puts "$m ..." 1235 1236 getpackage docstrip docstrip/docstrip.tcl 1237 1238 set mdir [file join $distribution modules $m] 1239 1240 foreach sf [glob -nocomplain -dir $mdir *.stitch] { 1241 puts "* [file tail $sf] ..." 1242 1243 set here [pwd] 1244 set fail [catch { 1245 cd [file dirname $sf] 1246 docstripRunStitch [file tail $sf] 1247 } msg] 1248 cd $here 1249 if {$fail} { 1250 puts " [join [split $::errorInfo \n] "\n "]" 1251 } 1252 } 1253 return 1254} 1255 1256proc docstripRunStitch {sf} { 1257 # Run the stitch file in a restricted sandbox ... 1258 1259 set box [restrictedIp { 1260 input ::dsrs::Input 1261 options ::dsrs::Options 1262 stitch ::dsrs::Stitch 1263 reset ::dsrs::Reset 1264 }] 1265 1266 ::dsrs::Init 1267 set fail [catch {interp eval $box [get_input $sf]} msg] 1268 if {$fail} { 1269 puts " [join [split $::errorInfo \n] "\n "]" 1270 } else { 1271 ::dsrs::Final 1272 } 1273 1274 interp delete $box 1275 return 1276} 1277 1278proc emptyIp {} { 1279 set box [interp create] 1280 foreach c [interp eval $box {info commands}] { 1281 if {[string equal $c "rename"]} continue 1282 interp eval $box [list rename $c {}] 1283 } 1284 # Rename command goes last. 1285 interp eval $box [list rename rename {}] 1286 return $box 1287} 1288 1289proc restrictedIp {dict} { 1290 set box [emptyIp] 1291 foreach {cmd localcmd} $dict { 1292 interp alias $box $cmd {} $localcmd 1293 } 1294 return $box 1295} 1296 1297# -------------------------------------------------------------- 1298# docstrip low level operations for stitching. 1299 1300namespace eval ::dsrs { 1301 # Standard preamble to preambles 1302 1303 variable preamble {} 1304 append preamble \n 1305 append preamble "This is the file `@output@'," \n 1306 append preamble "generated with the SAK utility" \n 1307 append preamble "(sak docstrip/regen)." \n 1308 append preamble \n 1309 append preamble "The original source files were:" \n 1310 append preamble \n 1311 append preamble "@input@ (with options: `@guards@')" \n 1312 append preamble \n 1313 1314 # Standard postamble to postambles 1315 1316 variable postamble {} 1317 append postamble \n 1318 append postamble \n 1319 append postamble "End of file `@output@'." 1320 1321 # Default values for the options which are relevant to the 1322 # application itself and thus have to be defined always. 1323 # They are processed as global options, as part of argv. 1324 1325 variable defaults {-metaprefix {%} -preamble {} -postamble {}} 1326 1327 variable options ; array set options {} 1328 variable outputs ; array set outputs {} 1329 variable inputs ; array set inputs {} 1330 variable input {} 1331} 1332 1333proc ::dsrs::Init {} { 1334 variable outputs ; unset outputs ; array set outputs {} 1335 variable inputs ; unset inputs ; array set inputs {} 1336 variable input {} 1337 1338 Reset ; # options 1339 return 1340} 1341 1342proc ::dsrs::Reset {} { 1343 variable defaults 1344 variable options ; unset options ; array set options {} 1345 eval [linsert $defaults 0 Options] 1346 return 1347} 1348 1349proc ::dsrs::Input {sourcefile} { 1350 # Relative to current directory = directory containing the active 1351 # stitch file. 1352 1353 variable input $sourcefile 1354} 1355 1356proc ::dsrs::Options {args} { 1357 variable options 1358 variable preamble 1359 variable postamble 1360 1361 while {[llength $args]} { 1362 set opt [lindex $args 0] 1363 1364 switch -exact -- $opt { 1365 -nopreamble - 1366 -nopostamble { 1367 set o -[string range $opt 3 end] 1368 set options($o) "" 1369 set args [lrange $args 1 end] 1370 } 1371 -preamble { 1372 set val $preamble[lindex $args 1] 1373 set options($opt) $val 1374 set args [lrange $args 2 end] 1375 } 1376 -postamble { 1377 set val [lindex $args 1]$postamble 1378 set options($opt) $val 1379 set args [lrange $args 2 end] 1380 } 1381 -metaprefix - 1382 -onerror - 1383 -trimlines { 1384 set val [lindex $args 1] 1385 set options($opt) $val 1386 set args [lrange $args 2 end] 1387 } 1388 default { 1389 return -code error "Unknown option: \"$opt\"" 1390 } 1391 } 1392 } 1393 return 1394} 1395 1396proc ::dsrs::Stitch {outputfile guards} { 1397 variable options 1398 variable inputs 1399 variable input 1400 variable outputs 1401 variable preamble 1402 variable postamble 1403 1404 if {[string equal $input {}]} { 1405 return -code error "No input file defined" 1406 } 1407 1408 if {![info exist inputs($input)]} { 1409 set inputs($input) [get_input $input] 1410 } 1411 1412 set intext $inputs($input) 1413 set otext "" 1414 1415 set c $options(-metaprefix) 1416 set cc $c$c 1417 1418 set pmap [list @output@ $outputfile \ 1419 @input@ $input \ 1420 @guards@ $guards] 1421 1422 if {[info exists options(-preamble)]} { 1423 set pre $options(-preamble) 1424 1425 if {![string equal $pre ""]} { 1426 append otext [Subst $pre $pmap $cc] \n 1427 } 1428 } 1429 1430 array set o [array get options] 1431 catch {unset o(-preamble)} 1432 catch {unset o(-postamble)} 1433 set opt [array get o] 1434 1435 append otext [eval [linsert $opt 0 docstrip::extract $intext $guards]] 1436 1437 if {[info exists options(-postamble)]} { 1438 set post $options(-postamble) 1439 1440 if {![string equal $post ""]} { 1441 append otext [Subst $post $pmap $cc] 1442 } 1443 } 1444 1445 # Accumulate outputs in memory 1446 1447 append outputs($outputfile) $otext 1448 return 1449} 1450 1451proc ::dsrs::Subst {text pmap cc} { 1452 return [string trim "$cc [join [split [string map $pmap $text] \n] "\n$cc "]"] 1453} 1454 1455proc ::dsrs::Final {} { 1456 variable outputs 1457 foreach o [array names outputs] { 1458 puts " = Writing $o ..." 1459 1460 if {[string equal \ 1461 docstrip/docstrip.tcl \ 1462 [file join [file tail [pwd]] $o]]} { 1463 1464 # We are writing over code required by ourselves. 1465 # For easy recovery in case of problems we save 1466 # the original 1467 1468 puts " *Saving original of code important to docstrip/regen itself*" 1469 write_out $o.bak [get_input $o] 1470 } 1471 1472 write_out $o $outputs($o) 1473 } 1474} 1475 1476# -------------------------------------------------------------- 1477# Configuration 1478 1479proc __name {} {global package_name ; puts -nonewline $package_name} 1480proc __version {} {global package_version ; puts -nonewline $package_version} 1481proc __minor {} {global package_version ; puts -nonewline [lindex [split $package_version .] 1]} 1482proc __major {} {global package_version ; puts -nonewline [lindex [split $package_version .] 0]} 1483 1484# -------------------------------------------------------------- 1485# Development 1486 1487proc __imodules {} {puts [imodules]} 1488proc __modules {} {puts [modules]} 1489proc __lmodules {} {puts [join [modules] \n]} 1490 1491 1492proc nparray {a {chan stdout}} { 1493 upvar $a packages 1494 1495 set maxl 0 1496 foreach name [lsort [array names packages]] { 1497 if {[string length $name] > $maxl} { 1498 set maxl [string length $name] 1499 } 1500 } 1501 foreach name [lsort [array names packages]] { 1502 foreach v $packages($name) { 1503 puts $chan [format "%-*s %s" $maxl $name $v] 1504 } 1505 } 1506 return 1507} 1508 1509proc __packages {} { 1510 array set packages {} 1511 foreach {p vm} [ipackages] { 1512 set packages($p) [lindex $vm 0] 1513 } 1514 nparray packages 1515 return 1516} 1517 1518proc __provided {} { 1519 array set packages [ppackages] 1520 nparray packages 1521 return 1522} 1523 1524proc checkmod {} { 1525 global argv 1526 package require sak::util 1527 return [sak::util::checkModules argv] 1528} 1529 1530# ------------------------------------------------------------------------- 1531# Critcl stuff 1532# ------------------------------------------------------------------------- 1533 1534# Build critcl modules. If no args then build the default critcl module. 1535proc __critcl {} { 1536 global argv critcl critclmodules critcldefault critclnotes tcl_platform 1537 if {$tcl_platform(platform) == "windows"} { 1538 1539 # Windows is a bit more complicated. We have to choose an 1540 # interpreter, and a starkit for it, and call both. 1541 # 1542 # We prefer tclkitsh, but try to make do with a tclsh. That 1543 # one will have to have all the necessary packages to support 1544 # starkits. ActiveTcl for example. 1545 1546 set interpreter {} 1547 foreach i {critcl.exe tclkitsh tclsh} { 1548 set interpreter [auto_execok $i] 1549 if {$interpreter != {}} break 1550 } 1551 1552 if {$interpreter == {}} { 1553 return -code error \ 1554 "failed to find either tclkitsh.exe or tclsh.exe in path" 1555 } 1556 1557 # The critcl starkit can come out of the environment, or we 1558 # try to locate it using several possible names. We try to 1559 # find it if and only if we did not find a critcl starpack 1560 # before. 1561 1562 if {[file tail $interpreter] == "critcl.exe"} { 1563 set critcl $interpreter 1564 } else { 1565 set kit {} 1566 if {[info exists ::env(CRITCL)]} { 1567 set kit $::env(CRITCL) 1568 } else { 1569 foreach k {critcl.kit critcl} { 1570 set kit [auto_execok $k] 1571 if {$kit != {}} break 1572 } 1573 } 1574 1575 if {$kit == {}} { 1576 return -code error "failed to find critcl.kit or critcl in \ 1577 path.\n\ 1578 You may wish to set the CRITCL environment variable to the\ 1579 location of your critcl(.kit) file." 1580 } 1581 set critcl [concat $interpreter $kit] 1582 } 1583 } else { 1584 # My, isn't it simpler under unix. 1585 set critcl [auto_execok critcl] 1586 } 1587 1588 set flags "" 1589 while {[string match -* [set option [lindex $argv 0]]]} { 1590 # -debug and -clean only work with critcl >= v04 1591 switch -exact -- $option { 1592 -keep { append flags " -keep" } 1593 -debug { 1594 append flags " -debug [lindex $argv 1]" 1595 set argv [lreplace $argv 0 0] 1596 } 1597 -clean { append flags " -clean" } 1598 -target { 1599 append flags " -target [lindex $argv 1]" 1600 set argv [lreplace $argv 0 0] 1601 } 1602 -- { set argv [lreplace $argv 0 0]; break } 1603 default { break } 1604 } 1605 set argv [lreplace $argv 0 0] 1606 } 1607 1608 if {$critcl != {}} { 1609 if {[llength $argv] == 0} { 1610 puts stderr "[string repeat - 72]" 1611 puts stderr "Building critcl components." 1612 if {$critclnotes != {}} { 1613 puts stderr $critclnotes 1614 } 1615 puts stderr "[string repeat - 72]" 1616 1617 critcl_module $critcldefault $flags 1618 } else { 1619 foreach m [dealias $argv] { 1620 if {[info exists critclmodules($m)]} { 1621 critcl_module $m $flags 1622 } else { 1623 puts "warning: $m is not a critcl module" 1624 } 1625 } 1626 } 1627 } else { 1628 puts "error: cannot find a critcl to run." 1629 return 1 1630 } 1631 return 1632} 1633 1634# Prints a list of all the modules supporting critcl enhancement. 1635proc __critcl-modules {} { 1636 global critclmodules critcldefault 1637 foreach m [lsort -dict [array names critclmodules]] { 1638 if {$m == $critcldefault} { 1639 puts "$m **" 1640 } else { 1641 puts $m 1642 } 1643 } 1644 return 1645} 1646 1647proc critcl_module {pkg {extra ""}} { 1648 global critcl distribution critclmodules critcldefault 1649 1650 lappend extra -cache [pwd]/.critcl 1651 1652 if {$pkg == $critcldefault} { 1653 set files {} 1654 foreach f $critclmodules($critcldefault) { 1655 lappend files [file join $distribution modules $f] 1656 } 1657 foreach m [array names critclmodules] { 1658 if {$m == $critcldefault} continue 1659 foreach f $critclmodules($m) { 1660 lappend files [file join $distribution modules $f] 1661 } 1662 } 1663 } else { 1664 foreach f $critclmodules($pkg) { 1665 lappend files [file join $distribution modules $f] 1666 } 1667 } 1668 set target [file join $distribution modules] 1669 catch { 1670 puts "$critcl $extra -force -libdir [list $target] -pkg [list $pkg] $files" 1671 eval exec $critcl $extra -force -libdir [list $target] -pkg [list $pkg] $files 1672 } r 1673 puts $r 1674 return 1675} 1676 1677# ------------------------------------------------------------------------- 1678 1679proc __bench/edit {} { 1680 global argv argv0 1681 1682 set format text 1683 set output {} 1684 1685 while {[string match -* [set option [lindex $argv 0]]]} { 1686 set val [lindex $argv 1] 1687 switch -exact -- $option { 1688 -format { 1689 switch -exact -- $val { 1690 raw - csv - text {} 1691 default { 1692 return -error "Bad format \"$val\", expected text, csv, or raw" 1693 } 1694 } 1695 set format $val 1696 } 1697 -o {set output $val} 1698 -- { 1699 set argv [lrange $argv 1 end] 1700 break 1701 } 1702 default { break } 1703 } 1704 set argv [lrange $argv 2 end] 1705 } 1706 1707 switch -exact -- $format { 1708 raw {} 1709 csv { 1710 getpackage csv csv/csv.tcl 1711 getpackage bench::out::csv bench/bench_wcsv.tcl 1712 } 1713 text { 1714 getpackage report report/report.tcl 1715 getpackage struct::matrix struct/matrix.tcl 1716 getpackage bench::out::text bench/bench_wtext.tcl 1717 } 1718 } 1719 1720 getpackage bench::in bench/bench_read.tcl 1721 getpackage bench bench/bench.tcl 1722 1723 if {[llength $argv] != 3} { 1724 puts "Usage: $argv0 benchdata column newvalue" 1725 } 1726 1727 foreach {in col new} $argv break 1728 1729 _bench_write $output \ 1730 [bench::edit \ 1731 [bench::in::read $in] \ 1732 $col $new] \ 1733 {} $format 1734 return 1735} 1736 1737proc __bench/del {} { 1738 global argv argv0 1739 1740 set format text 1741 set output {} 1742 1743 while {[string match -* [set option [lindex $argv 0]]]} { 1744 set val [lindex $argv 1] 1745 switch -exact -- $option { 1746 -format { 1747 switch -exact -- $val { 1748 raw - csv - text {} 1749 default { 1750 return -error "Bad format \"$val\", expected text, csv, or raw" 1751 } 1752 } 1753 set format $val 1754 } 1755 -o {set output $val} 1756 -- { 1757 set argv [lrange $argv 1 end] 1758 break 1759 } 1760 default { break } 1761 } 1762 set argv [lrange $argv 2 end] 1763 } 1764 1765 switch -exact -- $format { 1766 raw {} 1767 csv { 1768 getpackage csv csv/csv.tcl 1769 getpackage bench::out::csv bench/bench_wcsv.tcl 1770 } 1771 text { 1772 getpackage report report/report.tcl 1773 getpackage struct::matrix struct/matrix.tcl 1774 getpackage bench::out::text bench/bench_wtext.tcl 1775 } 1776 } 1777 1778 getpackage bench::in bench/bench_read.tcl 1779 getpackage bench bench/bench.tcl 1780 1781 if {[llength $argv] < 2} { 1782 puts "Usage: $argv0 benchdata column..." 1783 } 1784 1785 set in [lindex $argv 0] 1786 1787 set data [bench::in::read $in] 1788 1789 foreach c [lrange $argv 1 end] { 1790 set data [bench::del $data $c] 1791 } 1792 1793 _bench_write $output $data {} $format 1794 return 1795} 1796 1797proc __bench/show {} { 1798 global argv 1799 1800 set format text 1801 set output {} 1802 set norm {} 1803 1804 while {[string match -* [set option [lindex $argv 0]]]} { 1805 set val [lindex $argv 1] 1806 switch -exact -- $option { 1807 -format { 1808 switch -exact -- $val { 1809 raw - csv - text {} 1810 default { 1811 return -error "Bad format \"$val\", expected text, csv, or raw" 1812 } 1813 } 1814 set format $val 1815 } 1816 -o {set output $val} 1817 -norm {set norm $val} 1818 -- { 1819 set argv [lrange $argv 1 end] 1820 break 1821 } 1822 default { break } 1823 } 1824 set argv [lrange $argv 2 end] 1825 } 1826 1827 switch -exact -- $format { 1828 raw {} 1829 csv { 1830 getpackage csv csv/csv.tcl 1831 getpackage bench::out::csv bench/bench_wcsv.tcl 1832 } 1833 text { 1834 getpackage report report/report.tcl 1835 getpackage struct::matrix struct/matrix.tcl 1836 getpackage bench::out::text bench/bench_wtext.tcl 1837 } 1838 } 1839 1840 getpackage bench::in bench/bench_read.tcl 1841 1842 array set DATA {} 1843 1844 foreach path $argv { 1845 array set DATA [bench::in::read $path] 1846 } 1847 1848 _bench_write $output [array get DATA] $norm $format 1849 return 1850} 1851 1852proc __bench {} { 1853 global argv 1854 1855 # I. Process command line arguments for the 1856 # benchmark commands - Validation, possible 1857 # translation ... 1858 1859 set flags {} 1860 set norm {} 1861 set format text 1862 set verbose warn 1863 set output {} 1864 set paths {} 1865 set interp {} 1866 set repeat 0 1867 set collate min 1868 1869 while {[string match -* [set option [lindex $argv 0]]]} { 1870 set val [lindex $argv 1] 1871 switch -exact -- $option { 1872 -throwerrors {lappend flags -errors $val} 1873 -match - 1874 -rmatch - 1875 -iters - 1876 -threads {lappend flags $option $val} 1877 -o {set output $val} 1878 -norm {set norm $val} 1879 -path {lappend paths $val} 1880 -interp {set interp $val} 1881 -format { 1882 switch -exact -- $val { 1883 raw - csv - text {} 1884 default { 1885 return -error "Bad format \"$val\", expected text, csv, or raw" 1886 } 1887 } 1888 set format $val 1889 } 1890 -collate { 1891 switch -exact -- $val { 1892 min - max - avg {} 1893 default { 1894 return -error "Bad collation \"$val\", expected avg, max, or min" 1895 } 1896 } 1897 set collate $val 1898 } 1899 -repeat { 1900 # TODO: test for integer >= 0 1901 set repeat $val 1902 } 1903 -verbose { 1904 set verbose info 1905 set argv [lrange $argv 1 end] 1906 continue 1907 } 1908 -debug { 1909 set verbose debug 1910 set argv [lrange $argv 1 end] 1911 continue 1912 } 1913 -- { 1914 set argv [lrange $argv 1 end] 1915 break 1916 } 1917 default { break } 1918 } 1919 set argv [lrange $argv 2 end] 1920 } 1921 1922 switch -exact -- $format { 1923 raw {} 1924 csv { 1925 getpackage csv csv/csv.tcl 1926 getpackage bench::out::csv bench/bench_wcsv.tcl 1927 } 1928 text { 1929 getpackage report report/report.tcl 1930 getpackage struct::matrix struct/matrix.tcl 1931 getpackage bench::out::text bench/bench_wtext.tcl 1932 } 1933 } 1934 1935 # Choose between benchmarking everything, or 1936 # only selected modules. 1937 1938 if {[llength $argv] == 0} { 1939 _bench_all $paths $interp $flags $norm $format $verbose $output $collate $repeat 1940 } else { 1941 if {![checkmod]} {return} 1942 _bench_module [dealias $argv] $paths $interp $flags $norm $format $verbose $output $collate $repeat 1943 } 1944 return 1945} 1946 1947proc _bench_module {mlist paths interp flags norm format verbose output coll rep} { 1948 global package_name package_version 1949 1950 puts "Benchmarking $package_name $package_version development" 1951 puts "======================================================" 1952 bench_mod $mlist $paths $interp $flags $norm $format $verbose $output $coll $rep 1953 puts "------------------------------------------------------" 1954 puts "" 1955 return 1956} 1957 1958proc _bench_all {paths flags interp norm format verbose output coll rep} { 1959 _bench_module [modules] $paths $interp $flags $norm $format $verbose $output $coll $rep 1960 return 1961} 1962 1963# ------------------------------------------------------------------------- 1964 1965proc __oldvalidate_v {} { 1966 global argv 1967 if {[llength $argv] == 0} { 1968 _validate_all_v 1969 } else { 1970 if {![checkmod]} {return} 1971 foreach m [dealias $argv] { 1972 _validate_module_v $m 1973 } 1974 } 1975 return 1976} 1977 1978proc _validate_all_v {} { 1979 global package_name package_version 1980 set i 0 1981 1982 puts "Validating $package_name $package_version development" 1983 puts "===================================================" 1984 puts "[incr i]: Consistency of package versions ..." 1985 puts "------------------------------------------------------" 1986 validate_versions 1987 puts "------------------------------------------------------" 1988 puts "" 1989 return 1990} 1991 1992proc _validate_module_v {m} { 1993 global package_name package_version 1994 set i 0 1995 1996 puts "Validating $package_name $package_version development -- $m" 1997 puts "===================================================" 1998 puts "[incr i]: Consistency of package versions ..." 1999 puts "------------------------------------------------------" 2000 validate_versions_mod $m 2001 puts "------------------------------------------------------" 2002 puts "" 2003 return 2004} 2005 2006 2007proc __oldvalidate {} { 2008 global argv 2009 if {[llength $argv] == 0} { 2010 _validate_all 2011 } else { 2012 if {![checkmod]} {return} 2013 foreach m $argv { 2014 _validate_module $m 2015 } 2016 } 2017 return 2018} 2019 2020proc _validate_all {} { 2021 global package_name package_version 2022 set i 0 2023 2024 puts "Validating $package_name $package_version development" 2025 puts "===================================================" 2026 puts "[incr i]: Existence of testsuites ..." 2027 puts "------------------------------------------------------" 2028 validate_testsuites 2029 puts "------------------------------------------------------" 2030 puts "" 2031 2032 puts "[incr i]: Existence of package indices ..." 2033 puts "------------------------------------------------------" 2034 validate_pkgIndex 2035 puts "------------------------------------------------------" 2036 puts "" 2037 2038 puts "[incr i]: Consistency of package versions ..." 2039 puts "------------------------------------------------------" 2040 validate_versions 2041 puts "------------------------------------------------------" 2042 puts "" 2043 2044 puts "[incr i]: Installed vs. developed modules ..." 2045 puts "------------------------------------------------------" 2046 validate_imodules 2047 puts "------------------------------------------------------" 2048 puts "" 2049 2050 puts "[incr i]: Existence of documentation ..." 2051 puts "------------------------------------------------------" 2052 validate_doc_existence 2053 puts "------------------------------------------------------" 2054 puts "" 2055 2056 puts "[incr i]: Validate documentation markup (doctools) ..." 2057 puts "------------------------------------------------------" 2058 validate_doc_markup 2059 puts "------------------------------------------------------" 2060 puts "" 2061 2062 puts "[incr i]: Static syntax check ..." 2063 puts "------------------------------------------------------" 2064 2065 set frink [auto_execok frink] 2066 set procheck [auto_execok procheck] 2067 set tclchecker [auto_execok tclchecker] 2068 set nagelfar [auto_execok nagelfar] 2069 2070 if {$frink == {}} {puts " Tool 'frink' not found, no check"} 2071 if {($procheck == {}) || ($tclchecker == {})} { 2072 puts " Tools 'procheck'/'tclchecker' not found, no check" 2073 } 2074 if {$nagelfar == {}} {puts " Tool 'nagelfar' not found, no check"} 2075 2076 if {($frink == {}) || ($procheck == {}) || ($tclchecker == {}) 2077 || ($nagelfar == {})} { 2078 puts "------------------------------------------------------" 2079 } 2080 if {($frink == {}) && ($procheck == {}) && ($tclchecker == {}) 2081 && ($nagelfar == {})} { 2082 return 2083 } 2084 if {$frink != {}} { 2085 run-frink 2086 puts "------------------------------------------------------" 2087 } 2088 if {$tclchecker != {}} { 2089 run-tclchecker 2090 puts "------------------------------------------------------" 2091 } elseif {$procheck != {}} { 2092 run-procheck 2093 puts "------------------------------------------------------" 2094 } 2095 if {$nagelfar !={}} { 2096 run-nagelfar 2097 puts "------------------------------------------------------" 2098 } 2099 puts "" 2100 return 2101} 2102 2103proc _validate_module {m} { 2104 global package_name package_version 2105 set i 0 2106 2107 puts "Validating $package_name $package_version development -- $m" 2108 puts "===================================================" 2109 puts "[incr i]: Existence of testsuites ..." 2110 puts "------------------------------------------------------" 2111 validate_testsuite_mod $m 2112 puts "------------------------------------------------------" 2113 puts "" 2114 2115 puts "[incr i]: Existence of package indices ..." 2116 puts "------------------------------------------------------" 2117 validate_pkgIndex_mod $m 2118 puts "------------------------------------------------------" 2119 puts "" 2120 2121 puts "[incr i]: Consistency of package versions ..." 2122 puts "------------------------------------------------------" 2123 validate_versions_mod $m 2124 puts "------------------------------------------------------" 2125 puts "" 2126 2127 #puts "[incr i]: Installed vs. developed modules ..." 2128 puts "------------------------------------------------------" 2129 validate_imodules_mod $m 2130 puts "------------------------------------------------------" 2131 puts "" 2132 2133 puts "[incr i]: Existence of documentation ..." 2134 puts "------------------------------------------------------" 2135 validate_doc_existence_mod $m 2136 puts "------------------------------------------------------" 2137 puts "" 2138 2139 puts "[incr i]: Validate documentation markup (doctools) ..." 2140 puts "------------------------------------------------------" 2141 validate_doc_markup_mod $m 2142 puts "------------------------------------------------------" 2143 puts "" 2144 2145 puts "[incr i]: Static syntax check ..." 2146 puts "------------------------------------------------------" 2147 2148 set frink [auto_execok frink] 2149 set procheck [auto_execok procheck] 2150 set nagelfar [auto_execok nagelfar] 2151 set tclchecker [auto_execok tclchecker] 2152 2153 if {$frink == {}} {puts " Tool 'frink' not found, no check"} 2154 if {($procheck == {}) || ($tclchecker == {})} { 2155 puts " Tools 'procheck'/'tclchecker' not found, no check" 2156 } 2157 if {$nagelfar == {}} {puts " Tool 'nagelfar' not found, no check"} 2158 2159 if {($frink == {}) || ($procheck == {}) || ($tclchecker == {}) || 2160 ($nagelfar == {})} { 2161 puts "------------------------------------------------------" 2162 } 2163 if {($frink == {}) && ($procheck == {}) && ($nagelfar == {}) 2164 && ($tclchecker == {})} { 2165 return 2166 } 2167 if {$frink != {}} { 2168 run-frink $m 2169 puts "------------------------------------------------------" 2170 } 2171 if {$tclchecker != {}} { 2172 run-tclchecker $m 2173 puts "------------------------------------------------------" 2174 } elseif {$procheck != {}} { 2175 run-procheck $m 2176 puts "------------------------------------------------------" 2177 } 2178 if {$nagelfar !={}} { 2179 run-nagelfar $m 2180 puts "------------------------------------------------------" 2181 } 2182 puts "" 2183 2184 return 2185} 2186 2187# -------------------------------------------------------------- 2188# Release engineering 2189 2190proc __gendist {} { 2191 gd-cleanup 2192 gd-tip55 2193 gd-gen-rpmspec 2194 gd-gen-tap 2195 gd-gen-yml 2196 gd-assemble 2197 gd-gen-archives 2198 2199 puts ...Done 2200 return 2201} 2202 2203proc __gentip55 {} { 2204 gd-tip55 2205 puts "Created DESCRIPTION.txt" 2206 return 2207} 2208 2209proc __yml {} { 2210 global package_name 2211 gd-gen-yml 2212 puts "Created YAML spec file \"${package_name}.yml\"" 2213 return 2214} 2215 2216proc __contributors {} { 2217 global contributors 2218 contributors 2219 foreach person [lsort [array names contributors]] { 2220 puts "$person <$contributors($person)>" 2221 } 2222 return 2223} 2224 2225proc __tap {} { 2226 global package_name 2227 gd-gen-tap 2228 puts "Created Tcl Dev Kit \"${package_name}.tap\"" 2229} 2230 2231proc __rpmspec {} { 2232 global package_name 2233 gd-gen-rpmspec 2234 puts "Created RPM spec file \"${package_name}.spec\"" 2235} 2236 2237 2238proc __release {} { 2239 # Regenerate PACKAGES, and extend 2240 gd-gen-packages 2241 return 2242 2243 global argv argv0 distribution package_name package_version 2244 2245 getpackage textutil textutil/textutil.tcl 2246 2247 if {[llength $argv] != 2} { 2248 puts stderr "$argv0: wrong#args: release name sf-user-id" 2249 exit 1 2250 } 2251 2252 foreach {name sfuser} $argv break 2253 set email "<${sfuser}@users.sourceforge.net>" 2254 set pname [textutil::cap $package_name] 2255 2256 set notice "[clock format [clock seconds] -format "%Y-%m-%d"] $name $email 2257 2258 * 2259 * Released and tagged $pname $package_version ======================== 2260 * 2261 2262" 2263 2264 set logs [list [file join $distribution ChangeLog]] 2265 foreach m [modules] { 2266 set m [file join $distribution modules $m ChangeLog] 2267 if {![file exists $m]} continue 2268 lappend logs $m 2269 } 2270 2271 foreach f $logs { 2272 puts "\tAdding release notice to $f" 2273 set fh [open $f r] ; set data [read $fh] ; close $fh 2274 set fh [open $f w] ; puts -nonewline $fh $notice$data ; close $fh 2275 } 2276 2277 gd-gen-packages 2278 return 2279} 2280 2281# -------------------------------------------------------------- 2282# Documentation 2283 2284proc __desc {} { 2285 global argv ; if {![checkmod]} return 2286 array set pd [getpdesc] 2287 2288 getpackage struct::matrix struct/matrix.tcl 2289 getpackage textutil textutil/textutil.tcl 2290 2291 struct::matrix m 2292 m add columns 3 2293 2294 puts {Descriptions...} 2295 if {[llength $argv] == 0} {set argv [modules]} 2296 2297 foreach m [lsort [dealias $argv]] { 2298 array set _ {} 2299 set pkg {} 2300 foreach {p vlist} [ppackages $m] { 2301 catch {set _([lindex $pd($p) 0]) .} 2302 lappend pkg $p 2303 } 2304 set desc [string trim [join [array names _] ", "] " \n\t\r,"] 2305 set desc [textutil::adjust $desc -length 20] 2306 unset _ 2307 2308 m add row [list $m $desc] 2309 m add row {} 2310 2311 foreach p [lsort -dictionary $pkg] { 2312 set desc "" 2313 catch {set desc [lindex $pd($p) 1]} 2314 if {$desc != ""} { 2315 set desc [string trim $desc] 2316 set desc [textutil::adjust $desc -length 50] 2317 m add row [list {} $p $desc] 2318 } else { 2319 m add row [list {**} $p ] 2320 } 2321 } 2322 m add row {} 2323 } 2324 2325 m format 2chan 2326 puts "" 2327 return 2328} 2329 2330proc __desc/2 {} { 2331 global argv ; if {![checkmod]} return 2332 array set pd [getpdesc] 2333 2334 getpackage struct::matrix struct/matrix.tcl 2335 getpackage textutil textutil/textutil.tcl 2336 2337 puts {Descriptions...} 2338 if {[llength $argv] == 0} {set argv [modules]} 2339 2340 foreach m [lsort [dealias $argv]] { 2341 struct::matrix m 2342 m add columns 3 2343 2344 m add row {} 2345 2346 set pkg {} 2347 foreach {p vlist} [ppackages $m] {lappend pkg $p} 2348 2349 foreach p [lsort -dictionary $pkg] { 2350 set desc "" 2351 set sdes "" 2352 catch {set desc [lindex $pd($p) 1]} 2353 catch {set sdes [lindex $pd($p) 0]} 2354 2355 if {$desc != ""} { 2356 set desc [string trim $desc] 2357 #set desc [textutil::adjust $desc -length 50] 2358 } 2359 2360 if {$desc != ""} { 2361 set desc [string trim $desc] 2362 #set desc [textutil::adjust $desc -length 50] 2363 } 2364 2365 m add row [list $p " $sdes" " $desc"] 2366 } 2367 m format 2chan 2368 puts "" 2369 m destroy 2370 } 2371 2372 return 2373} 2374 2375# -------------------------------------------------------------- 2376 2377proc __docstrip/users {} { 2378 # Print the list of modules using docstrip for their code. 2379 2380 set argv [modules] 2381 foreach m [lsort $argv] { 2382 if {[docstripUser $m]} { 2383 puts $m 2384 } 2385 } 2386 2387 return 2388} 2389 2390proc __docstrip/regen {} { 2391 # Regenerate modules based on docstrip. 2392 2393 global argv ; if {![checkmod]} return 2394 if {[llength $argv] == 0} {set argv [modules]} 2395 2396 foreach m [lsort [dealias $argv]] { 2397 if {[docstripUser $m]} { 2398 docstripRegen $m 2399 } 2400 } 2401 2402 return 2403} 2404 2405# -------------------------------------------------------------- 2406## Make sak specific packages visible. 2407 2408lappend auto_path [file join $distribution support devel sak] 2409 2410# -------------------------------------------------------------- 2411## Dispatcher to the sak commands. 2412 2413set cmd [lindex $argv 0] 2414set argv [lrange $argv 1 end] 2415incr argc -1 2416 2417# Prefer a command implementation found in the support tree. 2418# Then see if the command is implemented here, in this file. 2419# At last fail and report possible commands. 2420 2421set base [file dirname [info script]] 2422set sbase [file join $base support devel sak] 2423set cbase [file join $sbase $cmd] 2424set cmdf [file join $cbase cmd.tcl] 2425 2426if {[file exists $cmdf] && [file readable $cmdf]} { 2427 source $cmdf 2428 exit 0 2429} 2430 2431if {[llength [info procs __$cmd]] == 0} { 2432 puts stderr "$argv0 : Illegal command \"$cmd\"" 2433 set fl {} 2434 foreach p [info procs __*] { 2435 lappend fl [string range $p 2 end] 2436 } 2437 foreach p [glob -nocomplain -directory $sbase */cmd.tcl] { 2438 lappend fl [lindex [file split $p] end-1] 2439 } 2440 2441 regsub -all . $argv0 { } blank 2442 puts stderr "$blank : Should have been [linsert [join [lsort -uniq $fl] ", "] end-1 or]" 2443 exit 1 2444} 2445 2446__$cmd 2447exit 0 2448