1#!/bin/sh 2# -*- tcl -*- \ 3exec tclsh "$0" ${1+"$@"} 4package require Tcl 8.4 5unset -nocomplain ::errorInfo 6set me [file normalize [info script]] 7proc main {} { 8 global argv 9 if {![llength $argv]} { set argv help} 10 if {[catch { 11 eval _$argv 12 }]} usage 13 exit 0 14} 15set packages { 16 {app-critcl {.. critcl critcl.tcl} critcl-app} 17 {critcl critcl.tcl} 18 {critcl-bitmap bitmap.tcl} 19 {critcl-class class.tcl} 20 {critcl-cutil cutil.tcl} 21 {critcl-emap emap.tcl} 22 {critcl-enum enum.tcl} 23 {critcl-iassoc iassoc.tcl} 24 {critcl-literals literals.tcl} 25 {critcl-platform platform.tcl} 26 {critcl-util util.tcl} 27 {dict84 dict.tcl} 28 {lassign84 lassign.tcl} 29 {lmap84 lmap.tcl} 30 {stubs_container container.tcl} 31 {stubs_gen_decl gen_decl.tcl} 32 {stubs_gen_header gen_header.tcl} 33 {stubs_gen_init gen_init.tcl} 34 {stubs_gen_lib gen_lib.tcl} 35 {stubs_gen_macro gen_macro.tcl} 36 {stubs_gen_slot gen_slot.tcl} 37 {stubs_genframe genframe.tcl} 38 {stubs_reader reader.tcl} 39 {stubs_writer writer.tcl} 40} 41proc usage {{status 1}} { 42 global errorInfo 43 if {[info exists errorInfo] && ($errorInfo ne {}) && 44 ![string match {invalid command name "_*"*} $errorInfo] 45 } { 46 puts stderr $::errorInfo 47 exit 48 } 49 50 global argv0 51 set prefix "Usage: " 52 foreach c [lsort -dict [info commands _*]] { 53 set c [string range $c 1 end] 54 if {[catch { 55 H${c} 56 } res]} { 57 puts stderr "$prefix$argv0 $c args...\n" 58 } else { 59 puts stderr "$prefix$argv0 $c $res\n" 60 } 61 set prefix " " 62 } 63 exit $status 64} 65proc +x {path} { 66 catch { file attributes $path -permissions ugo+x } 67 return 68} 69proc critapp {dst} { 70 global tcl_platform 71 set app [file join $dst critcl] 72 if {$tcl_platform(platform) eq "windows"} { 73 append app .tcl 74 } 75 return $app 76} 77proc vfile {dir vfile} { 78 global me 79 set selfdir [file dirname $me] 80 eval [linsert $vfile 0 file join $selfdir lib $dir] 81} 82proc grep {file pattern} { 83 set lines [split [read [set chan [open $file r]]] \n] 84 close $chan 85 return [lsearch -all -inline -glob $lines $pattern] 86} 87proc version {file} { 88 set provisions [grep $file {*package provide*}] 89 #puts /$provisions/ 90 return [lindex $provisions 0 3] 91} 92proc tmpdir {} { 93 package require fileutil 94 set tmpraw [fileutil::tempfile critcl.] 95 set tmpdir $tmpraw.[pid] 96 file delete -force $tmpdir 97 file mkdir $tmpdir 98 file delete -force $tmpraw 99 100 puts "Assembly in: $tmpdir" 101 return $tmpdir 102} 103proc findlib {path} { 104 while {1} { 105 if {[file tail $path] eq "lib"} { 106 return $path 107 } 108 set new [file dirname $path] 109 if {$new eq $path} break 110 set path $new 111 } 112 return $path 113} 114proc dstlfromlib {path} { 115 # kinda the inverse of findlib above, it returns the path to 116 # dstl relative the */lib path returned by findlib. The path 117 # is returned as a list of segments 118 set relpath {} 119 while {1} { 120 if {[file tail $path] eq "lib"} { 121 break 122 } 123 set new [file dirname $path] 124 set relpath [linsert $relpath[set relpath {}] 0 [file tail $path]] 125 if {$new eq $path} break 126 set path $new 127 } 128 return $relpath 129} 130proc id {cv vv} { 131 upvar 1 $cv commit $vv version 132 133 set commit [exec git log -1 --pretty=format:%H] 134 set version [exec git describe] 135 136 puts "Commit: $commit" 137 puts "Version: $version" 138 return 139} 140proc savedoc {tmpdir} { 141 puts {Collecting the documentation ...} 142 file copy -force [file join embedded www] [file join $tmpdir doc] 143 return 144} 145 146proc pkgdirname {name version} { 147 return $name$version 148} 149 150 151proc placedoc {tmpdir} { 152 file delete -force doc 153 file copy -force [file join $tmpdir doc] doc 154 return 155} 156proc 2website {} { 157 puts {Switching to gh-pages...} 158 exec 2>@ stderr >@ stdout git checkout gh-pages 159 return 160} 161proc reminder {commit} { 162 puts "" 163 puts "We are in branch gh-pages now, coming from $commit" 164 puts "" 165 return 166} 167proc shquote value { 168 return "\"[string map [list \\ \\\\ $ \\$ ` \\`] $value]\"" 169} 170 171proc targets libdir { 172 if {$libdir eq {} } { 173 set exe [file dirname [file normalize [file join [info nameofexecutable] ...]]] 174 set dstl [info library] 175 set dsta [file dirname $exe] 176 set dsti [file join [file dirname $dsta] include] 177 } else { 178 set dstl $libdir 179 set libdir [findlib $dstl] 180 set top [file dirname $libdir] 181 set dsta [file join $top bin] 182 set dsti [file join $top include] 183 } 184 list $dsta $dsti $dstl 185} 186 187proc Hsynopsis {} { return "\n\tGenerate a synopsis of procs and builtin types" } 188proc _synopsis {} { 189 puts Public: 190 puts [exec grep -n ^proc lib/critcl/critcl.tcl \ 191 | sed -e "s| \{$||" -e {s/:proc ::critcl::/ /} \ 192 | grep -v { [A-Z]} \ 193 | grep -v { at::[A-Z]} \ 194 | sort -k 2 \ 195 | sed -e {s/^/ /}] 196 197 puts Private: 198 puts [exec grep -n ^proc lib/critcl/critcl.tcl \ 199 | sed -e "s| \{$||" -e {s/:proc ::critcl::/ /} \ 200 | grep {[A-Z]} \ 201 | sort -k 2 \ 202 | sed -e {s/^/ /}] 203 204 puts "Builtin argument types:" 205 puts [exec grep -n { argtype} lib/critcl/critcl.tcl \ 206 | sed -e "s| \{$||" -e {s/:[ ]*argtype/ /} \ 207 | sort -k 2 \ 208 | sed -e {s/^/ /}] 209 210 puts "Builtin result types:" 211 puts [exec grep -n { resulttype} lib/critcl/critcl.tcl \ 212 | sed -e "s| \{$||" -e {s/:[ ]*resulttype/ /} \ 213 | sort -k 2 \ 214 | sed -e {s/^/ /}] 215 216 return 217} 218 219proc Hhelp {} { return "\n\tPrint this help" } 220proc _help {} { 221 usage 0 222 return 223} 224proc Hrecipes {} { return "\n\tList all build commands, without details." } 225proc _recipes {} { 226 set r {} 227 foreach c [info commands _*] { 228 lappend r [string range $c 1 end] 229 } 230 puts [lsort -dict $r] 231 return 232} 233proc Htest {} { return "\n\tRun the testsuite." } 234proc _test {} { 235 global argv 236 set argv {} ;# clear -- tcltest shall see nothing 237 # Run all .test files in the test directory. 238 set selfdir [file dirname $::me] 239 foreach testsuite [lsort -dict [glob -directory [file join $selfdir test] *.test]] { 240 puts "" 241 puts "_ _ __ ___ _____ ________ _____________ _____________________ *** [file tail $testsuite] ***" 242 if {[catch { 243 exec >@ stdout 2>@ stderr [info nameofexecutable] $testsuite 244 }]} { 245 puts $::errorInfo 246 } 247 } 248 249 puts "" 250 puts "_ _ __ ___ _____ ________ _____________ _____________________" 251 puts "" 252 return 253} 254proc Hdoc {} { return "\n\t(Re)Generate the embedded documentation." } 255proc _doc {} { 256 cd [file join [file dirname $::me] doc] 257 258 puts "Removing old documentation..." 259 file delete -force [file join .. embedded man] 260 file delete -force [file join .. embedded www] 261 262 file mkdir [file join .. embedded man] 263 file mkdir [file join .. embedded www] 264 265 puts "Generating man pages..." 266 exec 2>@ stderr >@ stdout /usr/local/bin/dtplite -ext n -o [file join .. embedded man] nroff . 267 puts "Generating html..." 268 exec 2>@ stderr >@ stdout /usr/local/bin/dtplite -o [file join .. embedded www] html . 269 270 cd [file join .. embedded man] 271 file delete -force .idxdoc .tocdoc 272 cd [file join .. www] 273 file delete -force .idxdoc .tocdoc 274 275 return 276} 277proc Htextdoc {} { return "destination\n\tGenerate plain text documentation in specified directory." } 278proc _textdoc {dst} { 279 set destination [file normalize $dst] 280 281 cd [file join [file dirname $::me] doc] 282 283 puts "Removing old text documentation at ${dst}..." 284 file delete -force $destination 285 286 file mkdir $destination 287 288 puts "Generating pages..." 289 exec 2>@ stderr >@ stdout /usr/local/bin/dtplite -ext txt -o $destination text . 290 291 cd $destination 292 file delete -force .idxdoc .tocdoc 293 294 return 295} 296proc Hfigures {} { return "\n\t(Re)Generate the figures and diagrams for the documentation." } 297proc _figures {} { 298 cd [file join [file dirname $::me] doc figures] 299 300 puts "Generating (tklib) diagrams..." 301 eval [linsert [glob *.dia] 0 exec 2>@ stderr >@ stdout dia convert -t -o . png] 302 303 return 304} 305proc Hrelease {} { return "\n\tGenerate a release from the current commit.\n\tAssumed to be properly tagged.\n\tLeaves checkout in the gh-pages branch, ready for commit+push" } 306proc _release {} { 307 # # ## ### ##### ######## ############# 308 # Get scratchpad to assemble the release in. 309 # Get version and hash of the commit to be released. 310 311 puts -nonewline "Have you run the tests ? " 312 flush stdout 313 set a [string tolower [gets stdin]] 314 315 if {($a ne "y" ) && ($a ne "yes")} { 316 puts "Please do" 317 exit 1 318 } 319 320 set tmpdir [tmpdir] 321 id commit version 322 323 savedoc $tmpdir 324 325 # # ## ### ##### ######## ############# 326 puts {Generate starkit...} 327 _starkit [file join $tmpdir critcl31.kit] 328 329 # # ## ### ##### ######## ############# 330 puts {Collecting starpack prefix...} 331 # which we use the existing starpack for, from the gh-pages branch 332 333 exec 2>@ stderr >@ stdout git checkout gh-pages 334 file copy [file join download critcl31.exe] [file join $tmpdir prefix.exe] 335 exec 2>@ stderr >@ stdout git checkout $commit 336 337 # # ## ### ##### ######## ############# 338 puts {Generate starpack...} 339 _starpack [file join $tmpdir prefix.exe] [file join $tmpdir critcl31.exe] 340 # TODO: vacuum the thing. fix permissions if so. 341 342 # # ## ### ##### ######## ############# 343 2website 344 placedoc $tmpdir 345 346 file copy -force [file join $tmpdir critcl31.kit] [file join downloadcritcl31.kit] 347 file copy -force [file join $tmpdir critcl31.exe] [file join download critcl31.exe] 348 349 set index [fileutil::cat index.html] 350 set pattern "\\\[commit .*\\\] \\(v\[^)\]*\\)<!-- current" 351 set replacement "\[commit $commit\] (v$version)<!-- current" 352 regsub $pattern $index $replacement index 353 fileutil::writeFile index.html $index 354 355 # # ## ### ##### ######## ############# 356 reminder $commit 357 358 # # ## ### ##### ######## ############# 359 return 360} 361proc Hrelease-doc {} { return "\n\tUpdate the release documentation from the current commit.\n\tAssumed to be properly tagged.\n\tLeaves the checkout in the gh-pages branch, ready for commit+push" } 362proc _release-doc {} { 363 # # ## ### ##### ######## ############# 364 # Get scratchpad to assemble the release in. 365 # Get version and hash of the commit to be released. 366 367 set tmpdir [tmpdir] 368 id _ commit ; # Just for the printout, we are actually not using the data. 369 370 savedoc $tmpdir 371 2website 372 placedoc $tmpdir 373 reminder $commit 374 375 # # ## ### ##### ######## ############# 376 return 377} 378 379proc Htargets {} { return "?destination?\n\tShow available targets.\n\tExpects critcl app to be installed in destination." } 380proc _targets args { 381 switch [llength $args] { 382 0 - 1 { 383 } 384 default { 385 error -list wrong # args 386 } 387 } 388 if {[llength [info level 0]] < 2} { 389 lassign [targets {}] dsta dsti dstl 390 } else { 391 lassign [targets [file join [file dirname [lindex [info level 0] 1]] lib]] dsta dsti dstl 392 } 393 puts [join [split [exec [file join $dsta critcl] -targets]] \n] 394 return 395} 396 397proc Hinstall {} { return "?-target T? ?destination?\n\tInstall all packages, and application.\n\tdestination = path of package directory, default \[info library\]." } 398proc _install {args} { 399 global packages me 400 401 set target {} 402 if {[lindex $args 0] eq "-target"} { 403 set target [lindex $args 1] 404 set args [lrange $args 2 end] 405 } 406 407 if {[llength $args] == 0} { 408 set libdir {} 409 410 } else { 411 set libdir [lindex $args 0] 412 } 413 lassign [targets $libdir] dsta dsti dstl 414 file mkdir $dsta $dsti 415 416 set selfdir [file dirname $me] 417 418 puts {Installing into:} 419 puts \tPackages:\t$dstl 420 puts \tApplication:\t$dsta 421 puts \tHeaders:\t$dsti 422 423 if {[catch { 424 # Create directories, might not exist. 425 file mkdir $dstl 426 file mkdir $dsta 427 set prefix \n 428 foreach item $packages { 429 # Package: /name/ 430 431 if {[llength $item] == 3} { 432 foreach {dir vfile name} $item break 433 } elseif {[llength $item] == 1} { 434 set dir $item 435 set vfile {} 436 set name $item 437 } else { 438 foreach {dir vfile} $item break 439 set name $dir 440 } 441 442 if {$vfile ne {}} { 443 set version [version [vfile $dir $vfile]] 444 } else { 445 set version {} 446 } 447 448 set namevers [file join $dstl [pkgdirname $name $version]] 449 450 file copy -force [file join $selfdir lib $dir] [file join $dstl ${name}-new] 451 file delete -force $namevers 452 puts "${prefix}Installed package: $namevers" 453 file rename [file join $dstl ${name}-new] $namevers 454 set prefix {} 455 } 456 457 # Application: critcl 458 459 set theapp [critapp $dsta] 460 set reldstl [dstlfromlib $dstl] 461 462 set c [open $theapp w] 463 lappend map @bs@ "\\" 464 lappend map @exe@ [shquote [file dirname [file normalize [ 465 file join [info nameofexecutable] ...]]]] 466 lappend map @path@ [list $reldstl] ;# insert the dst path 467 puts [list geedonk $reldstl] 468 lappend map "\t " {} ;# de-dent 469 puts $c [string trimleft [string map $map { 470 #!/bin/sh 471 # -*-tcl -*- 472 # hide next line from tcl @bs@ 473 exec @exe@ "$0" ${1+"$@"} 474 475 set libpath [file join [file dirname [file dirname [ 476 file normalize [file join [info script] ...]]]] .. lib] 477 set libpath [file join $libpath @path@] 478 if {[lsearch -exact $auto_path $libpath] < 0} { 479 set auto_path [linsert $auto_path[set auto_path {}] 0 $libpath] 480 } 481 482 package require critcl::app 483 critcl::app::main $argv}]] 484 close $c 485 +x $theapp 486 487 puts "${prefix}Installed application: $theapp" 488 489 # Special package: critcl_md5c 490 # Local MD5 hash implementation. 491 492 puts "\nInstalled C package:\tcritcl::md5c" 493 494 # It is special because it is a critcl-based package, not pure 495 # Tcl as everything else of critcl. Its installation makes it 496 # the first package which will be compiled with critcl on this 497 # machine. It uses the just-installed application for 498 # that. This is package-mode, where MD5 itself is not used, so 499 # there is no chicken vs. egg. 500 501 set src [file join $selfdir lib critcl-md5c md5c.tcl] 502 set version [version $src] 503 set name critcl_md5c 504 set dst [file join $dstl [pkgdirname $name $version]] 505 set cmd {} 506 507 lappend cmd exec >@ stdout 2>@ stderr 508 lappend cmd [info nameofexecutable] 509 lappend cmd $theapp 510 lappend cmd -cache [file join $selfdir cache] 511 if {$target ne {}} { 512 lappend cmd -target $target 513 } 514 lappend cmd -libdir [file join $dstl tmp] -pkg $src 515 puts [list executing $cmd] 516 eval $cmd 517 518 file delete -force $dst 519 file rename [file join $dstl tmp md5c] $dst 520 file delete -force [file join $dstl tmp] 521 522 puts "${prefix}Installed package: $dst" 523 524 # Special package: critcl::callback 525 # C/Tcl callback utility code. 526 527 puts "\nInstalled C package:\tcritcl::callback" 528 529 # It is special because it is a critcl-based package, not pure 530 # Tcl as everything else of critcl. Its installation makes it 531 # the second package which will be compiled with critcl on this 532 # machine. It uses the just-installed application for 533 # that. 534 535 set src [file join $selfdir lib critcl-callback callback.tcl] 536 set version [version $src] 537 set name critcl_callback 538 set dst [file join $dstl $name$version] 539 set dsth [file join $dsti $name] 540 set cmd {} 541 542 lappend cmd exec >@ stdout 2>@ stderr 543 lappend cmd [info nameofexecutable] 544 lappend cmd $theapp 545 lappend cmd -cache [file join $selfdir cache] 546 if {$target ne {}} { 547 lappend cmd -target $target 548 } 549 set dstl_tmp [file join $dstl tmp] 550 lappend cmd -libdir $dstl_tmp 551 lappend cmd -includedir $dstl_tmp 552 lappend cmd -pkg $src 553 eval $cmd 554 555 file delete -force $dst $dsth 556 file rename [file join $dstl tmp callback] $dst 557 file rename [file join $dstl tmp critcl_callback] $dsth 558 file delete -force $dstl_tmp 559 560 puts "${prefix}Installed package: $dst" 561 puts "${prefix}Installed headers: [ 562 file join $dsti critcl_callback]" 563 564 } msg]} { 565 if {![string match {*permission denied*} $msg]} { 566 return -code error -errorcode $::errorCode -errorinfo $::errorInfo $msg 567 } 568 puts stderr "\n$msg\n\nUse 'sudo' or some other way of running the operation under the user having access to the destination paths.\n" 569 exit 570 } 571 return 572} 573proc Huninstall {} { Hdrop } 574proc _uninstall {args} { eval [linsert $args 0 _drop] } 575 576proc Hdrop {} { return "?destination?\n\tRemove packages.\n\tdestination = path of package directory, default \[info library\]." } 577proc _drop {{dst {}}} { 578 global packages me 579 580 if {[llength [info level 0]] < 2} { 581 set dstl [info library] 582 set dsta [file dirname [file dirname [file normalize [file join [ 583 info nameofexecutable] ...]]]] 584 } else { 585 set dstl $dst 586 set dsta [file join [file dirname $dst] bin] 587 } 588 589 # Add the special package (see install). Not special with regard 590 # to removal. Except for the name 591 lappend packages [list critcl-md5c md5c.tcl critcl_md5c] 592 593 set selfdir [file dirname $me] 594 595 foreach item $packages { 596 # Package: /name/ 597 598 if {[llength $item] == 3} { 599 foreach {dir vfile name} $item break 600 } elseif {[llength $item] == 1} { 601 set dir $item 602 set vfile {} 603 set name $item 604 } else { 605 foreach {dir vfile} $item break 606 set name $dir 607 } 608 609 if {$vfile ne {}} { 610 set version [version [vfile $dir $vfile]] 611 } else { 612 set version {} 613 } 614 615 set namevers [file join $dstl $name$version] 616 617 file delete -force $namevers 618 puts "Removed package: $namevers" 619 } 620 621 # Application: critcl 622 set theapp [critapp $dsta] 623 file delete $theapp 624 puts "Removed application: $theapp" 625 return 626} 627proc Hstarkit {} { return "?destination? ?interpreter?\n\tGenerate a starkit\n\tdestination = path of result file, default 'critcl.kit'\n\tinterpreter = (path) name of tcl shell to use for execution, default 'tclkit'" } 628proc _starkit {{dst critcl.kit} {interp tclkit}} { 629 package require vfs::mk4 630 631 set c [open $dst w] 632 fconfigure $c -translation binary -encoding binary 633 puts -nonewline $c "#!/bin/sh\n# -*- tcl -*- \\\nexec $interp \"\$0\" \$\{1+\"\$@\"\}\npackage require starkit\nstarkit::header mk4 -readonly\n\032################################################################################################################################################################" 634 close $c 635 636 vfs::mk4::Mount $dst /KIT 637 file copy -force lib /KIT 638 file copy -force main.tcl /KIT 639 vfs::unmount /KIT 640 +x $dst 641 642 puts "Created starkit: $dst" 643 return 644} 645proc Hstarpack {} { return "prefix ?destination?\n\tGenerate a fully-selfcontained executable, i.e. a starpack\n\tprefix = path of tclkit/basekit runtime to use\n\tdestination = path of result file, default 'critcl'" } 646proc _starpack {prefix {dst critcl}} { 647 package require vfs::mk4 648 649 file copy -force $prefix $dst 650 651 vfs::mk4::Mount $dst /KIT 652 file mkdir [file join /KIT lib] 653 654 foreach d [glob -directory lib *] { 655 file delete -force [file join /KIT lib [file tail $d]] 656 file copy -force $d [file join /KIT lib] 657 } 658 659 file copy -force main.tcl /KIT 660 vfs::unmount /KIT 661 +x $dst 662 663 puts "Created starpack: $dst" 664 return 665} 666proc Hexamples {} { return "?args...?\n\tWithout arguments, list the examples.\n\tOtherwise run the recipe with its arguments on the examples." } 667proc _examples {args} { 668 global me 669 set selfdir [file dirname $me] 670 set self [file tail $me] 671 672 # List examples, or run the build code on the examples, passing any arguments. 673 674 set examples [lsort -dict [glob -directory [file join $selfdir examples] */$self]] 675 676 puts "" 677 if {![llength $args]} { 678 foreach b $examples { 679 puts "* [file dirname $b]" 680 } 681 } else { 682 foreach b $examples { 683 puts "$b _______________________________________________" 684 eval [linsert $args 0 exec 2>@ stderr >@ stdout [info nameofexecutable] $b] 685 puts "" 686 puts "" 687 } 688 } 689 return 690} 691main 692