1### 2# Amalgamated package for practcl 3# Do not edit directly, tweak the source in src/ and rerun 4# build.tcl 5### 6package require Tcl 8.5 7package provide practcl 0.11 8namespace eval ::practcl {} 9 10### 11# START: httpwget/wget.tcl 12### 13### 14# Tool to download file from the web 15# Enhacements to http 16### 17package provide http::wget 0.1 18package require http 19 20::namespace eval ::http {} 21 22### 23# topic: 1ed971e03ae89415e2f25d20e59b765c 24# description: this proc contributed by Donal Fellows 25### 26proc ::http::_followRedirects {url args} { 27 while 1 { 28 set token [geturl $url -validate 1] 29 set ncode [ncode $token] 30 if { $ncode eq "404" } { 31 error "URL Not found" 32 } 33 switch -glob $ncode { 34 30[1237] {### redirect - see below ###} 35 default {cleanup $token ; return $url} 36 } 37 upvar #0 $token state 38 array set meta [set ${token}(meta)] 39 cleanup $token 40 if {![info exists meta(Location)]} { 41 return $url 42 } 43 set url $meta(Location) 44 unset meta 45 } 46 return $url 47} 48 49### 50# topic: fced7bc395596569ac225a719c686dcc 51### 52proc ::http::wget {url destfile {verbose 1}} { 53 set tmpchan [open $destfile w] 54 fconfigure $tmpchan -translation binary 55 if { $verbose } { 56 puts [list GETTING [file tail $destfile] from $url] 57 } 58 set real_url [_followRedirects $url] 59 set token [geturl $real_url -channel $tmpchan -binary yes] 60 if {[ncode $token] != "200"} { 61 error "DOWNLOAD FAILED" 62 } 63 cleanup $token 64 close $tmpchan 65} 66 67 68### 69# END: httpwget/wget.tcl 70### 71### 72# START: setup.tcl 73### 74### 75# Practcl 76# An object oriented templating system for stamping out Tcl API calls to C 77### 78 79package require TclOO 80### 81# Seek out Tcllib if it's available 82### 83set tcllib_path {} 84foreach path {.. ../.. ../../..} { 85 foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] { 86 set tclib_path $path 87 lappend ::auto_path $path 88 break 89 } 90 if {$tcllib_path ne {}} break 91} 92namespace eval ::practcl {} 93namespace eval ::practcl::OBJECT {} 94 95### 96# END: setup.tcl 97### 98### 99# START: buildutil.tcl 100### 101### 102# Build utility functions 103### 104 105### 106# A command to do nothing. A handy way of 107# negating an instruction without 108# having to comment it completely out. 109# It's also a handy attachment point for 110# an object to be named later 111### 112if {[info command ::noop] eq {}} { 113 proc ::noop args {} 114} 115 116proc ::practcl::debug args { 117 #puts $args 118 ::practcl::cputs ::DEBUG_INFO $args 119} 120 121### 122# Drop in a static copy of Tcl 123### 124proc ::practcl::doexec args { 125 puts [list {*}$args] 126 exec {*}$args >&@ stdout 127} 128 129proc ::practcl::doexec_in {path args} { 130 set PWD [pwd] 131 cd $path 132 puts [list {*}$args] 133 exec {*}$args >&@ stdout 134 cd $PWD 135} 136 137proc ::practcl::dotclexec args { 138 puts [list [info nameofexecutable] {*}$args] 139 exec [info nameofexecutable] {*}$args >&@ stdout 140} 141 142proc ::practcl::domake {path args} { 143 set PWD [pwd] 144 cd $path 145 puts [list *** $path ***] 146 puts [list make {*}$args] 147 exec make {*}$args >&@ stdout 148 cd $PWD 149} 150 151proc ::practcl::domake.tcl {path args} { 152 set PWD [pwd] 153 cd $path 154 puts [list *** $path ***] 155 puts [list make.tcl {*}$args] 156 exec [info nameofexecutable] make.tcl {*}$args >&@ stdout 157 cd $PWD 158} 159 160proc ::practcl::fossil {path args} { 161 set PWD [pwd] 162 cd $path 163 puts [list {*}$args] 164 exec fossil {*}$args >&@ stdout 165 cd $PWD 166} 167 168 169proc ::practcl::fossil_status {dir} { 170 if {[info exists ::fosdat($dir)]} { 171 return $::fosdat($dir) 172 } 173 set result { 174tags experimental 175version {} 176 } 177 set pwd [pwd] 178 cd $dir 179 set info [exec fossil status] 180 cd $pwd 181 foreach line [split $info \n] { 182 if {[lindex $line 0] eq "checkout:"} { 183 set hash [lindex $line end-3] 184 set maxdate [lrange $line end-2 end-1] 185 dict set result hash $hash 186 dict set result maxdate $maxdate 187 regsub -all {[^0-9]} $maxdate {} isodate 188 dict set result isodate $isodate 189 } 190 if {[lindex $line 0] eq "tags:"} { 191 set tags [lrange $line 1 end] 192 dict set result tags $tags 193 break 194 } 195 } 196 set ::fosdat($dir) $result 197 return $result 198} 199 200proc ::practcl::os {} { 201 return [${::practcl::MAIN} define get TEACUP_OS] 202} 203 204if {[::package vcompare $::tcl_version 8.6] < 0} { 205 # Approximate ::zipfile::mkzip with exec calls 206 proc ::practcl::mkzip {exename barekit vfspath} { 207 set path [file dirname [file normalize $exename]] 208 set zipfile [file join $path [file rootname $exename].zip] 209 file copy -force $barekit $exename 210 set pwd [pwd] 211 cd $vfspath 212 exec zip -r $zipfile . 213 cd $pwd 214 set fout [open $exename a] 215 set fin [open $zipfile r] 216 chan configure $fout -translation binary 217 chan configure $fin -translation binary 218 chan copy $fin $fout 219 chan close $fin 220 chan close $fout 221 exec zip -A $exename 222 } 223 proc ::practcl::sort_dict list { 224 set result {} 225 foreach key [lsort -dictionary [dict keys $list]] { 226 dict set result $key [dict get $list $key] 227 } 228 return $result 229 } 230} else { 231 proc ::practcl::mkzip {exename barekit vfspath} { 232 ::practcl::tcllib_require zipfile::mkzip 233 ::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath 234 } 235 proc ::practcl::sort_dict list { 236 return [::lsort -stride 2 -dictionary $list] 237 } 238} 239 240proc ::practcl::local_os {} { 241 # If we have already run this command, return 242 # a cached copy of the data 243 if {[info exists ::practcl::LOCAL_INFO]} { 244 return $::practcl::LOCAL_INFO 245 } 246 set result [array get ::practcl::CONFIG] 247 dict set result TEACUP_PROFILE unknown 248 dict set result TEACUP_OS unknown 249 dict set result EXEEXT {} 250 set windows 0 251 if {$::tcl_platform(platform) eq "windows"} { 252 set windows 1 253 } 254 if {$windows} { 255 set system "windows" 256 set arch ix86 257 dict set result TEACUP_PROFILE win32-ix86 258 dict set result TEACUP_OS windows 259 dict set result EXEEXT .exe 260 } else { 261 set system [exec uname -s]-[exec uname -r] 262 set arch unknown 263 dict set result TEACUP_OS generic 264 } 265 dict set result TEA_PLATFORM $system 266 dict set result TEA_SYSTEM $system 267 if {[info exists ::SANDBOX]} { 268 dict set result sandbox $::SANDBOX 269 } 270 switch -glob $system { 271 Linux* { 272 dict set result TEACUP_OS linux 273 set arch [exec uname -m] 274 dict set result TEACUP_PROFILE "linux-glibc2.3-$arch" 275 } 276 GNU* { 277 set arch [exec uname -m] 278 dict set result TEACUP_OS "gnu" 279 } 280 NetBSD-Debian { 281 set arch [exec uname -m] 282 dict set result TEACUP_OS "netbsd-debian" 283 } 284 OpenBSD-* { 285 set arch [exec arch -s] 286 dict set result TEACUP_OS "openbsd" 287 } 288 Darwin* { 289 set arch [exec uname -m] 290 dict set result TEACUP_OS "macosx" 291 if {$arch eq "x86_64"} { 292 dict set result TEACUP_PROFILE "macosx10.5-i386-x86_84" 293 } else { 294 dict set result TEACUP_PROFILE "macosx-universal" 295 } 296 } 297 OpenBSD* { 298 set arch [exec arch -s] 299 dict set result TEACUP_OS "openbsd" 300 } 301 } 302 if {$arch eq "unknown"} { 303 catch {set arch [exec uname -m]} 304 } 305 switch -glob $arch { 306 i*86 { 307 set arch "ix86" 308 } 309 amd64 { 310 set arch "x86_64" 311 } 312 } 313 dict set result TEACUP_ARCH $arch 314 if {[dict get $result TEACUP_PROFILE] eq "unknown"} { 315 dict set result TEACUP_PROFILE [dict get $result TEACUP_OS]-$arch 316 } 317 set OS [dict get $result TEACUP_OS] 318 dict set result os $OS 319 320 # Look for a local preference file 321 set pathlist {} 322 set userhome [file normalize ~/tcl] 323 set local_install [file join $userhome lib] 324 switch $OS { 325 windows { 326 set userhome [file join [file normalize $::env(LOCALAPPDATA)] Tcl] 327 if {[file exists c:/Tcl/Teapot]} { 328 dict set result teapot c:/Tcl/Teapot 329 } 330 } 331 macosx { 332 set userhome [file join [file normalize {~/Library/Application Support/}] Tcl] 333 if {[file exists {~/Library/Application Support/ActiveState/Teapot/repository/}]} { 334 dict set result teapot [file normalize {~/Library/Application Support/ActiveState/Teapot/repository/}] 335 } 336 dict set result local_install [file normalize ~/Library/Tcl] 337 if {![dict exists $result sandbox]} { 338 dict set result sandbox [file normalize ~/Library/Tcl/sandbox] 339 } 340 } 341 default { 342 } 343 } 344 dict set result userhome $userhome 345 # Load user preferences 346 if {[file exists [file join $userhome practcl.rc]]} { 347 set dat [::practcl::read_rc_file [file join $userhome practcl.rc]] 348 foreach {f v} $dat { 349 dict set result $f $v 350 } 351 } 352 if {![dict exists $result prefix]} { 353 dict set result prefix $userhome 354 } 355 356 # Create a default path for the teapot 357 if {![dict exists $result teapot]} { 358 dict set result teapot [file join $userhome teapot] 359 } 360 # Create a default path for the local sandbox 361 if {![dict exists $result sandbox]} { 362 dict set result sandbox [file join $userhome sandbox] 363 } 364 # Create a default path for download folder 365 if {![dict exists $result download]} { 366 dict set result download [file join $userhome download] 367 } 368 # Path to install local packages 369 if {![dict exists $result local_install]} { 370 dict set result local_install [file join $userhome lib] 371 } 372 if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} { 373 dict set result fossil_mirror $::env(FOSSIL_MIRROR) 374 } 375 376 set ::practcl::LOCAL_INFO $result 377 return $result 378} 379 380 381### 382# Detect local platform 383### 384proc ::practcl::config.tcl {path} { 385 return [read_configuration $path] 386} 387 388proc ::practcl::read_configuration {path} { 389 dict set result buildpath $path 390 set result [local_os] 391 set OS [dict get $result TEACUP_OS] 392 set windows 0 393 dict set result USEMSVC 0 394 if {[file exists [file join $path config.tcl]]} { 395 # We have a definitive configuration file. Read its content 396 # and take it as gospel 397 set cresult [read_rc_file [file join $path config.tcl]] 398 set cresult [::practcl::de_shell $cresult] 399 if {[dict exists $cresult srcdir] && ![dict exists $cresult sandbox]} { 400 dict set cresult sandbox [file dirname [dict get $cresult srcdir]] 401 } 402 set result [dict merge $result [::practcl::de_shell $cresult]] 403 } 404 if {[file exists [file join $path config.site]]} { 405 # No config.tcl file is present but we do seed 406 dict set result USEMSVC 0 407 foreach {f v} [::practcl::de_shell [::practcl::read_sh_file [file join $path config.site]]] { 408 dict set result $f $v 409 dict set result XCOMPILE_${f} $v 410 } 411 dict set result CONFIG_SITE [file join $path config.site] 412 if {[dict exist $result XCOMPILE_CC] && [regexp mingw [dict get $result XCOMPILE_CC]]} { 413 set windows 1 414 } 415 } elseif {[info exists ::env(VisualStudioVersion)]} { 416 set windows 1 417 dict set result USEMSVC 1 418 } 419 if {$windows && [dict get $result TEACUP_OS] ne "windows"} { 420 if {![dict exists exists $result TEACUP_ARCH]} { 421 dict set result TEACUP_ARCH ix86 422 } 423 dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH] 424 dict set result TEACUP_OS windows 425 dict set result EXEEXT .exe 426 } 427 return $result 428} 429 430 431### 432# Convert an MSYS path to a windows native path 433### 434if {$::tcl_platform(platform) eq "windows"} { 435proc ::practcl::msys_to_tclpath msyspath { 436 return [exec sh -c "cd $msyspath ; pwd -W"] 437} 438proc ::practcl::tcl_to_myspath tclpath { 439 set path [file normalize $tclpath] 440 return "/[string index $path 0][string range $path 2 end]" 441 #return [exec sh -c "cd $tclpath ; pwd"] 442} 443} else { 444proc ::practcl::msys_to_tclpath msyspath { 445 return [file normalize $msyspath] 446} 447proc ::practcl::tcl_to_myspath msyspath { 448 return [file normalize $msyspath] 449} 450} 451 452 453# Try to load a package, and failing that 454# retrieve tcllib 455proc ::practcl::tcllib_require {pkg args} { 456 # Try to load the package from the local environment 457 if {[catch [list ::package require $pkg {*}$args] err]==0} { 458 return $err 459 } 460 ::practcl::LOCAL tool tcllib env-load 461 uplevel #0 [list ::package require $pkg {*}$args] 462} 463 464namespace eval ::practcl::platform {} 465 466proc ::practcl::platform::tcl_core_options {os} { 467 ### 468 # Download our required packages 469 ### 470 set tcl_config_opts {} 471 # Auto-guess options for the local operating system 472 switch $os { 473 windows { 474 #lappend tcl_config_opts --disable-stubs 475 } 476 linux { 477 } 478 macosx { 479 lappend tcl_config_opts --enable-corefoundation=yes --enable-framework=no 480 } 481 } 482 lappend tcl_config_opts --with-tzdata 483 return $tcl_config_opts 484} 485 486proc ::practcl::platform::tk_core_options {os} { 487 ### 488 # Download our required packages 489 ### 490 set tk_config_opts {} 491 492 # Auto-guess options for the local operating system 493 switch $os { 494 windows { 495 } 496 linux { 497 lappend tk_config_opts --enable-xft=no --enable-xss=no 498 } 499 macosx { 500 lappend tk_config_opts --enable-aqua=yes 501 } 502 } 503 return $tk_config_opts 504} 505 506### 507# Read a stylized key/value list stored in a file 508### 509proc ::practcl::read_rc_file {filename {localdat {}}} { 510 set result $localdat 511 set fin [open $filename r] 512 set bufline {} 513 set rawcount 0 514 set linecount 0 515 while {[gets $fin thisline]>=0} { 516 incr rawcount 517 append bufline \n $thisline 518 if {![info complete $bufline]} continue 519 set line [string trimleft $bufline] 520 set bufline {} 521 if {[string index [string trimleft $line] 0] eq "#"} continue 522 append result \n $line 523 #incr linecount 524 #set key [lindex $line 0] 525 #set value [lindex $line 1] 526 #dict set result $key $value 527 } 528 close $fin 529 return $result 530} 531 532### 533# topic: e71f3f61c348d56292011eec83e95f0aacc1c618 534# description: Converts a XXX.sh file into a series of Tcl variables 535### 536proc ::practcl::read_sh_subst {line info} { 537 regsub -all {\x28} $line \x7B line 538 regsub -all {\x29} $line \x7D line 539 540 #set line [string map $key [string trim $line]] 541 foreach {field value} $info { 542 catch {set $field $value} 543 } 544 if [catch {subst $line} result] { 545 return {} 546 } 547 set result [string trim $result] 548 return [string trim $result '] 549} 550 551### 552# topic: 03567140cca33c814664c7439570f669b9ab88e6 553### 554proc ::practcl::read_sh_file {filename {localdat {}}} { 555 set fin [open $filename r] 556 set result {} 557 if {$localdat eq {}} { 558 set top 1 559 set local [array get ::env] 560 dict set local EXE {} 561 } else { 562 set top 0 563 set local $localdat 564 } 565 while {[gets $fin line] >= 0} { 566 set line [string trim $line] 567 if {[string index $line 0] eq "#"} continue 568 if {$line eq {}} continue 569 catch { 570 if {[string range $line 0 6] eq "export "} { 571 set eq [string first "=" $line] 572 set field [string trim [string range $line 6 [expr {$eq - 1}]]] 573 set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] 574 dict set result $field [read_sh_subst $value $local] 575 dict set local $field $value 576 } elseif {[string range $line 0 7] eq "include "} { 577 set subfile [read_sh_subst [string range $line 7 end] $local] 578 foreach {field value} [read_sh_file $subfile $local] { 579 dict set result $field $value 580 } 581 } else { 582 set eq [string first "=" $line] 583 if {$eq > 0} { 584 set field [read_sh_subst [string range $line 0 [expr {$eq - 1}]] $local] 585 set value [string trim [string range $line [expr {$eq+1}] end] '] 586 #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] 587 dict set local $field $value 588 dict set result $field $value 589 } 590 } 591 } err opts 592 if {[dict get $opts -code] != 0} { 593 #puts $opts 594 puts "Error reading line:\n$line\nerr: $err\n***" 595 return $err {*}$opts 596 } 597 } 598 return $result 599} 600 601### 602# A simpler form of read_sh_file tailored 603# to pulling data from (tcl|tk)Config.sh 604### 605proc ::practcl::read_Config.sh filename { 606 set fin [open $filename r] 607 set result {} 608 set linecount 0 609 while {[gets $fin line] >= 0} { 610 set line [string trim $line] 611 if {[string index $line 0] eq "#"} continue 612 if {$line eq {}} continue 613 catch { 614 set eq [string first "=" $line] 615 if {$eq > 0} { 616 set field [string range $line 0 [expr {$eq - 1}]] 617 set value [string trim [string range $line [expr {$eq+1}] end] '] 618 #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] 619 dict set result $field $value 620 incr $linecount 621 } 622 } err opts 623 if {[dict get $opts -code] != 0} { 624 #puts $opts 625 puts "Error reading line:\n$line\nerr: $err\n***" 626 return $err {*}$opts 627 } 628 } 629 return $result 630} 631 632### 633# A simpler form of read_sh_file tailored 634# to pulling data from a Makefile 635### 636proc ::practcl::read_Makefile filename { 637 set fin [open $filename r] 638 set result {} 639 while {[gets $fin line] >= 0} { 640 set line [string trim $line] 641 if {[string index $line 0] eq "#"} continue 642 if {$line eq {}} continue 643 catch { 644 set eq [string first "=" $line] 645 if {$eq > 0} { 646 set field [string trim [string range $line 0 [expr {$eq - 1}]]] 647 set value [string trim [string trim [string range $line [expr {$eq+1}] end] ']] 648 switch $field { 649 PKG_LIB_FILE { 650 dict set result libfile $value 651 } 652 srcdir { 653 if {$value eq "."} { 654 dict set result srcdir [file dirname $filename] 655 } else { 656 dict set result srcdir $value 657 } 658 } 659 PACKAGE_NAME { 660 dict set result name $value 661 } 662 PACKAGE_VERSION { 663 dict set result version $value 664 } 665 LIBS { 666 dict set result PRACTCL_LIBS $value 667 } 668 PKG_LIB_FILE { 669 dict set result libfile $value 670 } 671 } 672 } 673 } err opts 674 if {[dict get $opts -code] != 0} { 675 #puts $opts 676 puts "Error reading line:\n$line\nerr: $err\n***" 677 return $err {*}$opts 678 } 679 # the Compile field is about where most TEA files start getting silly 680 if {$field eq "compile"} { 681 break 682 } 683 } 684 return $result 685} 686 687## Append arguments to a buffer 688# The command works like puts in that each call will also insert 689# a line feed. Unlike puts, blank links in the interstitial are 690# suppressed 691proc ::practcl::cputs {varname args} { 692 upvar 1 $varname buffer 693 if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} { 694 695 } 696 if {[info exist buffer]} { 697 if {[string index $buffer end] ne "\n"} { 698 append buffer \n 699 } 700 } else { 701 set buffer \n 702 } 703 # Trim leading \n's 704 append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end] 705} 706 707proc ::practcl::tcl_to_c {body} { 708 set result {} 709 foreach rawline [split $body \n] { 710 set line [string map [list \" \\\" \\ \\\\] $rawline] 711 cputs result "\n \"$line\\n\" \\" 712 } 713 return [string trimright $result \\] 714} 715 716 717proc ::practcl::_tagblock {text {style tcl} {note {}}} { 718 if {[string length [string trim $text]]==0} { 719 return {} 720 } 721 set output {} 722 switch $style { 723 tcl { 724 ::practcl::cputs output "# BEGIN $note" 725 } 726 c { 727 ::practcl::cputs output "/* BEGIN $note */" 728 } 729 default { 730 ::practcl::cputs output "# BEGIN $note" 731 } 732 } 733 ::practcl::cputs output $text 734 switch $style { 735 tcl { 736 ::practcl::cputs output "# END $note" 737 } 738 c { 739 ::practcl::cputs output "/* END $note */" 740 } 741 default { 742 ::practcl::cputs output "# END $note" 743 } 744 } 745 return $output 746} 747 748proc ::practcl::de_shell {data} { 749 set values {} 750 foreach flag {DEFS TCL_DEFS TK_DEFS} { 751 if {[dict exists $data $flag]} { 752 #set value {} 753 #foreach item [dict get $data $flag] { 754 # append value " " [string map {{ } {\ }} $item] 755 #} 756 dict set values $flag [dict get $data $flag] 757 } 758 } 759 set map {} 760 lappend map {${PKG_OBJECTS}} %LIBRARY_OBJECTS% 761 lappend map {$(PKG_OBJECTS)} %LIBRARY_OBJECTS% 762 lappend map {${PKG_STUB_OBJECTS}} %LIBRARY_STUB_OBJECTS% 763 lappend map {$(PKG_STUB_OBJECTS)} %LIBRARY_STUB_OBJECTS% 764 765 if {[dict exists $data name]} { 766 lappend map %LIBRARY_NAME% [dict get $data name] 767 lappend map %LIBRARY_VERSION% [dict get $data version] 768 lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} [dict get $data version]] 769 if {[dict exists $data libprefix]} { 770 lappend map %LIBRARY_PREFIX% [dict get $data libprefix] 771 } else { 772 lappend map %LIBRARY_PREFIX% [dict get $data prefix] 773 } 774 } 775 foreach flag [dict keys $data] { 776 if {$flag in {TCL_DEFS TK_DEFS DEFS}} continue 777 set value [string trim [dict get $data $flag] \"] 778 dict set map "\$\{${flag}\}" $value 779 dict set map "\$\(${flag}\)" $value 780 #dict set map "\$${flag}" $value 781 dict set map "%${flag}%" $value 782 dict set values $flag [dict get $data $flag] 783 #dict set map "\$\{${flag}\}" $proj($flag) 784 } 785 set changed 1 786 while {$changed} { 787 set changed 0 788 foreach {field value} $values { 789 if {$field in {TCL_DEFS TK_DEFS DEFS}} continue 790 dict with values {} 791 set newval [string map $map $value] 792 if {$newval eq $value} continue 793 set changed 1 794 dict set values $field $newval 795 } 796 } 797 return $values 798} 799 800### 801# END: buildutil.tcl 802### 803### 804# START: fileutil.tcl 805### 806### 807# Bits stolen from fileutil 808### 809proc ::practcl::cat fname { 810 if {![file exists $fname]} { 811 return 812 } 813 set fin [open $fname r] 814 set data [read $fin] 815 close $fin 816 return $data 817} 818 819proc ::practcl::grep {pattern {files {}}} { 820 set result [list] 821 if {[llength $files] == 0} { 822 # read from stdin 823 set lnum 0 824 while {[gets stdin line] >= 0} { 825 incr lnum 826 if {[regexp -- $pattern $line]} { 827 lappend result "${lnum}:${line}" 828 } 829 } 830 } else { 831 foreach filename $files { 832 set file [open $filename r] 833 set lnum 0 834 while {[gets $file line] >= 0} { 835 incr lnum 836 if {[regexp -- $pattern $line]} { 837 lappend result "${filename}:${lnum}:${line}" 838 } 839 } 840 close $file 841 } 842 } 843 return $result 844} 845 846proc ::practcl::file_lexnormalize {sp} { 847 set spx [file split $sp] 848 849 # Resolution of embedded relative modifiers (., and ..). 850 851 if { 852 ([lsearch -exact $spx . ] < 0) && 853 ([lsearch -exact $spx ..] < 0) 854 } { 855 # Quick path out if there are no relative modifiers 856 return $sp 857 } 858 859 set absolute [expr {![string equal [file pathtype $sp] relative]}] 860 # A volumerelative path counts as absolute for our purposes. 861 862 set sp $spx 863 set np {} 864 set noskip 1 865 866 while {[llength $sp]} { 867 set ele [lindex $sp 0] 868 set sp [lrange $sp 1 end] 869 set islast [expr {[llength $sp] == 0}] 870 871 if {[string equal $ele ".."]} { 872 if { 873 ($absolute && ([llength $np] > 1)) || 874 (!$absolute && ([llength $np] >= 1)) 875 } { 876 # .. : Remove the previous element added to the 877 # new path, if there actually is enough to remove. 878 set np [lrange $np 0 end-1] 879 } 880 } elseif {[string equal $ele "."]} { 881 # Ignore .'s, they stay at the current location 882 continue 883 } else { 884 # A regular element. 885 lappend np $ele 886 } 887 } 888 if {[llength $np] > 0} { 889 return [eval [linsert $np 0 file join]] 890 # 8.5: return [file join {*}$np] 891 } 892 return {} 893} 894 895proc ::practcl::file_relative {base dst} { 896 # Ensure that the link to directory 'dst' is properly done relative to 897 # the directory 'base'. 898 899 if {![string equal [file pathtype $base] [file pathtype $dst]]} { 900 return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" 901 } 902 903 set base [file_lexnormalize [file join [pwd] $base]] 904 set dst [file_lexnormalize [file join [pwd] $dst]] 905 906 set save $dst 907 set base [file split $base] 908 set dst [file split $dst] 909 910 while {[string equal [lindex $dst 0] [lindex $base 0]]} { 911 set dst [lrange $dst 1 end] 912 set base [lrange $base 1 end] 913 if {![llength $dst]} {break} 914 } 915 916 set dstlen [llength $dst] 917 set baselen [llength $base] 918 919 if {($dstlen == 0) && ($baselen == 0)} { 920 # Cases: 921 # (a) base == dst 922 923 set dst . 924 } else { 925 # Cases: 926 # (b) base is: base/sub = sub 927 # dst is: base = {} 928 929 # (c) base is: base = {} 930 # dst is: base/sub = sub 931 932 while {$baselen > 0} { 933 set dst [linsert $dst 0 ..] 934 incr baselen -1 935 } 936 # 8.5: set dst [file join {*}$dst] 937 set dst [eval [linsert $dst 0 file join]] 938 } 939 940 return $dst 941} 942 943proc ::practcl::log {fname comment} { 944 set fname [file normalize $fname] 945 if {[info exists ::practcl::logchan($fname)]} { 946 set fout $::practcl::logchan($fname) 947 after cancel $::practcl::logevent($fname) 948 } else { 949 set fout [open $fname a] 950 } 951 puts $fout $comment 952 # Defer close until idle 953 set ::practcl::logevent($fname) [after idle "close $fout ; unset ::practcl::logchan($fname)"] 954} 955 956### 957# END: fileutil.tcl 958### 959### 960# START: installutil.tcl 961### 962### 963# Installer tools 964### 965proc ::practcl::_isdirectory name { 966 return [file isdirectory $name] 967} 968### 969# Return true if the pkgindex file contains 970# any statement other than "package ifneeded" 971# and/or if any package ifneeded loads a DLL 972### 973proc ::practcl::_pkgindex_directory {path} { 974 set buffer {} 975 set pkgidxfile [file join $path pkgIndex.tcl] 976 if {![file exists $pkgidxfile]} { 977 # No pkgIndex file, read the source 978 foreach file [glob -nocomplain $path/*.tm] { 979 set file [file normalize $file] 980 set fname [file rootname [file tail $file]] 981 ### 982 # We used to be able to ... Assume the package is correct in the filename 983 # No hunt for a "package provides" 984 ### 985 set package [lindex [split $fname -] 0] 986 set version [lindex [split $fname -] 1] 987 ### 988 # Read the file, and override assumptions as needed 989 ### 990 set fin [open $file r] 991 set dat [read $fin] 992 close $fin 993 # Look for a teapot style Package statement 994 foreach line [split $dat \n] { 995 set line [string trim $line] 996 if { [string range $line 0 9] != "# Package " } continue 997 set package [lindex $line 2] 998 set version [lindex $line 3] 999 break 1000 } 1001 # Look for a package provide statement 1002 foreach line [split $dat \n] { 1003 set line [string trim $line] 1004 if { [string range $line 0 14] != "package provide" } continue 1005 set package [lindex $line 2] 1006 set version [lindex $line 3] 1007 break 1008 } 1009 if {[string trim $version] ne {}} { 1010 append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n 1011 } 1012 } 1013 foreach file [glob -nocomplain $path/*.tcl] { 1014 if { [file tail $file] == "version_info.tcl" } continue 1015 set fin [open $file r] 1016 set dat [read $fin] 1017 close $fin 1018 if {![regexp "package provide" $dat]} continue 1019 set fname [file rootname [file tail $file]] 1020 # Look for a package provide statement 1021 foreach line [split $dat \n] { 1022 set line [string trim $line] 1023 if { [string range $line 0 14] != "package provide" } continue 1024 set package [lindex $line 2] 1025 set version [lindex $line 3] 1026 if {[string index $package 0] in "\$ \[ @"} continue 1027 if {[string index $version 0] in "\$ \[ @"} continue 1028 append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n 1029 break 1030 } 1031 } 1032 return $buffer 1033 } 1034 set fin [open $pkgidxfile r] 1035 set dat [read $fin] 1036 close $fin 1037 set trace 0 1038 #if {[file tail $path] eq "tool"} { 1039 # set trace 1 1040 #} 1041 set thisline {} 1042 foreach line [split $dat \n] { 1043 append thisline $line \n 1044 if {![info complete $thisline]} continue 1045 set line [string trim $line] 1046 if {[string length $line]==0} { 1047 set thisline {} ; continue 1048 } 1049 if {[string index $line 0] eq "#"} { 1050 set thisline {} ; continue 1051 } 1052 if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} { 1053 if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"} 1054 set thisline {} ; continue 1055 } 1056 if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} { 1057 if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" } 1058 set thisline {} ; continue 1059 } 1060 if {![regexp "package.*ifneeded" $thisline]} { 1061 # This package index contains arbitrary code 1062 # source instead of trying to add it to the master 1063 # package index 1064 if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" } 1065 return {source [file join $dir pkgIndex.tcl]} 1066 } 1067 append buffer $thisline \n 1068 set thisline {} 1069 } 1070 if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} 1071 return $buffer 1072} 1073 1074 1075proc ::practcl::_pkgindex_path_subdir {path} { 1076 set result {} 1077 foreach subpath [glob -nocomplain [file join $path *]] { 1078 if {[file isdirectory $subpath]} { 1079 lappend result $subpath {*}[_pkgindex_path_subdir $subpath] 1080 } 1081 } 1082 return $result 1083} 1084### 1085# Index all paths given as though they will end up in the same 1086# virtual file system 1087### 1088proc ::practcl::pkgindex_path {args} { 1089 set stack {} 1090 set buffer { 1091lappend ::PATHSTACK $dir 1092 } 1093 foreach base $args { 1094 set base [file normalize $base] 1095 set paths {} 1096 foreach dir [glob -nocomplain [file join $base *]] { 1097 if {[file tail $dir] eq "teapot"} continue 1098 lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir] 1099 } 1100 set i [string length $base] 1101 # Build a list of all of the paths 1102 if {[llength $paths]} { 1103 foreach path $paths { 1104 if {$path eq $base} continue 1105 set path_indexed($path) 0 1106 } 1107 } else { 1108 puts [list WARNING: NO PATHS FOUND IN $base] 1109 } 1110 set path_indexed($base) 1 1111 set path_indexed([file join $base boot tcl]) 1 1112 foreach path $paths { 1113 if {$path_indexed($path)} continue 1114 set thisdir [file_relative $base $path] 1115 set idxbuf [::practcl::_pkgindex_directory $path] 1116 if {[string length $idxbuf]} { 1117 incr path_indexed($path) 1118 append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n 1119 append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n 1120 } 1121 } 1122 } 1123 append buffer { 1124set dir [lindex $::PATHSTACK end] 1125set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] 1126} 1127 return $buffer 1128} 1129 1130proc ::practcl::installDir {d1 d2} { 1131 puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] 1132 file delete -force -- $d2 1133 file mkdir $d2 1134 1135 foreach ftail [glob -directory $d1 -nocomplain -tails *] { 1136 set f [file join $d1 $ftail] 1137 if {[file isdirectory $f] && [string compare CVS $ftail]} { 1138 installDir $f [file join $d2 $ftail] 1139 } elseif {[file isfile $f]} { 1140 file copy -force $f [file join $d2 $ftail] 1141 if {$::tcl_platform(platform) eq {unix}} { 1142 file attributes [file join $d2 $ftail] -permissions 0644 1143 } else { 1144 file attributes [file join $d2 $ftail] -readonly 1 1145 } 1146 } 1147 } 1148 1149 if {$::tcl_platform(platform) eq {unix}} { 1150 file attributes $d2 -permissions 0755 1151 } else { 1152 file attributes $d2 -readonly 1 1153 } 1154} 1155 1156proc ::practcl::copyDir {d1 d2 {toplevel 1}} { 1157 #if {$toplevel} { 1158 # puts [list ::practcl::copyDir $d1 -> $d2] 1159 #} 1160 #file delete -force -- $d2 1161 file mkdir $d2 1162 if {[file isfile $d1]} { 1163 file copy -force $d1 $d2 1164 set ftail [file tail $d1] 1165 if {$::tcl_platform(platform) eq {unix}} { 1166 file attributes [file join $d2 $ftail] -permissions 0644 1167 } else { 1168 file attributes [file join $d2 $ftail] -readonly 1 1169 } 1170 } else { 1171 foreach ftail [glob -directory $d1 -nocomplain -tails *] { 1172 set f [file join $d1 $ftail] 1173 if {[file isdirectory $f] && [string compare CVS $ftail]} { 1174 copyDir $f [file join $d2 $ftail] 0 1175 } elseif {[file isfile $f]} { 1176 file copy -force $f [file join $d2 $ftail] 1177 if {$::tcl_platform(platform) eq {unix}} { 1178 file attributes [file join $d2 $ftail] -permissions 0644 1179 } else { 1180 file attributes [file join $d2 $ftail] -readonly 1 1181 } 1182 } 1183 } 1184 } 1185} 1186 1187### 1188# END: installutil.tcl 1189### 1190### 1191# START: makeutil.tcl 1192### 1193### 1194# Backward compatible Make facilities 1195# These were used early in development and are consdiered deprecated 1196### 1197 1198proc ::practcl::trigger {args} { 1199 ::practcl::LOCAL make trigger {*}$args 1200 foreach {name obj} [::practcl::LOCAL make objects] { 1201 set ::make($name) [$obj do] 1202 } 1203} 1204 1205proc ::practcl::depends {args} { 1206 ::practcl::LOCAL make depends {*}$args 1207} 1208 1209proc ::practcl::target {name info {action {}}} { 1210 set obj [::practcl::LOCAL make task $name $info $action] 1211 set ::make($name) 0 1212 set filename [$obj define get filename] 1213 if {$filename ne {}} { 1214 set ::target($name) $filename 1215 } 1216} 1217### 1218# END: makeutil.tcl 1219### 1220### 1221# START: class metaclass.tcl 1222### 1223::oo::class create ::practcl::metaclass { 1224 superclass ::oo::object 1225 1226 method _MorphPatterns {} { 1227 return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}} 1228 } 1229 1230 method define {submethod args} { 1231 my variable define 1232 switch $submethod { 1233 dump { 1234 return [array get define] 1235 } 1236 add { 1237 set field [lindex $args 0] 1238 if {![info exists define($field)]} { 1239 set define($field) {} 1240 } 1241 foreach arg [lrange $args 1 end] { 1242 if {$arg ni $define($field)} { 1243 lappend define($field) $arg 1244 } 1245 } 1246 return $define($field) 1247 } 1248 remove { 1249 set field [lindex $args 0] 1250 if {![info exists define($field)]} { 1251 return 1252 } 1253 set rlist [lrange $args 1 end] 1254 set olist $define($field) 1255 set nlist {} 1256 foreach arg $olist { 1257 if {$arg in $rlist} continue 1258 lappend nlist $arg 1259 } 1260 set define($field) $nlist 1261 return $nlist 1262 } 1263 exists { 1264 set field [lindex $args 0] 1265 return [info exists define($field)] 1266 } 1267 getnull - 1268 get - 1269 cget { 1270 set field [lindex $args 0] 1271 if {[info exists define($field)]} { 1272 return $define($field) 1273 } 1274 return [lindex $args 1] 1275 } 1276 set { 1277 if {[llength $args]==1} { 1278 set arglist [lindex $args 0] 1279 } else { 1280 set arglist $args 1281 } 1282 array set define $arglist 1283 if {[dict exists $arglist class]} { 1284 my select 1285 } 1286 } 1287 default { 1288 array $submethod define {*}$args 1289 } 1290 } 1291 } 1292 1293 1294 method meta {submethod args} { 1295 my variable meta 1296 if {![info exists meta]} { 1297 set meta {} 1298 } 1299 switch $submethod { 1300 dump { 1301 return $meta 1302 } 1303 add { 1304 set field [lindex $args 0] 1305 if {![dict exists $meta $field]} { 1306 dict set meta $field {} 1307 } 1308 foreach arg [lrange $args 1 end] { 1309 if {$arg ni [dict get $meta $field]} { 1310 dict lappend meta $field $arg 1311 } 1312 } 1313 return [dict get $meta $field] 1314 } 1315 remove { 1316 set field [lindex $args 0] 1317 if {![dict exists meta $field]} { 1318 return 1319 } 1320 set rlist [lrange $args 1 end] 1321 set olist [dict get $meta $field] 1322 set nlist {} 1323 foreach arg $olist { 1324 if {$arg in $rlist} continue 1325 lappend nlist $arg 1326 } 1327 dict set meta $field $nlist 1328 return $nlist 1329 } 1330 exists { 1331 return [dict exists $meta {*}$args] 1332 } 1333 getnull - 1334 get { 1335 if {[dict exists $meta {*}$args]} { 1336 return [dict get $meta {*}$args] 1337 } 1338 return {} 1339 } 1340 cget { 1341 set field [lindex $args 0] 1342 if {[dict exists $meta $field]} { 1343 return [dict get $meta $field] 1344 } 1345 return [lindex $args 1] 1346 } 1347 set { 1348 if {[llength $args]==1} { 1349 foreach {field value} $args { 1350 dict set meta [string trimright $field :]: $value 1351 } 1352 } else { 1353 set field [lindex $args end-1] 1354 set value [lindex $args end] 1355 dict set meta {*}[lrange $args 0 end-2] [string trimright $field :]: $value 1356 } 1357 } 1358 default { 1359 error "Valid: add cget dump exists get getnull remove set" 1360 } 1361 } 1362 } 1363 1364 method graft args { 1365 my variable organs 1366 if {[llength $args] == 1} { 1367 error "Need two arguments" 1368 } 1369 set object {} 1370 foreach {stub object} $args { 1371 dict set organs $stub $object 1372 oo::objdefine [self] forward <${stub}> $object 1373 oo::objdefine [self] export <${stub}> 1374 } 1375 return $object 1376 } 1377 1378 method initialize {} {} 1379 1380 1381 method link {command args} { 1382 my variable links 1383 switch $command { 1384 object { 1385 foreach obj $args { 1386 foreach linktype [$obj linktype] { 1387 my link add $linktype $obj 1388 } 1389 } 1390 } 1391 add { 1392 ### 1393 # Add a link to an object that was externally created 1394 ### 1395 if {[llength $args] ne 2} { error "Usage: link add LINKTYPE OBJECT"} 1396 lassign $args linktype object 1397 if {[info exists links($linktype)] && $object in $links($linktype)} { 1398 return 1399 } 1400 lappend links($linktype) $object 1401 } 1402 remove { 1403 set object [lindex $args 0] 1404 if {[llength $args]==1} { 1405 set ltype * 1406 } else { 1407 set ltype [lindex $args 1] 1408 } 1409 foreach {linktype elements} [array get links $ltype] { 1410 if {$object in $elements} { 1411 set nlist {} 1412 foreach e $elements { 1413 if { $object ne $e } { lappend nlist $e } 1414 } 1415 set links($linktype) $nlist 1416 } 1417 } 1418 } 1419 list { 1420 if {[llength $args]==0} { 1421 return [array get links] 1422 } 1423 if {[llength $args] != 1} { error "Usage: link list LINKTYPE"} 1424 set linktype [lindex $args 0] 1425 if {![info exists links($linktype)]} { 1426 return {} 1427 } 1428 return $links($linktype) 1429 } 1430 dump { 1431 return [array get links] 1432 } 1433 } 1434 } 1435 1436 method morph classname { 1437 my variable define 1438 if {$classname ne {}} { 1439 set map [list @name@ $classname] 1440 foreach pattern [string map $map [my _MorphPatterns]] { 1441 set pattern [string trim $pattern] 1442 set matches [info commands $pattern] 1443 if {![llength $matches]} continue 1444 set class [lindex $matches 0] 1445 break 1446 } 1447 set mixinslot {} 1448 foreach {slot pattern} { 1449 distribution ::practcl::distribution* 1450 product ::practcl::product* 1451 toolset ::practcl::toolset* 1452 } { 1453 if {[string match $pattern $class]} { 1454 set mixinslot $slot 1455 break 1456 } 1457 } 1458 if {$mixinslot ne {}} { 1459 my mixin $mixinslot $class 1460 } elseif {[info command $class] ne {}} { 1461 if {[info object class [self]] ne $class} { 1462 ::oo::objdefine [self] class $class 1463 ::practcl::debug [self] morph $class 1464 my define set class $class 1465 } 1466 } else { 1467 error "[self] Could not detect class for $classname" 1468 } 1469 } 1470 if {[::info exists define(oodefine)]} { 1471 ::oo::objdefine [self] $define(oodefine) 1472 #unset define(oodefine) 1473 } 1474 } 1475 1476 method mixin {slot classname} { 1477 my variable mixinslot 1478 set class {} 1479 set map [list @slot@ $slot @name@ $classname] 1480 foreach pattern [split [string map $map { 1481 @name@ 1482 @slot@.@name@ 1483 ::practcl::@name@ 1484 ::practcl::@slot@.@name@ 1485 ::practcl::@slot@*@name@ 1486 ::practcl::*@name@* 1487 }] \n] { 1488 set pattern [string trim $pattern] 1489 set matches [info commands $pattern] 1490 if {![llength $matches]} continue 1491 set class [lindex $matches 0] 1492 break 1493 } 1494 ::practcl::debug [self] mixin $slot $class 1495 dict set mixinslot $slot $class 1496 set mixins {} 1497 foreach {s c} $mixinslot { 1498 if {$c eq {}} continue 1499 lappend mixins $c 1500 } 1501 oo::objdefine [self] mixin {*}$mixins 1502 } 1503 1504 method organ {{stub all}} { 1505 my variable organs 1506 if {![info exists organs]} { 1507 return {} 1508 } 1509 if { $stub eq "all" } { 1510 return $organs 1511 } 1512 if {[dict exists $organs $stub]} { 1513 return [dict get $organs $stub] 1514 } 1515 } 1516 1517 method script script { 1518 eval $script 1519 } 1520 1521 method select {} { 1522 my variable define 1523 if {[info exists define(class)]} { 1524 my morph $define(class) 1525 } else { 1526 if {[::info exists define(oodefine)]} { 1527 ::oo::objdefine [self] $define(oodefine) 1528 #unset define(oodefine) 1529 } 1530 } 1531 } 1532 1533 method source filename { 1534 source $filename 1535 } 1536} 1537 1538### 1539# END: class metaclass.tcl 1540### 1541### 1542# START: class toolset baseclass.tcl 1543### 1544### 1545# Ancestor-less class intended to be a mixin 1546# which defines a family of build related behaviors 1547# that are modified when targetting either gcc or msvc 1548### 1549oo::class create ::practcl::toolset { 1550 ### 1551 # find or fake a key/value list describing this project 1552 ### 1553 method config.sh {} { 1554 return [my read_configuration] 1555 } 1556 1557 method BuildDir {PWD} { 1558 set name [my define get name] 1559 set debug [my define get debug 0] 1560 if {[my <project> define get LOCAL 0]} { 1561 return [my define get builddir [file join $PWD local $name]] 1562 } 1563 if {$debug} { 1564 return [my define get builddir [file join $PWD debug $name]] 1565 } else { 1566 return [my define get builddir [file join $PWD pkg $name]] 1567 } 1568 } 1569 1570 method MakeDir {srcdir} { 1571 return $srcdir 1572 } 1573 1574 method read_configuration {} { 1575 my variable conf_result 1576 if {[info exists conf_result]} { 1577 return $conf_result 1578 } 1579 set result {} 1580 set name [my define get name] 1581 set PWD $::CWD 1582 set builddir [my define get builddir] 1583 my unpack 1584 set srcdir [my define get srcdir] 1585 if {![file exists $builddir]} { 1586 my Configure 1587 } 1588 set filename [file join $builddir config.tcl] 1589 # Project uses the practcl template. Use the leavings from autoconf 1590 if {[file exists $filename]} { 1591 set dat [::practcl::read_configuration $builddir] 1592 foreach {item value} [::practcl::sort_dict $dat] { 1593 dict set result $item $value 1594 } 1595 set conf_result $result 1596 return $result 1597 } 1598 set filename [file join $builddir ${name}Config.sh] 1599 if {[file exists $filename]} { 1600 set l [expr {[string length $name]+1}] 1601 foreach {field dat} [::practcl::read_Config.sh $filename] { 1602 set field [string tolower $field] 1603 if {[string match ${name}_* $field]} { 1604 set field [string range $field $l end] 1605 } 1606 switch $field { 1607 version { 1608 dict set result pkg_vers $dat 1609 } 1610 lib_file { 1611 set field libfile 1612 } 1613 } 1614 dict set result $field $dat 1615 } 1616 set conf_result $result 1617 return $result 1618 } 1619 ### 1620 # Oh man... we have to guess 1621 ### 1622 set filename [file join $builddir Makefile] 1623 if {![file exists $filename]} { 1624 error "Could not locate any configuration data in $srcdir" 1625 } 1626 foreach {field dat} [::practcl::read_Makefile $filename] { 1627 dict set result $field $dat 1628 } 1629 if {![dict exists $result PRACTCL_PKG_LIBS] && [dict exists $result LIBS]} { 1630 dict set result PRACTCL_PKG_LIBS [dict get $result LIBS] 1631 } 1632 set conf_result $result 1633 cd $PWD 1634 return $result 1635 } 1636 1637 ## method DEFS 1638 # This method populates 4 variables: 1639 # name - The name of the package 1640 # version - The version of the package 1641 # defs - C flags passed to the compiler 1642 # includedir - A list of paths to feed to the compiler for finding headers 1643 # 1644 method build-cflags {PROJECT DEFS namevar versionvar defsvar} { 1645 upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs 1646 set name [string tolower [${PROJECT} define get name [${PROJECT} define get pkg_name]]] 1647 set NAME [string toupper $name] 1648 set version [${PROJECT} define get version [${PROJECT} define get pkg_vers]] 1649 if {$version eq {}} { 1650 set version 0.1a 1651 } 1652 set defs $DEFS 1653 foreach flag { 1654 -DPACKAGE_NAME 1655 -DPACKAGE_VERSION 1656 -DPACKAGE_TARNAME 1657 -DPACKAGE_STRING 1658 } { 1659 if {[set i [string first $flag $defs]] >= 0} { 1660 set j [string first -D $flag [expr {$i+[string length $flag]}]] 1661 set predef [string range $defs 0 [expr {$i-1}]] 1662 set postdef [string range $defs $j end] 1663 set defs "$predef $postdef" 1664 } 1665 } 1666 append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" 1667 append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" 1668 return $defs 1669 } 1670 1671 method critcl args { 1672 if {![info exists critcl]} { 1673 ::practcl::LOCAL tool critcl env-load 1674 set critcl [file join [::practcl::LOCAL tool critcl define get srcdir] main.tcl 1675 } 1676 set srcdir [my SourceRoot] 1677 set PWD [pwd] 1678 cd $srcdir 1679 ::practcl::dotclexec $critcl {*}$args 1680 cd $PWD 1681 } 1682 1683 method make-autodetect {} {} 1684} 1685 1686 1687oo::objdefine ::practcl::toolset { 1688 1689 1690 method select object { 1691 ### 1692 # Select the toolset to use for this project 1693 ### 1694 if {[$object define exists toolset]} { 1695 return [$object define get toolset] 1696 } 1697 set class [$object define get toolset] 1698 if {$class ne {}} { 1699 $object mixin toolset $class 1700 } else { 1701 if {[info exists ::env(VisualStudioVersion)]} { 1702 $object mixin toolset ::practcl::toolset.msvc 1703 } else { 1704 $object mixin toolset ::practcl::toolset.gcc 1705 } 1706 } 1707 } 1708} 1709 1710### 1711# END: class toolset baseclass.tcl 1712### 1713### 1714# START: class toolset gcc.tcl 1715### 1716 1717::oo::class create ::practcl::toolset.gcc { 1718 superclass ::practcl::toolset 1719 1720 method Autoconf {} { 1721 ### 1722 # Re-run autoconf for this project 1723 # Not a good idea in practice... but in the right hands it can be useful 1724 ### 1725 set pwd [pwd] 1726 set srcdir [file normalize [my define get srcdir]] 1727 cd $srcdir 1728 foreach template {configure.ac configure.in} { 1729 set input [file join $srcdir $template] 1730 if {[file exists $input]} { 1731 puts "autoconf -f $input > [file join $srcdir configure]" 1732 exec autoconf -f $input > [file join $srcdir configure] 1733 } 1734 } 1735 cd $pwd 1736 } 1737 1738 method BuildDir {PWD} { 1739 set name [my define get name] 1740 set debug [my define get debug 0] 1741 if {[my <project> define get LOCAL 0]} { 1742 return [my define get builddir [file join $PWD local $name]] 1743 } 1744 if {$debug} { 1745 return [my define get builddir [file join $PWD debug $name]] 1746 } else { 1747 return [my define get builddir [file join $PWD pkg $name]] 1748 } 1749 } 1750 1751 method ConfigureOpts {} { 1752 set opts {} 1753 set builddir [my define get builddir] 1754 1755 if {[my define get broken_destroot 0]} { 1756 set PREFIX [my <project> define get prefix_broken_destdir] 1757 } else { 1758 set PREFIX [my <project> define get prefix] 1759 } 1760 switch [my define get name] { 1761 tcl { 1762 set opts [::practcl::platform::tcl_core_options [my <project> define get TEACUP_OS]] 1763 } 1764 tk { 1765 set opts [::practcl::platform::tk_core_options [my <project> define get TEACUP_OS]] 1766 } 1767 } 1768 if {[my <project> define get CONFIG_SITE] != {}} { 1769 lappend opts --host=[my <project> define get HOST] 1770 } 1771 set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]] 1772 lappend opts --with-tclsh=[info nameofexecutable] 1773 if {![my <project> define get LOCAL 0]} { 1774 set obj [my <project> tclcore] 1775 if {$obj ne {}} { 1776 if {$inside_msys} { 1777 lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] 1778 } else { 1779 lappend opts --with-tcl=[file normalize [$obj define get builddir]] 1780 } 1781 } 1782 if {[my define get tk 0]} { 1783 set obj [my <project> tkcore] 1784 if {$obj ne {}} { 1785 if {$inside_msys} { 1786 lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] 1787 } else { 1788 lappend opts --with-tk=[file normalize [$obj define get builddir]] 1789 } 1790 } 1791 } 1792 } else { 1793 lappend opts --with-tcl=[file join $PREFIX lib] 1794 if {[my define get tk 0]} { 1795 lappend opts --with-tk=[file join $PREFIX lib] 1796 } 1797 } 1798 1799 lappend opts {*}[my define get config_opts] 1800 if {![regexp -- "--prefix" $opts]} { 1801 lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX 1802 } 1803 if {[my define get debug 0]} { 1804 lappend opts --enable-symbols=true 1805 } 1806 #--exec_prefix=$PREFIX 1807 #if {$::tcl_platform(platform) eq "windows"} { 1808 # lappend opts --disable-64bit 1809 #} 1810 if {[my define get static 1]} { 1811 lappend opts --disable-shared 1812 #--disable-stubs 1813 # 1814 } else { 1815 lappend opts --enable-shared 1816 } 1817 return $opts 1818 } 1819 1820 # Detect what directory contains the Makefile template 1821 method MakeDir {srcdir} { 1822 set localsrcdir $srcdir 1823 if {[file exists [file join $srcdir generic]]} { 1824 my define add include_dir [file join $srcdir generic] 1825 } 1826 set os [my <project> define get TEACUP_OS] 1827 switch $os { 1828 windows { 1829 if {[file exists [file join $srcdir win]]} { 1830 my define add include_dir [file join $srcdir win] 1831 } 1832 if {[file exists [file join $srcdir win Makefile.in]]} { 1833 set localsrcdir [file join $srcdir win] 1834 } 1835 } 1836 default { 1837 if {[file exists [file join $srcdir $os]]} { 1838 my define add include_dir [file join $srcdir $os] 1839 } 1840 if {[file exists [file join $srcdir unix]]} { 1841 my define add include_dir [file join $srcdir unix] 1842 } 1843 if {[file exists [file join $srcdir $os Makefile.in]]} { 1844 set localsrcdir [file join $srcdir $os] 1845 } elseif {[file exists [file join $srcdir unix Makefile.in]]} { 1846 set localsrcdir [file join $srcdir unix] 1847 } 1848 } 1849 } 1850 return $localsrcdir 1851 } 1852 1853 method make-autodetect {} { 1854 set srcdir [my define get srcdir] 1855 set localsrcdir [my define get localsrcdir] 1856 if {$srcdir eq $localsrcdir} { 1857 if {![file exists [file join $srcdir tclconfig install-sh]]} { 1858 # ensure we have tclconfig with all of the trimmings 1859 set teapath {} 1860 if {[file exists [file join $srcdir .. tclconfig install-sh]]} { 1861 set teapath [file join $srcdir .. tclconfig] 1862 } else { 1863 set tclConfigObj [::practcl::LOCAL tool tclconfig] 1864 $tclConfigObj load 1865 set teapath [$tclConfigObj define get srcdir] 1866 } 1867 set teapath [file normalize $teapath] 1868 #file mkdir [file join $srcdir tclconfig] 1869 if {[catch {file link -symbolic [file join $srcdir tclconfig] $teapath}]} { 1870 ::practcl::copyDir [file join $teapath] [file join $srcdir tclconfig] 1871 } 1872 } 1873 } 1874 set builddir [my define get builddir] 1875 file mkdir $builddir 1876 if {![file exists [file join $localsrcdir configure]]} { 1877 if {[file exists [file join $localsrcdir autogen.sh]]} { 1878 cd $localsrcdir 1879 catch {exec sh autogen.sh >>& [file join $builddir autoconf.log]} 1880 cd $::CWD 1881 } 1882 } 1883 set opts [my ConfigureOpts] 1884 if {[file exists [file join $builddir autoconf.log]]} { 1885 file delete [file join $builddir autoconf.log] 1886 } 1887 ::practcl::debug [list PKG [my define get name] CONFIGURE {*}$opts] 1888 ::practcl::log [file join $builddir autoconf.log] [list CONFIGURE {*}$opts] 1889 cd $builddir 1890 if {[my <project> define get CONFIG_SITE] ne {}} { 1891 set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE] 1892 } 1893 catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]} 1894 cd $::CWD 1895 } 1896 1897 method make-clean {} { 1898 set builddir [file normalize [my define get builddir]] 1899 catch {::practcl::domake $builddir clean} 1900 } 1901 1902 method make-compile {} { 1903 set name [my define get name] 1904 set srcdir [my define get srcdir] 1905 if {[my define get static 1]} { 1906 puts "BUILDING Static $name $srcdir" 1907 } else { 1908 puts "BUILDING Dynamic $name $srcdir" 1909 } 1910 cd $::CWD 1911 set builddir [file normalize [my define get builddir]] 1912 file mkdir $builddir 1913 if {![file exists [file join $builddir Makefile]]} { 1914 my Configure 1915 } 1916 if {[file exists [file join $builddir make.tcl]]} { 1917 if {[my define get debug 0]} { 1918 ::practcl::domake.tcl $builddir debug all 1919 } else { 1920 ::practcl::domake.tcl $builddir all 1921 } 1922 } else { 1923 ::practcl::domake $builddir all 1924 } 1925 } 1926 1927 method make-install DEST { 1928 set PWD [pwd] 1929 set builddir [my define get builddir] 1930 if {[my <project> define get LOCAL 0] || $DEST eq {}} { 1931 if {[file exists [file join $builddir make.tcl]]} { 1932 puts "[self] Local INSTALL (Practcl)" 1933 ::practcl::domake.tcl $builddir install 1934 } else {[my define get broken_destroot 0] == 0} { 1935 puts "[self] Local INSTALL (TEA)" 1936 ::practcl::domake $builddir install 1937 } 1938 } else { 1939 if {[file exists [file join $builddir make.tcl]]} { 1940 # Practcl builds can inject right to where we need them 1941 puts "[self] VFS INSTALL $DEST (Practcl)" 1942 ::practcl::domake.tcl $builddir install-package $DEST 1943 } elseif {[my define get broken_destroot 0] == 0} { 1944 # Most modern TEA projects understand DESTROOT in the makefile 1945 puts "[self] VFS INSTALL $DEST (TEA)" 1946 ::practcl::domake $builddir install DESTDIR=[::practcl::file_relative $builddir $DEST] 1947 } else { 1948 # But some require us to do an install into a fictitious filesystem 1949 # and then extract the gooey parts within. 1950 # (*cough*) TkImg 1951 set PREFIX [my <project> define get prefix] 1952 set BROKENROOT [::practcl::msys_to_tclpath [my <project> define get prefix_broken_destdir]] 1953 file delete -force $BROKENROOT 1954 file mkdir $BROKENROOT 1955 ::practcl::domake $builddir $install 1956 ::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]] 1957 file delete -force $BROKENROOT 1958 } 1959 } 1960 cd $PWD 1961 } 1962 1963 method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} { 1964 set objext [my define get OBJEXT o] 1965 set EXTERN_OBJS {} 1966 set OBJECTS {} 1967 set result {} 1968 set builddir [$PROJECT define get builddir] 1969 file mkdir [file join $builddir objs] 1970 set debug [$PROJECT define get debug 0] 1971 1972 set task {} 1973 ### 1974 # Compile the C sources 1975 ### 1976 ::practcl::debug ### COMPILE PRODUCTS 1977 foreach {ofile info} [${PROJECT} project-compile-products] { 1978 ::practcl::debug $ofile $info 1979 if {[dict exists $info library]} { 1980 #dict set task $ofile done 1 1981 continue 1982 } 1983 # Products with no cfile aren't compiled 1984 if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} { 1985 #dict set task $ofile done 1 1986 continue 1987 } 1988 set ofile [file rootname $ofile] 1989 dict set task $ofile done 0 1990 if {[dict exists $info external] && [dict get $info external]==1} { 1991 dict set task $ofile external 1 1992 } else { 1993 dict set task $ofile external 0 1994 } 1995 set cfile [dict get $info cfile] 1996 if {$debug} { 1997 set ofilename [file join $builddir objs [file rootname [file tail $ofile]].debug.${objext}] 1998 } else { 1999 set ofilename [file join $builddir objs [file tail $ofile]].${objext} 2000 } 2001 dict set task $ofile source $cfile 2002 dict set task $ofile objfile $ofilename 2003 if {![dict exist $info command]} { 2004 if {[file extension $cfile] in {.c++ .cpp}} { 2005 set cmd $CPPCOMPILE 2006 } else { 2007 set cmd $COMPILE 2008 } 2009 if {[dict exists $info extra]} { 2010 append cmd " [dict get $info extra]" 2011 } 2012 append cmd " $INCLUDES" 2013 append cmd " -c $cfile" 2014 append cmd " -o $ofilename" 2015 dict set task $ofile command $cmd 2016 } 2017 } 2018 set completed 0 2019 while {$completed==0} { 2020 set completed 1 2021 foreach {ofile info} $task { 2022 set waiting {} 2023 if {[dict exists $info done] && [dict get $info done]} continue 2024 ::practcl::debug COMPILING $ofile $info 2025 set filename [dict get $info objfile] 2026 if {[file exists $filename] && [file mtime $filename]>[file mtime [dict get $info source]]} { 2027 lappend result $filename 2028 dict set task $ofile done 1 2029 continue 2030 } 2031 if {[dict exists $info depend]} { 2032 foreach file [dict get $info depend] { 2033 if {[dict exists $task $file command] && [dict exists $task $file done] && [dict get $task $file done] != 1} { 2034 set waiting $file 2035 break 2036 } 2037 } 2038 } 2039 if {$waiting ne {}} { 2040 set completed 0 2041 puts "$ofile waiting for $waiting" 2042 continue 2043 } 2044 if {[dict exists $info command]} { 2045 set cmd [dict get $info command] 2046 puts "$cmd" 2047 exec {*}$cmd >&@ stdout 2048 } 2049 if {[file exists $filename]} { 2050 lappend result $filename 2051 dict set task $ofile done 1 2052 continue 2053 } 2054 error "Failed to produce $filename" 2055 } 2056 } 2057 return $result 2058 } 2059 2060method build-Makefile {path PROJECT} { 2061 array set proj [$PROJECT define dump] 2062 set path $proj(builddir) 2063 cd $path 2064 set includedir . 2065 set objext [my define get OBJEXT o] 2066 2067 #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] 2068 lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] 2069 lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] 2070 foreach include [$PROJECT toolset-include-directory] { 2071 set cpath [::practcl::file_relative $path [file normalize $include]] 2072 if {$cpath ni $includedir} { 2073 lappend includedir $cpath 2074 } 2075 } 2076 set INCLUDES "-I[join $includedir " -I"]" 2077 set NAME [string toupper $proj(name)] 2078 set result {} 2079 set products {} 2080 set libraries {} 2081 set thisline {} 2082 ::practcl::cputs result "${NAME}_DEFS = $proj(DEFS)\n" 2083 ::practcl::cputs result "${NAME}_INCLUDES = -I\"[join $includedir "\" -I\""]\"\n" 2084 ::practcl::cputs result "${NAME}_COMPILE = \$(CC) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" 2085 ::practcl::cputs result "${NAME}_CPPCOMPILE = \$(CXX) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" 2086 2087 foreach {ofile info} [$PROJECT project-compile-products] { 2088 dict set products $ofile $info 2089 set fname [file rootname ${ofile}].${objext} 2090 if {[dict exists $info library]} { 2091lappend libraries $ofile 2092continue 2093 } 2094 if {[dict exists $info depend]} { 2095 ::practcl::cputs result "\n${fname}: [dict get $info depend]" 2096 } else { 2097 ::practcl::cputs result "\n${fname}:" 2098 } 2099 set cfile [dict get $info cfile] 2100 if {[file extension $cfile] in {.c++ .cpp}} { 2101 set cmd "\t\$\(${NAME}_CPPCOMPILE\)" 2102 } else { 2103 set cmd "\t\$\(${NAME}_COMPILE\)" 2104 } 2105 if {[dict exists $info extra]} { 2106 append cmd " [dict get $info extra]" 2107 } 2108 append cmd " -c [dict get $info cfile] -o \$@\n\t" 2109 ::practcl::cputs result $cmd 2110 } 2111 2112 set map {} 2113 lappend map %LIBRARY_NAME% $proj(name) 2114 lappend map %LIBRARY_VERSION% $proj(version) 2115 lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)] 2116 lappend map %LIBRARY_PREFIX% [$PROJECT define getnull libprefix] 2117 2118 if {[string is true [$PROJECT define get SHARED_BUILD]]} { 2119 set outfile [$PROJECT define get libfile] 2120 } else { 2121 set outfile [$PROJECT shared_library] 2122 } 2123 $PROJECT define set shared_library $outfile 2124 ::practcl::cputs result " 2125${NAME}_SHLIB = $outfile 2126${NAME}_OBJS = [dict keys $products] 2127" 2128 2129 #lappend map %OUTFILE% {\[$]@} 2130 lappend map %OUTFILE% $outfile 2131 lappend map %LIBRARY_OBJECTS% "\$(${NAME}_OBJS)" 2132 ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" 2133 ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_SHARED_LIB]]" 2134 if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} { 2135 ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]]" 2136 } 2137 ::practcl::cputs result {} 2138 if {[string is true [$PROJECT define get SHARED_BUILD]]} { 2139 #set outfile [$PROJECT static_library] 2140 set outfile $proj(name).a 2141 } else { 2142 set outfile [$PROJECT define get libfile] 2143 } 2144 $PROJECT define set static_library $outfile 2145 dict set map %OUTFILE% $outfile 2146 ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" 2147 ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]" 2148 ::practcl::cputs result {} 2149 return $result 2150} 2151 2152### 2153# Produce a static or dynamic library 2154### 2155method build-library {outfile PROJECT} { 2156 array set proj [$PROJECT define dump] 2157 set path $proj(builddir) 2158 cd $path 2159 set includedir . 2160 #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] 2161 lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] 2162 lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] 2163 if {[$PROJECT define get tk 0]} { 2164 lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]] 2165 lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]] 2166 lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]] 2167 lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]] 2168 } 2169 foreach include [$PROJECT toolset-include-directory] { 2170 set cpath [::practcl::file_relative $path [file normalize $include]] 2171 if {$cpath ni $includedir} { 2172 lappend includedir $cpath 2173 } 2174 } 2175 my build-cflags $PROJECT $proj(DEFS) name version defs 2176 set NAME [string toupper $name] 2177 set debug [$PROJECT define get debug 0] 2178 set os [$PROJECT define get TEACUP_OS] 2179 2180 set INCLUDES "-I[join $includedir " -I"]" 2181 if {$debug} { 2182 set COMPILE "$proj(CC) $proj(CFLAGS_DEBUG) -ggdb \ 2183$proj(CFLAGS_WARNING) $INCLUDES $defs" 2184 2185 if {[info exists proc(CXX)]} { 2186 set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS_DEBUG) -ggdb \ 2187 $defs $proj(CFLAGS_WARNING)" 2188 } else { 2189 set COMPILECPP $COMPILE 2190 } 2191 } else { 2192 set COMPILE "$proj(CC) $proj(CFLAGS) $defs" 2193 2194 if {[info exists proc(CXX)]} { 2195 set COMPILECPP "$proj(CXX) $defs $proj(CFLAGS)" 2196 } else { 2197 set COMPILECPP $COMPILE 2198 } 2199 } 2200 2201 set products [my build-compile-sources $PROJECT $COMPILE $COMPILECPP $INCLUDES] 2202 2203 set map {} 2204 lappend map %LIBRARY_NAME% $proj(name) 2205 lappend map %LIBRARY_VERSION% $proj(version) 2206 lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)] 2207 lappend map %OUTFILE% $outfile 2208 lappend map %LIBRARY_OBJECTS% $products 2209 lappend map {${CFLAGS}} "$proj(CFLAGS_DEFAULT) $proj(CFLAGS_WARNING)" 2210 2211 if {[string is true [$PROJECT define get SHARED_BUILD 1]]} { 2212 set cmd [$PROJECT define get PRACTCL_SHARED_LIB] 2213 append cmd " [$PROJECT define get PRACTCL_LIBS]" 2214 set cmd [string map $map $cmd] 2215 puts $cmd 2216 exec {*}$cmd >&@ stdout 2217 if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} { 2218 set cmd [string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]] 2219 puts $cmd 2220 exec {*}$cmd >&@ stdout 2221 } 2222 } else { 2223 set cmd [string map $map [$PROJECT define get PRACTCL_STATIC_LIB]] 2224 puts $cmd 2225 exec {*}$cmd >&@ stdout 2226 } 2227 set ranlib [$PROJECT define get RANLIB] 2228 if {$ranlib ni {{} :}} { 2229 catch {exec $ranlib $outfile} 2230 } 2231} 2232 2233### 2234# Produce a static executable 2235### 2236method build-tclsh {outfile PROJECT} { 2237 puts " BUILDING STATIC TCLSH " 2238 set TCLOBJ [$PROJECT tclcore] 2239 ::practcl::toolset select $TCLOBJ 2240 set PKG_OBJS {} 2241 foreach item [$PROJECT link list core.library] { 2242 if {[string is true [$item define get static]]} { 2243 lappend PKG_OBJS $item 2244 } 2245 } 2246 foreach item [$PROJECT link list package] { 2247 if {[string is true [$item define get static]]} { 2248 lappend PKG_OBJS $item 2249 } 2250 } 2251 array set TCL [$TCLOBJ read_configuration] 2252 2253 set TKOBJ [$PROJECT tkcore] 2254 if {[info command $TKOBJ] eq {}} { 2255 set TKOBJ ::noop 2256 $PROJECT define set static_tk 0 2257 } else { 2258 ::practcl::toolset select $TKOBJ 2259 array set TK [$TKOBJ read_configuration] 2260 set do_tk [$TKOBJ define get static] 2261 $PROJECT define set static_tk $do_tk 2262 $PROJECT define set tk $do_tk 2263 set TKSRCDIR [$TKOBJ define get srcdir] 2264 } 2265 set path [file dirname $outfile] 2266 cd $path 2267 ### 2268 # For a static Tcl shell, we need to build all local sources 2269 # with the same DEFS flags as the tcl core was compiled with. 2270 # The DEFS produced by a TEA extension aren't intended to operate 2271 # with the internals of a staticly linked Tcl 2272 ### 2273 my build-cflags $PROJECT $TCL(defs) name version defs 2274 set debug [$PROJECT define get debug 0] 2275 set NAME [string toupper $name] 2276 set result {} 2277 set libraries {} 2278 set thisline {} 2279 set OBJECTS {} 2280 set EXTERN_OBJS {} 2281 foreach obj $PKG_OBJS { 2282 $obj compile 2283 set config($obj) [$obj read_configuration] 2284 } 2285 set os [$PROJECT define get TEACUP_OS] 2286 set TCLSRCDIR [$TCLOBJ define get srcdir] 2287 2288 set includedir . 2289 foreach include [$TCLOBJ toolset-include-directory] { 2290 set cpath [::practcl::file_relative $path [file normalize $include]] 2291 if {$cpath ni $includedir} { 2292 lappend includedir $cpath 2293 } 2294 } 2295 lappend includedir [::practcl::file_relative $path [file normalize ../tcl/compat/zlib]] 2296 if {[$PROJECT define get static_tk]} { 2297 lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR generic]]] 2298 lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR ttk]]] 2299 lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR xlib]]] 2300 lappend includedir [::practcl::file_relative $path [file normalize $TKSRCDIR]] 2301 } 2302 2303 foreach include [$PROJECT toolset-include-directory] { 2304 set cpath [::practcl::file_relative $path [file normalize $include]] 2305 if {$cpath ni $includedir} { 2306 lappend includedir $cpath 2307 } 2308 } 2309 2310 set INCLUDES "-I[join $includedir " -I"]" 2311 if {$debug} { 2312 set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) -ggdb \ 2313$TCL(cflags_warning) $TCL(extra_cflags)" 2314 } else { 2315 set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ 2316$TCL(cflags_warning) $TCL(extra_cflags)" 2317 } 2318 append COMPILE " " $defs 2319 lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES] 2320 2321 set TCLSRC [file normalize $TCLSRCDIR] 2322 2323 if {[${PROJECT} define get TEACUP_OS] eq "windows"} { 2324 set windres [$PROJECT define get RC windres] 2325 set RSOBJ [file join $path build tclkit.res.o] 2326 set RCSRC [${PROJECT} define get kit_resource_file] 2327 set RCMAN [${PROJECT} define get kit_manifest_file] 2328 2329 set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]] 2330 if {[$PROJECT define get static_tk]} { 2331 if {$RCSRC eq {} || ![file exists $RCSRC]} { 2332 set RCSRC [file join $TKSRCDIR win rc wish.rc] 2333 } 2334 if {$RCMAN eq {} || ![file exists $RCMAN]} { 2335 set RCMAN [file join [$TKOBJ define get builddir] wish.exe.manifest] 2336 } 2337 set TKSRC [file normalize $TKSRCDIR] 2338 lappend cmd --include [::practcl::file_relative $path [file join $TKSRC generic]] \ 2339 --include [::practcl::file_relative $path [file join $TKSRC win]] \ 2340 --include [::practcl::file_relative $path [file join $TKSRC win rc]] 2341 } else { 2342 if {$RCSRC eq {} || ![file exists $RCSRC]} { 2343 set RCSRC [file join $TCLSRCDIR tclsh.rc] 2344 } 2345 if {$RCMAN eq {} || ![file exists $RCMAN]} { 2346 set RCMAN [file join [$TCLOBJ define get builddir] tclsh.exe.manifest] 2347 } 2348 } 2349 foreach item [${PROJECT} define get resource_include] { 2350 lappend cmd --include [::practcl::file_relative $path [file normalize $item]] 2351 } 2352 lappend cmd [file tail $RCSRC] 2353 if {![file exists [file join $path [file tail $RCSRC]]]} { 2354 file copy -force $RCSRC [file join $path [file tail $RCSRC]] 2355 } 2356 if {![file exists [file join $path [file tail $RCMAN]]]} { 2357 file copy -force $RCMAN [file join $path [file tail $RCMAN]] 2358 } 2359 ::practcl::doexec {*}$cmd 2360 lappend OBJECTS $RSOBJ 2361 } 2362 puts "***" 2363 set cmd "$TCL(cc)" 2364 if {$debug} { 2365 append cmd " $TCL(cflags_debug)" 2366 } else { 2367 append cmd " $TCL(cflags_optimize)" 2368 } 2369 append cmd " $TCL(ld_flags)" 2370 if {$debug} { 2371 append cmd " $TCL(ldflags_debug)" 2372 } else { 2373 append cmd " $TCL(ldflags_optimize)" 2374 } 2375 2376 append cmd " $OBJECTS" 2377 append cmd " $EXTERN_OBJS" 2378 if {$debug && $os eq "windows"} { 2379 append cmd " -static" 2380 append cmd " -L${TCL(src_dir)}/win -ltcl86g" 2381 if {[$PROJECT define get static_tk]} { 2382 append cmd " -L${TK(src_dir)}/win -ltk86g" 2383 } 2384 } else { 2385 append cmd " $TCL(build_lib_spec)" 2386 if {[$PROJECT define get static_tk]} { 2387 append cmd " $TK(build_lib_spec)" 2388 } 2389 } 2390 foreach obj $PKG_OBJS { 2391 append cmd " [$obj linker-products $config($obj)]" 2392 } 2393 set LIBS {} 2394 foreach item $TCL(libs) { 2395 if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue 2396 lappend LIBS $item 2397 } 2398 if {[$PROJECT define get static_tk]} { 2399 foreach item $TK(libs) { 2400 if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue 2401 lappend LIBS $item 2402 } 2403 } 2404 if {[info exists TCL(extra_libs)]} { 2405 foreach item $TCL(extra_libs) { 2406 if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue 2407 lappend LIBS $item 2408 } 2409 } 2410 foreach obj $PKG_OBJS { 2411 puts [list Checking $obj for external dependencies] 2412 foreach item [$obj linker-external $config($obj)] { 2413 puts [list $obj adds $item] 2414 if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue 2415 lappend LIBS $item 2416 } 2417 } 2418 append cmd " ${LIBS}" 2419 foreach obj $PKG_OBJS { 2420 puts [list Checking $obj for additional link items] 2421 foreach item [$obj linker-extra $config($obj)] { 2422 append cmd $item 2423 } 2424 } 2425 if {$debug && $os eq "windows"} { 2426 append cmd " -L${TCL(src_dir)}/win ${TCL(stub_lib_flag)}" 2427 if {[$PROJECT define get static_tk]} { 2428 append cmd " -L${TK(src_dir)}/win ${TK(stub_lib_flag)}" 2429 } 2430 } else { 2431 append cmd " $TCL(build_stub_lib_spec)" 2432 if {[$PROJECT define get static_tk]} { 2433 append cmd " $TK(build_stub_lib_spec)" 2434 } 2435 } 2436 if {[info exists TCL(cc_search_flags)]} { 2437 append cmd " $TCL(cc_search_flags)" 2438 } 2439 append cmd " -o $outfile " 2440 if {$os eq "windows"} { 2441 set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} 2442 set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} 2443 append cmd " $LDFLAGS_CONSOLE" 2444 } 2445 puts "LINK: $cmd" 2446 exec {*}[string map [list "\n" " " " " " "] $cmd] >&@ stdout 2447} 2448 2449} 2450 2451### 2452# END: class toolset gcc.tcl 2453### 2454### 2455# START: class toolset msvc.tcl 2456### 2457::oo::class create ::practcl::toolset.msvc { 2458 superclass ::practcl::toolset 2459 2460 # MSVC always builds in the source directory 2461 method BuildDir {PWD} { 2462 set srcdir [my define get srcdir] 2463 return $srcdir 2464 } 2465 2466 2467 # Do nothing 2468 method make-autodetect {} { 2469 } 2470 2471 method make-clean {} { 2472 set PWD [pwd] 2473 set srcdir [my define get srcdir] 2474 cd $srcdir 2475 catch {::practcl::doexec nmake -f makefile.vc clean} 2476 cd $PWD 2477 } 2478 2479 method make-compile {} { 2480 set srcdir [my define get srcdir] 2481 if {[my define get static 1]} { 2482 puts "BUILDING Static $name $srcdir" 2483 } else { 2484 puts "BUILDING Dynamic $name $srcdir" 2485 } 2486 cd $srcdir 2487 if {[file exists [file join $srcdir make.tcl]]} { 2488 if {[my define get debug 0]} { 2489 ::practcl::domake.tcl $srcdir debug all 2490 } else { 2491 ::practcl::domake.tcl $srcdir all 2492 } 2493 } else { 2494 if {[file exists [file join $srcdir makefile.vc]]} { 2495 ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release 2496 } elseif {[file exists [file join $srcdir win makefile.vc]]} { 2497 cd [file join $srcdir win] 2498 ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release 2499 } else { 2500 error "No make.tcl or makefile.vc found for project $name" 2501 } 2502 } 2503 } 2504 2505 method make-install DEST { 2506 set PWD [pwd] 2507 set srcdir [my define get srcdir] 2508 cd $srcdir 2509 if {$DEST eq {}} { 2510 error "No destination given" 2511 } 2512 if {[my <project> define get LOCAL 0] || $DEST eq {}} { 2513 if {[file exists [file join $srcdir make.tcl]]} { 2514 # Practcl builds can inject right to where we need them 2515 puts "[self] Local Install (Practcl)" 2516 ::practcl::domake.tcl $srcdir install 2517 } else { 2518 puts "[self] Local Install (Nmake)" 2519 ::practcl::doexec nmake -f makefile.vc {*}[my NmakeOpts] install 2520 } 2521 } else { 2522 if {[file exists [file join $srcdir make.tcl]]} { 2523 # Practcl builds can inject right to where we need them 2524 puts "[self] VFS INSTALL $DEST (Practcl)" 2525 ::practcl::domake.tcl $srcdir install-package $DEST 2526 } else { 2527 puts "[self] VFS INSTALL $DEST" 2528 ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install 2529 } 2530 } 2531 cd $PWD 2532 } 2533 2534 # Detect what directory contains the Makefile template 2535 method MakeDir {srcdir} { 2536 set localsrcdir $srcdir 2537 if {[file exists [file join $srcdir generic]]} { 2538 my define add include_dir [file join $srcdir generic] 2539 } 2540 if {[file exists [file join $srcdir win]]} { 2541 my define add include_dir [file join $srcdir win] 2542 } 2543 if {[file exists [file join $srcdir makefile.vc]]} { 2544 set localsrcdir [file join $srcdir win] 2545 } 2546 return $localsrcdir 2547 } 2548 2549 method NmakeOpts {} { 2550 set opts {} 2551 set builddir [file normalize [my define get builddir]] 2552 2553 if {[my <project> define exists tclsrcdir]} { 2554 ### 2555 # On Windows we are probably running under MSYS, which doesn't deal with 2556 # spaces in filename well 2557 ### 2558 set TCLSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] ..]]] 2559 set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] .. generic]]] 2560 lappend opts TCLDIR=[file normalize $TCLSRCDIR] 2561 #--with-tclinclude=$TCLGENERIC 2562 } 2563 if {[my <project> define exists tksrcdir]} { 2564 set TKSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] ..]]] 2565 set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] .. generic]]] 2566 #lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC 2567 lappend opts TKDIR=[file normalize $TKSRCDIR] 2568 } 2569 return $opts 2570 } 2571} 2572 2573### 2574# END: class toolset msvc.tcl 2575### 2576### 2577# START: class target.tcl 2578### 2579 2580::oo::class create ::practcl::make_obj { 2581 superclass ::practcl::metaclass 2582 2583 constructor {module_object name info {action_body {}}} { 2584 my variable define triggered domake 2585 set triggered 0 2586 set domake 0 2587 set define(name) $name 2588 set define(action) {} 2589 array set define $info 2590 my select 2591 my initialize 2592 foreach {stub obj} [$module_object child organs] { 2593 my graft $stub $obj 2594 } 2595 if {$action_body ne {}} { 2596 set define(action) $action_body 2597 } 2598 } 2599 2600 method do {} { 2601 my variable domake 2602 return $domake 2603 } 2604 2605 method check {} { 2606 my variable needs_make domake 2607 if {$domake} { 2608 return 1 2609 } 2610 if {[info exists needs_make]} { 2611 return $needs_make 2612 } 2613 set make_objects [my <module> make objects] 2614 set needs_make 0 2615 foreach item [my define get depends] { 2616 if {![dict exists $make_objects $item]} continue 2617 set depobj [dict get $make_objects $item] 2618 if {$depobj eq [self]} { 2619 puts "WARNING [self] depends on itself" 2620 continue 2621 } 2622 if {[$depobj check]} { 2623 set needs_make 1 2624 } 2625 } 2626 if {!$needs_make} { 2627 foreach filename [my output] { 2628 if {$filename ne {} && ![file exists $filename]} { 2629 set needs_make 1 2630 } 2631 } 2632 } 2633 return $needs_make 2634 } 2635 2636 method output {} { 2637 set result {} 2638 set filename [my define get filename] 2639 if {$filename ne {}} { 2640 lappend result $filename 2641 } 2642 foreach filename [my define get files] { 2643 if {$filename ne {}} { 2644 lappend result $filename 2645 } 2646 } 2647 return $result 2648 } 2649 2650 method reset {} { 2651 my variable triggered domake needs_make 2652 set triggerd 0 2653 set domake 0 2654 set needs_make 0 2655 } 2656 2657 method triggers {} { 2658 my variable triggered domake define 2659 if {$triggered} { 2660 return $domake 2661 } 2662 set triggered 1 2663 set make_objects [my <module> make objects] 2664 2665 foreach item [my define get depends] { 2666 if {![dict exists $make_objects $item]} continue 2667 set depobj [dict get $make_objects $item] 2668 if {$depobj eq [self]} { 2669 puts "WARNING [self] triggers itself" 2670 continue 2671 } else { 2672 set r [$depobj check] 2673 if {$r} { 2674 $depobj triggers 2675 } 2676 } 2677 } 2678 set domake 1 2679 my <module> make trigger {*}[my define get triggers] 2680 } 2681} 2682 2683### 2684# END: class target.tcl 2685### 2686### 2687# START: class object.tcl 2688### 2689::oo::class create ::practcl::object { 2690 superclass ::practcl::metaclass 2691 2692 constructor {parent args} { 2693 my variable links define 2694 set organs [$parent child organs] 2695 my graft {*}$organs 2696 array set define $organs 2697 array set define [$parent child define] 2698 array set links {} 2699 if {[llength $args]==1 && [file exists [lindex $args 0]]} { 2700 my define set filename [lindex $args 0] 2701 ::practcl::product select [self] 2702 } elseif {[llength $args] == 1} { 2703 set data [uplevel 1 [list subst [lindex $args 0]]] 2704 array set define $data 2705 my select 2706 } else { 2707 array set define [uplevel 1 [list subst $args]] 2708 my select 2709 } 2710 my initialize 2711 2712 } 2713 2714 method child {method} { 2715 return {} 2716 } 2717 2718 method go {} { 2719 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 2720 my variable links 2721 foreach {linktype objs} [array get links] { 2722 foreach obj $objs { 2723 $obj go 2724 } 2725 } 2726 ::practcl::debug [list /[self] [self method] [self class]] 2727 } 2728} 2729 2730### 2731# END: class object.tcl 2732### 2733### 2734# START: class dynamic.tcl 2735### 2736 2737### 2738# Dynamic blocks do not generate their own .c files, 2739# instead the contribute to the amalgamation 2740# of the main library file 2741### 2742::oo::class create ::practcl::dynamic { 2743 2744 ### 2745 # Parser functions 2746 ### 2747 2748 method cstructure {name definition {argdat {}}} { 2749 my variable cstruct 2750 dict set cstruct $name body $definition 2751 foreach {f v} $argdat { 2752 dict set cstruct $name $f $v 2753 } 2754 if {![dict exists $cstruct $name public]} { 2755 dict set cstruct $name public 1 2756 } 2757 } 2758 2759 method include header { 2760 my define add include $header 2761 } 2762 2763 method include_dir args { 2764 my define add include_dir {*}$args 2765 } 2766 2767 method include_directory args { 2768 my define add include_dir {*}$args 2769 } 2770 2771 method c_header body { 2772 my variable code 2773 ::practcl::cputs code(header) $body 2774 } 2775 2776 method c_code body { 2777 my variable code 2778 ::practcl::cputs code(funct) $body 2779 } 2780 2781 method c_function {header body {info {}}} { 2782 set header [string map "\t \ \n \ \ \ \ " $header] 2783 my variable code cfunct 2784 foreach regexp { 2785 {(.*) ([a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} 2786 {(.*) (\x2a[a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} 2787 } { 2788 if {[regexp $regexp $header all keywords funcname arglist]} { 2789 set dat [dict merge {export 0 extern 0 public 1 inline 0} $info] 2790 dict set dat header $header 2791 dict set dat body $body 2792 dict set dat keywords $keywords 2793 dict set dat arglist $arglist 2794 if {"IRM_INLINE" in $keywords || "CTHULHU_INLINE" in $keywords} { 2795 dict set dat public 1 2796 dict set dat extern 0 2797 dict set dat inline 1 2798 } else { 2799 if {"inline" in $keywords} { 2800 dict set dat inline 1 2801 } 2802 if {"STUB_EXPORT" in $keywords} { 2803 dict set dat extern 1 2804 dict set dat public 1 2805 dict set dat export 1 2806 dict set dat inline 0 2807 } elseif {"extern" in $keywords} { 2808 dict set dat extern 1 2809 dict set dat public 1 2810 } elseif {"static" in $keywords} { 2811 dict set dat public 0 2812 } 2813 } 2814 if {[dict get $dat inline] && [dict get $dat public]} { 2815 set header [string map {IRM_INLINE {} CTHULHU_INLINE {} static {} inline {} extern {}} [dict get $dat header]] 2816 dict set dat header "extern $header" 2817 } 2818 dict set cfunct $funcname $dat 2819 return 2820 } 2821 } 2822 puts "WARNING: NON CONFORMING FUNCTION DEFINITION: $headers $body" 2823 ::practcl::cputs code(header) "$header\;" 2824 # Could not parse that block as a function 2825 # append it verbatim to our c_implementation 2826 ::practcl::cputs code(funct) "$header [list $body]" 2827 } 2828 2829 method c_tcloomethod {name body {arginfo {}}} { 2830 my variable methods code 2831 foreach {f v} $arginfo { 2832 dict set methods $name $f $v 2833 } 2834 dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ 2835$body" 2836 } 2837 2838 # Alias to classic name 2839 method cmethod {name body {arginfo {}}} { 2840 my variable methods code 2841 foreach {f v} $arginfo { 2842 dict set methods $name $f $v 2843 } 2844 dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ 2845$body" 2846 } 2847 2848 method c_tclproc_nspace nspace { 2849 my variable code 2850 if {![info exists code(nspace)]} { 2851 set code(nspace) {} 2852 } 2853 if {$nspace ni $code(nspace)} { 2854 lappend code(nspace) $nspace 2855 } 2856 } 2857 2858 method c_tclcmd {name body {arginfo {}}} { 2859 my variable tclprocs code 2860 2861 foreach {f v} $arginfo { 2862 dict set tclprocs $name $f $v 2863 } 2864 dict set tclprocs $name body $body 2865 } 2866 2867 # Alias to classic name 2868 method c_tclproc_raw {name body {arginfo {}}} { 2869 my variable tclprocs code 2870 2871 foreach {f v} $arginfo { 2872 dict set tclprocs $name $f $v 2873 } 2874 dict set tclprocs $name body $body 2875 } 2876 2877 method tcltype {name argdat} { 2878 my variable tcltype 2879 foreach {f v} $argdat { 2880 dict set tcltype $name $f $v 2881 } 2882 if {![dict exists tcltype $name cname]} { 2883 dict set tcltype $name cname [string tolower $name]_tclobjtype 2884 } 2885 lappend map @NAME@ $name 2886 set info [dict get $tcltype $name] 2887 foreach {f v} $info { 2888 lappend map @[string toupper $f]@ $v 2889 } 2890 foreach {func fpat template} { 2891 freeproc {@Name@Obj_freeIntRepProc} {void @FNAME@(Tcl_Obj *objPtr)} 2892 dupproc {@Name@Obj_dupIntRepProc} {void @FNAME@(Tcl_Obj *srcPtr,Tcl_Obj *dupPtr)} 2893 updatestringproc {@Name@Obj_updateStringRepProc} {void @FNAME@(Tcl_Obj *objPtr)} 2894 setfromanyproc {@Name@Obj_setFromAnyProc} {int @FNAME@(Tcl_Interp *interp,Tcl_Obj *objPtr)} 2895 } { 2896 if {![dict exists $info $func]} { 2897 error "$name does not define $func" 2898 } 2899 set body [dict get $info $func] 2900 # We were given a function name to call 2901 if {[llength $body] eq 1} continue 2902 set fname [string map [list @Name@ [string totitle $name]] $fpat] 2903 my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body] 2904 dict set tcltype $name $func $fname 2905 } 2906 } 2907 2908 ### 2909 # Module interactions 2910 ### 2911 2912 2913 method project-compile-products {} { 2914 set filename [my define get output_c] 2915 set result {} 2916 if {$filename ne {}} { 2917 ::practcl::debug [self] [self class] [self method] project-compile-products $filename 2918 2919 if {[my define exists ofile]} { 2920 set ofile [my define get ofile] 2921 } else { 2922 set ofile [my Ofile $filename] 2923 my define set ofile $ofile 2924 } 2925 lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] 2926 } else { 2927 set filename [my define get cfile] 2928 if {$filename ne {}} { 2929 ::practcl::debug [self] [self class] [self method] project-compile-products $filename 2930 if {[my define exists ofile]} { 2931 set ofile [my define get ofile] 2932 } else { 2933 set ofile [my Ofile $filename] 2934 my define set ofile $ofile 2935 } 2936 lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] 2937 } 2938 } 2939 foreach item [my link list subordinate] { 2940 lappend result {*}[$item project-compile-products] 2941 } 2942 return $result 2943 } 2944 2945 2946 method implement path { 2947 my go 2948 my Collate_Source $path 2949 if {[my define get output_c] eq {}} return 2950 set filename [file join $path [my define get output_c]] 2951 ::practcl::debug [self] [my define get filename] WANTS TO GENERATE $filename 2952 my define set cfile $filename 2953 set fout [open $filename w] 2954 puts $fout [my generate-c] 2955 if {[my define get initfunc] ne {}} { 2956 puts $fout "extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \x7B" 2957 puts $fout [my generate-loader-module] 2958 if {[my define get pkg_name] ne {}} { 2959 puts $fout " Tcl_PkgProvide(interp, \"[my define get pkg_name]\", \"[my define get pkg_vers]\");" 2960 } 2961 puts $fout " return TCL_OK\;" 2962 puts $fout "\x7D" 2963 } 2964 close $fout 2965 } 2966 2967 2968 2969 ### 2970 # Practcl internals 2971 ### 2972 2973 method initialize {} { 2974 set filename [my define get filename] 2975 if {$filename eq {}} { 2976 return 2977 } 2978 if {[my define get name] eq {}} { 2979 my define set name [file tail [file rootname $filename]] 2980 } 2981 if {[my define get localpath] eq {}} { 2982 my define set localpath [my <module> define get localpath]_[my define get name] 2983 } 2984 ::source $filename 2985 } 2986 2987 method linktype {} { 2988 return {subordinate product dynamic} 2989 } 2990 2991 method generate-cfile-constant {} { 2992 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 2993 set result {} 2994 my variable code cstruct methods tcltype 2995 if {[info exists code(constant)]} { 2996 ::practcl::cputs result "/* [my define get filename] CONSTANT */" 2997 ::practcl::cputs result $code(constant) 2998 } 2999 if {[info exists cstruct]} { 3000 foreach {name info} $cstruct { 3001 set map {} 3002 lappend map @NAME@ $name 3003 lappend map @MACRO@ GET[string toupper $name] 3004 3005 if {[dict exists $info deleteproc]} { 3006 lappend map @DELETEPROC@ [dict get $info deleteproc] 3007 } else { 3008 lappend map @DELETEPROC@ NULL 3009 } 3010 if {[dict exists $info cloneproc]} { 3011 lappend map @CLONEPROC@ [dict get $info cloneproc] 3012 } else { 3013 lappend map @CLONEPROC@ NULL 3014 } 3015 ::practcl::cputs result [string map $map { 3016const static Tcl_ObjectMetadataType @NAME@DataType = { 3017 TCL_OO_METADATA_VERSION_CURRENT, 3018 "@NAME@", 3019 @DELETEPROC@, 3020 @CLONEPROC@ 3021}; 3022#define @MACRO@(OBJCONTEXT) (@NAME@ *) Tcl_ObjectGetMetadata(OBJCONTEXT,&@NAME@DataType) 3023}] 3024 } 3025 } 3026 if {[info exists tcltype]} { 3027 foreach {type info} $tcltype { 3028 dict with info {} 3029 ::practcl::cputs result "const Tcl_ObjType $cname = \{\n .name=\"$type\",\n .freeIntRepProc = &${freeproc},\n .dupIntRepProc = &${dupproc},\n .updateStringProc = &${updatestringproc},\n .setFromAnyProc = &${setfromanyproc}\n\}\;" 3030 } 3031 } 3032 3033 if {[info exists methods]} { 3034 set mtypes {} 3035 foreach {name info} $methods { 3036 set callproc [dict get $info callproc] 3037 set methodtype [dict get $info methodtype] 3038 if {$methodtype in $mtypes} continue 3039 lappend mtypes $methodtype 3040 ### 3041 # Build the data struct for this method 3042 ### 3043 ::practcl::cputs result "const static Tcl_MethodType $methodtype = \{" 3044 ::practcl::cputs result " .version = TCL_OO_METADATA_VERSION_CURRENT,\n .name = \"$name\",\n .callProc = $callproc," 3045 if {[dict exists $info deleteproc]} { 3046 set deleteproc [dict get $info deleteproc] 3047 } else { 3048 set deleteproc NULL 3049 } 3050 if {$deleteproc ni { {} NULL }} { 3051 ::practcl::cputs result " .deleteProc = $deleteproc," 3052 } else { 3053 ::practcl::cputs result " .deleteProc = NULL," 3054 } 3055 if {[dict exists $info cloneproc]} { 3056 set cloneproc [dict get $info cloneproc] 3057 } else { 3058 set cloneproc NULL 3059 } 3060 if {$cloneproc ni { {} NULL }} { 3061 ::practcl::cputs result " .cloneProc = $cloneproc\n\}\;" 3062 } else { 3063 ::practcl::cputs result " .cloneProc = NULL\n\}\;" 3064 } 3065 dict set methods $name methodtype $methodtype 3066 } 3067 } 3068 foreach obj [my link list product] { 3069 # Exclude products that will generate their own C files 3070 if {[$obj define get output_c] ne {}} continue 3071 ::practcl::cputs result [$obj generate-cfile-constant] 3072 } 3073 return $result 3074 } 3075 3076 method generate-cfile-header {} { 3077 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3078 my variable code cfunct cstruct methods tcltype tclprocs 3079 set result {} 3080 if {[info exists code(header)]} { 3081 ::practcl::cputs result $code(header) 3082 } 3083 ::practcl::debug [list cfunct [info exists cfunct]] 3084 if {[info exists cfunct]} { 3085 foreach {funcname info} $cfunct { 3086 if {[dict get $info public]} continue 3087 ::practcl::cputs result "[dict get $info header]\;" 3088 } 3089 } 3090 ::practcl::debug [list tclprocs [info exists tclprocs]] 3091 if {[info exists tclprocs]} { 3092 foreach {name info} $tclprocs { 3093 if {[dict exists $info header]} { 3094 ::practcl::cputs result "[dict get $info header]\;" 3095 } 3096 } 3097 } 3098 ::practcl::debug [list methods [info exists methods] [my define get cclass]] 3099 if {[info exists methods]} { 3100 set thisclass [my define get cclass] 3101 foreach {name info} $methods { 3102 if {[dict exists $info header]} { 3103 ::practcl::cputs result "[dict get $info header]\;" 3104 } 3105 } 3106 # Add the initializer wrapper for the class 3107 ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp)\;" 3108 } 3109 foreach obj [my link list product] { 3110 # Exclude products that will generate their own C files 3111 if {[$obj define get output_c] ne {}} continue 3112 set dat [$obj generate-cfile-header] 3113 if {[string length [string trim $dat]]} { 3114 ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" 3115 ::practcl::cputs result $dat 3116 ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" 3117 } 3118 } 3119 return $result 3120 } 3121 3122 ### 3123 # Generate code that provides implements Tcl API 3124 # calls 3125 ### 3126 method generate-cfile-tclapi {} { 3127 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3128 my variable code methods tclprocs 3129 set result {} 3130 if {[info exists code(method)]} { 3131 ::practcl::cputs result $code(method) 3132 } 3133 3134 if {[info exists tclprocs]} { 3135 foreach {name info} $tclprocs { 3136 if {![dict exists $info body]} continue 3137 set callproc [dict get $info callproc] 3138 set header [dict get $info header] 3139 set body [dict get $info body] 3140 ::practcl::cputs result "/* Tcl Proc $name */" 3141 ::practcl::cputs result "${header} \{${body}\}" 3142 } 3143 } 3144 3145 3146 if {[info exists methods]} { 3147 set thisclass [my define get cclass] 3148 foreach {name info} $methods { 3149 if {![dict exists $info body]} continue 3150 set callproc [dict get $info callproc] 3151 set header [dict get $info header] 3152 set body [dict get $info body] 3153 ::practcl::cputs result "/* OO Method $thisclass $name */" 3154 ::practcl::cputs result "${header} \{${body}\}" 3155 } 3156 # Build the OO_Init function 3157 ::practcl::cputs result "/* Loader for $thisclass */" 3158 ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp) \{" 3159 ::practcl::cputs result [string map [list @CCLASS@ $thisclass @TCLCLASS@ [my define get class]] { 3160 /* 3161 ** Build the "@TCLCLASS@" class 3162 */ 3163 Tcl_Obj* nameObj; /* Name of a class or method being looked up */ 3164 Tcl_Object curClassObject; /* Tcl_Object representing the current class */ 3165 Tcl_Class curClass; /* Tcl_Class representing the current class */ 3166 3167 /* 3168 * Find the "@TCLCLASS@" class, and attach an 'init' method to it. 3169 */ 3170 3171 nameObj = Tcl_NewStringObj("@TCLCLASS@", -1); 3172 Tcl_IncrRefCount(nameObj); 3173 if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { 3174 Tcl_DecrRefCount(nameObj); 3175 return TCL_ERROR; 3176 } 3177 Tcl_DecrRefCount(nameObj); 3178 curClass = Tcl_GetObjectAsClass(curClassObject); 3179}] 3180 if {[dict exists $methods constructor]} { 3181 set mtype [dict get $methods constructor methodtype] 3182 ::practcl::cputs result [string map [list @MTYPE@ $mtype] { 3183 /* Attach the constructor to the class */ 3184 Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &@MTYPE@, NULL)); 3185 }] 3186 } 3187 foreach {name info} $methods { 3188 dict with info {} 3189 if {$name in {constructor destructor}} continue 3190 ::practcl::cputs result [string map [list @NAME@ $name @MTYPE@ $methodtype] { 3191 nameObj=Tcl_NewStringObj("@NAME@",-1); 3192 Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); 3193 Tcl_DecrRefCount(nameObj); 3194}] 3195 if {[dict exists $info aliases]} { 3196 foreach alias [dict get $info aliases] { 3197 if {[dict exists $methods $alias]} continue 3198 ::practcl::cputs result [string map [list @NAME@ $alias @MTYPE@ $methodtype] { 3199 nameObj=Tcl_NewStringObj("@NAME@",-1); 3200 Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); 3201 Tcl_DecrRefCount(nameObj); 3202}] 3203 } 3204 } 3205 } 3206 ::practcl::cputs result " return TCL_OK\;\n\}\n" 3207 } 3208 foreach obj [my link list product] { 3209 # Exclude products that will generate their own C files 3210 if {[$obj define get output_c] ne {}} continue 3211 ::practcl::cputs result [$obj generate-cfile-tclapi] 3212 } 3213 return $result 3214 } 3215 3216 ### 3217 # Generate code that runs when the package/module is 3218 # initialized into the interpreter 3219 ### 3220 method generate-loader-module {} { 3221 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3222 set result {} 3223 my variable code methods tclprocs 3224 if {[info exists code(nspace)]} { 3225 ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" 3226 foreach nspace $code(nspace) { 3227 ::practcl::cputs result [string map [list @NSPACE@ $nspace] { 3228 modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); 3229 if(!modPtr) { 3230 modPtr = Tcl_CreateNamespace(interp, "@NSPACE@", NULL, NULL); 3231 } 3232}] 3233 } 3234 ::practcl::cputs result " \}" 3235 } 3236 if {[info exists code(tclinit)]} { 3237 ::practcl::cputs result $code(tclinit) 3238 } 3239 if {[info exists code(cinit)]} { 3240 ::practcl::cputs result $code(cinit) 3241 } 3242 if {[info exists code(initfuncts)]} { 3243 foreach func $code(initfuncts) { 3244 ::practcl::cputs result " if (${func}(interp) != TCL_OK) return TCL_ERROR\;" 3245 } 3246 } 3247 if {[info exists tclprocs]} { 3248 foreach {name info} $tclprocs { 3249 set map [list @NAME@ $name @CALLPROC@ [dict get $info callproc]] 3250 ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] 3251 if {[dict exists $info aliases]} { 3252 foreach alias [dict get $info aliases] { 3253 set map [list @NAME@ $alias @CALLPROC@ [dict get $info callproc]] 3254 ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] 3255 } 3256 } 3257 } 3258 } 3259 3260 if {[info exists code(nspace)]} { 3261 ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" 3262 foreach nspace $code(nspace) { 3263 ::practcl::cputs result [string map [list @NSPACE@ $nspace] { 3264 modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); 3265 Tcl_CreateEnsemble(interp, modPtr->fullName, modPtr, TCL_ENSEMBLE_PREFIX); 3266 Tcl_Export(interp, modPtr, "[a-z]*", 1); 3267}] 3268 } 3269 ::practcl::cputs result " \}" 3270 } 3271 set result [::practcl::_tagblock $result c [my define get filename]] 3272 foreach obj [my link list product] { 3273 # Exclude products that will generate their own C files 3274 if {[$obj define get output_c] ne {}} { 3275 ::practcl::cputs result [$obj generate-loader-external] 3276 } else { 3277 ::practcl::cputs result [$obj generate-loader-module] 3278 } 3279 } 3280 return $result 3281 } 3282 3283 method Collate_Source CWD { 3284 my variable methods code cstruct tclprocs 3285 if {[info exists methods]} { 3286 ::practcl::debug [self] methods [my define get cclass] 3287 set thisclass [my define get cclass] 3288 foreach {name info} $methods { 3289 # Provide a callproc 3290 if {![dict exists $info callproc]} { 3291 set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} OOMethod_${thisclass}_${name}]] 3292 dict set methods $name callproc $callproc 3293 } else { 3294 set callproc [dict get $info callproc] 3295 } 3296 if {[dict exists $info body] && ![dict exists $info header]} { 3297 dict set methods $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext ,int objc ,Tcl_Obj *const *objv)" 3298 } 3299 if {![dict exists $info methodtype]} { 3300 set methodtype [string map {{ } _ : _} OOMethodType_${thisclass}_${name}] 3301 dict set methods $name methodtype $methodtype 3302 } 3303 } 3304 if {![info exists code(initfuncts)] || "${thisclass}_OO_Init" ni $code(initfuncts)} { 3305 lappend code(initfuncts) "${thisclass}_OO_Init" 3306 } 3307 } 3308 set thisnspace [my define get nspace] 3309 3310 if {[info exists tclprocs]} { 3311 ::practcl::debug [self] tclprocs [dict keys $tclprocs] 3312 foreach {name info} $tclprocs { 3313 if {![dict exists $info callproc]} { 3314 set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} TclCmd_${thisnspace}_${name}]] 3315 dict set tclprocs $name callproc $callproc 3316 } else { 3317 set callproc [dict get $info callproc] 3318 } 3319 if {[dict exists $info body] && ![dict exists $info header]} { 3320 dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])" 3321 } 3322 } 3323 } 3324 } 3325 3326 # Once an object marks itself as some 3327 # flavor of dynamic, stop trying to morph 3328 # it into something else 3329 method select {} {} 3330 3331} 3332 3333 3334 3335### 3336# END: class dynamic.tcl 3337### 3338### 3339# START: class product.tcl 3340### 3341 3342::oo::class create ::practcl::product { 3343 3344 3345 method code {section body} { 3346 my variable code 3347 ::practcl::cputs code($section) $body 3348 } 3349 3350 method Collate_Source CWD {} 3351 3352 method project-compile-products {} { 3353 set result {} 3354 noop { 3355 set filename [my define get filename] 3356 if {$filename ne {}} { 3357 ::practcl::debug [self] [self class] [self method] project-compile-products $filename 3358 if {[my define exists ofile]} { 3359 set ofile [my define get ofile] 3360 } else { 3361 set ofile [my Ofile $filename] 3362 my define set ofile $ofile 3363 } 3364 lappend result $ofile [list cfile $filename include [my define get include] extra [my define get extra] external [string is true -strict [my define get external]] object [self]] 3365 } 3366 } 3367 foreach item [my link list subordinate] { 3368 lappend result {*}[$item project-compile-products] 3369 } 3370 return $result 3371 } 3372 3373 method generate-debug {{spaces {}}} { 3374 set result {} 3375 ::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my define get filename]] links [my link list]]" 3376 foreach item [my link list subordinate] { 3377 practcl::cputs result [$item generate-debug "$spaces "] 3378 } 3379 return $result 3380 } 3381 3382 method generate-cfile-constant {} { 3383 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3384 set result {} 3385 my variable code cstruct methods tcltype 3386 if {[info exists code(constant)]} { 3387 ::practcl::cputs result "/* [my define get filename] CONSTANT */" 3388 ::practcl::cputs result $code(constant) 3389 } 3390 foreach obj [my link list product] { 3391 # Exclude products that will generate their own C files 3392 if {[$obj define get output_c] ne {}} continue 3393 ::practcl::cputs result [$obj generate-cfile-constant] 3394 } 3395 return $result 3396 } 3397 3398 ### 3399 # Populate const static data structures 3400 ### 3401 method generate-cfile-public-structure {} { 3402 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3403 my variable code cstruct methods tcltype 3404 set result {} 3405 if {[info exists code(struct)]} { 3406 ::practcl::cputs result $code(struct) 3407 } 3408 foreach obj [my link list product] { 3409 # Exclude products that will generate their own C files 3410 if {[$obj define get output_c] ne {}} continue 3411 ::practcl::cputs result [$obj generate-cfile-public-structure] 3412 } 3413 return $result 3414 } 3415 3416 method generate-cfile-header {} { 3417 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3418 my variable code cfunct cstruct methods tcltype tclprocs 3419 set result {} 3420 if {[info exists code(header)]} { 3421 ::practcl::cputs result $code(header) 3422 } 3423 foreach obj [my link list product] { 3424 # Exclude products that will generate their own C files 3425 if {[$obj define get output_c] ne {}} continue 3426 set dat [$obj generate-cfile-header] 3427 if {[string length [string trim $dat]]} { 3428 ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" 3429 ::practcl::cputs result $dat 3430 ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" 3431 } 3432 } 3433 return $result 3434 } 3435 3436 method generate-cfile-global {} { 3437 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3438 my variable code cfunct cstruct methods tcltype tclprocs 3439 set result {} 3440 if {[info exists code(global)]} { 3441 ::practcl::cputs result $code(global) 3442 } 3443 foreach obj [my link list product] { 3444 # Exclude products that will generate their own C files 3445 if {[$obj define get output_c] ne {}} continue 3446 set dat [$obj generate-cfile-global] 3447 if {[string length [string trim $dat]]} { 3448 ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-global */" 3449 ::practcl::cputs result $dat 3450 ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-global */" 3451 } 3452 } 3453 return $result 3454 } 3455 3456 method generate-cfile-private-typedef {} { 3457 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3458 my variable code cstruct 3459 set result {} 3460 if {[info exists code(private-typedef)]} { 3461 ::practcl::cputs result $code(private-typedef) 3462 } 3463 if {[info exists cstruct]} { 3464 # Add defintion for native c data structures 3465 foreach {name info} $cstruct { 3466 if {[dict get $info public]==1} continue 3467 ::practcl::cputs result "typedef struct $name ${name}\;" 3468 if {[dict exists $info aliases]} { 3469 foreach n [dict get $info aliases] { 3470 ::practcl::cputs result "typedef struct $name ${n}\;" 3471 } 3472 } 3473 } 3474 } 3475 set result [::practcl::_tagblock $result c [my define get filename]] 3476 foreach mod [my link list product] { 3477 ::practcl::cputs result [$mod generate-cfile-private-typedef] 3478 } 3479 return $result 3480 } 3481 3482 method generate-cfile-private-structure {} { 3483 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3484 my variable code cstruct 3485 set result {} 3486 if {[info exists code(private-structure)]} { 3487 ::practcl::cputs result $code(private-structure) 3488 } 3489 if {[info exists cstruct]} { 3490 foreach {name info} $cstruct { 3491 if {[dict get $info public]==1} continue 3492 if {[dict exists $info comment]} { 3493 ::practcl::cputs result [dict get $info comment] 3494 } 3495 ::practcl::cputs result "struct $name \{[dict get $info body]\}\;" 3496 } 3497 } 3498 set result [::practcl::_tagblock $result c [my define get filename]] 3499 foreach mod [my link list product] { 3500 ::practcl::cputs result [$mod generate-cfile-private-structure] 3501 } 3502 return $result 3503 } 3504 3505 3506 ### 3507 # Generate code that provides subroutines called by 3508 # Tcl API methods 3509 ### 3510 method generate-cfile-functions {} { 3511 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3512 my variable code cfunct 3513 set result {} 3514 if {[info exists code(funct)]} { 3515 ::practcl::cputs result $code(funct) 3516 } 3517 if {[info exists cfunct]} { 3518 foreach {funcname info} $cfunct { 3519 ::practcl::cputs result "/* $funcname */" 3520 if {[dict get $info inline] && [dict get $info public]} { 3521 ::practcl::cputs result "\ninline [dict get $info header]\{[dict get $info body]\}" 3522 } else { 3523 ::practcl::cputs result "\n[dict get $info header]\{[dict get $info body]\}" 3524 } 3525 } 3526 } 3527 foreach obj [my link list product] { 3528 # Exclude products that will generate their own C files 3529 if {[$obj define get output_c] ne {}} { 3530 continue 3531 } 3532 ::practcl::cputs result [$obj generate-cfile-functions] 3533 } 3534 return $result 3535 } 3536 3537 ### 3538 # Generate code that provides implements Tcl API 3539 # calls 3540 ### 3541 method generate-cfile-tclapi {} { 3542 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3543 my variable code methods tclprocs 3544 set result {} 3545 if {[info exists code(method)]} { 3546 ::practcl::cputs result $code(method) 3547 } 3548 foreach obj [my link list product] { 3549 # Exclude products that will generate their own C files 3550 if {[$obj define get output_c] ne {}} continue 3551 ::practcl::cputs result [$obj generate-cfile-tclapi] 3552 } 3553 return $result 3554 } 3555 3556 3557 method generate-hfile-public-define {} { 3558 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3559 my variable code 3560 set result {} 3561 if {[info exists code(public-define)]} { 3562 ::practcl::cputs result $code(public-define) 3563 } 3564 set result [::practcl::_tagblock $result c [my define get filename]] 3565 foreach mod [my link list product] { 3566 ::practcl::cputs result [$mod generate-hfile-public-define] 3567 } 3568 return $result 3569 } 3570 3571 method generate-hfile-public-macro {} { 3572 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3573 my variable code 3574 set result {} 3575 if {[info exists code(public-macro)]} { 3576 ::practcl::cputs result $code(public-macro) 3577 } 3578 set result [::practcl::_tagblock $result c [my define get filename]] 3579 foreach mod [my link list product] { 3580 ::practcl::cputs result [$mod generate-hfile-public-macro] 3581 } 3582 return $result 3583 } 3584 3585 method generate-hfile-public-typedef {} { 3586 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3587 my variable code cstruct 3588 set result {} 3589 if {[info exists code(public-typedef)]} { 3590 ::practcl::cputs result $code(public-typedef) 3591 } 3592 if {[info exists cstruct]} { 3593 # Add defintion for native c data structures 3594 foreach {name info} $cstruct { 3595 if {[dict get $info public]==0} continue 3596 ::practcl::cputs result "typedef struct $name ${name}\;" 3597 if {[dict exists $info aliases]} { 3598 foreach n [dict get $info aliases] { 3599 ::practcl::cputs result "typedef struct $name ${n}\;" 3600 } 3601 } 3602 } 3603 } 3604 set result [::practcl::_tagblock $result c [my define get filename]] 3605 foreach mod [my link list product] { 3606 ::practcl::cputs result [$mod generate-hfile-public-typedef] 3607 } 3608 return $result 3609 } 3610 3611 method generate-hfile-public-structure {} { 3612 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3613 my variable code cstruct 3614 set result {} 3615 if {[info exists code(public-structure)]} { 3616 ::practcl::cputs result $code(public-structure) 3617 } 3618 if {[info exists cstruct]} { 3619 foreach {name info} $cstruct { 3620 if {[dict get $info public]==0} continue 3621 if {[dict exists $info comment]} { 3622 ::practcl::cputs result [dict get $info comment] 3623 } 3624 ::practcl::cputs result "struct $name \{[dict get $info body]\}\;" 3625 } 3626 } 3627 set result [::practcl::_tagblock $result c [my define get filename]] 3628 foreach mod [my link list product] { 3629 ::practcl::cputs result [$mod generate-hfile-public-structure] 3630 } 3631 return $result 3632 } 3633 3634 method generate-hfile-public-headers {} { 3635 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3636 my variable code tcltype 3637 set result {} 3638 if {[info exists code(public-header)]} { 3639 ::practcl::cputs result $code(public-header) 3640 } 3641 if {[info exists tcltype]} { 3642 foreach {type info} $tcltype { 3643 if {![dict exists $info cname]} { 3644 set cname [string tolower ${type}]_tclobjtype 3645 dict set tcltype $type cname $cname 3646 } else { 3647 set cname [dict get $info cname] 3648 } 3649 ::practcl::cputs result "extern const Tcl_ObjType $cname\;" 3650 } 3651 } 3652 if {[info exists code(public)]} { 3653 ::practcl::cputs result $code(public) 3654 } 3655 set result [::practcl::_tagblock $result c [my define get filename]] 3656 foreach mod [my link list product] { 3657 ::practcl::cputs result [$mod generate-hfile-public-headers] 3658 } 3659 return $result 3660 } 3661 3662 method generate-hfile-public-function {} { 3663 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3664 my variable code cfunct tcltype 3665 set result {} 3666 3667 if {[my define get initfunc] ne {}} { 3668 ::practcl::cputs result "int [my define get initfunc](Tcl_Interp *interp);" 3669 } 3670 if {[info exists cfunct]} { 3671 foreach {funcname info} $cfunct { 3672 if {![dict get $info public]} continue 3673 ::practcl::cputs result "[dict get $info header]\;" 3674 } 3675 } 3676 set result [::practcl::_tagblock $result c [my define get filename]] 3677 foreach mod [my link list product] { 3678 ::practcl::cputs result [$mod generate-hfile-public-function] 3679 } 3680 return $result 3681 } 3682 3683 method generate-hfile-public-includes {} { 3684 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3685 set includes {} 3686 foreach item [my define get public-include] { 3687 if {$item ni $includes} { 3688 lappend includes $item 3689 } 3690 } 3691 foreach mod [my link list product] { 3692 foreach item [$mod generate-hfile-public-includes] { 3693 if {$item ni $includes} { 3694 lappend includes $item 3695 } 3696 } 3697 } 3698 return $includes 3699 } 3700 3701 method generate-hfile-public-verbatim {} { 3702 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3703 set includes {} 3704 foreach item [my define get public-verbatim] { 3705 if {$item ni $includes} { 3706 lappend includes $item 3707 } 3708 } 3709 foreach mod [my link list subordinate] { 3710 foreach item [$mod generate-hfile-public-verbatim] { 3711 if {$item ni $includes} { 3712 lappend includes $item 3713 } 3714 } 3715 } 3716 return $includes 3717 } 3718 3719 method generate-loader-external {} { 3720 if {[my define get initfunc] eq {}} { 3721 return "/* [my define get filename] declared not initfunc */" 3722 } 3723 return " if([my define get initfunc](interp)) return TCL_ERROR\;" 3724 } 3725 3726 method generate-loader-module {} { 3727 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3728 my variable code 3729 set result {} 3730 if {[info exists code(cinit)]} { 3731 ::practcl::cputs result $code(cinit) 3732 } 3733 if {[my define get initfunc] ne {}} { 3734 ::practcl::cputs result " if([my define get initfunc](interp)!=TCL_OK) return TCL_ERROR\;" 3735 } 3736 set result [::practcl::_tagblock $result c [my define get filename]] 3737 foreach item [my link list product] { 3738 if {[$item define get output_c] ne {}} { 3739 ::practcl::cputs result [$item generate-loader-external] 3740 } else { 3741 ::practcl::cputs result [$item generate-loader-module] 3742 } 3743 } 3744 return $result 3745 } 3746 3747 method generate-stub-function {} { 3748 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3749 my variable code cfunct tcltype 3750 set result {} 3751 foreach mod [my link list product] { 3752 foreach {funct def} [$mod generate-stub-function] { 3753 dict set result $funct $def 3754 } 3755 } 3756 if {[info exists cfunct]} { 3757 foreach {funcname info} $cfunct { 3758 if {![dict get $info export]} continue 3759 dict set result $funcname [dict get $info header] 3760 } 3761 } 3762 return $result 3763 } 3764 3765 3766 method IncludeAdd {headervar args} { 3767 upvar 1 $headervar headers 3768 foreach inc $args { 3769 if {[string index $inc 0] ni {< \"}} { 3770 set inc "\"$inc\"" 3771 } 3772 if {$inc ni $headers} { 3773 lappend headers $inc 3774 } 3775 } 3776 } 3777 3778 method generate-tcl-loader {} { 3779 set result {} 3780 set PKGINIT [my define get pkginit] 3781 set PKG_NAME [my define get name [my define get pkg_name]] 3782 set PKG_VERSION [my define get pkg_vers [my define get version]] 3783 if {[string is true [my define get SHARED_BUILD 0]]} { 3784 set LIBFILE [my define get libfile] 3785 ::practcl::cputs result [string map \ 3786 [list @LIBFILE@ $LIBFILE @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { 3787# Shared Library Style 3788load [file join [file dirname [file join [pwd] [info script]]] @LIBFILE@] @PKGINIT@ 3789package provide @PKG_NAME@ @PKG_VERSION@ 3790}] 3791 } else { 3792 ::practcl::cputs result [string map \ 3793 [list @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { 3794# Tclkit Style 3795load {} @PKGINIT@ 3796package provide @PKG_NAME@ @PKG_VERSION@ 3797}] 3798 } 3799 return $result 3800 } 3801 3802 ### 3803 # This methods generates any Tcl script file 3804 # which is required to pre-initialize the C library 3805 ### 3806 method generate-tcl-pre {} { 3807 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3808 set result {} 3809 my variable code 3810 if {[info exists code(tcl)]} { 3811 set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] 3812 } 3813 if {[info exists code(tcl-pre)]} { 3814 set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] 3815 } 3816 foreach mod [my link list product] { 3817 ::practcl::cputs result [$mod generate-tcl-pre] 3818 } 3819 return $result 3820 } 3821 3822 method generate-tcl-post {} { 3823 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3824 set result {} 3825 my variable code 3826 if {[info exists code(tcl-post)]} { 3827 set result [::practcl::_tagblock $code(tcl-post) tcl [my define get filename]] 3828 } 3829 foreach mod [my link list product] { 3830 ::practcl::cputs result [$mod generate-tcl-post] 3831 } 3832 return $result 3833 } 3834 3835 3836 method linktype {} { 3837 return {subordinate product} 3838 } 3839 3840 method Ofile filename { 3841 set lpath [my <module> define get localpath] 3842 if {$lpath eq {}} { 3843 set lpath [my <module> define get name] 3844 } 3845 return ${lpath}_[file rootname [file tail $filename]] 3846 } 3847 3848 ### 3849 # Methods called by the master project 3850 ### 3851 3852 method project-static-packages {} { 3853 set result [my define get static_packages] 3854 set initfunc [my define get initfunc] 3855 if {$initfunc ne {}} { 3856 set pkg_name [my define get pkg_name] 3857 if {$pkg_name ne {}} { 3858 dict set result $pkg_name initfunc $initfunc 3859 dict set result $pkg_name version [my define get version [my define get pkg_vers]] 3860 dict set result $pkg_name autoload [my define get autoload 0] 3861 } 3862 } 3863 foreach item [my link list subordinate] { 3864 foreach {pkg info} [$item project-static-packages] { 3865 dict set result $pkg $info 3866 } 3867 } 3868 return $result 3869 } 3870 3871 ### 3872 # Methods called by the toolset 3873 ### 3874 3875 method toolset-include-directory {} { 3876 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 3877 set result [my define get include_dir] 3878 foreach obj [my link list product] { 3879 foreach path [$obj toolset-include-directory] { 3880 lappend result $path 3881 } 3882 } 3883 return $result 3884 } 3885 3886 method target {method args} { 3887 switch $method { 3888 is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } 3889 } 3890 } 3891 3892} 3893 3894oo::objdefine ::practcl::product { 3895 method select {object} { 3896 set class [$object define get class] 3897 set mixin [$object define get product] 3898 if {$class eq {} && $mixin eq {}} { 3899 set filename [$object define get filename] 3900 if {$filename ne {} && [file exists $filename]} { 3901 switch [file extension $filename] { 3902 .tcl { 3903 set mixin ::practcl::product.dynamic 3904 } 3905 .h { 3906 set mixin ::practcl::product.cheader 3907 } 3908 .c { 3909 set mixin ::practcl::product.csource 3910 } 3911 .ini { 3912 switch [file tail $filename] { 3913 module.ini { 3914 set class ::practcl::module 3915 } 3916 library.ini { 3917 set class ::practcl::subproject 3918 } 3919 } 3920 } 3921 .so - 3922 .dll - 3923 .dylib - 3924 .a { 3925 set mixin ::practcl::product.clibrary 3926 } 3927 } 3928 } 3929 } 3930 if {$class ne {}} { 3931 $object morph $class 3932 } 3933 if {$mixin ne {}} { 3934 $object mixin product $mixin 3935 } 3936 } 3937} 3938 3939### 3940# Flesh out several trivial varieties of product 3941### 3942::oo::class create ::practcl::product.cheader { 3943 superclass ::practcl::product 3944 3945 method project-compile-products {} {} 3946 method generate-loader-module {} {} 3947} 3948 3949::oo::class create ::practcl::product.csource { 3950 superclass ::practcl::product 3951 3952 method project-compile-products {} { 3953 set result {} 3954 set filename [my define get filename] 3955 if {$filename ne {}} { 3956 ::practcl::debug [self] [self class] [self method] project-compile-products $filename 3957 if {[my define exists ofile]} { 3958 set ofile [my define get ofile] 3959 } else { 3960 set ofile [my Ofile $filename] 3961 my define set ofile $ofile 3962 } 3963 lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]] object [self]] 3964 } 3965 foreach item [my link list subordinate] { 3966 lappend result {*}[$item project-compile-products] 3967 } 3968 return $result 3969 } 3970} 3971 3972::oo::class create ::practcl::product.clibrary { 3973 superclass ::practcl::product 3974 3975 method linker-products {configdict} { 3976 return [my define get filename] 3977 } 3978 3979} 3980 3981::oo::class create ::practcl::product.dynamic { 3982 superclass ::practcl::dynamic ::practcl::product 3983 3984 method initialize {} { 3985 set filename [my define get filename] 3986 if {$filename eq {}} { 3987 return 3988 } 3989 if {[my define get name] eq {}} { 3990 my define set name [file tail [file rootname $filename]] 3991 } 3992 if {[my define get localpath] eq {}} { 3993 my define set localpath [my <module> define get localpath]_[my define get name] 3994 } 3995 # Future Development: 3996 # Scan source file to see if it is encoded in criticl or practcl notation 3997 #set thisline {} 3998 #foreach line [split [::practcl::cat $filename] \n] { 3999 # 4000 #} 4001 ::source $filename 4002 if {[my define get output_c] ne {}} { 4003 # Turn into a module if we have an output_c file 4004 my morph ::practcl::module 4005 } 4006 } 4007} 4008 4009::oo::class create ::practcl::product.critcl { 4010 superclass ::practcl::dynamic ::practcl::product 4011} 4012 4013 4014### 4015# END: class product.tcl 4016### 4017### 4018# START: class module.tcl 4019### 4020 4021### 4022# In the end, all C code must be loaded into a module 4023# This will either be a dynamically loaded library implementing 4024# a tcl extension, or a compiled in segment of a custom shell/app 4025### 4026::oo::class create ::practcl::module { 4027 superclass ::practcl::object ::practcl::product.dynamic 4028 4029 method _MorphPatterns {} { 4030 return {{@name@} {::practcl::module.@name@} ::practcl::module} 4031 } 4032 4033 method add args { 4034 my variable links 4035 set object [::practcl::object new [self] {*}$args] 4036 foreach linktype [$object linktype] { 4037 lappend links($linktype) $object 4038 } 4039 return $object 4040 } 4041 4042 4043 method install-headers args {} 4044 4045 ### 4046 # Target handling 4047 ### 4048 method make {command args} { 4049 my variable make_object 4050 if {![info exists make_object]} { 4051 set make_object {} 4052 } 4053 switch $command { 4054 pkginfo { 4055 ### 4056 # Build local variables needed for install 4057 ### 4058 package require platform 4059 set result {} 4060 set dat [my define dump] 4061 set PKG_DIR [dict get $dat name][dict get $dat version] 4062 dict set result PKG_DIR $PKG_DIR 4063 dict with dat {} 4064 if {![info exists DESTDIR]} { 4065 set DESTDIR {} 4066 } 4067 dict set result profile [::platform::identify] 4068 dict set result os $::tcl_platform(os) 4069 dict set result platform $::tcl_platform(platform) 4070 foreach {field value} $dat { 4071 switch $field { 4072 includedir - 4073 mandir - 4074 datadir - 4075 libdir - 4076 libfile - 4077 name - 4078 output_tcl - 4079 version - 4080 authors - 4081 license - 4082 requires { 4083 dict set result $field $value 4084 } 4085 TEA_PLATFORM { 4086 dict set result platform $value 4087 } 4088 TEACUP_OS { 4089 dict set result os $value 4090 } 4091 TEACUP_PROFILE { 4092 dict set result profile $value 4093 } 4094 TEACUP_ZIPFILE { 4095 dict set result zipfile $value 4096 } 4097 } 4098 } 4099 if {![dict exists $result zipfile]} { 4100 dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip" 4101 } 4102 return $result 4103 } 4104 objects { 4105 return $make_object 4106 } 4107 object { 4108 set name [lindex $args 0] 4109 if {[dict exists $make_object $name]} { 4110 return [dict get $make_object $name] 4111 } 4112 return {} 4113 } 4114 reset { 4115 foreach {name obj} $make_object { 4116 $obj reset 4117 } 4118 } 4119 trigger { 4120 foreach {name obj} $make_object { 4121 if {$name in $args} { 4122 $obj triggers 4123 } 4124 } 4125 } 4126 depends { 4127 foreach {name obj} $make_object { 4128 if {$name in $args} { 4129 $obj check 4130 } 4131 } 4132 } 4133 filename { 4134 set name [lindex $args 0] 4135 if {[dict exists $make_object $name]} { 4136 return [[dict get $make_object $name] define get filename] 4137 } 4138 } 4139 task - 4140 target - 4141 add { 4142 set name [lindex $args 0] 4143 set info [uplevel #0 [list subst [lindex $args 1]]] 4144 set body [lindex $args 2] 4145 4146 set nspace [namespace current] 4147 if {[dict exist $make_object $name]} { 4148 set obj [dict get $$make_object $name] 4149 } else { 4150 set obj [::practcl::make_obj new [self] $name $info $body] 4151 dict set make_object $name $obj 4152 dict set target_make $name 0 4153 dict set target_trigger $name 0 4154 } 4155 if {[dict exists $info aliases]} { 4156 foreach item [dict get $info aliases] { 4157 if {![dict exists $make_object $item]} { 4158 dict set make_object $item $obj 4159 } 4160 } 4161 } 4162 return $obj 4163 } 4164 todo { 4165 foreach {name obj} $make_object { 4166 if {[$obj do]} { 4167 lappend result $name 4168 } 4169 } 4170 } 4171 do { 4172 global CWD SRCDIR project SANDBOX 4173 foreach {name obj} $make_object { 4174 if {[$obj do]} { 4175 eval [$obj define get action] 4176 } 4177 } 4178 } 4179 } 4180 } 4181 4182 method child which { 4183 switch $which { 4184 organs { 4185 return [list project [my define get project] module [self]] 4186 } 4187 } 4188 } 4189 4190 ### 4191 # This methods generates the contents of an amalgamated .c file 4192 # which implements the loader for a batch of tools 4193 ### 4194 method generate-c {} { 4195 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 4196 set result { 4197/* This file was generated by practcl */ 4198 } 4199 set includes {} 4200 4201 foreach mod [my link list product] { 4202 # Signal modules to formulate final implementation 4203 $mod go 4204 } 4205 set headers {} 4206 4207 my IncludeAdd headers <tcl.h> <tclOO.h> 4208 if {[my define get tk 0]} { 4209 my IncludeAdd headers <tk.h> 4210 } 4211 if {[my define get output_h] ne {}} { 4212 my IncludeAdd headers [my define get output_h] 4213 } 4214 my IncludeAdd headers {*}[my define get include] 4215 4216 foreach mod [my link list dynamic] { 4217 my IncludeAdd headers {*}[$mod define get include] 4218 } 4219 foreach inc $headers { 4220 ::practcl::cputs result "#include $inc" 4221 } 4222 foreach {method} { 4223 generate-cfile-header 4224 generate-cfile-private-typedef 4225 generate-cfile-private-structure 4226 generate-cfile-public-structure 4227 generate-cfile-constant 4228 generate-cfile-global 4229 generate-cfile-functions 4230 generate-cfile-tclapi 4231 } { 4232 set dat [my $method] 4233 if {[string length [string trim $dat]]} { 4234 ::practcl::cputs result "/* BEGIN $method [my define get filename] */" 4235 ::practcl::cputs result $dat 4236 ::practcl::cputs result "/* END $method [my define get filename] */" 4237 } 4238 } 4239 ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] 4240 return $result 4241 } 4242 4243 4244 ### 4245 # This methods generates the contents of an amalgamated .h file 4246 # which describes the public API of this module 4247 ### 4248 method generate-h {} { 4249 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 4250 set result {} 4251 set includes [my generate-hfile-public-includes] 4252 foreach inc $includes { 4253 if {[string index $inc 0] ni {< \"}} { 4254 ::practcl::cputs result "#include \"$inc\"" 4255 } else { 4256 ::practcl::cputs result "#include $inc" 4257 } 4258 } 4259 4260 foreach method { 4261 generate-hfile-public-define 4262 generate-hfile-public-macro 4263 generate-hfile-public-typedef 4264 generate-hfile-public-structure 4265 } { 4266 ::practcl::cputs result "/* BEGIN SECTION $method */" 4267 ::practcl::cputs result [my $method] 4268 ::practcl::cputs result "/* END SECTION $method */" 4269 } 4270 4271 foreach file [my generate-hfile-public-verbatim] { 4272 ::practcl::cputs result "/* BEGIN $file */" 4273 ::practcl::cputs result [::practcl::cat $file] 4274 ::practcl::cputs result "/* END $file */" 4275 } 4276 4277 foreach method { 4278 generate-hfile-public-headers 4279 generate-hfile-public-function 4280 } { 4281 ::practcl::cputs result "/* BEGIN SECTION $method */" 4282 ::practcl::cputs result [my $method] 4283 ::practcl::cputs result "/* END SECTION $method */" 4284 } 4285 return $result 4286 } 4287 4288 method generate-loader {} { 4289 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 4290 set result {} 4291 if {[my define get initfunc] eq {}} return 4292 ::practcl::cputs result " 4293extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \{" 4294 ::practcl::cputs result { 4295 /* Initialise the stubs tables. */ 4296 #ifdef USE_TCL_STUBS 4297 if (Tcl_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR; 4298 if (TclOOInitializeStubs(interp, "1.0") == NULL) return TCL_ERROR; 4299} 4300 if {[my define get tk 0]} { 4301 ::practcl::cputs result { if (Tk_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR;} 4302 } 4303 ::practcl::cputs result { #endif} 4304 set TCLINIT [my generate-tcl-pre] 4305 if {[string length [string trim $TCLINIT]]} { 4306 ::practcl::cputs result " if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }" 4307 } 4308 ::practcl::cputs result [my generate-loader-module] 4309 4310 set TCLINIT [my generate-tcl-post] 4311 if {[string length [string trim $TCLINIT]]} { 4312 ::practcl::cputs result " if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }" 4313 } 4314 if {[my define exists pkg_name]} { 4315 ::practcl::cputs result " if (Tcl_PkgProvide(interp, \"[my define get pkg_name [my define get name]]\" , \"[my define get pkg_vers [my define get version]]\" )) return TCL_ERROR\;" 4316 } 4317 ::practcl::cputs result " return TCL_OK\;\n\}\n" 4318 return $result 4319 } 4320 method initialize {} { 4321 set filename [my define get filename] 4322 if {$filename eq {}} { 4323 return 4324 } 4325 if {[my define get name] eq {}} { 4326 my define set name [file tail [file dirname $filename]] 4327 } 4328 if {[my define get localpath] eq {}} { 4329 my define set localpath [my <project> define get name]_[my define get name] 4330 } 4331 my graft module [self] 4332 ::practcl::debug [self] SOURCE $filename 4333 my source $filename 4334 } 4335 4336 method implement path { 4337 my go 4338 my Collate_Source $path 4339 set errs {} 4340 foreach item [my link list dynamic] { 4341 if {[catch {$item implement $path} err errdat]} { 4342 lappend errs "Skipped $item: [$item define get filename] $err" 4343 if {[dict exists $errdat -errorinfo]} { 4344 lappend errs [dict get $errdat -errorinfo] 4345 } else { 4346 lappend errs $errdat 4347 } 4348 } 4349 } 4350 foreach item [my link list module] { 4351 if {[catch {$item implement $path} err errdat]} { 4352 lappend errs "Skipped $item: [$item define get filename] $err" 4353 if {[dict exists $errdat -errorinfo]} { 4354 lappend errs [dict get $errdat -errorinfo] 4355 } else { 4356 lappend errs $errdat 4357 } 4358 } 4359 } 4360 if {[llength $errs]} { 4361 set logfile [file join $::CWD practcl.log] 4362 ::practcl::log $logfile "*** ERRORS ***" 4363 foreach {item trace} $errs { 4364 ::practcl::log $logfile "###\n# ERROR\n###\n$item" 4365 ::practcl::log $logfile "###\n# TRACE\n###\n$trace" 4366 } 4367 ::practcl::log $logfile "*** DEBUG INFO ***" 4368 ::practcl::log $logfile $::DEBUG_INFO 4369 puts stderr "Errors saved to $logfile" 4370 exit 1 4371 } 4372 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 4373 set filename [my define get output_c] 4374 if {$filename eq {}} { 4375 ::practcl::debug [list /[self] [self method] [self class]] 4376 return 4377 } 4378 set cout [open [file join $path [file rootname $filename].c] w] 4379 puts $cout [subst {/* 4380** This file is generated by the [info script] script 4381** any changes will be overwritten the next time it is run 4382*/}] 4383 puts $cout [my generate-c] 4384 puts $cout [my generate-loader] 4385 close $cout 4386 ::practcl::debug [list /[self] [self method] [self class]] 4387 } 4388 4389 method linktype {} { 4390 return {subordinate product dynamic module} 4391 } 4392} 4393 4394### 4395# END: class module.tcl 4396### 4397### 4398# START: class project baseclass.tcl 4399### 4400 4401::oo::class create ::practcl::project { 4402 superclass ::practcl::module 4403 4404 method _MorphPatterns {} { 4405 return {{@name@} {::practcl::@name@} {::practcl::project.@name@} {::practcl::project}} 4406 } 4407 4408 constructor args { 4409 my variable define 4410 if {[llength $args] == 1} { 4411 set rawcontents [lindex $args 0] 4412 } else { 4413 set rawcontents $args 4414 } 4415 if {[catch {uplevel 1 [list subst $rawcontents]} contents]} { 4416 set contents $rawcontents 4417 } 4418 ### 4419 # The first instance of ::practcl::project (or its descendents) 4420 # registers itself as the ::practcl::MAIN. If a project other 4421 # than ::practcl::LOCAL is created, odds are that was the one 4422 # the developer intended to be the main project 4423 ### 4424 if {$::practcl::MAIN eq "::practcl::LOCAL"} { 4425 set ::practcl::MAIN [self] 4426 } 4427 # DEFS fields need to be passed unchanged and unsubstituted 4428 # as we need to preserve their escape characters 4429 foreach field {TCL_DEFS DEFS TK_DEFS} { 4430 if {[dict exists $rawcontents $field]} { 4431 dict set contents $field [dict get $rawcontents $field] 4432 } 4433 } 4434 my graft module [self] 4435 array set define $contents 4436 ::practcl::toolset select [self] 4437 my initialize 4438 } 4439 4440 method add_object object { 4441 my link object $object 4442 } 4443 4444 method add_project {pkg info {oodefine {}}} { 4445 ::practcl::debug [self] add_project $pkg $info 4446 set os [my define get TEACUP_OS] 4447 if {$os eq {}} { 4448 set os [::practcl::os] 4449 my define set os $os 4450 } 4451 set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]] 4452 if {[dict exists $info os] && ($os ni [dict get $info os])} return 4453 # Select which tag to use here. 4454 # For production builds: tag-release 4455 set profile [my define get profile release]: 4456 if {[dict exists $info profile $profile]} { 4457 dict set info tag [dict get $info profile $profile] 4458 } 4459 dict set info USEMSVC [my define get USEMSVC 0] 4460 dict set info debug [my define get debug 0] 4461 set obj [namespace current]::PROJECT.$pkg 4462 if {[info command $obj] eq {}} { 4463 set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0 class subproject.binary] $info]] 4464 } 4465 my link object $obj 4466 oo::objdefine $obj $oodefine 4467 $obj define set masterpath $::CWD 4468 $obj go 4469 return $obj 4470 } 4471 4472 method add_tool {pkg info {oodefine {}}} { 4473 ::practcl::debug [self] add_tool $pkg $info 4474 set info [dict merge [::practcl::local_os] $info] 4475 4476 set os [dict get $info TEACUP_OS] 4477 set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]] 4478 if {[dict exists $info os] && ($os ni [dict get $info os])} return 4479 # Select which tag to use here. 4480 # For production builds: tag-release 4481 set profile [my define get profile release]: 4482 if {[dict exists $info profile $profile]} { 4483 dict set info tag [dict get $info profile $profile] 4484 } 4485 set obj ::practcl::OBJECT::TOOL.$pkg 4486 if {[info command $obj] eq {}} { 4487 set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0] $info]] 4488 } 4489 my link add tool $obj 4490 oo::objdefine $obj $oodefine 4491 $obj define set masterpath $::CWD 4492 $obj go 4493 return $obj 4494 } 4495 4496 method build-tclcore {} { 4497 set os [my define get TEACUP_OS] 4498 set tcl_config_opts [::practcl::platform::tcl_core_options $os] 4499 set tk_config_opts [::practcl::platform::tk_core_options $os] 4500 4501 lappend tcl_config_opts --prefix [my define get prefix] --exec-prefix [my define get prefix] 4502 set tclobj [my tclcore] 4503 if {[my define get debug 0]} { 4504 $tclobj define set debug 1 4505 lappend tcl_config_opts --enable-symbols=true 4506 } 4507 $tclobj define set config_opts $tcl_config_opts 4508 $tclobj go 4509 $tclobj compile 4510 4511 set _TclSrcDir [$tclobj define get localsrcdir] 4512 my define set tclsrcdir $_TclSrcDir 4513 4514 set tkobj [my tkcore] 4515 lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj define get builddir] [$tclobj define get builddir]] 4516 if {[my define get debug 0]} { 4517 $tkobj define set debug 1 4518 lappend tk_config_opts --enable-symbols=true 4519 } 4520 $tkobj define set config_opts $tk_config_opts 4521 $tkobj compile 4522 } 4523 4524 method child which { 4525 switch $which { 4526 organs { 4527 # A library can be a project, it can be a module. Any 4528 # subordinate modules will indicate their existance 4529 return [list project [self] module [self]] 4530 } 4531 } 4532 } 4533 4534 method linktype {} { 4535 return project 4536 } 4537 4538 4539 # Exercise the methods of a sub-object 4540 method project {pkg args} { 4541 set obj [namespace current]::PROJECT.$pkg 4542 if {[llength $args]==0} { 4543 return $obj 4544 } 4545 ${obj} {*}$args 4546 } 4547 4548 4549 method tclcore {} { 4550 if {[info commands [set obj [my organ tclcore]]] ne {}} { 4551 return $obj 4552 } 4553 if {[info commands [set obj [my project TCLCORE]]] ne {}} { 4554 my graft tclcore $obj 4555 return $obj 4556 } 4557 if {[info commands [set obj [my project tcl]]] ne {}} { 4558 my graft tclcore $obj 4559 return $obj 4560 } 4561 if {[info commands [set obj [my tool tcl]]] ne {}} { 4562 my graft tclcore $obj 4563 return $obj 4564 } 4565 # Provide a fallback 4566 set obj [my add_tool tcl { 4567 tag release class subproject.core 4568 fossil_url http://core.tcl.tk/tcl 4569 }] 4570 my graft tclcore $obj 4571 return $obj 4572 } 4573 4574 method tkcore {} { 4575 if {[set obj [my organ tkcore]] ne {}} { 4576 return $obj 4577 } 4578 if {[set obj [my project tk]] ne {}} { 4579 my graft tkcore $obj 4580 return $obj 4581 } 4582 if {[set obj [my tool tk]] ne {}} { 4583 my graft tkcore $obj 4584 return $obj 4585 } 4586 # Provide a fallback 4587 set obj [my add_tool tk { 4588 tag release class tool.core 4589 fossil_url http://core.tcl.tk/tk 4590 }] 4591 my graft tkcore $obj 4592 return $obj 4593 } 4594 4595 method tool {pkg args} { 4596 set obj ::practcl::OBJECT::TOOL.$pkg 4597 if {[llength $args]==0} { 4598 return $obj 4599 } 4600 ${obj} {*}$args 4601 } 4602} 4603 4604### 4605# END: class project baseclass.tcl 4606### 4607### 4608# START: class project library.tcl 4609### 4610 4611::oo::class create ::practcl::library { 4612 superclass ::practcl::project 4613 4614 4615 method clean {PATH} { 4616 set objext [my define get OBJEXT o] 4617 foreach {ofile info} [my project-compile-products] { 4618 if {[file exists [file join $PATH objs $ofile].${objext}]} { 4619 file delete [file join $PATH objs $ofile].${objext} 4620 } 4621 } 4622 foreach ofile [glob -nocomplain [file join $PATH *.${objext}]] { 4623 file delete $ofile 4624 } 4625 foreach ofile [glob -nocomplain [file join $PATH objs *]] { 4626 file delete $ofile 4627 } 4628 set libfile [my define get libfile] 4629 if {[file exists [file join $PATH $libfile]]} { 4630 file delete [file join $PATH $libfile] 4631 } 4632 my implement $PATH 4633 } 4634 4635 method project-compile-products {} { 4636 set result {} 4637 foreach item [my link list subordinate] { 4638 lappend result {*}[$item project-compile-products] 4639 } 4640 set filename [my define get output_c] 4641 if {$filename ne {}} { 4642 ::practcl::debug [self] [self class] [self method] project-compile-products $filename 4643 set ofile [file rootname [file tail $filename]]_main 4644 lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] 4645 } 4646 return $result 4647 } 4648 4649 4650 method go {} { 4651 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 4652 set name [my define getnull name] 4653 if {$name eq {}} { 4654 set name generic 4655 my define name generic 4656 } 4657 if {[my define get tk] eq {@TEA_TK_EXTENSION@}} { 4658 my define set tk 0 4659 } 4660 set output_c [my define getnull output_c] 4661 if {$output_c eq {}} { 4662 set output_c [file rootname $name].c 4663 my define set output_c $output_c 4664 } 4665 set output_h [my define getnull output_h] 4666 if {$output_h eq {}} { 4667 set output_h [file rootname $output_c].h 4668 my define set output_h $output_h 4669 } 4670 set output_tcl [my define getnull output_tcl] 4671 #if {$output_tcl eq {}} { 4672 # set output_tcl [file rootname $output_c].tcl 4673 # my define set output_tcl $output_tcl 4674 #} 4675 #set output_mk [my define getnull output_mk] 4676 #if {$output_mk eq {}} { 4677 # set output_mk [file rootname $output_c].mk 4678 # my define set output_mk $output_mk 4679 #} 4680 set initfunc [my define getnull initfunc] 4681 if {$initfunc eq {}} { 4682 set initfunc [string totitle $name]_Init 4683 my define set initfunc $initfunc 4684 } 4685 set output_decls [my define getnull output_decls] 4686 if {$output_decls eq {}} { 4687 set output_decls [file rootname $output_c].decls 4688 my define set output_decls $output_decls 4689 } 4690 my variable links 4691 foreach {linktype objs} [array get links] { 4692 foreach obj $objs { 4693 $obj go 4694 } 4695 } 4696 ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] 4697 } 4698 4699 4700 method generate-decls {pkgname path} { 4701 ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] 4702 set outfile [file join $path/$pkgname.decls] 4703 4704 ### 4705 # Build the decls file 4706 ## # 4707 set fout [open $outfile w] 4708 puts $fout [subst {### 4709 # $outfile 4710 # 4711 # This file was generated by [info script] 4712 ### 4713 4714library $pkgname 4715interface $pkgname 4716}] 4717 4718 ### 4719 # Generate list of functions 4720 ### 4721 set stubfuncts [my generate-stub-function] 4722 set thisline {} 4723 set functcount 0 4724 foreach {func header} $stubfuncts { 4725 puts $fout [list declare [incr functcount] $header] 4726 } 4727 puts $fout [list export "int [my define get initfunc](Tcl_Inter *interp)"] 4728 puts $fout [list export "char *[string totitle [my define get name]]_InitStubs(Tcl_Inter *interp, char *version, int exact)"] 4729 4730 close $fout 4731 4732 ### 4733 # Build [package]Decls.h 4734 ### 4735 set hout [open [file join $path ${pkgname}Decls.h] w] 4736 close $hout 4737 4738 set cout [open [file join $path ${pkgname}StubInit.c] w] 4739 puts $cout [string map [list %pkgname% $pkgname %PkgName% [string totitle $pkgname]] { 4740#ifndef USE_TCL_STUBS 4741#define USE_TCL_STUBS 4742#endif 4743#undef USE_TCL_STUB_PROCS 4744 4745#include "tcl.h" 4746#include "%pkgname%.h" 4747 4748/* 4749** Ensure that Tdom_InitStubs is built as an exported symbol. The other stub 4750** functions should be built as non-exported symbols. 4751*/ 4752 4753#undef TCL_STORAGE_CLASS 4754#define TCL_STORAGE_CLASS DLLEXPORT 4755 4756%PkgName%Stubs *%pkgname%StubsPtr; 4757 4758 /* 4759 **---------------------------------------------------------------------- 4760 ** 4761 ** %PkgName%_InitStubs -- 4762 ** 4763 ** Checks that the correct version of %PkgName% is loaded and that it 4764 ** supports stubs. It then initialises the stub table pointers. 4765 ** 4766 ** Results: 4767 ** The actual version of %PkgName% that satisfies the request, or 4768 ** NULL to indicate that an error occurred. 4769 ** 4770 ** Side effects: 4771 ** Sets the stub table pointers. 4772 ** 4773 **---------------------------------------------------------------------- 4774 */ 4775 4776char * 4777%PkgName%_InitStubs (Tcl_Interp *interp, char *version, int exact) 4778{ 4779 char *actualVersion; 4780 actualVersion = Tcl_PkgRequireEx(interp, "%pkgname%", version, exact,(ClientData *) &%pkgname%StubsPtr); 4781 if (!actualVersion) { 4782 return NULL; 4783 } 4784 if (!%pkgname%StubsPtr) { 4785 Tcl_SetResult(interp,"This implementation of %PkgName% does not support stubs",TCL_STATIC); 4786 return NULL; 4787 } 4788 return actualVersion; 4789} 4790}] 4791 close $cout 4792 } 4793 4794 method implement path { 4795 my go 4796 my Collate_Source $path 4797 set errs {} 4798 foreach item [my link list dynamic] { 4799 if {[catch {$item implement $path} err errdat]} { 4800 lappend errs "Skipped $item: [$item define get filename] $err" 4801 if {[dict exists $errdat -errorinfo]} { 4802 lappend errs [dict get $errdat -errorinfo] 4803 } else { 4804 lappend errs $errdat 4805 } 4806 } 4807 } 4808 foreach item [my link list module] { 4809 if {[catch {$item implement $path} err errdat]} { 4810 lappend errs "Skipped $item: [$item define get filename] $err" 4811 if {[dict exists $errdat -errorinfo]} { 4812 lappend errs [dict get $errdat -errorinfo] 4813 } else { 4814 lappend errs $errdat 4815 } 4816 } 4817 } 4818 if {[llength $errs]} { 4819 set logfile [file join $::CWD practcl.log] 4820 ::practcl::log $logfile "*** ERRORS ***" 4821 foreach {item trace} $errs { 4822 ::practcl::log $logfile "###\n# ERROR\n###$item" 4823 ::practcl::log $logfile "###\n# TRACE\n###$trace" 4824 } 4825 ::practcl::log $logfile "*** DEBUG INFO ***" 4826 ::practcl::log $logfile $::DEBUG_INFO 4827 puts stderr "Errors saved to $logfile" 4828 exit 1 4829 } 4830 set cout [open [file join $path [my define get output_c]] w] 4831 puts $cout [subst {/* 4832** This file is generated by the [info script] script 4833** any changes will be overwritten the next time it is run 4834*/}] 4835 puts $cout [my generate-c] 4836 puts $cout [my generate-loader] 4837 close $cout 4838 4839 set macro HAVE_[string toupper [file rootname [my define get output_h]]]_H 4840 set hout [open [file join $path [my define get output_h]] w] 4841 puts $hout [subst {/* 4842** This file is generated by the [info script] script 4843** any changes will be overwritten the next time it is run 4844*/}] 4845 puts $hout "#ifndef ${macro}" 4846 puts $hout "#define ${macro} 1" 4847 puts $hout [my generate-h] 4848 puts $hout "#endif" 4849 close $hout 4850 4851 set output_tcl [my define get output_tcl] 4852 if {$output_tcl ne {}} { 4853 set tclout [open [file join $path [my define get output_tcl]] w] 4854 puts $tclout "### 4855# This file is generated by the [info script] script 4856# any changes will be overwritten the next time it is run 4857###" 4858 puts $tclout [my generate-tcl-pre] 4859 puts $tclout [my generate-tcl-loader] 4860 puts $tclout [my generate-tcl-post] 4861 close $tclout 4862 } 4863 } 4864 4865 # Backward compadible call 4866 method generate-make path { 4867 my build-Makefile $path [self] 4868 } 4869 4870 method linktype {} { 4871 return library 4872 } 4873 4874 # Create a "package ifneeded" 4875 # Args are a list of aliases for which this package will answer to 4876 method package-ifneeded {args} { 4877 set result {} 4878 set name [my define get pkg_name [my define get name]] 4879 set version [my define get pkg_vers [my define get version]] 4880 if {$version eq {}} { 4881 set version 0.1a 4882 } 4883 set output_tcl [my define get output_tcl] 4884 if {$output_tcl ne {}} { 4885 set script "\[list source \[file join \$dir $output_tcl\]\]" 4886 } elseif {[string is true -strict [my define get SHARED_BUILD]]} { 4887 set script "\[list load \[file join \$dir [my define get libfile]\] $name\]" 4888 } else { 4889 # Provide a null passthrough 4890 set script "\[list package provide $name $version\]" 4891 } 4892 set result "package ifneeded [list $name] [list $version] $script" 4893 foreach alias $args { 4894 set script "package require $name $version \; package provide $alias $version" 4895 append result \n\n [list package ifneeded $alias $version $script] 4896 } 4897 return $result 4898 } 4899 4900 4901 method shared_library {{filename {}}} { 4902 set name [string tolower [my define get name [my define get pkg_name]]] 4903 set NAME [string toupper $name] 4904 set version [my define get version [my define get pkg_vers]] 4905 set map {} 4906 lappend map %LIBRARY_NAME% $name 4907 lappend map %LIBRARY_VERSION% $version 4908 lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] 4909 lappend map %LIBRARY_PREFIX% [my define getnull libprefix] 4910 set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]][my define get SHLIB_SUFFIX] 4911 return $outfile 4912 } 4913 4914 method static_library {{filename {}}} { 4915 set name [string tolower [my define get name [my define get pkg_name]]] 4916 set NAME [string toupper $name] 4917 set version [my define get version [my define get pkg_vers]] 4918 set map {} 4919 lappend map %LIBRARY_NAME% $name 4920 lappend map %LIBRARY_VERSION% $version 4921 lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] 4922 lappend map %LIBRARY_PREFIX% [my define getnull libprefix] 4923 set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]].a 4924 return $outfile 4925 } 4926} 4927 4928### 4929# END: class project library.tcl 4930### 4931### 4932# START: class project tclkit.tcl 4933### 4934 4935 4936::oo::class create ::practcl::tclkit { 4937 superclass ::practcl::library 4938 4939 method build-tclkit_main {PROJECT PKG_OBJS} { 4940 ### 4941 # Build static package list 4942 ### 4943 set statpkglist {} 4944 foreach cobj [list {*}${PKG_OBJS} $PROJECT] { 4945 foreach {pkg info} [$cobj project-static-packages] { 4946 dict set statpkglist $pkg $info 4947 } 4948 } 4949 foreach {ofile info} [${PROJECT} project-compile-products] { 4950 if {![dict exists $info object]} continue 4951 set cobj [dict get $info object] 4952 foreach {pkg info} [$cobj project-static-packages] { 4953 dict set statpkglist $pkg $info 4954 } 4955 } 4956 4957 set result {} 4958 $PROJECT include {<tcl.h>} 4959 $PROJECT include {"tclInt.h"} 4960 $PROJECT include {"tclFileSystem.h"} 4961 $PROJECT include {<assert.h>} 4962 $PROJECT include {<stdio.h>} 4963 $PROJECT include {<stdlib.h>} 4964 $PROJECT include {<string.h>} 4965 $PROJECT include {<math.h>} 4966 4967 $PROJECT code header { 4968#ifndef MODULE_SCOPE 4969# define MODULE_SCOPE extern 4970#endif 4971 4972/* 4973** Provide a dummy Tcl_InitStubs if we are using this as a static 4974** library. 4975*/ 4976#ifndef USE_TCL_STUBS 4977# undef Tcl_InitStubs 4978# define Tcl_InitStubs(a,b,c) TCL_VERSION 4979#endif 4980#define STATIC_BUILD 1 4981#undef USE_TCL_STUBS 4982 4983/* Make sure the stubbed variants of those are never used. */ 4984#undef Tcl_ObjSetVar2 4985#undef Tcl_NewStringObj 4986#undef Tk_Init 4987#undef Tk_MainEx 4988#undef Tk_SafeInit 4989} 4990 4991 # Build an area of the file for #define directives and 4992 # function declarations 4993 set define {} 4994 set mainhook [$PROJECT define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] 4995 set mainfunc [$PROJECT define get TCL_LOCAL_APPINIT Tclkit_AppInit] 4996 set mainscript [$PROJECT define get main.tcl main.tcl] 4997 set vfsroot [$PROJECT define get vfsroot "[$PROJECT define get ZIPFS_VOLUME]app"] 4998 set vfs_main "${vfsroot}/${mainscript}" 4999 5000 set map {} 5001 foreach var { 5002 vfsroot mainhook mainfunc vfs_main 5003 } { 5004 dict set map %${var}% [set $var] 5005 } 5006 set preinitscript { 5007set ::odie(boot_vfs) %vfsroot% 5008set ::SRCDIR $::odie(boot_vfs) 5009if {[file exists [file join %vfsroot% tcl_library init.tcl]]} { 5010 set ::tcl_library [file join %vfsroot% tcl_library] 5011 set ::auto_path {} 5012} 5013if {[file exists [file join %vfsroot% tk_library tk.tcl]]} { 5014 set ::tk_library [file join %vfsroot% tk_library] 5015} 5016} ; # Preinitscript 5017 5018 set zvfsboot { 5019/* 5020 * %mainhook% -- 5021 * Performs the argument munging for the shell 5022 */ 5023 } 5024 ::practcl::cputs zvfsboot { 5025 CONST char *archive; 5026 Tcl_FindExecutable(*argv[0]); 5027 archive=Tcl_GetNameOfExecutable(); 5028} 5029 # We have to initialize the virtual filesystem before calling 5030 # Tcl_Init(). Otherwise, Tcl_Init() will not be able to find 5031 # its startup script files. 5032 if {![$PROJECT define get tip_430 0]} { 5033 # Add declarations of functions that tip430 puts in the stub files 5034 $PROJECT code public-header { 5035int TclZipfs_Init(Tcl_Interp *interp); 5036int TclZipfs_Mount( 5037 Tcl_Interp *interp, 5038 const char *mntpt, 5039 const char *zipname, 5040 const char *passwd 5041); 5042int TclZipfs_Mount_Buffer( 5043 Tcl_Interp *interp, 5044 const char *mntpt, 5045 unsigned char *data, 5046 size_t datalen, 5047 int copy 5048); 5049} 5050 ::practcl::cputs zvfsboot { TclZipfs_Init(NULL);} 5051 } 5052 ::practcl::cputs zvfsboot " if(!TclZipfs_Mount(NULL, \"app\", archive, NULL)) \x7B " 5053 ::practcl::cputs zvfsboot { 5054 Tcl_Obj *vfsinitscript; 5055 vfsinitscript=Tcl_NewStringObj("%vfs_main%",-1); 5056 Tcl_IncrRefCount(vfsinitscript); 5057 if(Tcl_FSAccess(vfsinitscript,F_OK)==0) { 5058 /* Startup script should be set before calling Tcl_AppInit */ 5059 Tcl_SetStartupScript(vfsinitscript,NULL); 5060 } 5061 } 5062 ::practcl::cputs zvfsboot " TclSetPreInitScript([::practcl::tcl_to_c $preinitscript])\;" 5063 ::practcl::cputs zvfsboot " \x7D else \x7B" 5064 ::practcl::cputs zvfsboot " TclSetPreInitScript([::practcl::tcl_to_c { 5065foreach path {../tcl} { 5066 set p [file join $path library init.tcl] 5067 if {[file exists [file join $path library init.tcl]]} { 5068 set ::tcl_library [file normalize [file join $path library]] 5069 break 5070 } 5071} 5072foreach path { 5073 ../tk 5074} { 5075 if {[file exists [file join $path library tk.tcl]]} { 5076 set ::tk_library [file normalize [file join $path library]] 5077 break 5078 } 5079} 5080}])\;" 5081 ::practcl::cputs zvfsboot " \x7D" 5082 ::practcl::cputs zvfsboot " return TCL_OK;" 5083 5084 if {[$PROJECT define get TEACUP_OS] eq "windows"} { 5085 set header {int %mainhook%(int *argc, TCHAR ***argv)} 5086 } else { 5087 set header {int %mainhook%(int *argc, char ***argv)} 5088 } 5089 $PROJECT c_function [string map $map $header] [string map $map $zvfsboot] 5090 5091 practcl::cputs appinit "int %mainfunc%(Tcl_Interp *interp) \x7B" 5092 5093 # Build AppInit() 5094 set appinit {} 5095 practcl::cputs appinit { 5096 if ((Tcl_Init)(interp) == TCL_ERROR) { 5097 return TCL_ERROR; 5098 } 5099 5100} 5101 if {![$PROJECT define get tip_430 0]} { 5102 ::practcl::cputs appinit { TclZipfs_Init(interp);} 5103 } 5104 set main_init_script {} 5105 5106 foreach {statpkg info} $statpkglist { 5107 set initfunc {} 5108 if {[dict exists $info initfunc]} { 5109 set initfunc [dict get $info initfunc] 5110 } 5111 if {$initfunc eq {}} { 5112 set initfunc [string totitle ${statpkg}]_Init 5113 } 5114 if {![dict exists $info version]} { 5115 error "$statpkg HAS NO VERSION" 5116 } 5117 # We employ a NULL to prevent the package system from thinking the 5118 # package is actually loaded into the interpreter 5119 $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" 5120 set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] 5121 append main_init_script \n [list set ::kitpkg(${statpkg}) $script] 5122 if {[dict get $info autoload]} { 5123 ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" 5124 ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" 5125 } else { 5126 ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" 5127 append main_init_script \n $script 5128 } 5129 } 5130 append main_init_script \n { 5131if {[file exists [file join $::SRCDIR packages.tcl]]} { 5132 #In a wrapped exe, we don't go out to the environment 5133 set dir $::SRCDIR 5134 source [file join $::SRCDIR packages.tcl] 5135} 5136# Specify a user-specific startup file to invoke if the application 5137# is run interactively. Typically the startup file is "~/.apprc" 5138# where "app" is the name of the application. If this line is deleted 5139# then no user-specific startup file will be run under any conditions. 5140} 5141 append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]] 5142 practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);" 5143 practcl::cputs appinit { return TCL_OK;} 5144 $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] 5145 } 5146 5147 method Collate_Source CWD { 5148 next $CWD 5149 set name [my define get name] 5150 # Assume a static shell 5151 if {[my define exists SHARED_BUILD]} { 5152 my define set SHARED_BUILD 0 5153 } 5154 if {![my define exists TCL_LOCAL_APPINIT]} { 5155 my define set TCL_LOCAL_APPINIT Tclkit_AppInit 5156 } 5157 if {![my define exists TCL_LOCAL_MAIN_HOOK]} { 5158 my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook 5159 } 5160 set PROJECT [self] 5161 set os [$PROJECT define get TEACUP_OS] 5162 if {[my define get SHARED_BUILD]} { 5163 puts [list BUILDING TCLSH FOR OS $os] 5164 } else { 5165 puts [list BUILDING KIT FOR OS $os] 5166 } 5167 set TCLOBJ [$PROJECT tclcore] 5168 ::practcl::toolset select $TCLOBJ 5169 5170 set TCLSRCDIR [$TCLOBJ define get srcdir] 5171 set PKG_OBJS {} 5172 foreach item [$PROJECT link list core.library] { 5173 if {[string is true [$item define get static]]} { 5174 lappend PKG_OBJS $item 5175 } 5176 } 5177 foreach item [$PROJECT link list package] { 5178 if {[string is true [$item define get static]]} { 5179 lappend PKG_OBJS $item 5180 } 5181 } 5182 # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK 5183 if {$os eq "windows"} { 5184 set PLATFORM_SRC_DIR win 5185 if {[my define get SHARED_BUILD]} { 5186 my add class csource filename [file join $TCLSRCDIR win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.1 autoload 1 5187 my add class csource filename [file join $TCLSRCDIR win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 autoload 1 5188 } 5189 my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] 5190 } else { 5191 set PLATFORM_SRC_DIR unix 5192 my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] 5193 } 5194 5195 if {[my define get SHARED_BUILD]} { 5196 ### 5197 # Add local static Zlib implementation 5198 ### 5199 set cdir [file join $TCLSRCDIR compat zlib] 5200 foreach file { 5201 adler32.c compress.c crc32.c 5202 deflate.c infback.c inffast.c 5203 inflate.c inftrees.c trees.c 5204 uncompr.c zutil.c 5205 } { 5206 my add [file join $cdir $file] 5207 } 5208 } 5209 ### 5210 # Pre 8.7, Tcl doesn't include a Zipfs implementation 5211 # in the core. Grab the one from odielib 5212 ### 5213 set zipfs [file join $TCLSRCDIR generic tclZipfs.c] 5214 if {![$PROJECT define exists ZIPFS_VOLUME]} { 5215 $PROJECT define set ZIPFS_VOLUME "zipfs:/" 5216 } 5217 $PROJECT code header "#define ZIPFS_VOLUME \"[$PROJECT define get ZIPFS_VOLUME]\"" 5218 if {[file exists $zipfs]} { 5219 $TCLOBJ define set tip_430 1 5220 my define set tip_430 1 5221 } else { 5222 # The Tclconfig project maintains a mirror of the version 5223 # released with the Tcl core 5224 my define set tip_430 0 5225 ::practcl::LOCAL tool tclconfig unpack 5226 set COMPATSRCROOT [::practcl::LOCAL tool tclconfig define get srcdir] 5227 my add class csource ofile tclZipfs.o filename [file join $COMPATSRCROOT compat tclZipfs.c] extra -I[::practcl::file_relative $CWD [file join $TCLSRCDIR compat zlib contrib minizip]] 5228 } 5229 5230 my define add include_dir [file join $TCLSRCDIR generic] 5231 my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] 5232 # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK 5233 my build-tclkit_main $PROJECT $PKG_OBJS 5234 } 5235 5236 ## Wrap an executable 5237 # 5238 method wrap {PWD exename vfspath args} { 5239 cd $PWD 5240 if {![file exists $vfspath]} { 5241 file mkdir $vfspath 5242 } 5243 foreach item [my link list core.library] { 5244 set name [$item define get name] 5245 set libsrcdir [$item define get srcdir] 5246 if {[file exists [file join $libsrcdir library]]} { 5247 ::practcl::copyDir [file join $libsrcdir library] [file join $vfspath ${name}_library] 5248 } 5249 } 5250 # Assume the user will populate the VFS path 5251 #if {[my define get installdir] ne {}} { 5252 # ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib] 5253 #} 5254 foreach arg $args { 5255 ::practcl::copyDir $arg $vfspath 5256 } 5257 5258 set fout [open [file join $vfspath packages.tcl] w] 5259 puts $fout [string map [list %platform% [my define get TEACUP_PROFILE]] {set ::tcl_teapot_profile {%platform%}}] 5260 puts $fout { 5261set ::PKGIDXFILE [info script] 5262set dir [file dirname $::PKGIDXFILE] 5263if {$::tcl_platform(platform) eq "windows"} { 5264 set ::g(HOME) [file join [file normalize $::env(LOCALAPPDATA)] tcl] 5265} else { 5266 set ::g(HOME) [file normalize ~/tcl] 5267} 5268set ::tcl_teapot [file join $::g(HOME) teapot $::tcl_teapot_profile] 5269lappend ::auto_path $::tcl_teapot 5270} 5271 puts $fout [list proc installDir [info args ::practcl::installDir] [info body ::practcl::installDir]] 5272 set buffer [::practcl::pkgindex_path $vfspath] 5273 puts $fout $buffer 5274 puts $fout { 5275# Advertise statically linked packages 5276foreach {pkg script} [array get ::kitpkg] { 5277 eval $script 5278} 5279} 5280 puts $fout { 5281### 5282# Cache binary packages distributed as dynamic libraries in a known location 5283### 5284foreach teapath [glob -nocomplain [file join $dir teapot $::tcl_teapot_profile *]] { 5285 set pkg [file tail $teapath] 5286 set pkginstall [file join $::tcl_teapot $pkg] 5287 if {![file exists $pkginstall]} { 5288 installDir $teapath $pkginstall 5289 } 5290} 5291} 5292 close $fout 5293 5294 set EXEEXT [my define get EXEEXT] 5295 set tclkit_bare [my define get tclkit_bare] 5296 ::practcl::mkzip ${exename}${EXEEXT} $tclkit_bare $vfspath 5297 if { [my define get TEACUP_OS] ne "windows" } { 5298 file attributes ${exename}${EXEEXT} -permissions a+x 5299 } 5300 } 5301} 5302 5303### 5304# END: class project tclkit.tcl 5305### 5306### 5307# START: class distro baseclass.tcl 5308### 5309 5310### 5311# Standalone class to manage code distribution 5312# This class is intended to be mixed into another class 5313# (Thus the lack of ancestors) 5314### 5315oo::class create ::practcl::distribution { 5316 5317 method scm_info {} { 5318 return { 5319 scm None 5320 hash {} 5321 maxdate {} 5322 tags {} 5323 isodate {} 5324 } 5325 } 5326 5327 method DistroMixIn {} { 5328 my define set scm none 5329 } 5330 5331 method Sandbox {} { 5332 if {[my define exists sandbox]} { 5333 return [my define get sandbox] 5334 } 5335 if {[my organ project] ni {::noop {}}} { 5336 set sandbox [my <project> define get sandbox] 5337 if {$sandbox ne {}} { 5338 my define set sandbox $sandbox 5339 return $sandbox 5340 } 5341 } 5342 set sandbox [file normalize [file join $::CWD ..]] 5343 my define set sandbox $sandbox 5344 return $sandbox 5345 } 5346 5347 method SrcDir {} { 5348 set pkg [my define get name] 5349 if {[my define exists srcdir]} { 5350 return [my define get srcdir] 5351 } 5352 set sandbox [my Sandbox] 5353 set srcdir [file join [my Sandbox] $pkg] 5354 my define set srcdir $srcdir 5355 return $srcdir 5356 } 5357 5358 method ScmTag {} {} 5359 method ScmClone {} {} 5360 method ScmUnpack {} {} 5361 method ScmUpdate {} {} 5362 5363 method Unpack {} { 5364 set srcdir [my SrcDir] 5365 if {[file exists $srcdir]} { 5366 return 5367 } 5368 set pkg [my define get name] 5369 if {[my define exists download]} { 5370 # Utilize a staged download 5371 set download [my define get download] 5372 if {[file exists [file join $download $pkg.zip]]} { 5373 ::practcl::tcllib_require zipfile::decode 5374 ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir 5375 return 5376 } 5377 } 5378 my ScmUnpack 5379 } 5380} 5381 5382oo::objdefine ::practcl::distribution { 5383 5384 method Sandbox {object} { 5385 if {[$object define exists sandbox]} { 5386 return [$object define get sandbox] 5387 } 5388 if {[$object organ project] ni {::noop {}}} { 5389 set sandbox [$object <project> define get sandbox] 5390 if {$sandbox ne {}} { 5391 $object define set sandbox $sandbox 5392 return $sandbox 5393 } 5394 } 5395 set pkg [$object define get name] 5396 set sandbox [file normalize [file join $::CWD ..]] 5397 $object define set sandbox $sandbox 5398 return $sandbox 5399 } 5400 5401 method select object { 5402 if {[$object define exists scm]} { 5403 return [$object define get scm] 5404 } 5405 5406 set pkg [$object define get name] 5407 if {[$object define get srcdir] ne {}} { 5408 set srcdir [$object define get srcdir] 5409 } else { 5410 set srcdir [file join [my Sandbox $object] $pkg] 5411 $object define set srcdir $srcdir 5412 } 5413 5414 set classprefix ::practcl::distribution. 5415 if {[file exists $srcdir]} { 5416 foreach class [::info commands ${classprefix}*] { 5417 if {[$class claim_path $srcdir]} { 5418 $object mixin distribution $class 5419 $object define set scm [string range $class [string length ::practcl::distribution.] end] 5420 return [$object define get scm] 5421 } 5422 } 5423 } 5424 foreach class [::info commands ${classprefix}*] { 5425 if {[$class claim_object $object]} { 5426 $object mixin distribution $class 5427 $object define set scm [string range $class [string length ::practcl::distribution.] end] 5428 return [$object define get scm] 5429 } 5430 } 5431 if {[$object define get scm] eq {} && [$object define exists file_url]} { 5432 set class ::practcl::distribution.snapshot 5433 $object define set scm snapshot 5434 $object mixin distribution $class 5435 return [$object define get scm] 5436 } 5437 error "Cannot determine source distribution method" 5438 } 5439 5440 method claim_path path { 5441 return false 5442 } 5443 method claim_object object { 5444 return false 5445 } 5446} 5447 5448### 5449# END: class distro baseclass.tcl 5450### 5451### 5452# START: class distro snapshot.tcl 5453### 5454 5455oo::class create ::practcl::distribution.snapshot { 5456 superclass ::practcl::distribution 5457 5458 method ScmUnpack {} { 5459 set srcdir [my SrcDir] 5460 if {[file exists [file join $srcdir .download]]} { 5461 return 0 5462 } 5463 set dpath [::practcl::LOCAL define get download] 5464 set url [my define get file_url] 5465 set fname [file tail $url] 5466 set archive [file join $dpath $fname] 5467 if {![file exists $archive]} { 5468 ::http::wget $url $archive 5469 } 5470 set CWD [pwd] 5471 switch [file extension $fname] { 5472 .zip { 5473 # Zipfile 5474 5475 } 5476 .tar { 5477 ::practcl::tcllib_require tar 5478 } 5479 .tgz - 5480 .gz { 5481 # Tarball 5482 ::practcl::tcllib_require tcl::transform::zlib 5483 ::practcl::tcllib_require tar 5484 set fh [::open $archive] 5485 fconfigure $fh -encoding binary -translation lf -eofchar {} 5486 ::tcl::transform::zlib $fh 5487 } 5488 } 5489 set fosdb [my ScmClone] 5490 set tag [my ScmTag] 5491 file mkdir $srcdir 5492 ::practcl::fossil $srcdir open $fosdb $tag 5493 return 1 5494 } 5495} 5496 5497oo::objdefine ::practcl::distribution.snapshot { 5498 method claim_path path { 5499 if {[file exists [file join $path .download]]} { 5500 return true 5501 } 5502 return false 5503 } 5504 method claim_object object { 5505 return false 5506 } 5507} 5508 5509### 5510# END: class distro snapshot.tcl 5511### 5512### 5513# START: class distro fossil.tcl 5514### 5515 5516oo::class create ::practcl::distribution.fossil { 5517 superclass ::practcl::distribution 5518 5519 method scm_info {} { 5520 set info [next] 5521 dict set info scm fossil 5522 foreach {field value} [::practcl::fossil_status [my define get srcdir]] { 5523 dict set info $field $value 5524 } 5525 return $info 5526 } 5527 5528 # Clone the source 5529 method ScmClone {} { 5530 set srcdir [my SrcDir] 5531 if {[file exists [file join $srcdir .fslckout]]} { 5532 return 5533 } 5534 if {[file exists [file join $srcdir _FOSSIL_]]} { 5535 return 5536 } 5537 if {![::info exists ::practcl::fossil_dbs]} { 5538 # Get a list of local fossil databases 5539 set ::practcl::fossil_dbs [exec fossil all list] 5540 } 5541 set pkg [my define get name] 5542 # Return an already downloaded fossil repo 5543 foreach line [split $::practcl::fossil_dbs \n] { 5544 set line [string trim $line] 5545 if {[file rootname [file tail $line]] eq $pkg} { 5546 return $line 5547 } 5548 } 5549 set download [::practcl::LOCAL define get download] 5550 set fosdb [file join $download $pkg.fos] 5551 if {[file exists $fosdb]} { 5552 return $fosdb 5553 } 5554 5555 file mkdir [file join $download fossil] 5556 set fosdb [file join $download fossil $pkg.fos] 5557 if {[file exists $fosdb]} { 5558 return $fosdb 5559 } 5560 5561 set cloned 0 5562 # Attempt to clone from a local network mirror 5563 if {[::practcl::LOCAL define exists fossil_mirror]} { 5564 set localmirror [::practcl::LOCAL define get fossil_mirror] 5565 catch { 5566 ::practcl::doexec fossil clone $localmirror/$pkg $fosdb 5567 set cloned 1 5568 } 5569 if {$cloned} { 5570 return $fosdb 5571 } 5572 } 5573 # Attempt to clone from the canonical source 5574 if {[my define get fossil_url] ne {}} { 5575 catch { 5576 ::practcl::doexec fossil clone [my define get fossil_url] $fosdb 5577 set cloned 1 5578 } 5579 if {$cloned} { 5580 return $fosdb 5581 } 5582 } 5583 # Fall back to the fossil mirror on the island of misfit toys 5584 ::practcl::doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb 5585 return $fosdb 5586 } 5587 5588 method ScmTag {} { 5589 if {[my define exists scm_tag]} { 5590 return [my define get scm_tag] 5591 } 5592 if {[my define exists tag]} { 5593 set tag [my define get tag] 5594 } else { 5595 set tag trunk 5596 } 5597 my define set scm_tag $tag 5598 return $tag 5599 } 5600 5601 method ScmUnpack {} { 5602 set srcdir [my SrcDir] 5603 if {[file exists [file join $srcdir .fslckout]]} { 5604 return 0 5605 } 5606 if {[file exists [file join $srcdir _FOSSIL_]]} { 5607 return 0 5608 } 5609 set CWD [pwd] 5610 set fosdb [my ScmClone] 5611 set tag [my ScmTag] 5612 file mkdir $srcdir 5613 ::practcl::fossil $srcdir open $fosdb $tag 5614 return 1 5615 } 5616 5617 method ScmUpdate {} { 5618 if {[my ScmUnpack]} { 5619 return 5620 } 5621 set srcdir [my SrcDir] 5622 set tag [my ScmTag] 5623 ::practcl::fossil $srcdir update $tag 5624 } 5625} 5626 5627oo::objdefine ::practcl::distribution.fossil { 5628 5629 # Check for markers in the source root 5630 method claim_path path { 5631 if {[file exists [file join $path .fslckout]]} { 5632 return true 5633 } 5634 if {[file exists [file join $path _FOSSIL_]]} { 5635 return true 5636 } 5637 return false 5638 } 5639 5640 # Check for markers in the metadata 5641 method claim_object obj { 5642 set path [$obj define get srcdir] 5643 if {[my claim_path $path]} { 5644 return true 5645 } 5646 if {[$obj define get fossil_url] ne {}} { 5647 return true 5648 } 5649 return false 5650 } 5651} 5652 5653### 5654# END: class distro fossil.tcl 5655### 5656### 5657# START: class distro git.tcl 5658### 5659 5660 5661oo::class create ::practcl::distribution.git { 5662 superclass ::practcl::distribution 5663 5664 method ScmTag {} { 5665 if {[my define exists scm_tag]} { 5666 return [my define get scm_tag] 5667 } 5668 if {[my define exists tag]} { 5669 set tag [my define get tag] 5670 } else { 5671 set tag master 5672 } 5673 my define set scm_tag $tag 5674 return $tag 5675 } 5676 5677 method ScmUnpack {} { 5678 set srcdir [my SrcDir] 5679 if {[file exists [file join $srcdir .git]]} { 5680 return 0 5681 } 5682 set CWD [pwd] 5683 set tag [my ScmTag] 5684 set pkg [my define get name] 5685 if {[my define exists git_url]} { 5686 ::practcl::doexec git clone --branch $tag [my define get git_url] $srcdir 5687 } else { 5688 ::practcl::doexec git clone --branch $tag https://github.com/eviltwinskippy/$pkg $srcdir 5689 } 5690 return 1 5691 } 5692 5693 method ScmUpdate {} { 5694 if {[my ScmUnpack]} { 5695 return 5696 } 5697 set CWD [pwd] 5698 set srcdir [my SrcDir] 5699 set tag [my ScmTag] 5700 ::practcl::doexec_in $srcdir git pull 5701 cd $CWD 5702 } 5703 5704} 5705oo::objdefine ::practcl::distribution.git { 5706 method claim_path path { 5707 if {[file exists [file join $path .git]]} { 5708 return true 5709 } 5710 return false 5711 } 5712 method claim_object obj { 5713 set path [$obj define get srcdir] 5714 if {[my claim_path $path]} { 5715 return true 5716 } 5717 if {[$obj define get git_url] ne {}} { 5718 return true 5719 } 5720 return false 5721 } 5722} 5723 5724### 5725# END: class distro git.tcl 5726### 5727### 5728# START: class subproject baseclass.tcl 5729### 5730oo::class create ::practcl::subproject { 5731 superclass ::practcl::module 5732 5733 method _MorphPatterns {} { 5734 return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}} 5735 } 5736 5737 5738 method BuildDir {PWD} { 5739 return [my define get srcdir] 5740 } 5741 5742 method child which { 5743 switch $which { 5744 organs { 5745 # A library can be a project, it can be a module. Any 5746 # subordinate modules will indicate their existance 5747 return [list project [self] module [self]] 5748 } 5749 } 5750 } 5751 5752 method compile {} {} 5753 5754 5755 method go {} { 5756 ::practcl::distribution select [self] 5757 set name [my define get name] 5758 my define set builddir [my BuildDir [my define get masterpath]] 5759 my define set builddir [my BuildDir [my define get masterpath]] 5760 my sources 5761 } 5762 5763 # Install project into the local build system 5764 method install args {} 5765 5766 method linktype {} { 5767 return {subordinate package} 5768 } 5769 5770 method linker-products {configdict} {} 5771 5772 method linker-external {configdict} { 5773 if {[dict exists $configdict PRACTCL_PKG_LIBS]} { 5774 return [dict get $configdict PRACTCL_PKG_LIBS] 5775 } 5776 if {[dict exists $configdict LIBS]} { 5777 return [dict get $configdict LIBS] 5778 } 5779 } 5780 5781 method linker-extra {configdict} { 5782 if {[dict exists $configdict PRACTCL_LINKER_EXTRA]} { 5783 return [dict get $configdict PRACTCL_LINKER_EXTRA] 5784 } 5785 return {} 5786 } 5787 5788 ### 5789 # Methods for packages/tools that can be downloaded 5790 # possibly built and used internally by this Practcl 5791 # process 5792 ### 5793 5794 ### 5795 # Load the facility into the interpreter 5796 ### 5797 method env-bootstrap {} { 5798 set pkg [my define get pkg_name [my define get name]] 5799 package require $pkg 5800 } 5801 5802 ### 5803 # Return a file path that exec can call 5804 ### 5805 method env-exec {} {} 5806 5807 ### 5808 # Install the tool into the local environment 5809 ### 5810 method env-install {} { 5811 my unpack 5812 } 5813 5814 ### 5815 # Do whatever is necessary to get the tool 5816 # into the local environment 5817 ### 5818 method env-load {} { 5819 my variable loaded 5820 if {[info exists loaded]} { 5821 return 0 5822 } 5823 if {![my env-present]} { 5824 my env-install 5825 } 5826 my env-bootstrap 5827 set loaded 1 5828 } 5829 5830 ### 5831 # Check if tool is available for load/already loaded 5832 ### 5833 method env-present {} { 5834 set pkg [my define get pkg_name [my define get name]] 5835 if {[catch [list package require $pkg]]} { 5836 return 0 5837 } 5838 return 1 5839 } 5840 5841 method sources {} {} 5842 5843 method update {} { 5844 my ScmUpdate 5845 } 5846 5847 method unpack {} { 5848 ::practcl::distribution select [self] 5849 my Unpack 5850 ::practcl::toolset select [self] 5851 } 5852} 5853 5854### 5855# Trivial implementations 5856### 5857 5858 5859### 5860# A project which the kit compiles and integrates 5861# the source for itself 5862### 5863oo::class create ::practcl::subproject.source { 5864 superclass ::practcl::subproject ::practcl::library 5865 5866 method env-bootstrap {} { 5867 set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] 5868 if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { 5869 set ::auto_path [linsert $::auto_path 0 $LibraryRoot] 5870 } 5871 } 5872 5873 method env-present {} { 5874 set path [my define get srcdir] 5875 return [file exists $path] 5876 } 5877 5878 method linktype {} { 5879 return {subordinate package source} 5880 } 5881 5882} 5883 5884# a copy from the teapot 5885oo::class create ::practcl::subproject.teapot { 5886 superclass ::practcl::subproject 5887 5888 method env-bootstrap {} { 5889 set pkg [my define get pkg_name [my define get name]] 5890 package require $pkg 5891 } 5892 5893 method env-install {} { 5894 set pkg [my define get pkg_name [my define get name]] 5895 set download [my <project> define get download] 5896 my unpack 5897 set prefix [string trimleft [my <project> define get prefix] /] 5898 ::practcl::tcllib_require zipfile::decode 5899 ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $prefix lib $pkg] 5900 } 5901 5902 method env-present {} { 5903 set pkg [my define get pkg_name [my define get name]] 5904 if {[catch [list package require $pkg]]} { 5905 return 0 5906 } 5907 return 1 5908 } 5909 5910 method install DEST { 5911 set pkg [my define get pkg_name [my define get name]] 5912 set download [my <project> define get download] 5913 my unpack 5914 set prefix [string trimleft [my <project> define get prefix] /] 5915 ::practcl::tcllib_require zipfile::decode 5916 ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg] 5917 } 5918} 5919 5920oo::class create ::practcl::subproject.kettle { 5921 superclass ::practcl::subproject 5922 5923 method kettle {path args} { 5924 my variable kettle 5925 if {![info exists kettle]} { 5926 ::practcl::LOCAL tool kettle env-load 5927 set kettle [file join [::practcl::LOCAL tool kettle define get srcdir] kettle] 5928 } 5929 set srcdir [my SourceRoot] 5930 ::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args 5931 } 5932 5933 method install DEST { 5934 my kettle reinstall --prefix $DEST 5935 } 5936} 5937 5938oo::class create ::practcl::subproject.critcl { 5939 superclass ::practcl::subproject 5940 5941 method install DEST { 5942 my critcl -pkg [my define get name] 5943 set srcdir [my SourceRoot] 5944 ::practcl::copyDir [file join $srcdir [my define get name]] [file join $DEST lib [my define get name]] 5945 } 5946} 5947 5948 5949oo::class create ::practcl::subproject.sak { 5950 superclass ::practcl::subproject 5951 5952 method env-bootstrap {} { 5953 set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] 5954 if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { 5955 set ::auto_path [linsert $::auto_path 0 $LibraryRoot] 5956 } 5957 } 5958 5959 method env-install {} { 5960 ### 5961 # Handle teapot installs 5962 ### 5963 set pkg [my define get pkg_name [my define get name]] 5964 my unpack 5965 set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] 5966 set srcdir [my define get srcdir] 5967 ::practcl::dotclexec [file join $srcdir installer.tcl] \ 5968 -apps -app-path [file join $prefix apps] \ 5969 -html -html-path [file join $prefix doc html $pkg] \ 5970 -pkg-path [file join $prefix lib $pkg] \ 5971 -no-nroff -no-wait -no-gui 5972 } 5973 5974 method env-present {} { 5975 set path [my define get srcdir] 5976 return [file exists $path] 5977 } 5978 5979 method install DEST { 5980 ### 5981 # Handle teapot installs 5982 ### 5983 set pkg [my define get pkg_name [my define get name]] 5984 my unpack 5985 set prefix [string trimleft [my <project> define get prefix] /] 5986 set srcdir [my define get srcdir] 5987 ::practcl::dotclexec [file join $srcdir installer.tcl] \ 5988 -pkg-path [file join $DEST $prefix lib $pkg] \ 5989 -no-examples -no-html -no-nroff \ 5990 -no-wait -no-gui -no-apps 5991 } 5992} 5993 5994### 5995# END: class subproject baseclass.tcl 5996### 5997### 5998# START: class subproject binary.tcl 5999### 6000 6001### 6002# A binary package 6003### 6004oo::class create ::practcl::subproject.binary { 6005 superclass ::practcl::subproject 6006 6007 method clean {} { 6008 set builddir [file normalize [my define get builddir]] 6009 if {![file exists $builddir]} return 6010 if {[file exists [file join $builddir make.tcl]]} { 6011 ::practcl::domake.tcl $builddir clean 6012 } else { 6013 catch {::practcl::domake $builddir clean} 6014 } 6015 } 6016 6017 method env-install {} { 6018 ### 6019 # Handle tea installs 6020 ### 6021 set pkg [my define get pkg_name [my define get name]] 6022 set os [::practcl::local_os] 6023 my define set os $os 6024 my unpack 6025 set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] 6026 set srcdir [my define get srcdir] 6027 lappend options --prefix $prefix --exec-prefix $prefix 6028 my define set config_opts $options 6029 my go 6030 my clean 6031 my compile 6032 my make-install {} 6033 } 6034 6035 method project-compile-products {} {} 6036 6037 method ComputeInstall {} { 6038 if {[my define exists install]} { 6039 switch [my define get install] { 6040 static { 6041 my define set static 1 6042 my define set autoload 0 6043 } 6044 static-autoload { 6045 my define set static 1 6046 my define set autoload 1 6047 } 6048 vfs { 6049 my define set static 0 6050 my define set autoload 0 6051 my define set vfsinstall 1 6052 } 6053 null { 6054 my define set static 0 6055 my define set autoload 0 6056 my define set vfsinstall 0 6057 } 6058 default { 6059 6060 } 6061 } 6062 } 6063 } 6064 6065 method go {} { 6066 next 6067 ::practcl::distribution select [self] 6068 my ComputeInstall 6069 my define set builddir [my BuildDir [my define get masterpath]] 6070 } 6071 6072 method linker-products {configdict} { 6073 if {![my define get static 0]} { 6074 return {} 6075 } 6076 set srcdir [my define get builddir] 6077 if {[dict exists $configdict libfile]} { 6078 return " [file join $srcdir [dict get $configdict libfile]]" 6079 } 6080 } 6081 6082 method project-static-packages {} { 6083 if {![my define get static 0]} { 6084 return {} 6085 } 6086 set result [my define get static_packages] 6087 set statpkg [my define get static_pkg] 6088 set initfunc [my define get initfunc] 6089 if {$initfunc ne {}} { 6090 set pkg_name [my define get pkg_name] 6091 if {$pkg_name ne {}} { 6092 dict set result $pkg_name initfunc $initfunc 6093 set version [my define get version] 6094 if {$version eq {}} { 6095 my unpack 6096 set info [my read_configuration] 6097 set version [dict get $info version] 6098 set pl {} 6099 if {[dict exists $info patch_level]} { 6100 set pl [dict get $info patch_level] 6101 append version $pl 6102 } 6103 my define set version $version 6104 } 6105 dict set result $pkg_name version $version 6106 dict set result $pkg_name autoload [my define get autoload 0] 6107 } 6108 } 6109 foreach item [my link list subordinate] { 6110 foreach {pkg info} [$item project-static-packages] { 6111 dict set result $pkg $info 6112 } 6113 } 6114 return $result 6115 } 6116 6117 method BuildDir {PWD} { 6118 set name [my define get name] 6119 set debug [my define get debug 0] 6120 if {[my <project> define get LOCAL 0]} { 6121 return [my define get builddir [file join $PWD local $name]] 6122 } 6123 if {$debug} { 6124 return [my define get builddir [file join $PWD debug $name]] 6125 } else { 6126 return [my define get builddir [file join $PWD pkg $name]] 6127 } 6128 } 6129 6130 method compile {} { 6131 set name [my define get name] 6132 set PWD $::CWD 6133 cd $PWD 6134 my unpack 6135 set srcdir [file normalize [my SrcDir]] 6136 set localsrcdir [my MakeDir $srcdir] 6137 my define set localsrcdir $localsrcdir 6138 my Collate_Source $PWD 6139 ### 6140 # Build a starter VFS for both Tcl and wish 6141 ### 6142 set srcdir [my define get srcdir] 6143 if {[my define get static 1]} { 6144 puts "BUILDING Static $name $srcdir" 6145 } else { 6146 puts "BUILDING Dynamic $name $srcdir" 6147 } 6148 my make-compile 6149 cd $PWD 6150 } 6151 6152 method Configure {} { 6153 cd $::CWD 6154 my unpack 6155 ::practcl::toolset select [self] 6156 set srcdir [file normalize [my define get srcdir]] 6157 set builddir [file normalize [my define get builddir]] 6158 file mkdir $builddir 6159 my make-autodetect 6160 } 6161 6162 method install DEST { 6163 set PWD [pwd] 6164 set PREFIX [my <project> define get prefix] 6165 ### 6166 # Handle teapot installs 6167 ### 6168 set pkg [my define get pkg_name [my define get name]] 6169 if {[my <project> define get teapot] ne {}} { 6170 set TEAPOT [my <project> define get teapot] 6171 set found 0 6172 foreach ver [my define get pkg_vers [my define get version]] { 6173 set teapath [file join $TEAPOT $pkg$ver] 6174 if {[file exists $teapath]} { 6175 set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]] 6176 ::practcl::copyDir $teapath $dest 6177 return 6178 } 6179 } 6180 } 6181 my compile 6182 my make-install $DEST 6183 cd $PWD 6184 } 6185} 6186 6187oo::class create ::practcl::subproject.tea { 6188 superclass ::practcl::subproject.binary 6189 6190} 6191 6192oo::class create ::practcl::subproject.library { 6193 superclass ::practcl::subproject.binary ::practcl::library 6194 method install DEST { 6195 my compile 6196 } 6197} 6198 6199# An external library 6200oo::class create ::practcl::subproject.external { 6201 superclass ::practcl::subproject.binary 6202 method install DEST { 6203 my compile 6204 } 6205} 6206 6207### 6208# END: class subproject binary.tcl 6209### 6210### 6211# START: class subproject core.tcl 6212### 6213 6214oo::class create ::practcl::subproject.core { 6215 superclass ::practcl::subproject.binary 6216 6217 method env-bootstrap {} {} 6218 6219 method env-present {} { 6220 set PREFIX [my <project> define get prefix] 6221 set name [my define get name] 6222 set fname [file join $PREFIX lib ${name}Config.sh] 6223 return [file exists $fname] 6224 } 6225 6226 method env-install {} { 6227 my unpack 6228 set os [::practcl::local_os] 6229 6230 set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] 6231 lappend options --prefix $prefix --exec-prefix $prefix 6232 my define set config_opts $options 6233 puts [list [self] OS [dict get $os TEACUP_OS] options $options] 6234 my go 6235 my compile 6236 my make-install {} 6237 } 6238 6239 method go {} { 6240 my define set core_binary 1 6241 next 6242 } 6243 6244 method linktype {} { 6245 return {subordinate core.library} 6246 } 6247} 6248 6249### 6250# END: class subproject core.tcl 6251### 6252### 6253# START: class tool.tcl 6254### 6255### 6256# Create an object to represent the local environment 6257### 6258set ::practcl::MAIN ::practcl::LOCAL 6259# Defer the creation of the ::practcl::LOCAL object until it is called 6260# in order to allow packages to 6261set ::auto_index(::practcl::LOCAL) { 6262 ::practcl::project create ::practcl::LOCAL 6263 ::practcl::LOCAL define set [::practcl::local_os] 6264 ::practcl::LOCAL define set LOCAL 1 6265 6266 # Until something better comes along, use ::practcl::LOCAL 6267 # as our main project 6268 # Add tclconfig as a project of record 6269 ::practcl::LOCAL add_tool tclconfig { 6270 name tclconfig tag practcl class subproject.source fossil_url http://core.tcl.tk/tclconfig 6271 } 6272 # Add tcllib as a project of record 6273 ::practcl::LOCAL add_tool tcllib { 6274 tag trunk class sak fossil_url http://core.tcl.tk/tcllib 6275 } 6276 ::practcl::LOCAL add_tool kettle { 6277 tag trunk class sak fossil_url http://fossil.etoyoc.com/fossil/kettle 6278 } 6279 ::practcl::LOCAL add_tool tclvfs { 6280 tag trunk class tea 6281 fossil_url http://fossil.etoyoc.com/fossil/tclvfs 6282 } 6283 ::practcl::LOCAL add_tool critcl { 6284 tag master class subproject.binary 6285 git_url http://github.com/andreas-kupries/critcl 6286 modules lib 6287 } { 6288 method env-bootstrap {} { 6289 package require critcl::app 6290 } 6291 method env-install {} { 6292 my unpack 6293 set prefix [my <project> define get prefix [file join [file normalize ~] tcl]] 6294 set srcdir [my define get srcdir] 6295 ::practcl::dotclexec [file join $srcdir build.tcl] install [file join $prefix lib] 6296 } 6297 } 6298 ::practcl::LOCAL add_tool odie { 6299 tag trunk class subproject.source 6300 fossil_url http://fossil.etoyoc.com/fossil/odie 6301 } 6302 ::practcl::LOCAL add_tool tcl { 6303 tag release class subproject.core 6304 fossil_url http://core.tcl.tk/tcl 6305 } 6306 ::practcl::LOCAL add_tool tk { 6307 tag release class subproject.core 6308 fossil_url http://core.tcl.tk/tcl 6309 } 6310 ::practcl::LOCAL add_tool sqlite { 6311 tag practcl 6312 class subproject.tea 6313 pkg_name sqlite3 6314 fossil_url http://fossil.etoyoc.com/fossil/sqlite 6315 } 6316} 6317 6318### 6319# END: class tool.tcl 6320### 6321 6322namespace eval ::practcl { 6323 namespace export * 6324} 6325 6326