Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Updating Practcl to the latest version from tcllib |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | practcl |
Files: | files | file ages | folders |
SHA3-256: |
68c6d500d5e4dad05240eb7829e8b861 |
User & Date: | hypnotoad 2018-09-24 14:05:31.509 |
Context
2018-09-24
| ||
14:16 | Pulling changes from TEA check-in: 72a7e44a99 user: hypnotoad tags: practcl | |
14:05 | Updating Practcl to the latest version from tcllib check-in: 68c6d500d5 user: hypnotoad tags: practcl | |
2018-07-13
| ||
18:51 | Pulling changes from trunk check-in: 19783bad7e user: hypnotoad tags: practcl | |
Changes
Changes to practcl.tcl.
1 2 3 4 5 | ### # Amalgamated package for practcl # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### | | | < < < < < | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | ### # Amalgamated package for practcl # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### package require Tcl 8.6 package provide practcl 0.13 namespace eval ::practcl {} ### # START: httpwget/wget.tcl ### package provide http::wget 0.1 package require http ::namespace eval ::http { } proc ::http::_followRedirects {url args} { while 1 { set token [geturl $url -validate 1] set ncode [ncode $token] if { $ncode eq "404" } { error "URL Not found" } |
︙ | ︙ | |||
41 42 43 44 45 46 47 | return $url } set url $meta(Location) unset meta } return $url } | < < < < < | | < | < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < | < < < < < < < | < < < < | < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 | return $url } set url $meta(Location) unset meta } return $url } proc ::http::wget {url destfile {verbose 1}} { set tmpchan [open $destfile w] fconfigure $tmpchan -translation binary if { $verbose } { puts [list GETTING [file tail $destfile] from $url] } set real_url [_followRedirects $url] set token [geturl $real_url -channel $tmpchan -binary yes] if {[ncode $token] != "200"} { error "DOWNLOAD FAILED" } cleanup $token close $tmpchan } ### # END: httpwget/wget.tcl ### ### # START: dicttool/build/core.tcl ### namespace eval ::dicttool { } proc ::PROC {name arglist body {ninja {}}} { if {[info commands $name] ne {}} return proc $name $arglist $body eval $ninja } PROC ::noop args {} PROC ::putb {buffername args} { upvar 1 $buffername buffer switch [llength $args] { 1 { append buffer [lindex $args 0] \n } 2 { append buffer [string map {*}$args] \n } default { error "usage: putb buffername ?map? string" } } } ### # END: dicttool/build/core.tcl ### ### # START: dicttool/build/dict.tcl ### PROC ::tcl::dict::getnull {dictionary args} { if {[exists $dictionary {*}$args]} { get $dictionary {*}$args } } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull] } PROC ::tcl::dict::is_dict { d } { # is it a dict, or can it be treated like one? if {[catch {dict size $d} err]} { #::set ::errorInfo {} return 0 } return 1 } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict] } PROC ::dicttool::is_branch { dict path } { set field [lindex $path end] if {[string index $field end] eq ":"} { return 0 } if {[string index $field 0] eq "."} { return 0 } if {[string index $field end] eq "/"} { return 1 } return [dict exists $dict {*}$path .] } PROC ::dicttool::print {dict} { ::set result {} ::set level -1 ::dicttool::_dictputb $level result $dict return $result } proc ::dicttool::_dictputb {level varname dict} { upvar 1 $varname result incr level dict for {field value} $dict { if {$field eq "."} continue if {[dicttool::is_branch $dict $field]} { putb result "[string repeat " " $level]$field \{" _dictputb $level result $value putb result "[string repeat " " $level]\}" } else { putb result "[string repeat " " $level][list $field $value]" } } } PROC ::dicttool::sanitize {dict} { ::set result {} ::set level -1 ::dicttool::_sanitizeb {} result $dict return $result } proc ::dicttool::_sanitizeb {path varname dict} { upvar 1 $varname result dict for {field value} $dict { if {$field eq "."} continue if {[dicttool::is_branch $dict $field]} { _sanitizeb [list {*}$path $field] result $value } else { dict set result {*}$path $field $value } } } proc ::dicttool::canonical {rawpath} { set path {} set tail [string index $rawpath end] foreach element $rawpath { set items [split [string trim $element /] /] foreach item $items { if {$item eq {}} continue if {$item eq {.}} continue lappend path [string trim ${item} :]/ } } if {$tail eq {/}} { return $path } else { return [lreplace $path end end [string trim [lindex $path end] /]] } } proc ::dicttool::storage {rawpath} { set isleafvar 0 set path {} set tail [string index $rawpath end] foreach element $rawpath { set items [split [string trim $element /] /] foreach item $items { if {$item eq {}} continue lappend path [string trim ${item} :/] } } return $path } proc ::dicttool::dictset {varname args} { upvar 1 $varname result if {[llength $args] < 2} { error "Usage: ?path...? path value" } elseif {[llength $args]==2} { set rawpath [lindex $args 0] } else { set rawpath [lrange $args 0 end-1] } set value [lindex $args end] set path [canonical $rawpath] set dot . set one [string is true 1] dict set result $dot $one set dpath {} foreach item $path { set field $item lappend dpath [string trim $item /] if {[string index $item end] eq "/"} { dict set result {*}$dpath $dot $one } } if {[dict is_dict $value] && [dict exists $result {*}$dpath $dot]} { dict set result {*}$dpath [::dicttool::merge [dict get $result {*}$dpath] $value] } else { dict set result {*}$dpath $value } return $result } proc ::dicttool::dictmerge {varname args} { upvar 1 $varname result set dot . set one [string is true 1] dict set result $dot $one foreach dict $args { dict for {f v} $dict { set field [string trim $f :/] set bbranch [dicttool::is_branch $dict $f] if {![dict exists $result $field]} { dict set result $field $v if {$bbranch} { dict set result $field [dicttool::merge $v] } else { dict set result $field $v } } elseif {[dict exists $result $field $dot]} { if {$bbranch} { dict set result $field [dicttool::merge [dict get $result $field] $v] } else { dict set result $field $v } } } } return $result } PROC ::dicttool::merge {args} { ### # The result of a merge is always a dict with branches ### set dot . set one [string is true 1] dict set result $dot $one set argument 0 foreach b $args { # Merge b into a, and handle nested dicts appropriately if {![dict is_dict $b]} { error "Element $b is not a dictionary" } dict for { k v } $b { if {$k eq $dot} { dict set result $dot $one continue } set bbranch [is_branch $b $k] set field [string trim $k /:] if { ![dict exists $result $field] } { if {$bbranch} { dict set result $field [merge $v] } else { dict set result $field $v } } else { set abranch [dict exists $result $field $dot] if {$abranch && $bbranch} { dict set result $field [merge [dict get $result $field] $v] } else { dict set result $field $v if {$bbranch} { dict set result $field $dot $one } } } } } return $result } PROC ::tcl::dict::isnull {dictionary args} { if {![exists $dictionary {*}$args]} {return 1} return [expr {[get $dictionary {*}$args] in {{} NULL null}}] } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull] } ### # END: dicttool/build/dict.tcl ### ### # START: dicttool/build/list.tcl ### PROC ::ladd {varname args} { upvar 1 $varname var if ![info exists var] { set var {} } foreach item $args { if {$item in $var} continue lappend var $item } return $var } PROC ::ldelete {varname args} { upvar 1 $varname var if ![info exists var] { return } foreach item [lsort -unique $args] { while {[set i [lsearch $var $item]]>=0} { set var [lreplace $var $i $i] } } return $var } PROC ::lrandom list { set len [llength $list] set idx [expr int(rand()*$len)] return [lindex $list $idx] } ### # END: dicttool/build/list.tcl ### ### # START: clay/build/procs.tcl ### namespace eval ::clay { } set ::clay::trace 0 proc ::clay::ancestors args { set result {} set queue {} foreach class [lreverse $args] { lappend queue $class } |
︙ | ︙ | |||
163 164 165 166 167 168 169 | if { $item ni $result } { lappend result $item } } } return $result } | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 | if { $item ni $result } { lappend result $item } } } return $result } proc ::clay::args_to_dict args { if {[llength $args]==1} { return [lindex $args 0] } return $args } proc ::clay::args_to_options args { set result {} foreach {var val} [args_to_dict {*}$args] { lappend result [string trim $var -:] $val } return $result } proc ::clay::dynamic_arguments {ensemble method arglist args} { set idx 0 set len [llength $args] if {$len > [llength $arglist]} { ### # Catch if the user supplies too many arguments ### |
︙ | ︙ | |||
321 322 323 324 325 326 327 | } } else { uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]] } incr idx } } | < < < < < < < < < < < < > < | > > > > > > > > > > | | > > > > | > > | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | < < < | < < < < < < < < < | > < < < > > > > > > > > > > | | | > > > | | > | | | | | | < < | | | | < | | | | | | | | > | | | | | | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 | } } else { uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]] } incr idx } } proc ::clay::dynamic_wrongargs_message {arglist} { set result "" set dargs 0 foreach argdef $arglist { if {$argdef in {args dictargs}} { set dargs 1 break } if {[llength $argdef]==1} { append result " $argdef" } else { append result " ?[lindex $argdef 0]?" } } if { $dargs } { append result " ?option value?..." } return $result } proc ::clay::is_dict { d } { # is it a dict, or can it be treated like one? if {[catch {::dict size $d} err]} { #::set ::errorInfo {} return 0 } return 1 } proc ::clay::is_null value { return [expr {$value in {{} NULL}}] } proc ::clay::leaf args { set marker [string index [lindex $args end] end] set result [path {*}${args}] if {$marker eq "/"} { return $result } return [list {*}[lrange $result 0 end-1] [string trim [string trim [lindex $result end]] /]] } proc ::clay::path args { set result {} foreach item $args { set item [string trim $item :./] foreach subitem [split $item /] { lappend result [string trim ${subitem}]/ } } return $result } proc ::clay::script_path {} { set path [file dirname [file join [pwd] [info script]]] return $path } proc ::clay::NSNormalize qualname { if {![string match ::* $qualname]} { set qualname ::clay::classes::$qualname } regsub -all {::+} $qualname "::" } proc ::clay::uuid_generate args { return [uuid::uuid generate] } namespace eval ::clay { variable option_class {} variable core_classes {::oo::class ::oo::object} } ### # END: clay/build/procs.tcl ### ### # START: clay/build/class.tcl ### oo::define oo::class { method clay {submethod args} { my variable clay if {![info exists clay]} { set clay {} } switch $submethod { ancestors { tailcall ::clay::ancestors [self] } exists { if {![info exists clay]} { return 0 } return [dict exists $clay {*}[::dicttool::storage $args]] } dump { return $clay } dget { if {![info exists clay]} { return {} } set path [::dicttool::storage $args] if {![dict exists $clay {*}$path]} { return {} } return [dict get $clay {*}$path] } getnull - get { if {![info exists clay]} { return {} } set path [::dicttool::storage $args] if {[dict exists $clay {*}$path .]} { return [::dicttool::sanitize [dict get $clay {*}$path]] } if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } return {} } find { set path [::dicttool::storage $args] if {![info exists clay]} { set clay {} } set clayorder [::clay::ancestors [self]] set found 0 foreach class $clayorder { if {[$class clay exists {*}$path .]} { # Found a branch break set found 1 break } if {[$class clay exists {*}$path]} { # Found a leaf. Return that value immediately return [$class clay get {*}$path] } } if {!$found} { return {} } set result {} # Leaf searches return one data field at a time # Search in our local dict # Search in the in our list of classes for an answer foreach class [lreverse $clayorder] { ::dicttool::dictmerge result [$class clay dget {*}$path] } return [::dicttool::sanitize $result] } merge { foreach arg $args { ::dicttool::dictmerge clay {*}$arg } } search { foreach aclass [::clay::ancestors [self]] { if {[$aclass clay exists {*}$args]} { return [$aclass clay get {*}$args] } } } set { ::dicttool::dictset clay {*}$args } default { dict $submethod clay {*}$args } } } } ### # END: clay/build/class.tcl ### ### # START: clay/build/object.tcl ### oo::define oo::object { method clay {submethod args} { my variable clay claycache clayorder config option_canonical if {![info exists clay]} {set clay {}} if {![info exists claycache]} {set claycache {}} if {![info exists config]} {set config {}} if {![info exists clayorder] || [llength $clayorder]==0} { set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]] } switch $submethod { ancestors { return $clayorder } cget { # Leaf searches return one data field at a time # Search in our local dict if {[llength $args]==1} { set field [string trim [lindex $args 0] -:/] if {[info exists option_canonical($field)]} { set field $option_canonical($field) } if {[dict exists $config $field]} { return [dict get $config $field] } } set path [::dicttool::storage $args] if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } # Search in our local cache if {[dict exists $claycache {*}$path]} { if {[dict exists $claycache {*}$path .]} { return [dict remove [dict get $claycache {*}$path] .] } else { return [dict get $claycache {*}$path] } } # Search in the in our list of classes for an answer foreach class $clayorder { if {[$class clay exists {*}$path]} { set value [$class clay get {*}$path] dict set claycache {*}$path $value return $value } if {[$class clay exists const {*}$path]} { set value [$class clay get const {*}$path] dict set claycache {*}$path $value return $value } if {[$class clay exists option {*}$path default]} { set value [$class clay get option {*}$path default] dict set claycache {*}$path $value return $value } } return {} } delegate { if {![dict exists $clay .delegate <class>]} { dict set clay .delegate <class> [info object class [self]] } if {[llength $args]==0} { return [dict get $clay .delegate] } if {[llength $args]==1} { set stub <[string trim [lindex $args 0] <>]> if {![dict exists $clay .delegate $stub]} { return {} } return [dict get $clay .delegate $stub] } if {([llength $args] % 2)} { error "Usage: delegate OR delegate stub OR delegate stub OBJECT ?stub OBJECT? ..." } foreach {stub object} $args { set stub <[string trim $stub <>]> dict set clay .delegate $stub $object oo::objdefine [self] forward ${stub} $object oo::objdefine [self] export ${stub} } } dump { # Do a full dump of clay data set result {} # Search in the in our list of classes for an answer foreach class $clayorder { ::dicttool::dictmerge result [$class clay dump] } ::dicttool::dictmerge result $clay return $result } ensemble_map { set ensemble [lindex $args 0] my variable claycache set mensemble [string trim $ensemble :/] if {[dict exists $claycache method_ensemble $mensemble]} { return [dicttool::sanitize [dict get $claycache method_ensemble $mensemble]] } set emap [my clay dget method_ensemble $mensemble] dict set claycache method_ensemble $mensemble $emap return [dicttool::sanitize $emap] } eval { set script [lindex $args 0] set buffer {} set thisline {} foreach line [split $script \n] { append thisline $line |
︙ | ︙ | |||
596 597 598 599 600 601 602 | } elseif { append buffer "my $thisline" \n } set thisline {} } eval $buffer } | | > | > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | < | > > | | | < < | > | | | > | | > > > > | | | | | < > | < | | > | < < < | > | > > > | > > > | | > > > | | | | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 | } elseif { append buffer "my $thisline" \n } set thisline {} } eval $buffer } evolve - initialize { my InitializePublic } exists { # Leaf searches return one data field at a time # Search in our local dict set path [::dicttool::storage $args] if {[dict exists $clay {*}$path]} { return 1 } # Search in our local cache if {[dict exists $claycache {*}$path]} { return 2 } set count 2 # Search in the in our list of classes for an answer foreach class $clayorder { incr count if {[$class clay exists {*}$path]} { return $count } } return 0 } flush { set claycache {} set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]] } forward { oo::objdefine [self] forward {*}$args } dget { # Search in our local cache set path [::dicttool::storage $args] #if {[dict exists $claycache {*}$path]} { # return [dict get $claycache {*}$path] #} if {[dict exists $clay {*}$path .]} { # Path is a branch set result {} foreach class [lreverse $clayorder] { if {[$class clay exists {*}$path .]} { set value [$class clay dget {*}$path] ::dicttool::dictmerge result $value } } ::dicttool::dictmerge result [dict get $clay {*}$path] dict set claycache {*}$path $result return $result } elseif {[dict exists $clay {*}$path]} { # Path is a leaf return [dict get $clay {*}$path] } # Search in the in our list of classes for an answer set found 0 foreach class $clayorder { if {[$class clay exists {*}$path .]} { set found 1 break } if {[$class clay exists {*}$path]} { # Found a leaf. set result [$class clay get {*}$path] dict set claycache {*}$path $result return $result } } set result {} if {$found} { # One of our ancestors has this as a branch # Do a recursive merge across all classes foreach class [lreverse $clayorder] { if {[$class clay exists {*}$path .]} { set value [$class clay dget {*}$path] ::dicttool::dictmerge result $value } } } dict set claycache {*}$path $result return $result } getnull - get { set path [::dicttool::storage $args] if {[dict exists $claycache {*}$path .]} { return [::dicttool::sanitize [dict get $claycache {*}$path]] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { # Path is a leaf return [dict get $clay {*}$path] } set found 0 set branch [dict exists $clay {*}$path .] foreach class $clayorder { if {[$class clay exists {*}$path .]} { set found 1 break } if {!$branch && [$class clay exists {*}$path]} { set result [$class clay dget {*}$path] dict set claycache {*}$path $result return $result } } # Path is a branch set result {} foreach class [lreverse $clayorder] { if {[$class clay exists {*}$path .]} { set value [$class clay dget {*}$path] ::dicttool::dictmerge result $value } } if {[dict exists $clay {*}$path .]} { ::dicttool::dictmerge result [dict get $clay {*}$path] } dict set claycache {*}$path $result return [dicttool::sanitize $result] } leaf { # Leaf searches return one data field at a time # Search in our local dict set path [::dicttool::storage $args] if {[dict exists $clay {*}$path .]} { return [dicttool::sanitize [dict get $clay {*}$path]] } if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [dicttool::sanitize [dict get $claycache {*}$path]] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } # Search in the in our list of classes for an answer foreach class $clayorder { if {[$class clay exists {*}$path]} { set value [$class clay get {*}$path] dict set claycache {*}$path $value return $value } } } merge { foreach arg $args { ::dicttool::dictmerge clay {*}$arg } } mixin { ### # Mix in the class ### set prior [info object mixins [self]] |
︙ | ︙ | |||
711 712 713 714 715 716 717 | } } ::oo::objdefine [self] mixin {*}$args ### # Build a compsite map of all ensembles defined by the object's current # class as well as all of the classes being mixed in ### | | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 | } } ::oo::objdefine [self] mixin {*}$args ### # Build a compsite map of all ensembles defined by the object's current # class as well as all of the classes being mixed in ### my InitializePublic foreach class $newmixin { if {$class ni $prior} { set script [$class clay search mixin/ map-script] if {[string length $script]} { if {[catch $script err errdat]} { puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]" } |
︙ | ︙ | |||
733 734 735 736 737 738 739 | puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]" } break } } } mixinmap { | > > > > > > > > > | | | | | | | | | | | > > | > > > > > > | < > > > > > > > > > > > > > > > > > > > | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > < > > > > > > > < < < < < < < < | > | > | > | < | < < < < > | | | < < < < < < < < < < < | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 | puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]" } break } } } mixinmap { my variable clay if {![dict exists $clay .mixin]} { dict set clay .mixin {} } if {[llength $args]==0} { return [dict get $clay .mixin] } elseif {[llength $args]==1} { return [dict getnull $clay .mixin [lindex $args 0]] } else { foreach {slot classes} $args { dict set clay .mixin $slot $classes } set claycache {} set classlist {} foreach {item class} [dict get $clay .mixin] { if {$class ne {}} { lappend classlist $class } } my clay mixin {*}$classlist } } provenance { if {[dict exists $clay {*}$args]} { return self } foreach class $clayorder { if {[$class clay exists {*}$args]} { return $class } } return {} } replace { set clay [lindex $args 0] } source { source [lindex $args 0] } set { #puts [list [self] clay SET {*}$args] set claycache {} ::dicttool::dictset clay {*}$args } default { dict $submethod clay {*}$args } } } method InitializePublic {} { my variable clayorder clay claycache config option_canonical set claycache {} set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]] if {![info exists clay]} { set clay {} } if {![info exists config]} { set config {} } dict for {var value} [my clay get variable] { if { $var in {. clay} } continue set var [string trim $var :/] my variable $var if {![info exists $var]} { if {$::clay::trace>2} {puts [list initialize variable $var $value]} set $var $value } } dict for {var value} [my clay get dict/] { if { $var in {. clay} } continue set var [string trim $var :/] my variable $var if {![info exists $var]} { set $var {} } foreach {f v} $value { if {![dict exists ${var} $f]} { if {$::clay::trace>2} {puts [list initialize dict $var $f $v]} dict set ${var} $f $v } } } foreach {var value} [my clay get dict/] { if { $var in {. clay} } continue set var [string trim $var :/] foreach {f v} [my clay get $var/] { if {![dict exists ${var} $f]} { if {$::clay::trace>2} {puts [list initialize dict (from const) $var $f $v]} dict set ${var} $f $v } } } foreach {var value} [my clay get array/] { if { $var in {. clay} } continue set var [string trim $var :/] if { $var eq {clay} } continue my variable $var if {![info exists $var]} { array set $var {} } foreach {f v} $value { if {![array exists ${var}($f)]} { if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]} set ${var}($f) $v } } } foreach {var value} [my clay get array/] { if { $var in {. clay} } continue set var [string trim $var :/] foreach {f v} [my clay get $var/] { if {![array exists ${var}($f)]} { if {$::clay::trace>2} {puts [list initialize array (from const) $var\($f\) $v]} set ${var}($f) $v } } } foreach {field info} [my clay get option/] { if { $field in {. clay} } continue set field [string trim $field -/:] foreach alias [dict getnull $info aliases] { set option_canonical($alias) $field } if {[dict exists $config $field]} continue set getcmd [dict getnull $info default-command] if {$getcmd ne {}} { set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]] } else { set value [dict getnull $info default] } dict set config $field $value set setcmd [dict getnull $info set-command] if {$setcmd ne {}} { {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd] } } } } ### # END: clay/build/object.tcl ### ### # START: clay/build/doctool.tcl ### ### # END: clay/build/doctool.tcl ### ### # START: setup.tcl ### package require TclOO set tcllib_path {} foreach path {.. ../.. ../../..} { foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] { set tclib_path $path lappend ::auto_path $path break } if {$tcllib_path ne {}} break } namespace eval ::practcl { } namespace eval ::practcl::OBJECT { } ### # END: setup.tcl ### ### # START: docbuild.tcl ### ### # END: docbuild.tcl ### ### # START: buildutil.tcl ### proc Proc {name arglist body} { if {[info command $name] ne {}} return proc $name $arglist $body } Proc ::noop args {} proc ::practcl::debug args { #puts $args ::practcl::cputs ::DEBUG_INFO $args } proc ::practcl::doexec args { puts [list {*}$args] exec {*}$args >&@ stdout } proc ::practcl::doexec_in {path args} { set PWD [pwd] cd $path puts [list {*}$args] exec {*}$args >&@ stdout cd $PWD } proc ::practcl::dotclexec args { puts [list [info nameofexecutable] {*}$args] exec [info nameofexecutable] {*}$args >&@ stdout } proc ::practcl::domake {path args} { set PWD [pwd] cd $path puts [list *** $path ***] puts [list make {*}$args] exec make {*}$args >&@ stdout cd $PWD } proc ::practcl::domake.tcl {path args} { set PWD [pwd] cd $path puts [list *** $path ***] puts [list make.tcl {*}$args] exec [info nameofexecutable] make.tcl {*}$args >&@ stdout cd $PWD } proc ::practcl::fossil {path args} { set PWD [pwd] cd $path puts [list {*}$args] exec fossil {*}$args >&@ stdout cd $PWD } proc ::practcl::fossil_status {dir} { if {[info exists ::fosdat($dir)]} { return $::fosdat($dir) } set result { tags experimental version {} |
︙ | ︙ | |||
910 911 912 913 914 915 916 | dict set result tags $tags break } } set ::fosdat($dir) $result return $result } | < > > > | > > > | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 | dict set result tags $tags break } } set ::fosdat($dir) $result return $result } proc ::practcl::os {} { return [${::practcl::MAIN} define get TEACUP_OS] } proc ::practcl::mkzip {exename barekit vfspath} { ::practcl::tcllib_require zipfile::mkzip ::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath } proc ::practcl::sort_dict list { return [::lsort -stride 2 -dictionary $list] } if {[::package vcompare $::tcl_version 8.6] < 0} { # Approximate ::zipfile::mkzip with exec calls proc ::practcl::mkzip {exename barekit vfspath} { set path [file dirname [file normalize $exename]] set zipfile [file join $path [file rootname $exename].zip] file copy -force $barekit $exename set pwd [pwd] |
︙ | ︙ | |||
941 942 943 944 945 946 947 | proc ::practcl::sort_dict list { set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } | < < < < | < < < < < | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 | proc ::practcl::sort_dict list { set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } } proc ::practcl::local_os {} { # If we have already run this command, return # a cached copy of the data if {[info exists ::practcl::LOCAL_INFO]} { return $::practcl::LOCAL_INFO } set result [array get ::practcl::CONFIG] |
︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 | if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} { dict set result fossil_mirror $::env(FOSSIL_MIRROR) } set ::practcl::LOCAL_INFO $result return $result } | < < < < < < | 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 | if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} { dict set result fossil_mirror $::env(FOSSIL_MIRROR) } set ::practcl::LOCAL_INFO $result return $result } proc ::practcl::config.tcl {path} { return [read_configuration $path] } proc ::practcl::read_configuration {path} { dict set result buildpath $path set result [local_os] set OS [dict get $result TEACUP_OS] set windows 0 dict set result USEMSVC 0 if {[file exists [file join $path config.tcl]]} { |
︙ | ︙ | |||
1140 1141 1142 1143 1144 1145 1146 | } dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH] dict set result TEACUP_OS windows dict set result EXEEXT .exe } return $result } | < < < < < < < < < < | | < < < < < | 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 | } dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH] dict set result TEACUP_OS windows dict set result EXEEXT .exe } return $result } if {$::tcl_platform(platform) eq "windows"} { proc ::practcl::msys_to_tclpath msyspath { return [exec sh -c "cd $msyspath ; pwd -W"] } proc ::practcl::tcl_to_myspath tclpath { set path [file normalize $tclpath] return "/[string index $path 0][string range $path 2 end]" #return [exec sh -c "cd $tclpath ; pwd"] } } else { proc ::practcl::msys_to_tclpath msyspath { return [file normalize $msyspath] } proc ::practcl::tcl_to_myspath msyspath { return [file normalize $msyspath] } } proc ::practcl::tcllib_require {pkg args} { # Try to load the package from the local environment if {[catch [list ::package require $pkg {*}$args] err]==0} { return $err } ::practcl::LOCAL tool tcllib env-load uplevel #0 [list ::package require $pkg {*}$args] } namespace eval ::practcl::platform { } proc ::practcl::platform::tcl_core_options {os} { ### # Download our required packages ### set tcl_config_opts {} # Auto-guess options for the local operating system switch $os { windows { #lappend tcl_config_opts --disable-stubs } linux { } macosx { lappend tcl_config_opts --enable-corefoundation=yes --enable-framework=no } } lappend tcl_config_opts --with-tzdata return $tcl_config_opts } proc ::practcl::platform::tk_core_options {os} { ### # Download our required packages ### set tk_config_opts {} # Auto-guess options for the local operating system switch $os { windows { } linux { lappend tk_config_opts --enable-xft=no --enable-xss=no } macosx { lappend tk_config_opts --enable-aqua=yes } } return $tk_config_opts } proc ::practcl::read_rc_file {filename {localdat {}}} { set result $localdat set fin [open $filename r] set bufline {} set rawcount 0 set linecount 0 while {[gets $fin thisline]>=0} { |
︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 | #set key [lindex $line 0] #set value [lindex $line 1] #dict set result $key $value } close $fin return $result } | < < < < < < < < < | 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 | #set key [lindex $line 0] #set value [lindex $line 1] #dict set result $key $value } close $fin return $result } proc ::practcl::read_sh_subst {line info} { regsub -all {\x28} $line \x7B line regsub -all {\x29} $line \x7D line #set line [string map $key [string trim $line]] foreach {field value} $info { catch {set $field $value} } if [catch {subst $line} result] { return {} } set result [string trim $result] return [string trim $result '] } proc ::practcl::read_sh_file {filename {localdat {}}} { set fin [open $filename r] set result {} if {$localdat eq {}} { set top 1 set local [array get ::env] dict set local EXE {} |
︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 | #puts $opts puts "Error reading line:\n$line\nerr: $err\n***" return $err {*}$opts } } return $result } | < < < < < | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 | #puts $opts puts "Error reading line:\n$line\nerr: $err\n***" return $err {*}$opts } } return $result } proc ::practcl::read_Config.sh filename { set fin [open $filename r] set result {} set linecount 0 while {[gets $fin line] >= 0} { set line [string trim $line] if {[string index $line 0] eq "#"} continue |
︙ | ︙ | |||
1342 1343 1344 1345 1346 1347 1348 | #puts $opts puts "Error reading line:\n$line\nerr: $err\n***" return $err {*}$opts } } return $result } | < < < < < | 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 | #puts $opts puts "Error reading line:\n$line\nerr: $err\n***" return $err {*}$opts } } return $result } proc ::practcl::read_Makefile filename { set fin [open $filename r] set result {} while {[gets $fin line] >= 0} { set line [string trim $line] if {[string index $line 0] eq "#"} continue if {$line eq {}} continue |
︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 | # the Compile field is about where most TEA files start getting silly if {$field eq "compile"} { break } } return $result } | < < < < < < < < | 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 | # the Compile field is about where most TEA files start getting silly if {$field eq "compile"} { break } } return $result } proc ::practcl::cputs {varname args} { upvar 1 $varname buffer if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} { } if {[info exist buffer]} { if {[string index $buffer end] ne "\n"} { append buffer \n } } else { set buffer \n } # Trim leading \n's append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end] } proc ::practcl::tcl_to_c {body} { set result {} foreach rawline [split $body \n] { set line [string map [list \" \\\" \\ \\\\] $rawline] cputs result "\n \"$line\\n\" \\" } return [string trimright $result \\] } proc ::practcl::_tagblock {text {style tcl} {note {}}} { if {[string length [string trim $text]]==0} { return {} } set output {} switch $style { tcl { |
︙ | ︙ | |||
1458 1459 1460 1461 1462 1463 1464 | } default { ::practcl::cputs output "# END $note" } } return $output } | < | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 | } default { ::practcl::cputs output "# END $note" } } return $output } proc ::practcl::de_shell {data} { set values {} foreach flag {DEFS TCL_DEFS TK_DEFS} { if {[dict exists $data $flag]} { #set value {} #foreach item [dict get $data $flag] { # append value " " [string map {{ } {\ }} $item] |
︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 | ### # END: buildutil.tcl ### ### # START: fileutil.tcl ### | < < < < | 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 | ### # END: buildutil.tcl ### ### # START: fileutil.tcl ### proc ::practcl::cat fname { if {![file exists $fname]} { return } set fin [open $fname r] set data [read $fin] close $fin return $data } proc ::practcl::grep {pattern {files {}}} { set result [list] if {[llength $files] == 0} { # read from stdin set lnum 0 while {[gets stdin line] >= 0} { incr lnum |
︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 | } } close $file } } return $result } | < | 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 | } } close $file } } return $result } proc ::practcl::file_lexnormalize {sp} { set spx [file split $sp] # Resolution of embedded relative modifiers (., and ..). if { ([lsearch -exact $spx . ] < 0) && |
︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 | } if {[llength $np] > 0} { return [eval [linsert $np 0 file join]] # 8.5: return [file join {*}$np] } return {} } | < | 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 | } if {[llength $np] > 0} { return [eval [linsert $np 0 file join]] # 8.5: return [file join {*}$np] } return {} } proc ::practcl::file_relative {base dst} { # Ensure that the link to directory 'dst' is properly done relative to # the directory 'base'. if {![string equal [file pathtype $base] [file pathtype $dst]]} { return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" } |
︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 | } # 8.5: set dst [file join {*}$dst] set dst [eval [linsert $dst 0 file join]] } return $dst } | < < < < < < < < < | 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 | } # 8.5: set dst [file join {*}$dst] set dst [eval [linsert $dst 0 file join]] } return $dst } proc ::practcl::log {fname comment} { set fname [file normalize $fname] if {[info exists ::practcl::logchan($fname)]} { set fout $::practcl::logchan($fname) after cancel $::practcl::logevent($fname) } else { set fout [open $fname a] } puts $fout $comment # Defer close until idle set ::practcl::logevent($fname) [after idle "close $fout ; unset ::practcl::logchan($fname)"] } ### # END: fileutil.tcl ### ### # START: installutil.tcl ### proc ::practcl::_isdirectory name { return [file isdirectory $name] } proc ::practcl::_pkgindex_directory {path} { set buffer {} set pkgidxfile [file join $path pkgIndex.tcl] if {![file exists $pkgidxfile]} { # No pkgIndex file, read the source foreach file [glob -nocomplain $path/*.tm] { set file [file normalize $file] |
︙ | ︙ | |||
1784 1785 1786 1787 1788 1789 1790 | } append buffer $thisline \n set thisline {} } if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} return $buffer } | < < < < < < | 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 | } append buffer $thisline \n set thisline {} } if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} return $buffer } proc ::practcl::_pkgindex_path_subdir {path} { set result {} if {[file exists [file join $path src build.tcl]]} { # Tool style module, don't dive into subdirectories return $path } foreach subpath [glob -nocomplain [file join $path *]] { if {[file isdirectory $subpath]} { if {[file tail $subpath] eq "build" && [file exists [file join $subpath build.tcl]]} continue lappend result $subpath {*}[_pkgindex_path_subdir $subpath] } } return $result } proc ::practcl::pkgindex_path {args} { set stack {} set buffer { lappend ::PATHSTACK $dir set IDXPATH [lindex $::PATHSTACK end] } set preindexed {} |
︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 | } append buffer { set dir [lindex $::PATHSTACK end] set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] } return $buffer } | < | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 | } append buffer { set dir [lindex $::PATHSTACK end] set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] } return $buffer } proc ::practcl::installDir {d1 d2} { puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] file delete -force -- $d2 file mkdir $d2 foreach ftail [glob -directory $d1 -nocomplain -tails *] { set f [file join $d1 $ftail] |
︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 | if {$::tcl_platform(platform) eq {unix}} { file attributes $d2 -permissions 0755 } else { file attributes $d2 -readonly 1 } } | < | 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 | if {$::tcl_platform(platform) eq {unix}} { file attributes $d2 -permissions 0755 } else { file attributes $d2 -readonly 1 } } proc ::practcl::copyDir {d1 d2 {toplevel 1}} { #if {$toplevel} { # puts [list ::practcl::copyDir $d1 -> $d2] #} #file delete -force -- $d2 file mkdir $d2 if {[file isfile $d1]} { |
︙ | ︙ | |||
1929 1930 1931 1932 1933 1934 1935 | ### # END: installutil.tcl ### ### # START: makeutil.tcl ### | < < < < < < < > < < | 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 | ### # END: installutil.tcl ### ### # START: makeutil.tcl ### proc ::practcl::trigger {args} { ::practcl::LOCAL make trigger {*}$args foreach {name obj} [::practcl::LOCAL make objects] { set ::make($name) [$obj do] } } proc ::practcl::depends {args} { ::practcl::LOCAL make depends {*}$args } proc ::practcl::target {name info {action {}}} { set obj [::practcl::LOCAL make task $name $info $action] set ::make($name) 0 set filename [$obj define get filename] if {$filename ne {}} { set ::target($name) $filename } } ### # END: makeutil.tcl ### ### # START: class metaclass.tcl ### ::oo::class create ::practcl::metaclass { superclass ::oo::object method _MorphPatterns {} { return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}} } method define {submethod args} { my variable define switch $submethod { dump { return [array get define] } add { |
︙ | ︙ | |||
2028 2029 2030 2031 2032 2033 2034 | } } default { array $submethod define {*}$args } } } | < < < < | 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 | } } default { array $submethod define {*}$args } } } method graft args { return [my clay delegate {*}$args] } method initialize {} {} method link {command args} { my variable links switch $command { object { foreach obj $args { foreach linktype [$obj linktype] { my link add $linktype $obj |
︙ | ︙ | |||
2090 2091 2092 2093 2094 2095 2096 | return $links($linktype) } dump { return [array get links] } } } | < | 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 | return $links($linktype) } dump { return [array get links] } } } method morph classname { my variable define if {$classname ne {}} { set map [list @name@ $classname] foreach pattern [string map $map [my _MorphPatterns]] { set pattern [string trim $pattern] set matches [info commands $pattern] |
︙ | ︙ | |||
2130 2131 2132 2133 2134 2135 2136 | } } if {[::info exists define(oodefine)]} { ::oo::objdefine [self] $define(oodefine) #unset define(oodefine) } } | < | 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 | } } if {[::info exists define(oodefine)]} { ::oo::objdefine [self] $define(oodefine) #unset define(oodefine) } } method mixin {slot classname} { my variable mixinslot set class {} set map [list @slot@ $slot @name@ $classname] foreach pattern [split [string map $map { @name@ @slot@.@name@ |
︙ | ︙ | |||
2158 2159 2160 2161 2162 2163 2164 | set mixins {} foreach {s c} $mixinslot { if {$c eq {}} continue lappend mixins $c } oo::objdefine [self] mixin {*}$mixins } | < < < < < < < < < < < < < < < | 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 | set mixins {} foreach {s c} $mixinslot { if {$c eq {}} continue lappend mixins $c } oo::objdefine [self] mixin {*}$mixins } method organ args { return [my clay delegate {*}$args] } method script script { eval $script } method select {} { my variable define if {[info exists define(class)]} { my morph $define(class) } else { if {[::info exists define(oodefine)]} { ::oo::objdefine [self] $define(oodefine) #unset define(oodefine) } } } method source filename { source $filename } } ### # END: class metaclass.tcl ### ### # START: class toolset baseclass.tcl ### oo::class create ::practcl::toolset { method config.sh {} { return [my read_configuration] } method BuildDir {PWD} { set name [my define get name] set debug [my define get debug 0] if {[my <project> define get LOCAL 0]} { return [my define get builddir [file join $PWD local $name]] } if {$debug} { return [my define get builddir [file join $PWD debug $name]] } else { return [my define get builddir [file join $PWD pkg $name]] } } method MakeDir {srcdir} { return $srcdir } method read_configuration {} { my variable conf_result if {[info exists conf_result]} { return $conf_result } set result {} set name [my define get name] |
︙ | ︙ | |||
2282 2283 2284 2285 2286 2287 2288 | if {![dict exists $result PRACTCL_PKG_LIBS] && [dict exists $result LIBS]} { dict set result PRACTCL_PKG_LIBS [dict get $result LIBS] } set conf_result $result cd $PWD return $result } | < < < < < < < < | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 | if {![dict exists $result PRACTCL_PKG_LIBS] && [dict exists $result LIBS]} { dict set result PRACTCL_PKG_LIBS [dict get $result LIBS] } set conf_result $result cd $PWD return $result } method build-cflags {PROJECT DEFS namevar versionvar defsvar} { upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs set name [string tolower [${PROJECT} define get name [${PROJECT} define get pkg_name]]] set NAME [string toupper $name] set version [${PROJECT} define get version [${PROJECT} define get pkg_vers]] if {$version eq {}} { set version 0.1a |
︙ | ︙ | |||
2316 2317 2318 2319 2320 2321 2322 | set defs "$predef $postdef" } } append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" return $defs } | < < < < | 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 | set defs "$predef $postdef" } } append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" return $defs } method critcl args { if {![info exists critcl]} { ::practcl::LOCAL tool critcl env-load set critcl [file join [::practcl::LOCAL tool critcl define get srcdir] main.tcl } set srcdir [my SourceRoot] set PWD [pwd] cd $srcdir ::practcl::dotclexec $critcl {*}$args cd $PWD } method make-autodetect {} {} } oo::objdefine ::practcl::toolset { method select object { ### # Select the toolset to use for this project ### |
︙ | ︙ | |||
2362 2363 2364 2365 2366 2367 2368 | ### # END: class toolset baseclass.tcl ### ### # START: class toolset gcc.tcl ### | < < < < | 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 | ### # END: class toolset baseclass.tcl ### ### # START: class toolset gcc.tcl ### ::oo::class create ::practcl::toolset.gcc { superclass ::practcl::toolset method Autoconf {} { ### # Re-run autoconf for this project # Not a good idea in practice... but in the right hands it can be useful ### set pwd [pwd] set srcdir [file normalize [my define get srcdir]] cd $srcdir foreach template {configure.ac configure.in} { set input [file join $srcdir $template] if {[file exists $input]} { puts "autoconf -f $input > [file join $srcdir configure]" exec autoconf -f $input > [file join $srcdir configure] } } cd $pwd } method BuildDir {PWD} { set name [my define get name] set debug [my define get debug 0] if {[my <project> define get LOCAL 0]} { return [my define get builddir [file join $PWD local $name]] } if {$debug} { return [my define get builddir [file join $PWD debug $name]] } else { return [my define get builddir [file join $PWD pkg $name]] } } method ConfigureOpts {} { set opts {} set builddir [my define get builddir] if {[my define get broken_destroot 0]} { set PREFIX [my <project> define get prefix_broken_destdir] } else { |
︙ | ︙ | |||
2465 2466 2467 2468 2469 2470 2471 | #--disable-stubs # } else { lappend opts --enable-shared } return $opts } | < < | 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 | #--disable-stubs # } else { lappend opts --enable-shared } return $opts } method MakeDir {srcdir} { set localsrcdir $srcdir if {[file exists [file join $srcdir generic]]} { my define add include_dir [file join $srcdir generic] } set os [my <project> define get TEACUP_OS] switch $os { |
︙ | ︙ | |||
2498 2499 2500 2501 2502 2503 2504 | } elseif {[file exists [file join $srcdir unix Makefile.in]]} { set localsrcdir [file join $srcdir unix] } } } return $localsrcdir } | < | 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 | } elseif {[file exists [file join $srcdir unix Makefile.in]]} { set localsrcdir [file join $srcdir unix] } } } return $localsrcdir } method make-autodetect {} { set srcdir [my define get srcdir] set localsrcdir [my define get localsrcdir] if {$srcdir eq $localsrcdir} { if {![file exists [file join $srcdir tclconfig install-sh]]} { # ensure we have tclconfig with all of the trimmings set teapath {} |
︙ | ︙ | |||
2542 2543 2544 2545 2546 2547 2548 | cd $builddir if {[my <project> define get CONFIG_SITE] ne {}} { set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE] } catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]} cd $::CWD } | < < | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 | cd $builddir if {[my <project> define get CONFIG_SITE] ne {}} { set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE] } catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]} cd $::CWD } method make-clean {} { set builddir [file normalize [my define get builddir]] catch {::practcl::domake $builddir clean} } method make-compile {} { set name [my define get name] set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" |
︙ | ︙ | |||
2572 2573 2574 2575 2576 2577 2578 | } else { ::practcl::domake.tcl $builddir all } } else { ::practcl::domake $builddir all } } | < | 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 | } else { ::practcl::domake.tcl $builddir all } } else { ::practcl::domake $builddir all } } method make-install DEST { set PWD [pwd] set builddir [my define get builddir] if {[my <project> define get LOCAL 0] || $DEST eq {}} { if {[file exists [file join $builddir make.tcl]]} { puts "[self] Local INSTALL (Practcl)" ::practcl::domake.tcl $builddir install |
︙ | ︙ | |||
2608 2609 2610 2611 2612 2613 2614 | ::practcl::domake $builddir $install ::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]] file delete -force $BROKENROOT } } cd $PWD } | < | 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 | ::practcl::domake $builddir $install ::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]] file delete -force $BROKENROOT } } cd $PWD } method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} { set objext [my define get OBJEXT o] set EXTERN_OBJS {} set OBJECTS {} set result {} set builddir [$PROJECT define get builddir] file mkdir [file join $builddir objs] |
︙ | ︙ | |||
2705 2706 2707 2708 2709 2710 2711 | continue } error "Failed to produce $filename" } } return $result } | < | 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 | continue } error "Failed to produce $filename" } } return $result } method build-Makefile {path PROJECT} { array set proj [$PROJECT define dump] set path $proj(builddir) cd $path set includedir . set objext [my define get OBJEXT o] |
︙ | ︙ | |||
2797 2798 2799 2800 2801 2802 2803 | $PROJECT define set static_library $outfile dict set map %OUTFILE% $outfile ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]" ::practcl::cputs result {} return $result } | < < < < | 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 | $PROJECT define set static_library $outfile dict set map %OUTFILE% $outfile ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]" ::practcl::cputs result {} return $result } method build-library {outfile PROJECT} { array set proj [$PROJECT define dump] set path $proj(builddir) cd $path set includedir . #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] |
︙ | ︙ | |||
2878 2879 2880 2881 2882 2883 2884 | exec {*}$cmd >&@ stdout } set ranlib [$PROJECT define get RANLIB] if {$ranlib ni {{} :}} { catch {exec $ranlib $outfile} } } | < < < < | 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 | exec {*}$cmd >&@ stdout } set ranlib [$PROJECT define get RANLIB] if {$ranlib ni {{} :}} { catch {exec $ranlib $outfile} } } method build-tclsh {outfile PROJECT} { puts " BUILDING STATIC TCLSH " set TCLOBJ [$PROJECT tclcore] ::practcl::toolset select $TCLOBJ set PKG_OBJS {} foreach item [$PROJECT link list core.library] { if {[string is true [$item define get static]]} { |
︙ | ︙ | |||
3097 3098 3099 3100 3101 3102 3103 | set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} append cmd " $LDFLAGS_CONSOLE" } puts "LINK: $cmd" exec {*}[string map [list "\n" " " " " " "] $cmd] >&@ stdout } | < < < < < < < < | 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 | set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} append cmd " $LDFLAGS_CONSOLE" } puts "LINK: $cmd" exec {*}[string map [list "\n" " " " " " "] $cmd] >&@ stdout } } ### # END: class toolset gcc.tcl ### ### # START: class toolset msvc.tcl ### ::oo::class create ::practcl::toolset.msvc { superclass ::practcl::toolset method BuildDir {PWD} { set srcdir [my define get srcdir] return $srcdir } method make-autodetect {} { } method make-clean {} { set PWD [pwd] set srcdir [my define get srcdir] cd $srcdir catch {::practcl::doexec nmake -f makefile.vc clean} cd $PWD } method make-compile {} { set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } |
︙ | ︙ | |||
3153 3154 3155 3156 3157 3158 3159 | cd [file join $srcdir win] ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release } else { error "No make.tcl or makefile.vc found for project $name" } } } | < | 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 | cd [file join $srcdir win] ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release } else { error "No make.tcl or makefile.vc found for project $name" } } } method make-install DEST { set PWD [pwd] set srcdir [my define get srcdir] cd $srcdir if {$DEST eq {}} { error "No destination given" } |
︙ | ︙ | |||
3182 3183 3184 3185 3186 3187 3188 | } else { puts "[self] VFS INSTALL $DEST" ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install } } cd $PWD } | < < < | 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 | } else { puts "[self] VFS INSTALL $DEST" ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install } } cd $PWD } method MakeDir {srcdir} { set localsrcdir $srcdir if {[file exists [file join $srcdir generic]]} { my define add include_dir [file join $srcdir generic] } if {[file exists [file join $srcdir win]]} { my define add include_dir [file join $srcdir win] } if {[file exists [file join $srcdir makefile.vc]]} { set localsrcdir [file join $srcdir win] } return $localsrcdir } method NmakeOpts {} { set opts {} set builddir [file normalize [my define get builddir]] if {[my <project> define exists tclsrcdir]} { ### # On Windows we are probably running under MSYS, which doesn't deal with |
︙ | ︙ | |||
3228 3229 3230 3231 3232 3233 3234 | ### # END: class toolset msvc.tcl ### ### # START: class target.tcl ### | < < < < | 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 | ### # END: class toolset msvc.tcl ### ### # START: class target.tcl ### ::oo::class create ::practcl::make_obj { superclass ::practcl::metaclass constructor {module_object name info {action_body {}}} { my variable define triggered domake set triggered 0 set domake 0 set define(name) $name set define(action) {} array set define $info my select my initialize foreach {stub obj} [$module_object child organs] { my graft $stub $obj } if {$action_body ne {}} { set define(action) $action_body } } method do {} { my variable domake return $domake } method check {} { my variable needs_make domake if {$domake} { return 1 } if {[info exists needs_make]} { return $needs_make |
︙ | ︙ | |||
3284 3285 3286 3287 3288 3289 3290 | if {$filename ne {} && ![file exists $filename]} { set needs_make 1 } } } return $needs_make } | < < < | 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 | if {$filename ne {} && ![file exists $filename]} { set needs_make 1 } } } return $needs_make } method output {} { set result {} set filename [my define get filename] if {$filename ne {}} { lappend result $filename } foreach filename [my define get files] { if {$filename ne {}} { lappend result $filename } } return $result } method reset {} { my variable triggered domake needs_make set triggerd 0 set domake 0 set needs_make 0 } method triggers {} { my variable triggered domake define if {$triggered} { return $domake } set triggered 1 set make_objects [my <module> make objects] |
︙ | ︙ | |||
3340 3341 3342 3343 3344 3345 3346 | # END: class target.tcl ### ### # START: class object.tcl ### ::oo::class create ::practcl::object { superclass ::practcl::metaclass | < | 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 | # END: class target.tcl ### ### # START: class object.tcl ### ::oo::class create ::practcl::object { superclass ::practcl::metaclass constructor {parent args} { my variable links define set organs [$parent child organs] my clay delegate {*}$organs array set define $organs array set define [$parent child define] array set links {} |
︙ | ︙ | |||
3362 3363 3364 3365 3366 3367 3368 | } else { array set define [uplevel 1 [list subst $args]] my select } my initialize } | < < < < < < < < < < < < < < < < < < < | 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 | } else { array set define [uplevel 1 [list subst $args]] my select } my initialize } method child {method} { return {} } method go {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable links foreach {linktype objs} [array get links] { foreach obj $objs { $obj go } } ::practcl::debug [list /[self] [self method] [self class]] } } ### # END: class object.tcl ### ### # START: class dynamic.tcl ### ::oo::class create ::practcl::dynamic { method cstructure {name definition {argdat {}}} { my variable cstruct dict set cstruct $name body $definition foreach {f v} $argdat { dict set cstruct $name $f $v } if {![dict exists $cstruct $name public]} { dict set cstruct $name public 1 } } method include header { my define add include $header } method include_dir args { my define add include_dir {*}$args } method include_directory args { my define add include_dir {*}$args } method c_header body { my variable code ::practcl::cputs code(header) $body } method c_code body { my variable code ::practcl::cputs code(funct) $body } method c_function {header body {info {}}} { set header [string map "\t \ \n \ \ \ \ " $header] my variable code cfunct foreach regexp { {(.*) ([a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} {(.*) (\x2a[a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} } { |
︙ | ︙ | |||
3477 3478 3479 3480 3481 3482 3483 | } puts "WARNING: NON CONFORMING FUNCTION DEFINITION: $headers $body" ::practcl::cputs code(header) "$header\;" # Could not parse that block as a function # append it verbatim to our c_implementation ::practcl::cputs code(funct) "$header [list $body]" } | < < < < < < < < | 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 | } puts "WARNING: NON CONFORMING FUNCTION DEFINITION: $headers $body" ::practcl::cputs code(header) "$header\;" # Could not parse that block as a function # append it verbatim to our c_implementation ::practcl::cputs code(funct) "$header [list $body]" } method c_tcloomethod {name body {arginfo {}}} { my variable methods code foreach {f v} $arginfo { dict set methods $name $f $v } dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ $body" } method cmethod {name body {arginfo {}}} { my variable methods code foreach {f v} $arginfo { dict set methods $name $f $v } dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ $body" } method c_tclproc_nspace nspace { my variable code if {![info exists code(nspace)]} { set code(nspace) {} } if {$nspace ni $code(nspace)} { lappend code(nspace) $nspace } } method c_tclcmd {name body {arginfo {}}} { my variable tclprocs code foreach {f v} $arginfo { dict set tclprocs $name $f $v } dict set tclprocs $name body $body } method c_tclproc_raw {name body {arginfo {}}} { my variable tclprocs code foreach {f v} $arginfo { dict set tclprocs $name $f $v } dict set tclprocs $name body $body } method tcltype {name argdat} { my variable tcltype foreach {f v} $argdat { dict set tcltype $name $f $v } if {![dict exists tcltype $name cname]} { dict set tcltype $name cname [string tolower $name]_tclobjtype |
︙ | ︙ | |||
3556 3557 3558 3559 3560 3561 3562 | # We were given a function name to call if {[llength $body] eq 1} continue set fname [string map [list @Name@ [string totitle $name]] $fpat] my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body] dict set tcltype $name $func $fname } } | < < < < < < | 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 | # We were given a function name to call if {[llength $body] eq 1} continue set fname [string map [list @Name@ [string totitle $name]] $fpat] my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body] dict set tcltype $name $func $fname } } method project-compile-products {} { set filename [my define get output_c] set result {} if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename if {[my define exists ofile]} { |
︙ | ︙ | |||
3593 3594 3595 3596 3597 3598 3599 | } } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } | < < < < < < < < < < < | 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 | } } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } method implement path { my go my Collate_Source $path if {[my define get output_c] eq {}} return set filename [file join $path [my define get output_c]] ::practcl::debug [self] [my define get filename] WANTS TO GENERATE $filename my define set cfile $filename set fout [open $filename w] puts $fout [my generate-c] if {[my define get initfunc] ne {}} { puts $fout "extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \x7B" puts $fout [my generate-loader-module] if {[my define get pkg_name] ne {}} { puts $fout " Tcl_PkgProvide(interp, \"[my define get pkg_name]\", \"[my define get pkg_vers]\");" } puts $fout " return TCL_OK\;" puts $fout "\x7D" } close $fout } method initialize {} { set filename [my define get filename] if {$filename eq {}} { return } if {[my define get name] eq {}} { my define set name [file tail [file rootname $filename]] } if {[my define get localpath] eq {}} { my define set localpath [my <module> define get localpath]_[my define get name] } ::source $filename } method linktype {} { return {subordinate product dynamic} } method generate-cfile-constant {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code cstruct methods tcltype if {[info exists code(constant)]} { ::practcl::cputs result "/* [my define get filename] CONSTANT */" ::practcl::cputs result $code(constant) |
︙ | ︙ | |||
3724 3725 3726 3727 3728 3729 3730 | foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-constant] } return $result } | < | 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 | foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-constant] } return $result } method generate-cfile-header {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct cstruct methods tcltype tclprocs set result {} if {[info exists code(header)]} { ::practcl::cputs result $code(header) } |
︙ | ︙ | |||
3770 3771 3772 3773 3774 3775 3776 | ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" ::practcl::cputs result $dat ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" } } return $result } | < < < < < | 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 | ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" ::practcl::cputs result $dat ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" } } return $result } method generate-cfile-tclapi {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code methods tclprocs set result {} if {[info exists code(method)]} { ::practcl::cputs result $code(method) } |
︙ | ︙ | |||
3864 3865 3866 3867 3868 3869 3870 | foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-tclapi] } return $result } | < < < < < | 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 | foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-tclapi] } return $result } method generate-loader-module {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code methods tclprocs if {[info exists code(nspace)]} { ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" foreach nspace $code(nspace) { |
︙ | ︙ | |||
3931 3932 3933 3934 3935 3936 3937 | ::practcl::cputs result [$obj generate-loader-external] } else { ::practcl::cputs result [$obj generate-loader-module] } } return $result } | < | 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 | ::practcl::cputs result [$obj generate-loader-external] } else { ::practcl::cputs result [$obj generate-loader-module] } } return $result } method Collate_Source CWD { my variable methods code cstruct tclprocs if {[info exists methods]} { ::practcl::debug [self] methods [my define get cclass] set thisclass [my define get cclass] foreach {name info} $methods { # Provide a callproc |
︙ | ︙ | |||
3974 3975 3976 3977 3978 3979 3980 | } if {[dict exists $info body] && ![dict exists $info header]} { dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])" } } } } | < < < < | < < < < < < < < < < < < < < < < < | 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 | } if {[dict exists $info body] && ![dict exists $info header]} { dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])" } } } } method select {} {} } ### # END: class dynamic.tcl ### ### # START: class product.tcl ### ::oo::class create ::practcl::product { method code {section body} { my variable code ::practcl::cputs code($section) $body } method Collate_Source CWD {} method project-compile-products {} { set result {} noop { set filename [my define get filename] if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename if {[my define exists ofile]} { set ofile [my define get ofile] } else { set ofile [my Ofile $filename] my define set ofile $ofile } 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]] } } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } method generate-debug {{spaces {}}} { set result {} ::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my define get filename]] links [my link list]]" foreach item [my link list subordinate] { practcl::cputs result [$item generate-debug "$spaces "] } return $result } method generate-cfile-constant {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code cstruct methods tcltype if {[info exists code(constant)]} { ::practcl::cputs result "/* [my define get filename] CONSTANT */" ::practcl::cputs result $code(constant) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-constant] } return $result } method generate-cfile-public-structure {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct methods tcltype set result {} if {[info exists code(struct)]} { ::practcl::cputs result $code(struct) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-public-structure] } return $result } method generate-cfile-header {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct cstruct methods tcltype tclprocs set result {} if {[info exists code(header)]} { ::practcl::cputs result $code(header) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue set dat [$obj generate-cfile-header] if {[string length [string trim $dat]]} { ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" ::practcl::cputs result $dat ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" } } return $result } method generate-cfile-global {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct cstruct methods tcltype tclprocs set result {} if {[info exists code(global)]} { ::practcl::cputs result $code(global) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue set dat [$obj generate-cfile-global] if {[string length [string trim $dat]]} { ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-global */" ::practcl::cputs result $dat ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-global */" } } return $result } method generate-cfile-private-typedef {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct set result {} if {[info exists code(private-typedef)]} { ::practcl::cputs result $code(private-typedef) } |
︙ | ︙ | |||
4130 4131 4132 4133 4134 4135 4136 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-cfile-private-typedef] } return $result } | < | 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-cfile-private-typedef] } return $result } method generate-cfile-private-structure {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct set result {} if {[info exists code(private-structure)]} { ::practcl::cputs result $code(private-structure) } |
︙ | ︙ | |||
4153 4154 4155 4156 4157 4158 4159 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-cfile-private-structure] } return $result } | < < < < < < | 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-cfile-private-structure] } return $result } method generate-cfile-functions {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct set result {} if {[info exists code(funct)]} { ::practcl::cputs result $code(funct) } |
︙ | ︙ | |||
4185 4186 4187 4188 4189 4190 4191 | if {[$obj define get output_c] ne {}} { continue } ::practcl::cputs result [$obj generate-cfile-functions] } return $result } | < < < < < < < < < | 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 | if {[$obj define get output_c] ne {}} { continue } ::practcl::cputs result [$obj generate-cfile-functions] } return $result } method generate-cfile-tclapi {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code methods tclprocs set result {} if {[info exists code(method)]} { ::practcl::cputs result $code(method) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-tclapi] } return $result } method generate-hfile-public-define {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code set result {} if {[info exists code(public-define)]} { ::practcl::cputs result $code(public-define) } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-define] } return $result } method generate-hfile-public-macro {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code set result {} if {[info exists code(public-macro)]} { ::practcl::cputs result $code(public-macro) } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-macro] } return $result } method generate-hfile-public-typedef {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct set result {} if {[info exists code(public-typedef)]} { ::practcl::cputs result $code(public-typedef) } |
︙ | ︙ | |||
4259 4260 4261 4262 4263 4264 4265 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-typedef] } return $result } | < | 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-typedef] } return $result } method generate-hfile-public-structure {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct set result {} if {[info exists code(public-structure)]} { ::practcl::cputs result $code(public-structure) } |
︙ | ︙ | |||
4282 4283 4284 4285 4286 4287 4288 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-structure] } return $result } | < | 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-structure] } return $result } method generate-hfile-public-headers {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code tcltype set result {} if {[info exists code(public-header)]} { ::practcl::cputs result $code(public-header) } |
︙ | ︙ | |||
4310 4311 4312 4313 4314 4315 4316 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-headers] } return $result } | < < < < < < < < < | 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-headers] } return $result } method generate-hfile-public-function {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct tcltype set result {} if {[my define get initfunc] ne {}} { ::practcl::cputs result "int [my define get initfunc](Tcl_Interp *interp);" } if {[info exists cfunct]} { foreach {funcname info} $cfunct { if {![dict get $info public]} continue ::practcl::cputs result "[dict get $info header]\;" } } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-function] } return $result } method generate-hfile-public-includes {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set includes {} foreach item [my define get public-include] { if {$item ni $includes} { lappend includes $item } } foreach mod [my link list product] { foreach item [$mod generate-hfile-public-includes] { if {$item ni $includes} { lappend includes $item } } } return $includes } method generate-hfile-public-verbatim {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set includes {} foreach item [my define get public-verbatim] { if {$item ni $includes} { lappend includes $item } } foreach mod [my link list subordinate] { foreach item [$mod generate-hfile-public-verbatim] { if {$item ni $includes} { lappend includes $item } } } return $includes } method generate-loader-external {} { if {[my define get initfunc] eq {}} { return "/* [my define get filename] declared not initfunc */" } return " if([my define get initfunc](interp)) return TCL_ERROR\;" } method generate-loader-module {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code set result {} if {[info exists code(cinit)]} { ::practcl::cputs result $code(cinit) } if {[my define get initfunc] ne {}} { ::practcl::cputs result " if([my define get initfunc](interp)!=TCL_OK) return TCL_ERROR\;" } set result [::practcl::_tagblock $result c [my define get filename]] foreach item [my link list product] { if {[$item define get output_c] ne {}} { ::practcl::cputs result [$item generate-loader-external] } else { ::practcl::cputs result [$item generate-loader-module] } } return $result } method generate-stub-function {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct tcltype set result {} foreach mod [my link list product] { foreach {funct def} [$mod generate-stub-function] { dict set result $funct $def } } if {[info exists cfunct]} { foreach {funcname info} $cfunct { if {![dict get $info export]} continue dict set result $funcname [dict get $info header] } } return $result } method IncludeAdd {headervar args} { upvar 1 $headervar headers foreach inc $args { if {[string index $inc 0] ni {< \"}} { set inc "\"$inc\"" } if {$inc ni $headers} { lappend headers $inc } } } method generate-tcl-loader {} { set result {} set PKGINIT [my define get pkginit] set PKG_NAME [my define get name [my define get pkg_name]] set PKG_VERSION [my define get pkg_vers [my define get version]] if {[string is true [my define get SHARED_BUILD 0]]} { set LIBFILE [my define get libfile] |
︙ | ︙ | |||
4450 4451 4452 4453 4454 4455 4456 | # Tclkit Style load {} @PKGINIT@ package provide @PKG_NAME@ @PKG_VERSION@ }] } return $result } | < < < < < < < < < < < < < < < < < < < < | < < | 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 | # Tclkit Style load {} @PKGINIT@ package provide @PKG_NAME@ @PKG_VERSION@ }] } return $result } method generate-tcl-pre {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code if {[info exists code(tcl)]} { set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] } if {[info exists code(tcl-pre)]} { set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] } foreach mod [my link list product] { ::practcl::cputs result [$mod generate-tcl-pre] } return $result } method generate-tcl-post {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code if {[info exists code(tcl-post)]} { set result [::practcl::_tagblock $code(tcl-post) tcl [my define get filename]] } foreach mod [my link list product] { ::practcl::cputs result [$mod generate-tcl-post] } return $result } method linktype {} { return {subordinate product} } method Ofile filename { set lpath [my <module> define get localpath] if {$lpath eq {}} { set lpath [my <module> define get name] } return ${lpath}_[file rootname [file tail $filename]] } method project-static-packages {} { set result [my define get static_packages] set initfunc [my define get initfunc] if {$initfunc ne {}} { set pkg_name [my define get pkg_name] if {$pkg_name ne {}} { dict set result $pkg_name initfunc $initfunc dict set result $pkg_name version [my define get version [my define get pkg_vers]] dict set result $pkg_name autoload [my define get autoload 0] } } foreach item [my link list subordinate] { foreach {pkg info} [$item project-static-packages] { dict set result $pkg $info } } return $result } method toolset-include-directory {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result [my define get include_dir] foreach obj [my link list product] { foreach path [$obj toolset-include-directory] { lappend result $path } } return $result } method target {method args} { switch $method { is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } } } } oo::objdefine ::practcl::product { method select {object} { set class [$object define get class] set mixin [$object define get product] if {$class eq {} && $mixin eq {}} { set filename [$object define get filename] if {$filename ne {} && [file exists $filename]} { |
︙ | ︙ | |||
4587 4588 4589 4590 4591 4592 4593 | $object morph $class } if {$mixin ne {}} { $object mixin product $mixin } } } | < < < < < < < < < | < < < | 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 | $object morph $class } if {$mixin ne {}} { $object mixin product $mixin } } } ::oo::class create ::practcl::product.cheader { superclass ::practcl::product method project-compile-products {} {} method generate-loader-module {} {} } ::oo::class create ::practcl::product.csource { superclass ::practcl::product method project-compile-products {} { set result {} set filename [my define get filename] if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename if {[my define exists ofile]} { set ofile [my define get ofile] } else { set ofile [my Ofile $filename] my define set ofile $ofile } lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]] object [self]] } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } } ::oo::class create ::practcl::product.clibrary { superclass ::practcl::product method linker-products {configdict} { return [my define get filename] } } ::oo::class create ::practcl::product.dynamic { superclass ::practcl::dynamic ::practcl::product method initialize {} { set filename [my define get filename] if {$filename eq {}} { return } if {[my define get name] eq {}} { my define set name [file tail [file rootname $filename]] |
︙ | ︙ | |||
4657 4658 4659 4660 4661 4662 4663 | ::source $filename if {[my define get output_c] ne {}} { # Turn into a module if we have an output_c file my morph ::practcl::module } } } | < < < < < < < < < < < < < < < < | 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 | ::source $filename if {[my define get output_c] ne {}} { # Turn into a module if we have an output_c file my morph ::practcl::module } } } ::oo::class create ::practcl::product.critcl { superclass ::practcl::dynamic ::practcl::product } ### # END: class product.tcl ### ### # START: class module.tcl ### ::oo::class create ::practcl::module { superclass ::practcl::object ::practcl::product.dynamic method _MorphPatterns {} { return {{@name@} {::practcl::module.@name@} ::practcl::module} } method add args { my variable links set object [::practcl::object new [self] {*}$args] foreach linktype [$object linktype] { lappend links($linktype) $object } return $object } method install-headers args {} method make {command args} { my variable make_object if {![info exists make_object]} { set make_object {} } switch $command { pkginfo { |
︙ | ︙ | |||
4830 4831 4832 4833 4834 4835 4836 | if {[$obj do]} { eval [$obj define get action] } } } } } | < < < < < < | 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 | if {[$obj do]} { eval [$obj define get action] } } } } } method child which { switch $which { delegate - organs { return [list project [my define get project] module [self]] } } } method generate-c {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result { /* This file was generated by practcl */ } set includes {} |
︙ | ︙ | |||
4892 4893 4894 4895 4896 4897 4898 | ::practcl::cputs result $dat ::practcl::cputs result "/* END $method [my define get filename] */" } } ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] return $result } | < < < < < < | 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 | ::practcl::cputs result $dat ::practcl::cputs result "/* END $method [my define get filename] */" } } ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] return $result } method generate-h {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} set includes [my generate-hfile-public-includes] foreach inc $includes { if {[string index $inc 0] ni {< \"}} { ::practcl::cputs result "#include \"$inc\"" |
︙ | ︙ | |||
4937 4938 4939 4940 4941 4942 4943 | } { ::practcl::cputs result "/* BEGIN SECTION $method */" ::practcl::cputs result [my $method] ::practcl::cputs result "/* END SECTION $method */" } return $result } | < | 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 | } { ::practcl::cputs result "/* BEGIN SECTION $method */" ::practcl::cputs result [my $method] ::practcl::cputs result "/* END SECTION $method */" } return $result } method generate-loader {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} if {[my define get initfunc] eq {}} return ::practcl::cputs result " extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \{" ::practcl::cputs result { |
︙ | ︙ | |||
4985 4986 4987 4988 4989 4990 4991 | if {[my define get localpath] eq {}} { my define set localpath [my <project> define get name]_[my define get name] } my graft module [self] ::practcl::debug [self] SOURCE $filename my source $filename } | < | 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 | if {[my define get localpath] eq {}} { my define set localpath [my <project> define get name]_[my define get name] } my graft module [self] ::practcl::debug [self] SOURCE $filename my source $filename } method implement path { my go my Collate_Source $path set errs {} foreach item [my link list dynamic] { if {[catch {$item implement $path} err errdat]} { lappend errs "Skipped $item: [$item define get filename] $err" |
︙ | ︙ | |||
5038 5039 5040 5041 5042 5043 5044 | ** any changes will be overwritten the next time it is run */}] puts $cout [my generate-c] puts $cout [my generate-loader] close $cout ::practcl::debug [list /[self] [self method] [self class]] } | < < < < | 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 | ** any changes will be overwritten the next time it is run */}] puts $cout [my generate-c] puts $cout [my generate-loader] close $cout ::practcl::debug [list /[self] [self method] [self class]] } method linktype {} { return {subordinate product dynamic module} } } ### # END: class module.tcl ### ### # START: class project baseclass.tcl ### ::oo::class create ::practcl::project { superclass ::practcl::module method _MorphPatterns {} { return {{@name@} {::practcl::@name@} {::practcl::project.@name@} {::practcl::project}} } constructor args { my variable define if {[llength $args] == 1} { set rawcontents [lindex $args 0] } else { set rawcontents $args } |
︙ | ︙ | |||
5089 5090 5091 5092 5093 5094 5095 | } } my graft module [self] array set define $contents ::practcl::toolset select [self] my initialize } | < < | 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 | } } my graft module [self] array set define $contents ::practcl::toolset select [self] my initialize } method add_object object { my link object $object } method add_project {pkg info {oodefine {}}} { ::practcl::debug [self] add_project $pkg $info set os [my define get TEACUP_OS] if {$os eq {}} { set os [::practcl::os] my define set os $os } |
︙ | ︙ | |||
5121 5122 5123 5124 5125 5126 5127 | } my link object $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } | < | 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 | } my link object $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } method add_tool {pkg info {oodefine {}}} { ::practcl::debug [self] add_tool $pkg $info set info [dict merge [::practcl::local_os] $info] set os [dict get $info TEACUP_OS] set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]] if {[dict exists $info os] && ($os ni [dict get $info os])} return |
︙ | ︙ | |||
5145 5146 5147 5148 5149 5150 5151 | } my link add tool $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } | < | 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 | } my link add tool $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } method build-tclcore {} { set os [my define get TEACUP_OS] set tcl_config_opts [::practcl::platform::tcl_core_options $os] set tk_config_opts [::practcl::platform::tk_core_options $os] lappend tcl_config_opts --prefix [my define get prefix] --exec-prefix [my define get prefix] set tclobj [my tclcore] |
︙ | ︙ | |||
5173 5174 5175 5176 5177 5178 5179 | if {[my define get debug 0]} { $tkobj define set debug 1 lappend tk_config_opts --enable-symbols=true } $tkobj define set config_opts $tk_config_opts $tkobj compile } | < < < < < < < | 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 | if {[my define get debug 0]} { $tkobj define set debug 1 lappend tk_config_opts --enable-symbols=true } $tkobj define set config_opts $tk_config_opts $tkobj compile } method child which { switch $which { delegate - organs { # A library can be a project, it can be a module. Any # subordinate modules will indicate their existance return [list project [self] module [self]] } } } method linktype {} { return project } method project {pkg args} { set obj [namespace current]::PROJECT.$pkg if {[llength $args]==0} { return $obj } ${obj} {*}$args } method tclcore {} { if {[info commands [set obj [my organ tclcore]]] ne {}} { return $obj } if {[info commands [set obj [my project TCLCORE]]] ne {}} { my graft tclcore $obj return $obj |
︙ | ︙ | |||
5224 5225 5226 5227 5228 5229 5230 | set obj [my add_tool tcl { tag release class subproject.core fossil_url http://core.tcl.tk/tcl }] my graft tclcore $obj return $obj } | < < < < < < < < | 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 | set obj [my add_tool tcl { tag release class subproject.core fossil_url http://core.tcl.tk/tcl }] my graft tclcore $obj return $obj } method tkcore {} { if {[set obj [my organ tkcore]] ne {}} { return $obj } if {[set obj [my project tk]] ne {}} { my graft tkcore $obj return $obj } if {[set obj [my tool tk]] ne {}} { my graft tkcore $obj return $obj } # Provide a fallback set obj [my add_tool tk { tag release class tool.core fossil_url http://core.tcl.tk/tk }] my graft tkcore $obj return $obj } method tool {pkg args} { set obj ::practcl::OBJECT::TOOL.$pkg if {[llength $args]==0} { return $obj } ${obj} {*}$args } } ### # END: class project baseclass.tcl ### ### # START: class project library.tcl ### ::oo::class create ::practcl::library { superclass ::practcl::project method clean {PATH} { set objext [my define get OBJEXT o] foreach {ofile info} [my project-compile-products] { if {[file exists [file join $PATH objs $ofile].${objext}]} { file delete [file join $PATH objs $ofile].${objext} } } foreach ofile [glob -nocomplain [file join $PATH *.${objext}]] { file delete $ofile } foreach ofile [glob -nocomplain [file join $PATH objs *]] { file delete $ofile } set libfile [my define get libfile] if {[file exists [file join $PATH $libfile]]} { file delete [file join $PATH $libfile] } my implement $PATH } method project-compile-products {} { set result {} foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } set filename [my define get output_c] if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename set ofile [file rootname [file tail $filename]]_main lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] } return $result } method go {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set name [my define getnull name] if {$name eq {}} { set name generic my define name generic } |
︙ | ︙ | |||
5349 5350 5351 5352 5353 5354 5355 | foreach {linktype objs} [array get links] { foreach obj $objs { $obj go } } ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] } | < < | 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 | foreach {linktype objs} [array get links] { foreach obj $objs { $obj go } } ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] } method generate-decls {pkgname path} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set outfile [file join $path/$pkgname.decls] ### # Build the decls file ## # |
︙ | ︙ | |||
5444 5445 5446 5447 5448 5449 5450 | return NULL; } return actualVersion; } }] close $cout } | < | 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 | return NULL; } return actualVersion; } }] close $cout } method implement path { my go my Collate_Source $path set errs {} foreach item [my link list dynamic] { if {[catch {$item implement $path} err errdat]} { lappend errs "Skipped $item: [$item define get filename] $err" |
︙ | ︙ | |||
5515 5516 5517 5518 5519 5520 5521 | ###" puts $tclout [my generate-tcl-pre] puts $tclout [my generate-tcl-loader] puts $tclout [my generate-tcl-post] close $tclout } } | < < < < < < | 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 | ###" puts $tclout [my generate-tcl-pre] puts $tclout [my generate-tcl-loader] puts $tclout [my generate-tcl-post] close $tclout } } method generate-make path { my build-Makefile $path [self] } method linktype {} { return library } method package-ifneeded {args} { set result {} set name [my define get pkg_name [my define get name]] set version [my define get pkg_vers [my define get version]] if {$version eq {}} { set version 0.1a } |
︙ | ︙ | |||
5550 5551 5552 5553 5554 5555 5556 | set result "package ifneeded [list $name] [list $version] $script" foreach alias $args { set script "package require $name $version \; package provide $alias $version" append result \n\n [list package ifneeded $alias $version $script] } return $result } | < < < < < < | 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 | set result "package ifneeded [list $name] [list $version] $script" foreach alias $args { set script "package require $name $version \; package provide $alias $version" append result \n\n [list package ifneeded $alias $version $script] } return $result } method shared_library {{filename {}}} { set name [string tolower [my define get name [my define get pkg_name]]] set NAME [string toupper $name] set version [my define get version [my define get pkg_vers]] set map {} lappend map %LIBRARY_NAME% $name lappend map %LIBRARY_VERSION% $version lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] lappend map %LIBRARY_PREFIX% [my define getnull libprefix] set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]][my define get SHLIB_SUFFIX] return $outfile } method static_library {{filename {}}} { set name [string tolower [my define get name [my define get pkg_name]]] set NAME [string toupper $name] set version [my define get version [my define get pkg_vers]] set map {} lappend map %LIBRARY_NAME% $name lappend map %LIBRARY_VERSION% $version lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] lappend map %LIBRARY_PREFIX% [my define getnull libprefix] set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]].a return $outfile } } ### # END: class project library.tcl ### ### # START: class project tclkit.tcl ### ::oo::class create ::practcl::tclkit { superclass ::practcl::library method build-tclkit_main {PROJECT PKG_OBJS} { ### # Build static package list ### set statpkglist {} foreach cobj [list {*}${PKG_OBJS} $PROJECT] { foreach {pkg info} [$cobj project-static-packages] { |
︙ | ︙ | |||
5797 5798 5799 5800 5801 5802 5803 | # then no user-specific startup file will be run under any conditions. } append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]] practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);" practcl::cputs appinit { return TCL_OK;} $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] } | < | 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 | # then no user-specific startup file will be run under any conditions. } append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]] practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);" practcl::cputs appinit { return TCL_OK;} $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] } method Collate_Source CWD { next $CWD set name [my define get name] # Assume a static shell if {[my define exists SHARED_BUILD]} { my define set SHARED_BUILD 0 } |
︙ | ︙ | |||
5886 5887 5888 5889 5890 5891 5892 | } my define add include_dir [file join $TCLSRCDIR generic] my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK my build-tclkit_main $PROJECT $PKG_OBJS } | < < < | 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 | } my define add include_dir [file join $TCLSRCDIR generic] my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK my build-tclkit_main $PROJECT $PKG_OBJS } method wrap {PWD exename vfspath args} { cd $PWD if {![file exists $vfspath]} { file mkdir $vfspath } foreach item [my link list core.library] { set name [$item define get name] |
︙ | ︙ | |||
5960 5961 5962 5963 5964 5965 5966 | ### # END: class project tclkit.tcl ### ### # START: class distro baseclass.tcl ### | < < < < < < < < < < < < < | 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 | ### # END: class project tclkit.tcl ### ### # START: class distro baseclass.tcl ### oo::class create ::practcl::distribution { method scm_info {} { return { scm None hash {} maxdate {} tags {} isodate {} } } method DistroMixIn {} { my define set scm none } method Sandbox {} { if {[my define exists sandbox]} { return [my define get sandbox] } if {[my organ project] ni {::noop {}}} { set sandbox [my <project> define get sandbox] if {$sandbox ne {}} { my define set sandbox $sandbox return $sandbox } } set sandbox [file normalize [file join $::CWD ..]] my define set sandbox $sandbox return $sandbox } method SrcDir {} { set pkg [my define get name] if {[my define exists srcdir]} { return [my define get srcdir] } set sandbox [my Sandbox] set srcdir [file join [my Sandbox] $pkg] my define set srcdir $srcdir return $srcdir } method ScmTag {} {} method ScmClone {} {} method ScmUnpack {} {} method ScmUpdate {} {} method Unpack {} { set srcdir [my SrcDir] if {[file exists $srcdir]} { return } set pkg [my define get name] if {[my define exists download]} { # Utilize a staged download set download [my define get download] if {[file exists [file join $download $pkg.zip]]} { ::practcl::tcllib_require zipfile::decode ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir return } } my ScmUnpack } } oo::objdefine ::practcl::distribution { method Sandbox {object} { if {[$object define exists sandbox]} { return [$object define get sandbox] } if {[$object organ project] ni {::noop {}}} { |
︙ | ︙ | |||
6105 6106 6107 6108 6109 6110 6111 | ### # END: class distro baseclass.tcl ### ### # START: class distro snapshot.tcl ### | < < | 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 | ### # END: class distro baseclass.tcl ### ### # START: class distro snapshot.tcl ### oo::class create ::practcl::distribution.snapshot { superclass ::practcl::distribution method ScmUnpack {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .download]]} { return 0 } set dpath [::practcl::LOCAL define get download] set url [my define get file_url] |
︙ | ︙ | |||
6147 6148 6149 6150 6151 6152 6153 | set fosdb [my ScmClone] set tag [my ScmTag] file mkdir $srcdir ::practcl::fossil $srcdir open $fosdb $tag return 1 } } | < < < < < | 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 | set fosdb [my ScmClone] set tag [my ScmTag] file mkdir $srcdir ::practcl::fossil $srcdir open $fosdb $tag return 1 } } oo::objdefine ::practcl::distribution.snapshot { method claim_path path { if {[file exists [file join $path .download]]} { return true } return false } method claim_object object { return false } } ### # END: class distro snapshot.tcl ### ### # START: class distro fossil.tcl ### oo::class create ::practcl::distribution.fossil { superclass ::practcl::distribution method scm_info {} { set info [next] dict set info scm fossil foreach {field value} [::practcl::fossil_status [my define get srcdir]] { dict set info $field $value } return $info } method ScmClone {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .fslckout]]} { return } if {[file exists [file join $srcdir _FOSSIL_]]} { return |
︙ | ︙ | |||
6238 6239 6240 6241 6242 6243 6244 | return $fosdb } } # Fall back to the fossil mirror on the island of misfit toys ::practcl::doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb return $fosdb } | < < < < | 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 | return $fosdb } } # Fall back to the fossil mirror on the island of misfit toys ::practcl::doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb return $fosdb } method ScmTag {} { if {[my define exists scm_tag]} { return [my define get scm_tag] } if {[my define exists tag]} { set tag [my define get tag] } else { set tag trunk } my define set scm_tag $tag return $tag } method ScmUnpack {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .fslckout]]} { return 0 } if {[file exists [file join $srcdir _FOSSIL_]]} { return 0 } set CWD [pwd] set fosdb [my ScmClone] set tag [my ScmTag] file mkdir $srcdir ::practcl::fossil $srcdir open $fosdb $tag return 1 } method ScmUpdate {} { if {[my ScmUnpack]} { return } set srcdir [my SrcDir] set tag [my ScmTag] ::practcl::fossil $srcdir update $tag } } oo::objdefine ::practcl::distribution.fossil { # Check for markers in the source root method claim_path path { if {[file exists [file join $path .fslckout]]} { return true } |
︙ | ︙ | |||
6310 6311 6312 6313 6314 6315 6316 | ### # END: class distro fossil.tcl ### ### # START: class distro git.tcl ### | < < < < < < | 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 | ### # END: class distro fossil.tcl ### ### # START: class distro git.tcl ### oo::class create ::practcl::distribution.git { superclass ::practcl::distribution method ScmTag {} { if {[my define exists scm_tag]} { return [my define get scm_tag] } if {[my define exists tag]} { set tag [my define get tag] } else { set tag master } my define set scm_tag $tag return $tag } method ScmUnpack {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .git]]} { return 0 } set CWD [pwd] set tag [my ScmTag] set pkg [my define get name] if {[my define exists git_url]} { ::practcl::doexec git clone --branch $tag [my define get git_url] $srcdir } else { ::practcl::doexec git clone --branch $tag https://github.com/eviltwinskippy/$pkg $srcdir } return 1 } method ScmUpdate {} { if {[my ScmUnpack]} { return } set CWD [pwd] set srcdir [my SrcDir] set tag [my ScmTag] ::practcl::doexec_in $srcdir git pull cd $CWD } } oo::objdefine ::practcl::distribution.git { method claim_path path { if {[file exists [file join $path .git]]} { return true } return false |
︙ | ︙ | |||
6383 6384 6385 6386 6387 6388 6389 | # END: class distro git.tcl ### ### # START: class subproject baseclass.tcl ### oo::class create ::practcl::subproject { superclass ::practcl::module | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 | # END: class distro git.tcl ### ### # START: class subproject baseclass.tcl ### oo::class create ::practcl::subproject { superclass ::practcl::module method _MorphPatterns {} { return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}} } method BuildDir {PWD} { return [my define get srcdir] } method child which { switch $which { delegate - organs { # A library can be a project, it can be a module. Any # subordinate modules will indicate their existance return [list project [self] module [self]] } } } method compile {} {} method go {} { ::practcl::distribution select [self] set name [my define get name] my define set builddir [my BuildDir [my define get masterpath]] my define set builddir [my BuildDir [my define get masterpath]] my sources } method install args {} method linktype {} { return {subordinate package} } method linker-products {configdict} {} method linker-external {configdict} { if {[dict exists $configdict PRACTCL_PKG_LIBS]} { return [dict get $configdict PRACTCL_PKG_LIBS] } if {[dict exists $configdict LIBS]} { return [dict get $configdict LIBS] } } method linker-extra {configdict} { if {[dict exists $configdict PRACTCL_LINKER_EXTRA]} { return [dict get $configdict PRACTCL_LINKER_EXTRA] } return {} } method env-bootstrap {} { set pkg [my define get pkg_name [my define get name]] package require $pkg } method env-exec {} {} method env-install {} { my unpack } method env-load {} { my variable loaded if {[info exists loaded]} { return 0 } if {![my env-present]} { my env-install } my env-bootstrap set loaded 1 } method env-present {} { set pkg [my define get pkg_name [my define get name]] if {[catch [list package require $pkg]]} { return 0 } return 1 } method sources {} {} method update {} { my ScmUpdate } method unpack {} { cd $::CWD ::practcl::distribution select [self] my Unpack ::practcl::toolset select [self] cd $::CWD } } oo::class create ::practcl::subproject.source { superclass ::practcl::subproject ::practcl::library method env-bootstrap {} { set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { set ::auto_path [linsert $::auto_path 0 $LibraryRoot] } } method env-present {} { set path [my define get srcdir] return [file exists $path] } method linktype {} { return {subordinate package source} } } oo::class create ::practcl::subproject.teapot { superclass ::practcl::subproject method env-bootstrap {} { set pkg [my define get pkg_name [my define get name]] package require $pkg } method env-install {} { set pkg [my define get pkg_name [my define get name]] set download [my <project> define get download] my unpack set prefix [string trimleft [my <project> define get prefix] /] ::practcl::tcllib_require zipfile::decode ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $prefix lib $pkg] } method env-present {} { set pkg [my define get pkg_name [my define get name]] if {[catch [list package require $pkg]]} { return 0 } return 1 } method install DEST { set pkg [my define get pkg_name [my define get name]] set download [my <project> define get download] my unpack set prefix [string trimleft [my <project> define get prefix] /] ::practcl::tcllib_require zipfile::decode ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg] } } oo::class create ::practcl::subproject.kettle { superclass ::practcl::subproject method kettle {path args} { my variable kettle if {![info exists kettle]} { ::practcl::LOCAL tool kettle env-load set kettle [file join [::practcl::LOCAL tool kettle define get srcdir] kettle] } set srcdir [my SourceRoot] ::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args } method install DEST { my kettle reinstall --prefix $DEST } } oo::class create ::practcl::subproject.critcl { superclass ::practcl::subproject method install DEST { my critcl -pkg [my define get name] set srcdir [my SourceRoot] ::practcl::copyDir [file join $srcdir [my define get name]] [file join $DEST lib [my define get name]] } } oo::class create ::practcl::subproject.sak { superclass ::practcl::subproject method env-bootstrap {} { set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { set ::auto_path [linsert $::auto_path 0 $LibraryRoot] } } method env-install {} { ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my unpack set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set srcdir [my define get srcdir] ::practcl::dotclexec [file join $srcdir installer.tcl] \ -apps -app-path [file join $prefix apps] \ -html -html-path [file join $prefix doc html $pkg] \ -pkg-path [file join $prefix lib $pkg] \ -no-nroff -no-wait -no-gui } method env-present {} { set path [my define get srcdir] return [file exists $path] } method install DEST { ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my unpack set prefix [string trimleft [my <project> define get prefix] /] set srcdir [my define get srcdir] ::practcl::dotclexec [file join $srcdir installer.tcl] \ -pkg-path [file join $DEST $prefix lib $pkg] \ -no-examples -no-html -no-nroff \ -no-wait -no-gui -no-apps } method install-module {DEST args} { set pkg [my define get pkg_name [my define get name]] set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set pkgpath [file join $prefix lib $pkg] foreach module $args { ::practcl::installDir [file join $pkgpath $module] [file join $DEST $module] } } } ### # END: class subproject baseclass.tcl ### ### # START: class subproject binary.tcl ### oo::class create ::practcl::subproject.binary { superclass ::practcl::subproject method clean {} { set builddir [file normalize [my define get builddir]] if {![file exists $builddir]} return if {[file exists [file join $builddir make.tcl]]} { ::practcl::domake.tcl $builddir clean } else { catch {::practcl::domake $builddir clean} } } method env-install {} { ### # Handle tea installs ### set pkg [my define get pkg_name [my define get name]] set os [::practcl::local_os] my define set os $os my unpack set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set srcdir [my define get srcdir] lappend options --prefix $prefix --exec-prefix $prefix my define set config_opts $options my go my clean my compile my make-install {} } method project-compile-products {} {} method ComputeInstall {} { if {[my define exists install]} { switch [my define get install] { static { my define set static 1 my define set autoload 0 } |
︙ | ︙ | |||
6727 6728 6729 6730 6731 6732 6733 | } default { } } } } | < < < | 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 | } default { } } } } method go {} { next ::practcl::distribution select [self] my ComputeInstall my define set builddir [my BuildDir [my define get masterpath]] } method linker-products {configdict} { if {![my define get static 0]} { return {} } set srcdir [my define get builddir] if {[dict exists $configdict libfile]} { return " [file join $srcdir [dict get $configdict libfile]]" } } method project-static-packages {} { if {![my define get static 0]} { return {} } set result [my define get static_packages] set statpkg [my define get static_pkg] set initfunc [my define get initfunc] |
︙ | ︙ | |||
6779 6780 6781 6782 6783 6784 6785 | foreach item [my link list subordinate] { foreach {pkg info} [$item project-static-packages] { dict set result $pkg $info } } return $result } | < < | 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 | foreach item [my link list subordinate] { foreach {pkg info} [$item project-static-packages] { dict set result $pkg $info } } return $result } method BuildDir {PWD} { set name [my define get name] set debug [my define get debug 0] if {[my <project> define get LOCAL 0]} { return [my define get builddir [file join $PWD local $name]] } if {$debug} { return [my define get builddir [file join $PWD debug $name]] } else { return [my define get builddir [file join $PWD pkg $name]] } } method compile {} { set name [my define get name] set PWD $::CWD cd $PWD my unpack set srcdir [file normalize [my SrcDir]] set localsrcdir [my MakeDir $srcdir] |
︙ | ︙ | |||
6814 6815 6816 6817 6818 6819 6820 | puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } my make-compile cd $PWD } | < < | 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 | puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } my make-compile cd $PWD } method Configure {} { cd $::CWD my unpack ::practcl::toolset select [self] set srcdir [file normalize [my define get srcdir]] set builddir [file normalize [my define get builddir]] file mkdir $builddir my make-autodetect } method install DEST { set PWD [pwd] set PREFIX [my <project> define get prefix] ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] |
︙ | ︙ | |||
6849 6850 6851 6852 6853 6854 6855 | } } my compile my make-install $DEST cd $PWD } } | < | < < < < < < < < < < < < < < < | 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 | } } my compile my make-install $DEST cd $PWD } } oo::class create ::practcl::subproject.tea { superclass ::practcl::subproject.binary } oo::class create ::practcl::subproject.library { superclass ::practcl::subproject.binary ::practcl::library method install DEST { my compile } } oo::class create ::practcl::subproject.external { superclass ::practcl::subproject.binary method install DEST { my compile } } ### # END: class subproject binary.tcl ### ### # START: class subproject core.tcl ### oo::class create ::practcl::subproject.core { superclass ::practcl::subproject.binary method env-bootstrap {} {} method env-present {} { set PREFIX [my <project> define get prefix] set name [my define get name] set fname [file join $PREFIX lib ${name}Config.sh] return [file exists $fname] } method env-install {} { my unpack set os [::practcl::local_os] set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] lappend options --prefix $prefix --exec-prefix $prefix my define set config_opts $options puts [list [self] OS [dict get $os TEACUP_OS] options $options] my go my compile my make-install {} } method go {} { my define set core_binary 1 next } method linktype {} { return {subordinate core.library} } } ### # END: class subproject core.tcl ### ### # START: class tool.tcl ### set ::practcl::MAIN ::practcl::LOCAL set ::auto_index(::practcl::LOCAL) { ::practcl::project create ::practcl::LOCAL ::practcl::LOCAL define set [::practcl::local_os] ::practcl::LOCAL define set LOCAL 1 # Until something better comes along, use ::practcl::LOCAL # as our main project |
︙ | ︙ |