diff options
Diffstat (limited to 'tclconfig/practcl.tcl')
| -rw-r--r-- | tclconfig/practcl.tcl | 4923 |
1 files changed, 0 insertions, 4923 deletions
diff --git a/tclconfig/practcl.tcl b/tclconfig/practcl.tcl deleted file mode 100644 index ecabbf8..0000000 --- a/tclconfig/practcl.tcl +++ /dev/null @@ -1,4923 +0,0 @@ -### -# Practcl -# An object oriented templating system for stamping out Tcl API calls to C -### -puts [list LOADED practcl.tcl from [info script]] - -package require TclOO -### -# Seek out Tcllib if it's available -### -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 -} - -### -# Build utility functions -### - - -### -# Extend http to follow redirects (ala Sourceforge downloads) -### -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" - } - switch -glob $ncode { - 30[1237] {### redirect - see below ###} - default {cleanup $token ; return $url} - } - upvar #0 $token state - array set meta [set ${token}(meta)] - cleanup $token - if {![info exists meta(Location)]} { - return $url - } - set url $meta(Location) - unset meta - } - return $url -} - -proc ::http::wget {url destfile {verbose 1}} { - package require http - 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 -} - -namespace eval ::practcl {} - -### -# A command to do nothing. A handy way of -# negating an instruction without -# having to comment it completely out. -# It's also a handy attachment point for -# an object to be named later -### -if {[info command ::noop] eq {}} { - proc ::noop args {} -} - -proc ::practcl::debug args { - #puts $args - ::practcl::cputs ::DEBUG_INFO $args -} - -### -# Drop in a static copy of Tcl -### -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 {} - } - set pwd [pwd] - cd $dir - set info [exec fossil status] - cd $pwd - foreach line [split $info \n] { - if {[lindex $line 0] eq "checkout:"} { - set hash [lindex $line end-3] - set maxdate [lrange $line end-2 end-1] - dict set result hash $hash - dict set result maxdate $maxdate - regsub -all {[^0-9]} $maxdate {} isodate - dict set result isodate $isodate - } - if {[lindex $line 0] eq "tags:"} { - set tags [lrange $line 1 end] - dict set result tags $tags - break - } - } - set ::fosdat($dir) $result - return $result -} - -proc ::practcl::os {} { - return [${::practcl::MAIN} define get TEACUP_OS] -} - -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] - cd $vfspath - exec zip -r $zipfile . - cd $pwd - set fout [open $exename a] - set fin [open $zipfile r] - chan configure $fout -translation binary - chan configure $fin -translation binary - chan copy $fin $fout - chan close $fin - chan close $fout - exec zip -A $exename - } - proc ::practcl::sort_dict list { - set result {} - foreach key [lsort -dictionary [dict keys $list]] { - dict set result $key [dict get $list $key] - } - return $result - } -} else { - 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] - } -} - -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] - dict set result TEACUP_PROFILE unknown - dict set result TEACUP_OS unknown - dict set result EXEEXT {} - set windows 0 - if {$::tcl_platform(platform) eq "windows"} { - set windows 1 - } - if {$windows} { - set system "windows" - set arch ix86 - dict set result TEACUP_PROFILE win32-ix86 - dict set result TEACUP_OS windows - dict set result EXEEXT .exe - } else { - set system [exec uname -s]-[exec uname -r] - set arch unknown - dict set result TEACUP_OS generic - } - dict set result TEA_PLATFORM $system - dict set result TEA_SYSTEM $system - if {[info exists ::SANDBOX]} { - dict set result sandbox $::SANDBOX - } - switch -glob $system { - Linux* { - dict set result TEACUP_OS linux - set arch [exec uname -m] - dict set result TEACUP_PROFILE "linux-glibc2.3-$arch" - } - GNU* { - set arch [exec uname -m] - dict set result TEACUP_OS "gnu" - } - NetBSD-Debian { - set arch [exec uname -m] - dict set result TEACUP_OS "netbsd-debian" - } - OpenBSD-* { - set arch [exec arch -s] - dict set result TEACUP_OS "openbsd" - } - Darwin* { - set arch [exec uname -m] - dict set result TEACUP_OS "macosx" - if {$arch eq "x86_64"} { - dict set result TEACUP_PROFILE "macosx10.5-i386-x86_84" - } else { - dict set result TEACUP_PROFILE "macosx-universal" - } - } - OpenBSD* { - set arch [exec arch -s] - dict set result TEACUP_OS "openbsd" - } - } - if {$arch eq "unknown"} { - catch {set arch [exec uname -m]} - } - switch -glob $arch { - i*86 { - set arch "ix86" - } - amd64 { - set arch "x86_64" - } - } - dict set result TEACUP_ARCH $arch - if {[dict get $result TEACUP_PROFILE] eq "unknown"} { - dict set result TEACUP_PROFILE [dict get $result TEACUP_OS]-$arch - } - set OS [dict get $result TEACUP_OS] - dict set result os $OS - - # Look for a local preference file - set pathlist {} - set userhome [file normalize ~/tcl] - set local_install [file join $userhome lib] - switch $OS { - windows { - set userhome [file join [file normalize $::env(LOCALAPPDATA)] Tcl] - if {[file exists c:/Tcl/Teapot]} { - dict set result teapot c:/Tcl/Teapot - } - } - macosx { - set userhome [file join [file normalize {~/Library/Application Support/}] Tcl] - if {[file exists {~/Library/Application Support/ActiveState/Teapot/repository/}]} { - dict set result teapot [file normalize {~/Library/Application Support/ActiveState/Teapot/repository/}] - } - dict set result local_install [file normalize ~/Library/Tcl] - if {![dict exists $result sandbox]} { - dict set result sandbox [file normalize ~/Library/Tcl/sandbox] - } - } - default { - } - } - dict set result userhome $userhome - # Load user preferences - if {[file exists [file join $userhome practcl.rc]]} { - set dat [::practcl::cat [file join $path practcl.rc]] - } - if {![dict exists $result prefix]} { - dict set result prefix $userhome - } - - # Create a default path for the teapot - if {![dict exists $result teapot]} { - dict set result teapot [file join $userhome teapot] - } - # Create a default path for the local sandbox - if {![dict exists $result sandbox]} { - dict set result sandbox [file join $userhome sandbox] - } - # Create a default path for download folder - if {![dict exists $result download]} { - dict set result download [file join $userhome download] - } - # Path to install local packages - if {![dict exists $result local_install]} { - dict set result local_install [file join $userhome lib] - } - 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 -} - - -### -# Detect local platform -### -proc ::practcl::config.tcl {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]]} { - # We have a definitive configuration file. Read its content - # and take it as gospel - set cresult [read_rc_file [file join $path config.tcl]] - set cresult [::practcl::de_shell $cresult] - if {[dict exists $cresult srcdir] && ![dict exists $cresult sandbox]} { - dict set cresult sandbox [file dirname [dict get $cresult srcdir]] - } - set result [dict merge $result [::practcl::de_shell $cresult]] - } - if {[file exists [file join $path config.site]]} { - # No config.tcl file is present but we do seed - dict set result USEMSVC 0 - foreach {f v} [::practcl::de_shell [::practcl::read_sh_file [file join $path config.site]]] { - dict set result $f $v - dict set result XCOMPILE_${f} $v - } - dict set result CONFIG_SITE [file join $path config.site] - if {[dict exist $result XCOMPILE_CC] && [regexp mingw [dict get $result XCOMPILE_CC]]} { - set windows 1 - } - } elseif {[info exists ::env(VisualStudioVersion)]} { - set windows 1 - dict set result USEMSVC 1 - } - if {$windows && [dict get $result TEACUP_OS] ne "windows"} { - if {![dict exists exists $result TEACUP_ARCH]} { - dict set result TEACUP_ARCH ix86 - } - dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH] - dict set result TEACUP_OS windows - dict set result EXEEXT .exe - } - return $result -} - - -### -# Convert an MSYS path to a windows native path -### -if {$::tcl_platform(platform) eq "windows"} { -proc ::practcl::msys_to_tclpath msyspath { - return [exec sh -c "cd $msyspath ; pwd -W"] -} -} else { -proc ::practcl::msys_to_tclpath msyspath { - return [file normalize $msyspath] -} -} - -### -# Bits stolen from fileutil -### -proc ::practcl::cat fname { - set fname [open $fname r] - set data [read $fname] - close $fname - return $data -} - -proc ::practcl::file_lexnormalize {sp} { - set spx [file split $sp] - - # Resolution of embedded relative modifiers (., and ..). - - if { - ([lsearch -exact $spx . ] < 0) && - ([lsearch -exact $spx ..] < 0) - } { - # Quick path out if there are no relative modifiers - return $sp - } - - set absolute [expr {![string equal [file pathtype $sp] relative]}] - # A volumerelative path counts as absolute for our purposes. - - set sp $spx - set np {} - set noskip 1 - - while {[llength $sp]} { - set ele [lindex $sp 0] - set sp [lrange $sp 1 end] - set islast [expr {[llength $sp] == 0}] - - if {[string equal $ele ".."]} { - if { - ($absolute && ([llength $np] > 1)) || - (!$absolute && ([llength $np] >= 1)) - } { - # .. : Remove the previous element added to the - # new path, if there actually is enough to remove. - set np [lrange $np 0 end-1] - } - } elseif {[string equal $ele "."]} { - # Ignore .'s, they stay at the current location - continue - } else { - # A regular element. - lappend np $ele - } - } - 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)" - } - - set base [file_lexnormalize [file join [pwd] $base]] - set dst [file_lexnormalize [file join [pwd] $dst]] - - set save $dst - set base [file split $base] - set dst [file split $dst] - - while {[string equal [lindex $dst 0] [lindex $base 0]]} { - set dst [lrange $dst 1 end] - set base [lrange $base 1 end] - if {![llength $dst]} {break} - } - - set dstlen [llength $dst] - set baselen [llength $base] - - if {($dstlen == 0) && ($baselen == 0)} { - # Cases: - # (a) base == dst - - set dst . - } else { - # Cases: - # (b) base is: base/sub = sub - # dst is: base = {} - - # (c) base is: base = {} - # dst is: base/sub = sub - - while {$baselen > 0} { - set dst [linsert $dst 0 ..] - incr baselen -1 - } - # 8.5: set dst [file join {*}$dst] - set dst [eval [linsert $dst 0 file join]] - } - - return $dst -} - -# Try to load a package, and failing that -# retrieve tcllib -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 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 -} - -### -# Read a stylized key/value list stored in a file -### -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} { - incr rawcount - append bufline \n $thisline - if {![info complete $bufline]} continue - set line [string trimleft $bufline] - set bufline {} - if {[string index [string trimleft $line] 0] eq "#"} continue - append result \n $line - #incr linecount - #set key [lindex $line 0] - #set value [lindex $line 1] - #dict set result $key $value - } - return $result -} - -### -# topic: e71f3f61c348d56292011eec83e95f0aacc1c618 -# description: Converts a XXX.sh file into a series of Tcl variables -### -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 '] -} - -### -# topic: 03567140cca33c814664c7439570f669b9ab88e6 -### -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 {} - } else { - set top 0 - set local $localdat - } - while {[gets $fin line] >= 0} { - set line [string trim $line] - if {[string index $line 0] eq "#"} continue - if {$line eq {}} continue - catch { - if {[string range $line 0 6] eq "export "} { - set eq [string first "=" $line] - set field [string trim [string range $line 6 [expr {$eq - 1}]]] - set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] - dict set result $field [read_sh_subst $value $local] - dict set local $field $value - } elseif {[string range $line 0 7] eq "include "} { - set subfile [read_sh_subst [string range $line 7 end] $local] - foreach {field value} [read_sh_file $subfile $local] { - dict set result $field $value - } - } else { - set eq [string first "=" $line] - if {$eq > 0} { - set field [read_sh_subst [string range $line 0 [expr {$eq - 1}]] $local] - set value [string trim [string range $line [expr {$eq+1}] end] '] - #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] - dict set local $field $value - dict set result $field $value - } - } - } err opts - if {[dict get $opts -code] != 0} { - #puts $opts - puts "Error reading line:\n$line\nerr: $err\n***" - return $err {*}$opts - } - } - return $result -} - -### -# A simpler form of read_sh_file tailored -# to pulling data from (tcl|tk)Config.sh -### -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 - if {$line eq {}} continue - catch { - set eq [string first "=" $line] - if {$eq > 0} { - set field [string range $line 0 [expr {$eq - 1}]] - set value [string trim [string range $line [expr {$eq+1}] end] '] - #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] - dict set result $field $value - incr $linecount - } - } err opts - if {[dict get $opts -code] != 0} { - #puts $opts - puts "Error reading line:\n$line\nerr: $err\n***" - return $err {*}$opts - } - } - return $result -} - -### -# A simpler form of read_sh_file tailored -# to pulling data from a Makefile -### -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 - catch { - set eq [string first "=" $line] - if {$eq > 0} { - set field [string trim [string range $line 0 [expr {$eq - 1}]]] - set value [string trim [string trim [string range $line [expr {$eq+1}] end] ']] - switch $field { - PKG_LIB_FILE { - dict set result libfile $value - } - srcdir { - if {$value eq "."} { - dict set result srcdir [file dirname $filename] - } else { - dict set result srcdir $value - } - } - PACKAGE_NAME { - dict set result name $value - } - PACKAGE_VERSION { - dict set result version $value - } - LIBS { - dict set result PRACTCL_LIBS $value - } - PKG_LIB_FILE { - dict set result libfile $value - } - } - } - } err opts - if {[dict get $opts -code] != 0} { - #puts $opts - puts "Error reading line:\n$line\nerr: $err\n***" - return $err {*}$opts - } - # the Compile field is about where most TEA files start getting silly - if {$field eq "compile"} { - break - } - } - return $result -} - -## Append arguments to a buffer -# The command works like puts in that each call will also insert -# a line feed. Unlike puts, blank links in the interstitial are -# suppressed -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 { - ::practcl::cputs output "# BEGIN $note" - } - c { - ::practcl::cputs output "/* BEGIN $note */" - } - default { - ::practcl::cputs output "# BEGIN $note" - } - } - ::practcl::cputs output $text - switch $style { - tcl { - ::practcl::cputs output "# END $note" - } - c { - ::practcl::cputs output "/* END $note */" - } - default { - ::practcl::cputs output "# END $note" - } - } - return $output -} - -proc ::practcl::_isdirectory name { - return [file isdirectory $name] -} - -### -# Return true if the pkgindex file contains -# any statement other than "package ifneeded" -# and/or if any package ifneeded loads a DLL -### -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] - set fname [file rootname [file tail $file]] - ### - # We used to be able to ... Assume the package is correct in the filename - # No hunt for a "package provides" - ### - set package [lindex [split $fname -] 0] - set version [lindex [split $fname -] 1] - ### - # Read the file, and override assumptions as needed - ### - set fin [open $file r] - set dat [read $fin] - close $fin - # Look for a teapot style Package statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 9] != "# Package " } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - # Look for a package provide statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n - } - foreach file [glob -nocomplain $path/*.tcl] { - if { [file tail $file] == "version_info.tcl" } continue - set fin [open $file r] - set dat [read $fin] - close $fin - if {![regexp "package provide" $dat]} continue - set fname [file rootname [file tail $file]] - # Look for a package provide statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - if {[string index $package 0] in "\$ \["} continue - if {[string index $version 0] in "\$ \["} continue - append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n - break - } - } - return $buffer - } - set fin [open $pkgidxfile r] - set dat [read $fin] - close $fin - set trace 0 - #if {[file tail $path] eq "tool"} { - # set trace 1 - #} - set thisline {} - foreach line [split $dat \n] { - append thisline $line \n - if {![info complete $thisline]} continue - set line [string trim $line] - if {[string length $line]==0} { - set thisline {} ; continue - } - if {[string index $line 0] eq "#"} { - set thisline {} ; continue - } - if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} { - if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"} - set thisline {} ; continue - } - if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} { - if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" } - set thisline {} ; continue - } - if {![regexp "package.*ifneeded" $thisline]} { - # This package index contains arbitrary code - # source instead of trying to add it to the master - # package index - if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" } - return {source [file join $dir pkgIndex.tcl]} - } - append buffer $thisline \n - set thisline {} - } - if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} - return $buffer -} - - -proc ::practcl::_pkgindex_path_subdir {path} { - set result {} - foreach subpath [glob -nocomplain [file join $path *]] { - if {[file isdirectory $subpath]} { - lappend result $subpath {*}[_pkgindex_path_subdir $subpath] - } - } - return $result -} -### -# Index all paths given as though they will end up in the same -# virtual file system -### -proc ::practcl::pkgindex_path args { - set stack {} - set buffer { -lappend ::PATHSTACK $dir - } - foreach base $args { - set base [file normalize $base] - set paths [::practcl::_pkgindex_path_subdir $base] - set i [string length $base] - # Build a list of all of the paths - foreach path $paths { - if {$path eq $base} continue - set path_indexed($path) 0 - } - set path_indexed($base) 1 - set path_indexed([file join $base boot tcl]) 1 - #set path_index([file join $base boot tk]) 1 - - foreach path $paths { - if {$path_indexed($path)} continue - set thisdir [file_relative $base $path] - #set thisdir [string range $path $i+1 end] - #append buffer "# DIR $thisdir" \n - set idxbuf [::practcl::_pkgindex_directory $path] - if {[string length $idxbuf]} { - incr path_indexed($path) - append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n - append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n - } - } - } - append buffer { -set dir [lindex $::PATHSTACK end] -set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] -} - return $buffer -} - -### -# topic: 64319f4600fb63c82b2258d908f9d066 -# description: Script to build the VFS file system -### -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] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - installDir $f [file join $d2 $ftail] - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - if {$::tcl_platform(platform) eq {unix}} { - file attributes [file join $d2 $ftail] -permissions 0644 - } else { - file attributes [file join $d2 $ftail] -readonly 1 - } - } - } - - 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 - - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - copyDir $f [file join $d2 $ftail] 0 - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - } - } -} - -::oo::class create ::practcl::metaclass { - superclass ::oo::object - - method script script { - eval $script - } - - method source filename { - source $filename - } - - method initialize {} {} - - method define {submethod args} { - my variable define - switch $submethod { - dump { - return [array get define] - } - add { - set field [lindex $args 0] - if {![info exists define($field)]} { - set define($field) {} - } - foreach arg [lrange $args 1 end] { - if {$arg ni $define($field)} { - lappend define($field) $arg - } - } - return $define($field) - } - remove { - set field [lindex $args 0] - if {![info exists define($field)]} { - return - } - set rlist [lrange $args 1 end] - set olist $define($field) - set nlist {} - foreach arg $olist { - if {$arg in $rlist} continue - lappend nlist $arg - } - set define($field) $nlist - return $nlist - } - exists { - set field [lindex $args 0] - return [info exists define($field)] - } - getnull - - get - - cget { - set field [lindex $args 0] - if {[info exists define($field)]} { - return $define($field) - } - return [lindex $args 1] - } - set { - if {[llength $args]==1} { - set arglist [lindex $args 0] - } else { - set arglist $args - } - array set define $arglist - if {[dict exists $arglist class]} { - my select - } - } - default { - array $submethod define {*}$args - } - } - } - - method graft args { - my variable organs - if {[llength $args] == 1} { - error "Need two arguments" - } - set object {} - foreach {stub object} $args { - dict set organs $stub $object - oo::objdefine [self] forward <${stub}> $object - oo::objdefine [self] export <${stub}> - } - return $object - } - - method organ {{stub all}} { - my variable organs - if {![info exists organs]} { - return {} - } - if { $stub eq "all" } { - return $organs - } - if {[dict exists $organs $stub]} { - return [dict get $organs $stub] - } - } - - method link {command args} { - my variable links - switch $command { - object { - foreach obj $args { - foreach linktype [$obj linktype] { - my link add $linktype $obj - } - } - } - add { - ### - # Add a link to an object that was externally created - ### - if {[llength $args] ne 2} { error "Usage: link add LINKTYPE OBJECT"} - lassign $args linktype object - if {[info exists links($linktype)] && $object in $links($linktype)} { - return - } - lappend links($linktype) $object - } - remove { - set object [lindex $args 0] - if {[llength $args]==1} { - set ltype * - } else { - set ltype [lindex $args 1] - } - foreach {linktype elements} [array get links $ltype] { - if {$object in $elements} { - set nlist {} - foreach e $elements { - if { $object ne $e } { lappend nlist $e } - } - set links($linktype) $nlist - } - } - } - list { - if {[llength $args]==0} { - return [array get links] - } - if {[llength $args] != 1} { error "Usage: link list LINKTYPE"} - set linktype [lindex $args 0] - if {![info exists links($linktype)]} { - return {} - } - return $links($linktype) - } - dump { - return [array get links] - } - } - } - - method select {} { - my variable define - set class {} - if {[info exists define(class)]} { - if {[info command $define(class)] ne {}} { - set class $define(class) - } elseif {[info command ::practcl::$define(class)] ne {}} { - set class ::practcl::$define(class) - } else { - switch $define(class) { - default { - set class ::practcl::object - } - } - } - } - if {$class ne {}} { - ::oo::objdefine [self] class $class - } - if {[::info exists define(oodefine)]} { - ::oo::objdefine [self] $define(oodefine) - unset define(oodefine) - } - } -} - -proc ::practcl::trigger {args} { - foreach name $args { - if {[dict exists $::make_objects $name]} { - [dict get $::make_objects $name] triggers - } - } -} - -proc ::practcl::depends {args} { - foreach name $args { - if {[dict exists $::make_objects $name]} { - [dict get $::make_objects $name] check - } - } -} - -proc ::practcl::target {name info} { - set obj [::practcl::target_obj new $name $info] - dict set ::make_objects $name $obj - if {[dict exists $info aliases]} { - foreach item [dict get $info aliases] { - if {![dict exists $::make_objects $item]} { - dict set ::make_objects $item $obj - } - } - } - set ::make($name) 0 - set ::trigger($name) 0 - set filename [$obj define get filename] - if {$filename ne {}} { - set ::target($name) $filename - } -} - -### Batch Tasks - -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] - #} - dict set values $flag [dict get $data $flag] - } - } - set map {} - lappend map {${PKG_OBJECTS}} %LIBRARY_OBJECTS% - lappend map {$(PKG_OBJECTS)} %LIBRARY_OBJECTS% - lappend map {${PKG_STUB_OBJECTS}} %LIBRARY_STUB_OBJECTS% - lappend map {$(PKG_STUB_OBJECTS)} %LIBRARY_STUB_OBJECTS% - - if {[dict exists $data name]} { - lappend map %LIBRARY_NAME% [dict get $data name] - lappend map %LIBRARY_VERSION% [dict get $data version] - lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} [dict get $data version]] - if {[dict exists $data libprefix]} { - lappend map %LIBRARY_PREFIX% [dict get $data libprefix] - } else { - lappend map %LIBRARY_PREFIX% [dict get $data prefix] - } - } - foreach flag [dict keys $data] { - if {$flag in {TCL_DEFS TK_DEFS DEFS}} continue - set value [string trim [dict get $data $flag] \"] - dict set map "\$\{${flag}\}" $value - dict set map "\$\(${flag}\)" $value - #dict set map "\$${flag}" $value - dict set map "%${flag}%" $value - dict set values $flag [dict get $data $flag] - #dict set map "\$\{${flag}\}" $proj($flag) - } - set changed 1 - while {$changed} { - set changed 0 - foreach {field value} $values { - if {$field in {TCL_DEFS TK_DEFS DEFS}} continue - dict with values {} - set newval [string map $map $value] - if {$newval eq $value} continue - set changed 1 - dict set values $field $newval - } - } - return $values -} - -### -# Ancestor-less class intended to be a mixin -# which defines a family of build related behaviors -# that are modified when targetting either gcc or msvc -### -::oo::class create ::practcl::build { - ## method DEFS - # This method populates 4 variables: - # name - The name of the package - # version - The version of the package - # defs - C flags passed to the compiler - # includedir - A list of paths to feed to the compiler for finding headers - # - 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 - } - set defs $DEFS - foreach flag { - -DPACKAGE_NAME - -DPACKAGE_VERSION - -DPACKAGE_TARNAME - -DPACKAGE_STRING - } { - if {[set i [string first $flag $defs]] >= 0} { - set j [string first -D $flag [expr {$i+[string length $flag]}]] - set predef [string range $defs 0 [expr {$i-1}]] - set postdef [string range $defs $j end] - 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 build-tclkit_main {PROJECT PKG_OBJS} { - ### - # Build static package list - ### - set statpkglist {} - foreach cobj [list {*}${PKG_OBJS} $PROJECT] { - foreach {pkg info} [$cobj static-packages] { - dict set statpkglist $pkg $info - } - } - foreach {ofile info} [${PROJECT} compile-products] { - if {![dict exists $info object]} continue - set cobj [dict get $info object] - foreach {pkg info} [$cobj static-packages] { - dict set statpkglist $pkg $info - } - } - - set result {} - $PROJECT include {<tcl.h>} - $PROJECT include {"tclInt.h"} - $PROJECT include {"tclFileSystem.h"} - $PROJECT include {<assert.h>} - $PROJECT include {<stdio.h>} - $PROJECT include {<stdlib.h>} - $PROJECT include {<string.h>} - $PROJECT include {<math.h>} - - $PROJECT code header { -#ifndef MODULE_SCOPE -# define MODULE_SCOPE extern -#endif - -/* -** Provide a dummy Tcl_InitStubs if we are using this as a static -** library. -*/ -#ifndef USE_TCL_STUBS -# undef Tcl_InitStubs -# define Tcl_InitStubs(a,b,c) TCL_VERSION -#endif -#define STATIC_BUILD 1 -#undef USE_TCL_STUBS - -/* Make sure the stubbed variants of those are never used. */ -#undef Tcl_ObjSetVar2 -#undef Tcl_NewStringObj -#undef Tk_Init -#undef Tk_MainEx -#undef Tk_SafeInit -} - - # Build an area of the file for #define directives and - # function declarations - set define {} - set mainhook [$PROJECT define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] - set mainfunc [$PROJECT define get TCL_LOCAL_APPINIT Tclkit_AppInit] - set mainscript [$PROJECT define get main.tcl main.tcl] - set vfsroot [$PROJECT define get vfsroot [file join [$PROJECT define get ZIPFS_VOLUME] app]] - set vfs_main "${vfsroot}/${mainscript}" - set vfs_tcl_library "${vfsroot}/boot/tcl" - set vfs_tk_library "${vfsroot}/boot/tk" - - set map {} - foreach var { - vfsroot mainhook mainfunc vfs_main vfs_tcl_library vfs_tk_library - } { - dict set map %${var}% [set $var] - } - set preinitscript { -set ::odie(boot_vfs) {%vfsroot%} -set ::SRCDIR {%vfsroot%} -if {[file exists {%vfs_tcl_library%}]} { - set ::tcl_library {%vfs_tcl_library%} - set ::auto_path {} -} -if {[file exists {%vfs_tk_library%}]} { - set ::tk_library {%vfs_tk_library%} -} -} ; # Preinitscript - - set zvfsboot { -/* - * %mainhook% -- - * Performs the argument munging for the shell - */ - } - ::practcl::cputs zvfsboot { - CONST char *archive; - Tcl_FindExecutable(*argv[0]); - archive=Tcl_GetNameOfExecutable(); - } - # We have to initialize the virtual filesystem before calling - # Tcl_Init(). Otherwise, Tcl_Init() will not be able to find - # its startup script files. - if {[$PROJECT define get tip_430 0]} { - ::practcl::cputs zvfsboot " if(!TclZipfsMount(NULL, archive, \"%vfsroot%\", NULL)) \x7B " - } else { - $PROJECT include {"tclZipfs.h"} - ::practcl::cputs zvfsboot { Tclzipfs_Init(NULL);} - ::practcl::cputs zvfsboot " if(!Tclzipfs_Mount(NULL, archive, \"%vfsroot%\", NULL)) \x7B " - } - ::practcl::cputs zvfsboot { - Tcl_Obj *vfsinitscript; - vfsinitscript=Tcl_NewStringObj("%vfs_main%",-1); - Tcl_IncrRefCount(vfsinitscript); - if(Tcl_FSAccess(vfsinitscript,F_OK)==0) { - /* Startup script should be set before calling Tcl_AppInit */ - Tcl_SetStartupScript(vfsinitscript,NULL); - } - } - ::practcl::cputs zvfsboot " TclSetPreInitScript([::practcl::tcl_to_c $preinitscript])\;" - ::practcl::cputs zvfsboot " \x7D else \x7B" - ::practcl::cputs zvfsboot " TclSetPreInitScript([::practcl::tcl_to_c { -foreach path { - ../tcl -} { - set p [file join $path library init.tcl] - if {[file exists [file join $path library init.tcl]]} { - set ::tcl_library [file normalize [file join $path library]] - break - } -} -foreach path { - ../tk -} { - if {[file exists [file join $path library tk.tcl]]} { - set ::tk_library [file normalize [file join $path library]] - break - } -} -}])\;" - - ::practcl::cputs zvfsboot " \x7D" - ::practcl::cputs zvfsboot " return TCL_OK;" - - if {[$PROJECT define get TEACUP_OS] eq "windows"} { - set header {int %mainhook%(int *argc, TCHAR ***argv)} - } else { - set header {int %mainhook%(int *argc, char ***argv)} - } - $PROJECT c_function [string map $map $header] [string map $map $zvfsboot] - - practcl::cputs appinit "int %mainfunc%(Tcl_Interp *interp) \x7B" - - # Build AppInit() - set appinit {} - practcl::cputs appinit { - if ((Tcl_Init)(interp) == TCL_ERROR) { - return TCL_ERROR; - } -} - set main_init_script {} - - foreach {statpkg info} $statpkglist { - set initfunc {} - if {[dict exists $info initfunc]} { - set initfunc [dict get $info initfunc] - } - if {$initfunc eq {}} { - set initfunc [string totitle ${statpkg}]_Init - } - if {![dict exists $info version]} { - error "$statpkg HAS NO VERSION" - } - # We employ a NULL to prevent the package system from thinking the - # package is actually loaded into the interpreter - $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" - set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] - append main_init_script \n [list set ::kitpkg(${statpkg}) $script] - if {[dict get $info autoload]} { - ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" - ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" - } else { - ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" - append main_init_script \n $script - } - } - append main_init_script \n { -if {[file exists [file join $::SRCDIR packages.tcl]]} { - #In a wrapped exe, we don't go out to the environment - set dir $::SRCDIR - source [file join $::SRCDIR packages.tcl] -} -# Specify a user-specific startup file to invoke if the application -# is run interactively. Typically the startup file is "~/.apprc" -# where "app" is the name of the application. If this line is deleted -# 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] -} - -} - - -::oo::class create ::practcl::build.gcc { - superclass ::practcl::build - - method build-compile-sources {PROJECT COMPILE {CPPCOMPILE {}}} { - set EXTERN_OBJS {} - set OBJECTS {} - set result {} - set builddir [$PROJECT define get builddir] - file mkdir [file join $builddir objs] - set debug [$PROJECT define get debug 0] - if {$CPPCOMPILE eq {}} { - set CPPCOMPILE $COMPILE - } - set task [${PROJECT} compile-products] - ### - # Compile the C sources - ### - foreach {ofile info} $task { - dict set task $ofile done 0 - if {[dict exists $info external] && [dict get $info external]==1} { - dict set task $ofile external 1 - } else { - dict set task $ofile external 0 - } - if {[dict exists $info library]} { - dict set task $ofile done 1 - continue - } - # Products with no cfile aren't compiled - if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} { - dict set task $ofile done 1 - continue - } - set cfile [dict get $info cfile] - set ofilename [file join $builddir objs [file tail $ofile]] - if {$debug} { - set ofilename [file join $builddir objs [file rootname [file tail $ofile]].debug.o] - } - dict set task $ofile filename $ofilename - if {[file exists $ofilename] && [file mtime $ofilename]>[file mtime $cfile]} { - lappend result $ofilename - dict set task $ofile done 1 - continue - } - if {![dict exist $info command]} { - if {[file extension $cfile] in {.c++ .cpp}} { - set cmd $CPPCOMPILE - } else { - set cmd $COMPILE - } - if {[dict exists $info extra]} { - append cmd " [dict get $info extra]" - } - append cmd " -c $cfile" - append cmd " -o $ofilename" - dict set task $ofile command $cmd - } - } - set completed 0 - while {$completed==0} { - set completed 1 - foreach {ofile info} $task { - set waiting {} - if {[dict exists $info done] && [dict get $info done]} continue - if {[dict exists $info depend]} { - foreach file [dict get $info depend] { - if {[dict exists $task $file command] && [dict exists $task $file done] && [dict get $task $file done] != 1} { - set waiting $file - break - } - } - } - if {$waiting ne {}} { - set completed 0 - puts "$ofile waiting for $waiting" - continue - } - if {[dict exists $info command]} { - set cmd [dict get $info command] - puts "$cmd" - exec {*}$cmd >&@ stdout - } - lappend result [dict get $info filename] - dict set task $ofile done 1 - } - } - return $result -} - -method build-Makefile {path 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]]] - lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] - foreach include [$PROJECT generate-include-directory] { - set cpath [::practcl::file_relative $path [file normalize $include]] - if {$cpath ni $includedir} { - lappend includedir $cpath - } - } - set INCLUDES "-I[join $includedir " -I"]" - set NAME [string toupper $proj(name)] - set result {} - set products {} - set libraries {} - set thisline {} - ::practcl::cputs result "${NAME}_DEFS = $proj(DEFS)\n" - ::practcl::cputs result "${NAME}_INCLUDES = -I\"[join $includedir "\" -I\""]\"\n" - ::practcl::cputs result "${NAME}_COMPILE = \$(CC) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" - ::practcl::cputs result "${NAME}_CPPCOMPILE = \$(CXX) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" - - foreach {ofile info} [$PROJECT compile-products] { - dict set products $ofile $info - if {[dict exists $info library]} { -lappend libraries $ofile -continue - } - if {[dict exists $info depend]} { - ::practcl::cputs result "\n${ofile}: [dict get $info depend]" - } else { - ::practcl::cputs result "\n${ofile}:" - } - set cfile [dict get $info cfile] - if {[file extension $cfile] in {.c++ .cpp}} { - set cmd "\t\$\(${NAME}_CPPCOMPILE\)" - } else { - set cmd "\t\$\(${NAME}_COMPILE\)" - } - if {[dict exists $info extra]} { - append cmd " [dict get $info extra]" - } - append cmd " -c [dict get $info cfile] -o \$@\n\t" - ::practcl::cputs result $cmd - } - - set map {} - lappend map %LIBRARY_NAME% $proj(name) - lappend map %LIBRARY_VERSION% $proj(version) - lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)] - lappend map %LIBRARY_PREFIX% [$PROJECT define getnull libprefix] - - if {[string is true [$PROJECT define get SHARED_BUILD]]} { - set outfile [$PROJECT define get libfile] - } else { - set outfile [$PROJECT shared_library] - } - $PROJECT define set shared_library $outfile - ::practcl::cputs result " -${NAME}_SHLIB = $outfile -${NAME}_OBJS = [dict keys $products] -" - - #lappend map %OUTFILE% {\[$]@} - lappend map %OUTFILE% $outfile - lappend map %LIBRARY_OBJECTS% "\$(${NAME}_OBJS)" - ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" - ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_SHARED_LIB]]" - if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} { - ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]]" - } - ::practcl::cputs result {} - if {[string is true [$PROJECT define get SHARED_BUILD]]} { - #set outfile [$PROJECT static_library] - set outfile $proj(name).a - } else { - set outfile [$PROJECT define get libfile] - } - $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 -} - -### -# Produce a static or dynamic library -### -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]]] - lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] - if {[$PROJECT define get tk 0]} { - lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]] - lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]] - lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]] - lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]] - } - foreach include [$PROJECT generate-include-directory] { - set cpath [::practcl::file_relative $path [file normalize $include]] - if {$cpath ni $includedir} { - lappend includedir $cpath - } - } - my build-cflags $PROJECT $proj(DEFS) name version defs - set NAME [string toupper $name] - set debug [$PROJECT define get debug 0] - set os [$PROJECT define get TEACUP_OS] - - set INCLUDES "-I[join $includedir " -I"]" - if {$debug} { - set COMPILE "$proj(CC) $proj(CFLAGS_DEBUG) -ggdb \ -$proj(CFLAGS_WARNING) $INCLUDES $defs" - - if {[info exists proc(CXX)]} { - set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS_DEBUG) -ggdb \ - $defs $proj(CFLAGS_WARNING)" - } else { - set COMPILECPP $COMPILE - } - } else { - set COMPILE "$proj(CC) $proj(CFLAGS) $defs $INCLUDES " - - if {[info exists proc(CXX)]} { - set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS) $defs" - } else { - set COMPILECPP $COMPILE - } - } - - set products [my build-compile-sources $PROJECT $COMPILE $COMPILECPP] - - set map {} - lappend map %LIBRARY_NAME% $proj(name) - lappend map %LIBRARY_VERSION% $proj(version) - lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)] - lappend map %OUTFILE% $outfile - lappend map %LIBRARY_OBJECTS% $products - lappend map {${CFLAGS}} "$proj(CFLAGS_DEFAULT) $proj(CFLAGS_WARNING)" - - if {[string is true [$PROJECT define get SHARED_BUILD 1]]} { - set cmd [$PROJECT define get PRACTCL_SHARED_LIB] - append cmd " [$PROJECT define get PRACTCL_LIBS]" - set cmd [string map $map $cmd] - puts $cmd - exec {*}$cmd >&@ stdout - if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} { - set cmd [string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]] - puts $cmd - exec {*}$cmd >&@ stdout - } - } else { - set cmd [string map $map [$PROJECT define get PRACTCL_STATIC_LIB]] - puts $cmd - exec {*}$cmd >&@ stdout - } - set ranlib [$PROJECT define get RANLIB] - if {$ranlib ni {{} :}} { - catch {exec $ranlib $outfile} - } -} - -### -# Produce a static executable -### -method build-tclsh {outfile PROJECT} { - puts " BUILDING STATIC TCLSH " - set TCLOBJ [$PROJECT project TCLCORE] - set PKG_OBJS {} - foreach item [$PROJECT link list core.library] { - if {[string is true [$item define get static]]} { - lappend PKG_OBJS $item - } - } - foreach item [$PROJECT link list package] { - if {[string is true [$item define get static]]} { - lappend PKG_OBJS $item - } - } - array set TCL [$TCLOBJ config.sh] - - set TKOBJ [$PROJECT project tk] - if {[info command $TKOBJ] eq {}} { - set TKOBJ ::noop - $PROJECT define set static_tk 0 - } else { - array set TK [$TKOBJ config.sh] - $PROJECT define set static_tk [$TKOBJ define get static] - set TKSRCDIR [$TKOBJ define get srcdir] - } - set path [file dirname $outfile] - cd $path - ### - # For a static Tcl shell, we need to build all local sources - # with the same DEFS flags as the tcl core was compiled with. - # The DEFS produced by a TEA extension aren't intended to operate - # with the internals of a staticly linked Tcl - ### - my build-cflags $PROJECT $TCL(defs) name version defs - set debug [$PROJECT define get debug 0] - set NAME [string toupper $name] - set result {} - set libraries {} - set thisline {} - set OBJECTS {} - set EXTERN_OBJS {} - foreach obj $PKG_OBJS { - $obj compile - set config($obj) [$obj config.sh] - } - set os [$PROJECT define get TEACUP_OS] - set TCLSRCDIR [$TCLOBJ define get srcdir] - - set includedir . - foreach include [$TCLOBJ generate-include-directory] { - set cpath [::practcl::file_relative $path [file normalize $include]] - if {$cpath ni $includedir} { - lappend includedir $cpath - } - } - lappend includedir [::practcl::file_relative $path [file normalize ../tcl/compat/zlib]] - foreach include [$PROJECT generate-include-directory] { - set cpath [::practcl::file_relative $path [file normalize $include]] - if {$cpath ni $includedir} { - lappend includedir $cpath - } - } - - set INCLUDES "-I[join $includedir " -I"]" - if {$debug} { - set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) -ggdb \ -$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" - } else { - set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ -$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" - } - append COMPILE " " $defs - lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE] - - set TCLSRC [file normalize $TCLSRCDIR] - - if {[${PROJECT} define get TEACUP_OS] eq "windows"} { - set windres [$PROJECT define get RC windres] - set RSOBJ [file join $path build tclkit.res.o] - set RCSRC [${PROJECT} define get kit_resource_file] - set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]] - if {[$PROJECT define get static_tk]} { - if {$RCSRC eq {} || ![file exists $RCSRC]} { - set RCSRC [file join $TKSRCDIR win rc wish.rc] - } - set TKSRC [file normalize $TKSRCDIR] - lappend cmd --include [::practcl::file_relative $path [file join $TKSRC generic]] \ - --include [::practcl::file_relative $path [file join $TKSRC win]] \ - --include [::practcl::file_relative $path [file join $TKSRC win rc]] - } else { - if {$RCSRC eq {} || ![file exists $RCSRC]} { - set RCSRC [file join $TCLSRCDIR tclsh.rc] - } - } - foreach item [${PROJECT} define get resource_include] { - lappend cmd --include [::practcl::file_relative $path [file normalize $item]] - } - lappend cmd $RCSRC - ::practcl::doexec {*}$cmd - lappend OBJECTS $RSOBJ - set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} - set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} - } else { - set LDFLAGS_CONSOLE {} - set LDFLAGS_WINDOW {} - } - puts "***" - if {$debug} { - set cmd "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) \ -$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" - } else { - set cmd "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ -$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" - } - append cmd " $OBJECTS" - append cmd " $EXTERN_OBJS " - # On OSX it is impossibly to generate a completely static - # executable - if {[$PROJECT define get TEACUP_OS] ne "macosx"} { - append cmd " -static " - } - if {$debug} { - if {$os eq "windows"} { - append cmd " -L${TCL(src_dir)}/win -ltcl86g" - if {[$PROJECT define get static_tk]} { - append cmd " -L${TK(src_dir)}/win -ltk86g" - } - } else { - append cmd " -L${TCL(src_dir)}/unix -ltcl86g" - if {[$PROJECT define get static_tk]} { - append cmd " -L${TK(src_dir)}/unix -ltk86g" - } - } - } else { - append cmd " $TCL(build_lib_spec)" - if {[$PROJECT define get static_tk]} { - append cmd " $TK(build_lib_spec)" - } - } - foreach obj $PKG_OBJS { - append cmd " [$obj linker-products $config($obj)]" - } - append cmd " $TCL(libs) " - if {[$PROJECT define get static_tk]} { - append cmd " $TK(libs)" - } - foreach obj $PKG_OBJS { - append cmd " [$obj linker-external $config($obj)]" - } - if {$debug} { - if {$os eq "windows"} { - append cmd " -L${TCL(src_dir)}/win ${TCL(stub_lib_flag)}" - if {[$PROJECT define get static_tk]} { - append cmd " -L${TK(src_dir)}/win ${TK(stub_lib_flag)}" - } - } else { - append cmd " -L${TCL(src_dir)}/unix ${TCL(stub_lib_flag)}" - if {[$PROJECT define get static_tk]} { - append cmd " -L${TK(src_dir)}/unix ${TK(stub_lib_flag)}" - } - } - } else { - append cmd " $TCL(build_stub_lib_spec)" - if {[$PROJECT define get static_tk]} { - append cmd " $TK(build_stub_lib_spec)" - } - } - append cmd " -o $outfile $LDFLAGS_CONSOLE" - puts "LINK: $cmd" - exec {*}$cmd >&@ stdout -} -} - - -::oo::class create ::practcl::build.msvc { - superclass ::practcl::build - -} - -::oo::class create ::practcl::target_obj { - superclass ::practcl::metaclass - - constructor {name info} { - my variable define triggered domake - set triggered 0 - set domake 0 - set define(name) $name - set data [uplevel 2 [list subst $info]] - array set define $data - my select - my initialize - } - - 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 - } - set needs_make 0 - foreach item [my define get depends] { - if {![dict exists $::make_objects $item]} continue - set depobj [dict get $::make_objects $item] - if {$depobj eq [self]} { - puts "WARNING [self] depends on itself" - continue - } - if {[$depobj check]} { - set needs_make 1 - } - } - if {!$needs_make} { - set filename [my define get filename] - if {$filename ne {} && ![file exists $filename]} { - set needs_make 1 - } - } - return $needs_make - } - - method triggers {} { - my variable triggered domake define - if {$triggered} { - return $domake - } - set triggered 1 - foreach item [my define get depends] { - if {![dict exists $::make_objects $item]} continue - set depobj [dict get $::make_objects $item] - if {$depobj eq [self]} { - puts "WARNING [self] triggers itself" - continue - } else { - set r [$depobj check] - if {$r} { - $depobj triggers - } - } - } - if {[info exists ::make($define(name))] && $::make($define(name))} { - return - } - set ::make($define(name)) 1 - ::practcl::trigger {*}[my define get triggers] - } -} - - -### -# Define the metaclass -### -::oo::class create ::practcl::object { - superclass ::practcl::metaclass - - constructor {parent args} { - my variable links define - set organs [$parent child organs] - my graft {*}$organs - array set define $organs - array set define [$parent child define] - array set links {} - if {[llength $args]==1 && [file exists [lindex $args 0]]} { - my InitializeSourceFile [lindex $args 0] - } elseif {[llength $args] == 1} { - set data [uplevel 1 [list subst [lindex $args 0]]] - array set define $data - my select - my initialize - } else { - array set define [uplevel 1 [list subst $args]] - my select - my initialize - } - } - - - method include_dir args { - my define add include_dir {*}$args - } - - method include_directory args { - my define add include_dir {*}$args - } - - method Collate_Source CWD {} - - - method child {method} { - return {} - } - - method InitializeSourceFile filename { - my define set filename $filename - set class {} - switch [file extension $filename] { - .tcl { - set class ::practcl::dynamic - } - .h { - set class ::practcl::cheader - } - .c { - set class ::practcl::csource - } - .ini { - switch [file tail $filename] { - module.ini { - set class ::practcl::module - } - library.ini { - set class ::practcl::subproject - } - } - } - .so - - .dll - - .dylib - - .a { - set class ::practcl::clibrary - } - } - if {$class ne {}} { - oo::objdefine [self] class $class - my initialize - } - } - - method add args { - my variable links - set object [::practcl::object new [self] {*}$args] - foreach linktype [$object linktype] { - lappend links($linktype) $object - } - return $object - } - - 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]] - } - - method code {section body} { - my variable code - ::practcl::cputs code($section) $body - } - - 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]].o - } - - method compile-products {} { - set filename [my define get filename] - set result {} - if {$filename ne {}} { - 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 compile-products] - } - return $result - } - - method generate-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 generate-include-directory] { - lappend result $path - } - } - 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 - } - - # Empty template methods - method generate-cheader {} { - ::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-cheader] - if {[string length [string trim $dat]]} { - ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cheader */" - ::practcl::cputs result $dat - ::practcl::cputs result "/* END [$obj define get filename] generate-cheader */" - } - } - ::practcl::debug [list cfunct [info exists cfunct]] - if {[info exists cfunct]} { - foreach {funcname info} $cfunct { - if {[dict get $info public]} continue - ::practcl::cputs result "[dict get $info header]\;" - } - } - ::practcl::debug [list tclprocs [info exists tclprocs]] - if {[info exists tclprocs]} { - foreach {name info} $tclprocs { - if {[dict exists $info header]} { - ::practcl::cputs result "[dict get $info header]\;" - } - } - } - ::practcl::debug [list methods [info exists methods] [my define get cclass]] - - if {[info exists methods]} { - set thisclass [my define get cclass] - foreach {name info} $methods { - if {[dict exists $info header]} { - ::practcl::cputs result "[dict get $info header]\;" - } - } - # Add the initializer wrapper for the class - ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp)\;" - } - return $result - } - - method generate-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-public-define] - } - return $result - } - - method generate-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-public-macro] - } - return $result - } - - method generate-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) - } - if {[info exists cstruct]} { - # Add defintion for native c data structures - foreach {name info} $cstruct { - if {[dict get $info public]==0} continue - ::practcl::cputs result "typedef struct $name ${name}\;" - if {[dict exists $info aliases]} { - foreach n [dict get $info aliases] { - ::practcl::cputs result "typedef struct $name ${n}\;" - } - } - } - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list product] { - ::practcl::cputs result [$mod generate-public-typedef] - } - return $result - } - - method generate-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) - } - if {[info exists cstruct]} { - # Add defintion for native c data structures - foreach {name info} $cstruct { - if {[dict get $info public]==1} continue - ::practcl::cputs result "typedef struct $name ${name}\;" - if {[dict exists $info aliases]} { - foreach n [dict get $info aliases] { - ::practcl::cputs result "typedef struct $name ${n}\;" - } - } - } - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list product] { - ::practcl::cputs result [$mod generate-private-typedef] - } - return $result - } - - method generate-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) - } - if {[info exists cstruct]} { - foreach {name info} $cstruct { - if {[dict get $info public]==0} continue - if {[dict exists $info comment]} { - ::practcl::cputs result [dict get $info comment] - } - ::practcl::cputs result "struct $name \{[dict get $info body]\}\;" - } - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list product] { - ::practcl::cputs result [$mod generate-public-structure] - } - return $result - } - - - method generate-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) - } - if {[info exists cstruct]} { - foreach {name info} $cstruct { - if {[dict get $info public]==1} continue - if {[dict exists $info comment]} { - ::practcl::cputs result [dict get $info comment] - } - ::practcl::cputs result "struct $name \{[dict get $info body]\}\;" - } - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list product] { - ::practcl::cputs result [$mod generate-private-structure] - } - return $result - } - - method generate-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) - } - if {[info exists tcltype]} { - foreach {type info} $tcltype { - if {![dict exists $info cname]} { - set cname [string tolower ${type}]_tclobjtype - dict set tcltype $type cname $cname - } else { - set cname [dict get $info cname] - } - ::practcl::cputs result "extern const Tcl_ObjType $cname\;" - } - } - if {[info exists code(public)]} { - ::practcl::cputs result $code(public) - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list product] { - ::practcl::cputs result [$mod generate-public-headers] - } - 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 generate-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-public-function] - } - return $result - } - - method generate-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-public-includes] { - if {$item ni $includes} { - lappend includes $item - } - } - } - return $includes - } - method generate-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-public-verbatim] { - if {$item ni $includes} { - lappend includes $item - } - } - } - return $includes - } - ### - # This methods generates the contents of an amalgamated .h file - # which describes the public API of this module - ### - 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-public-includes] - foreach inc $includes { - if {[string index $inc 0] ni {< \"}} { - ::practcl::cputs result "#include \"$inc\"" - } else { - ::practcl::cputs result "#include $inc" - } - } - - foreach method { - generate-public-define - generate-public-macro - generate-public-typedef - generate-public-structure - } { - ::practcl::cputs result "/* BEGIN SECTION $method */" - ::practcl::cputs result [my $method] - ::practcl::cputs result "/* END SECTION $method */" - } - - foreach file [my generate-public-verbatim] { - ::practcl::cputs result "/* BEGIN $file */" - ::practcl::cputs result [::practcl::cat $file] - ::practcl::cputs result "/* END $file */" - } - - foreach method { - generate-public-headers - generate-public-function - } { - ::practcl::cputs result "/* BEGIN SECTION $method */" - ::practcl::cputs result [my $method] - ::practcl::cputs result "/* END SECTION $method */" - } - 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 - } - } - } - - ### - # This methods generates the contents of an amalgamated .c file - # which implements the loader for a batch of tools - ### - 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 {} - - foreach mod [my link list product] { - # Signal modules to formulate final implementation - $mod go - } - set headers {} - - my IncludeAdd headers <tcl.h> <tclOO.h> - if {[my define get tk 0]} { - my IncludeAdd headers <tk.h> - } - if {[my define get output_h] ne {}} { - my IncludeAdd headers [my define get output_h] - } - my IncludeAdd headers {*}[my define get include] - - foreach mod [my link list dynamic] { - my IncludeAdd headers {*}[$mod define get include] - } - foreach inc $headers { - ::practcl::cputs result "#include $inc" - } - foreach {method} { - generate-cheader - generate-private-typedef - generate-private-structure - generate-cstruct - generate-constant - generate-cfunct - generate-cmethod - } { - set dat [my $method] - if {[string length [string trim $dat]]} { - ::practcl::cputs result "/* BEGIN $method [my define get filename] */" - ::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-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 { - /* Initialise the stubs tables. */ - #ifdef USE_TCL_STUBS - if (Tcl_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR; - if (TclOOInitializeStubs(interp, "1.0") == NULL) return TCL_ERROR; -} - if {[my define get tk 0]} { - ::practcl::cputs result { if (Tk_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR;} - } - ::practcl::cputs result { #endif} - set TCLINIT [my generate-tcl-pre] - if {[string length $TCLINIT]} { - ::practcl::cputs result " if(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR ;" - } - foreach item [my link list product] { - if {[$item define get output_c] ne {}} { - ::practcl::cputs result [$item generate-cinit-external] - } else { - ::practcl::cputs result [$item generate-cinit] - } - } - set TCLINIT [my generate-tcl-post] - if {[string length $TCLINIT]} { - ::practcl::cputs result " if(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR ;" - } - if {[my define exists pkg_name]} { - ::practcl::cputs result " if (Tcl_PkgProvide(interp, \"[my define get pkg_name [my define get name]]\" , \"[my define get pkg_vers [my define get version]]\" )) return TCL_ERROR\;" - } - ::practcl::cputs result " return TCL_OK\;\n\}\n" - return $result - } - - ### - # This methods generates any Tcl script file - # which is required to pre-initialize the C library - ### - 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 static-packages {} { - set result [my define get static_packages] - set statpkg [my define get static_pkg] - 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 static-packages] { - dict set result $pkg $info - } - } - return $result - } - - method target {method args} { - switch $method { - is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } - } - } - -} - -::oo::class create ::practcl::product { - superclass ::practcl::object - - method linktype {} { - return {subordinate product} - } - - method include header { - my define add include $header - } - - 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 generate-cinit {} { - ::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 obj [my link list product] { - ::practcl::cputs result [$obj generate-cinit] - } - return $result - } -} - -### -# Dynamic blocks do not generate their own .c files, -# instead the contribute to the amalgamation -# of the main library file -### -::oo::class create ::practcl::dynamic { - superclass ::practcl::product - - # Retrieve any additional source files required - - method compile-products {} { - set filename [my define get output_c] - set result {} - if {$filename ne {}} { - 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]]] - } else { - set filename [my define get cfile] - if {$filename ne {}} { - 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]]] - } - } - foreach item [my link list subordinate] { - lappend result {*}[$item 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]] - 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-cinit] - 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} - } - - ### - # Populate const static data structures - ### - method generate-cstruct {} { - ::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 dynamic] { - # Exclude products that will generate their own C files - if {[$obj define get output_c] ne {}} continue - ::practcl::cputs result [$obj generate-cstruct] - } - return $result - } - - method generate-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) - } - if {[info exists cstruct]} { - foreach {name info} $cstruct { - set map {} - lappend map @NAME@ $name - lappend map @MACRO@ GET[string toupper $name] - - if {[dict exists $info deleteproc]} { - lappend map @DELETEPROC@ [dict get $info deleteproc] - } else { - lappend map @DELETEPROC@ NULL - } - if {[dict exists $info cloneproc]} { - lappend map @CLONEPROC@ [dict get $info cloneproc] - } else { - lappend map @CLONEPROC@ NULL - } - ::practcl::cputs result [string map $map { -const static Tcl_ObjectMetadataType @NAME@DataType = { - TCL_OO_METADATA_VERSION_CURRENT, - "@NAME@", - @DELETEPROC@, - @CLONEPROC@ -}; -#define @MACRO@(OBJCONTEXT) (@NAME@ *) Tcl_ObjectGetMetadata(OBJCONTEXT,&@NAME@DataType) -}] - } - } - if {[info exists tcltype]} { - foreach {type info} $tcltype { - dict with info {} - ::practcl::cputs result "const Tcl_ObjType $cname = \{\n .freeIntRepProc = &${freeproc},\n .dupIntRepProc = &${dupproc},\n .updateStringProc = &${updatestringproc},\n .setFromAnyProc = &${setfromanyproc}\n\}\;" - } - } - - if {[info exists methods]} { - set mtypes {} - foreach {name info} $methods { - set callproc [dict get $info callproc] - set methodtype [dict get $info methodtype] - if {$methodtype in $mtypes} continue - lappend mtypes $methodtype - ### - # Build the data struct for this method - ### - ::practcl::cputs result "const static Tcl_MethodType $methodtype = \{" - ::practcl::cputs result " .version = TCL_OO_METADATA_VERSION_CURRENT,\n .name = \"$name\",\n .callProc = $callproc," - if {[dict exists $info deleteproc]} { - set deleteproc [dict get $info deleteproc] - } else { - set deleteproc NULL - } - if {$deleteproc ni { {} NULL }} { - ::practcl::cputs result " .deleteProc = $deleteproc," - } else { - ::practcl::cputs result " .deleteProc = NULL," - } - if {[dict exists $info cloneproc]} { - set cloneproc [dict get $info cloneproc] - } else { - set cloneproc NULL - } - if {$cloneproc ni { {} NULL }} { - ::practcl::cputs result " .cloneProc = $cloneproc\n\}\;" - } else { - ::practcl::cputs result " .cloneProc = NULL\n\}\;" - } - dict set methods $name methodtype $methodtype - } - } - foreach obj [my link list dynamic] { - # Exclude products that will generate their own C files - if {[$obj define get output_c] ne {}} continue - ::practcl::cputs result [$obj generate-constant] - } - return $result - } - - ### - # Generate code that provides subroutines called by - # Tcl API methods - ### - method generate-cfunct {} { - ::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) - } - if {[info exists cfunct]} { - foreach {funcname info} $cfunct { - ::practcl::cputs result "/* $funcname */" - ::practcl::cputs result "\n[dict get $info header]\{[dict get $info body]\}" - } - } - foreach obj [my link list dynamic] { - # Exclude products that will generate their own C files - if {[$obj define get output_c] ne {}} { - continue - } - ::practcl::cputs result [$obj generate-cfunct] - } - return $result - } - - ### - # Generate code that provides implements Tcl API - # calls - ### - method generate-cmethod {} { - ::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) - } - - if {[info exists tclprocs]} { - foreach {name info} $tclprocs { - if {![dict exists $info body]} continue - set callproc [dict get $info callproc] - set header [dict get $info header] - set body [dict get $info body] - ::practcl::cputs result "/* Tcl Proc $name */" - ::practcl::cputs result "${header} \{${body}\}" - } - } - - - if {[info exists methods]} { - set thisclass [my define get cclass] - foreach {name info} $methods { - if {![dict exists $info body]} continue - set callproc [dict get $info callproc] - set header [dict get $info header] - set body [dict get $info body] - ::practcl::cputs result "/* OO Method $thisclass $name */" - ::practcl::cputs result "${header} \{${body}\}" - } - # Build the OO_Init function - ::practcl::cputs result "/* Loader for $thisclass */" - ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp) \{" - ::practcl::cputs result [string map [list @CCLASS@ $thisclass @TCLCLASS@ [my define get class]] { - /* - ** Build the "@TCLCLASS@" class - */ - Tcl_Obj* nameObj; /* Name of a class or method being looked up */ - Tcl_Object curClassObject; /* Tcl_Object representing the current class */ - Tcl_Class curClass; /* Tcl_Class representing the current class */ - - /* - * Find the "@TCLCLASS@" class, and attach an 'init' method to it. - */ - - nameObj = Tcl_NewStringObj("@TCLCLASS@", -1); - Tcl_IncrRefCount(nameObj); - if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { - Tcl_DecrRefCount(nameObj); - return TCL_ERROR; - } - Tcl_DecrRefCount(nameObj); - curClass = Tcl_GetObjectAsClass(curClassObject); -}] - if {[dict exists $methods constructor]} { - set mtype [dict get $methods constructor methodtype] - ::practcl::cputs result [string map [list @MTYPE@ $mtype] { - /* Attach the constructor to the class */ - Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &@MTYPE@, NULL)); - }] - } - foreach {name info} $methods { - dict with info {} - if {$name in {constructor destructor}} continue - ::practcl::cputs result [string map [list @NAME@ $name @MTYPE@ $methodtype] { - nameObj=Tcl_NewStringObj("@NAME@",-1); - Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); - Tcl_DecrRefCount(nameObj); -}] - if {[dict exists $info aliases]} { - foreach alias [dict get $info aliases] { - if {[dict exists $methods $alias]} continue - ::practcl::cputs result [string map [list @NAME@ $alias @MTYPE@ $methodtype] { - nameObj=Tcl_NewStringObj("@NAME@",-1); - Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); - Tcl_DecrRefCount(nameObj); -}] - } - } - } - ::practcl::cputs result " return TCL_OK\;\n\}\n" - } - foreach obj [my link list dynamic] { - # Exclude products that will generate their own C files - if {[$obj define get output_c] ne {}} continue - ::practcl::cputs result [$obj generate-cmethod] - } - return $result - } - - method generate-cinit-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\;" - } - - ### - # Generate code that runs when the package/module is - # initialized into the interpreter - ### - method generate-cinit {} { - ::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) { - ::practcl::cputs result [string map [list @NSPACE@ $nspace] { - modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); - if(!modPtr) { - modPtr = Tcl_CreateNamespace(interp, "@NSPACE@", NULL, NULL); - } -}] - } - ::practcl::cputs result " \}" - } - if {[info exists code(tclinit)]} { - ::practcl::cputs result $code(tclinit) - } - if {[info exists code(cinit)]} { - ::practcl::cputs result $code(cinit) - } - if {[info exists code(initfuncts)]} { - foreach func $code(initfuncts) { - ::practcl::cputs result " if (${func}(interp) != TCL_OK) return TCL_ERROR\;" - } - } - if {[info exists tclprocs]} { - foreach {name info} $tclprocs { - set map [list @NAME@ $name @CALLPROC@ [dict get $info callproc]] - ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] - if {[dict exists $info aliases]} { - foreach alias [dict get $info aliases] { - set map [list @NAME@ $alias @CALLPROC@ [dict get $info callproc]] - ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] - } - } - } - } - - if {[info exists code(nspace)]} { - ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" - foreach nspace $code(nspace) { - ::practcl::cputs result [string map [list @NSPACE@ $nspace] { - modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); - Tcl_CreateEnsemble(interp, modPtr->fullName, modPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, modPtr, "[a-z]*", 1); -}] - } - ::practcl::cputs result " \}" - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach obj [my link list product] { - # Exclude products that will generate their own C files - if {[$obj define get output_c] ne {}} { - ::practcl::cputs result [$obj generate-cinit-external] - } else { - ::practcl::cputs result [$obj generate-cinit] - } - } - return $result - } - - 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_]*) *\((.*)\)} - } { - if {[regexp $regexp $header all keywords funcname arglist]} { - dict set cfunct $funcname header $header - dict set cfunct $funcname body $body - dict set cfunct $funcname keywords $keywords - dict set cfunct $funcname arglist $arglist - dict set cfunct $funcname inline [expr {"inline" ni $keywords}] - dict set cfunct $funcname public [expr {"static" ni $keywords}] - dict set cfunct $funcname export [expr {"STUB_EXPORT" in $keywords}] - foreach {f v} $info { - dict set cfunct $f $v - } - return - } - } - foreach {f v} $info { - dict set cfunct $f $v - } - ::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 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_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 go {} { - ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - next - 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 - if {![dict exists $info callproc]} { - set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} OOMethod_${thisclass}_${name}]] - dict set methods $name callproc $callproc - } else { - set callproc [dict get $info callproc] - } - if {[dict exists $info body] && ![dict exists $info header]} { - dict set methods $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext ,int objc ,Tcl_Obj *const *objv)" - } - if {![dict exists $info methodtype]} { - set methodtype [string map {{ } _ : _} OOMethodType_${thisclass}_${name}] - dict set methods $name methodtype $methodtype - } - } - if {![info exists code(initfuncts)] || "${thisclass}_OO_Init" ni $code(initfuncts)} { - lappend code(initfuncts) "${thisclass}_OO_Init" - } - } - set thisnspace [my define get nspace] - - if {[info exists tclprocs]} { - ::practcl::debug [self] tclprocs [dict keys $tclprocs] - foreach {name info} $tclprocs { - if {![dict exists $info callproc]} { - set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} TclCmd_${thisnspace}_${name}]] - dict set tclprocs $name callproc $callproc - } else { - set callproc [dict get $info callproc] - } - 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\[\])" - } - } - } - ::practcl::debug [list /[self] [self method] [self class]] - } - - # Once an object marks itself as some - # flavor of dynamic, stop trying to morph - # it into something else - method select {} {} - - - 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 - } - lappend map @NAME@ $name - set info [dict get $tcltype $name] - foreach {f v} $info { - lappend map @[string toupper $f]@ $v - } - foreach {func fpat template} { - freeproc {@Name@Obj_freeIntRepProc} {void @FNAME@(Tcl_Obj *objPtr)} - dupproc {@Name@Obj_dupIntRepProc} {void @FNAME@(Tcl_Obj *srcPtr,Tcl_Obj *dupPtr)} - updatestringproc {@Name@Obj_updateStringRepProc} {void @FNAME@(Tcl_Obj *objPtr)} - setfromanyproc {@Name@Obj_setFromAnyProc} {int @FNAME@(Tcl_Interp *interp,Tcl_Obj *objPtr)} - } { - if {![dict exists $info $func]} { - error "$name does not define $func" - } - set body [dict get $info $func] - # 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 - } - } -} - -::oo::class create ::practcl::cheader { - superclass ::practcl::product - - method compile-products {} {} - method generate-cinit {} {} -} - -::oo::class create ::practcl::csource { - superclass ::practcl::product -} - -::oo::class create ::practcl::clibrary { - superclass ::practcl::product - - method linker-products {configdict} { - return [my define get filename] - } - -} - -### -# In the end, all C code must be loaded into a module -# This will either be a dynamically loaded library implementing -# a tcl extension, or a compiled in segment of a custom shell/app -### -::oo::class create ::practcl::module { - superclass ::practcl::dynamic - - method child which { - switch $which { - organs { - return [list project [my define get project] module [self]] - } - } - } - - 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 dirname $filename]] - } - if {[my define get localpath] eq {}} { - my define set localpath [my <project> define get name]_[my define get name] - } - ::practcl::debug [self] SOURCE $filename - my source $filename - } - - method implement path { - my go - my Collate_Source $path - foreach item [my link list dynamic] { - if {[catch {$item implement $path} err]} { - puts "Skipped $item: $err" - } - } - foreach item [my link list module] { - if {[catch {$item implement $path} err]} { - puts "Skipped $item: $err" - } - } - ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set filename [my define get output_c] - if {$filename eq {}} { - ::practcl::debug [list /[self] [self method] [self class]] - return - } - set cout [open [file join $path [file rootname $filename].c] w] - puts $cout [subst {/* -** This file is generated by the [info script] script -** 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} - } -} - -::oo::class create ::practcl::autoconf { - - ### - # find or fake a key/value list describing this project - ### - method config.sh {} { - my variable conf_result - if {[info exists conf_result]} { - return $conf_result - } - set result {} - set name [my define get name] - set PWD $::CWD - set builddir [my define get builddir] - my unpack - set srcdir [my define get srcdir] - if {![file exists $builddir]} { - my Configure - } - set filename [file join $builddir config.tcl] - # Project uses the practcl template. Use the leavings from autoconf - if {[file exists $filename]} { - set dat [::practcl::config.tcl $builddir] - foreach {item value} [::practcl::sort_dict $dat] { - dict set result $item $value - } - set conf_result $result - return $result - } - set filename [file join $builddir ${name}Config.sh] - if {[file exists $filename]} { - set l [expr {[string length $name]+1}] - foreach {field dat} [::practcl::read_Config.sh $filename] { - set field [string tolower $field] - if {[string match ${name}_* $field]} { - set field [string range $field $l end] - } - dict set result $field $dat - } - set conf_result $result - return $result - } - ### - # Oh man... we have to guess - ### - set filename [file join $builddir Makefile] - if {![file exists $filename]} { - error "Could not locate any configuration data in $srcdir" - } - foreach {field dat} [::practcl::read_Makefile $filename] { - dict set result $field $dat - } - set conf_result $result - cd $PWD - return $result - } -} - - -::oo::class create ::practcl::project { - superclass ::practcl::module ::practcl::autoconf - - constructor args { - my variable define - if {[llength $args] == 1} { - set rawcontents [lindex $args 0] - } else { - set rawcontents $args - } - if {[catch {uplevel 1 [list subst $rawcontents]} contents]} { - set contents $rawcontents - } - ### - # The first instance of ::practcl::project (or its descendents) - # registers itself as the ::practcl::MAIN. If a project other - # than ::practcl::LOCAL is created, odds are that was the one - # the developer intended to be the main project - ### - if {$::practcl::MAIN eq "::practcl::LOCAL"} { - set ::practcl::MAIN [self] - } - # DEFS fields need to be passed unchanged and unsubstituted - # as we need to preserve their escape characters - foreach field {TCL_DEFS DEFS TK_DEFS} { - if {[dict exists $rawcontents $field]} { - dict set contents $field [dict get $rawcontents $field] - } - } - array set define $contents - my select - my initialize - } - - method add_project {pkg info {oodefine {}}} { - set os [my define get TEACUP_OS] - if {$os eq {}} { - set os [::practcl::os] - my define set os $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 - # Select which tag to use here. - # For production builds: tag-release - set profile [my define get profile release]: - if {[dict exists $info profile $profile]} { - dict set info tag [dict get $info profile $profile] - } - if {[my define get USEMSVC 0]} { - dict set info USEMSVC 1 - } - set obj [namespace current]::PROJECT.$pkg - if {[info command $obj] eq {}} { - set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0 class subproject.binary] $info]] - } - my link object $obj - oo::objdefine $obj $oodefine - $obj define set masterpath $::CWD - $obj go - return $obj - } - - method add_tool {pkg info {oodefine {}}} { - 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 - # Select which tag to use here. - # For production builds: tag-release - set profile [my define get profile release]: - if {[dict exists $info profile $profile]} { - dict set info tag [dict get $info profile $profile] - } - set obj [namespace current]::TOOL.$pkg - if {[info command $obj] eq {}} { - set obj [::practcl::tool create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0] $info]] - } - my link object $obj - oo::objdefine $obj $oodefine - $obj define set masterpath $::CWD - $obj go - return $obj - } - - method child which { - switch $which { - 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 - } - - # Exercise the methods of a sub-object - method project {pkg args} { - set obj [namespace current]::PROJECT.$pkg - if {[llength $args]==0} { - return $obj - } - ${obj} {*}$args - } - - method select {} { - next - ### - # Select the toolset to use for this project - ### - my variable define - set class {} - if {[info exists define(toolset)]} { - if {[info command $define(toolset)] ne {}} { - set class $define(toolset) - } elseif {[info command ::practcl::$define(toolset)] ne {}} { - set class ::practcl::$define(toolset) - } else { - switch $define(toolset) { - default { - set class ::practcl::build.gcc - } - } - } - } else { - if {[info exists ::env(VisualStudioVersion)]} { - set class ::practcl::build.msvc - } else { - set class ::practcl::build.gcc - } - } - ::oo::objdefine [self] mixin $class - } - - method tool {pkg args} { - set obj [namespace current]::TOOL.$pkg - if {[llength $args]==0} { - return $obj - } - ${obj} {*}$args - } -} - -::oo::class create ::practcl::library { - superclass ::practcl::project - - method compile-products {} { - set result {} - foreach item [my link list subordinate] { - lappend result {*}[$item compile-products] - } - set filename [my define get output_c] - if {$filename ne {}} { - set ofile [file rootname [file tail $filename]]_main.o - lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] - } - return $result - } - - 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] - ::practcl::cputs result [string map \ - [list @LIBFILE@ $LIBFILE @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { -# Shared Library Style -load [file join [file dirname [file join [pwd] [info script]]] @LIBFILE@] @PKGINIT@ -package provide @PKG_NAME@ @PKG_VERSION@ -}] - } else { - ::practcl::cputs result [string map \ - [list @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { -# Tclkit Style -load {} @PKGINIT@ -package provide @PKG_NAME@ @PKG_VERSION@ -}] - } - 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 - } - if {[my define get tk] eq {@TEA_TK_EXTENSION@}} { - my define set tk 0 - } - set output_c [my define getnull output_c] - if {$output_c eq {}} { - set output_c [file rootname $name].c - my define set output_c $output_c - } - set output_h [my define getnull output_h] - if {$output_h eq {}} { - set output_h [file rootname $output_c].h - my define set output_h $output_h - } - set output_tcl [my define getnull output_tcl] - #if {$output_tcl eq {}} { - # set output_tcl [file rootname $output_c].tcl - # my define set output_tcl $output_tcl - #} - #set output_mk [my define getnull output_mk] - #if {$output_mk eq {}} { - # set output_mk [file rootname $output_c].mk - # my define set output_mk $output_mk - #} - set initfunc [my define getnull initfunc] - if {$initfunc eq {}} { - set initfunc [string totitle $name]_Init - my define set initfunc $initfunc - } - set output_decls [my define getnull output_decls] - if {$output_decls eq {}} { - set output_decls [file rootname $output_c].decls - my define set output_decls $output_decls - } - my variable links - 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 implement path { - my go - my Collate_Source $path - foreach item [my link list dynamic] { - if {[catch {$item implement $path} err]} { - puts "Skipped $item: $err" - } - } - foreach item [my link list module] { - if {[catch {$item implement $path} err]} { - puts "Skipped $item: $err" - } - } - set cout [open [file join $path [my define get output_c]] w] - puts $cout [subst {/* -** This file is generated by the [info script] script -** any changes will be overwritten the next time it is run -*/}] - puts $cout [my generate-c] - puts $cout [my generate-loader] - close $cout - - set macro HAVE_[string toupper [file rootname [my define get output_h]]]_H - set hout [open [file join $path [my define get output_h]] w] - puts $hout [subst {/* -** This file is generated by the [info script] script -** any changes will be overwritten the next time it is run -*/}] - puts $hout "#ifndef ${macro}" - puts $hout "#define ${macro}" - puts $hout [my generate-h] - puts $hout "#endif" - close $hout - - set output_tcl [my define get output_tcl] - if {$output_tcl ne {}} { - set tclout [open [file join $path [my define get output_tcl]] w] - puts $tclout "### -# This file is generated by the [info script] script -# any changes will be overwritten the next time it is run -###" - puts $tclout [my generate-tcl-pre] - puts $tclout [my generate-tcl-loader] - puts $tclout [my generate-tcl-post] - close $tclout - } - } - - 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 - ### - set fout [open $outfile w] - puts $fout [subst {### - # $outfile - # - # This file was generated by [info script] - ### - - library $pkgname - interface $pkgname - }] - - ### - # Generate list of functions - ### - set stubfuncts [my generate-stub-function] - set thisline {} - set functcount 0 - foreach {func header} $stubfuncts { - puts $fout [list declare [incr functcount] $header] - } - puts $fout [list export "int [my define get initfunc](Tcl_Inter *interp)"] - puts $fout [list export "char *[string totitle [my define get name]]_InitStubs(Tcl_Inter *interp, char *version, int exact)"] - - close $fout - - ### - # Build [package]Decls.h - ### - set hout [open [file join $path ${pkgname}Decls.h] w] - - close $hout - - set cout [open [file join $path ${pkgname}StubInit.c] w] -puts $cout [string map [list %pkgname% $pkgname %PkgName% [string totitle $pkgname]] { -#ifndef USE_TCL_STUBS -#define USE_TCL_STUBS -#endif -#undef USE_TCL_STUB_PROCS - -#include "tcl.h" -#include "%pkgname%.h" - - /* - ** Ensure that Tdom_InitStubs is built as an exported symbol. The other stub - ** functions should be built as non-exported symbols. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT - -%PkgName%Stubs *%pkgname%StubsPtr; - - /* - **---------------------------------------------------------------------- - ** - ** %PkgName%_InitStubs -- - ** - ** Checks that the correct version of %PkgName% is loaded and that it - ** supports stubs. It then initialises the stub table pointers. - ** - ** Results: - ** The actual version of %PkgName% that satisfies the request, or - ** NULL to indicate that an error occurred. - ** - ** Side effects: - ** Sets the stub table pointers. - ** - **---------------------------------------------------------------------- - */ - -char * -%PkgName%_InitStubs (Tcl_Interp *interp, char *version, int exact) -{ - char *actualVersion; - actualVersion = Tcl_PkgRequireEx(interp, "%pkgname%", version, exact,(ClientData *) &%pkgname%StubsPtr); - if (!actualVersion) { - return NULL; - } - if (!%pkgname%StubsPtr) { - Tcl_SetResult(interp,"This implementation of %PkgName% does not support stubs",TCL_STATIC); - return NULL; - } - return actualVersion; -} -}] - close $cout - } - - # Backward compadible call - method generate-make path { - my build-Makefile $path [self] - } - - method install-headers {} { - set result {} - return $result - } - - method linktype {} { - return library - } - - # Create a "package ifneeded" - # Args are a list of aliases for which this package will answer to - 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 - } - set output_tcl [my define get output_tcl] - if {$output_tcl ne {}} { - set script "\[list source \[file join \$dir $output_tcl\]\]" - } elseif {[string is true -strict [my define get SHARED_BUILD]]} { - set script "\[list load \[file join \$dir [my define get libfile]\] $name\]" - } else { - # Provide a null passthrough - set script "\[list package provide $name $version\]" - } - 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 {} { - 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 - } -} - -::oo::class create ::practcl::tclkit { - superclass ::practcl::library - - method Collate_Source CWD { - set name [my define get name] - # Assume a static shell - if {[my define exists SHARED_BUILD]} { - my define exists SHARED_BUILD 0 - } - if {![my define exists TCL_LOCAL_APPINIT]} { - my define set TCL_LOCAL_APPINIT Tclkit_AppInit - } - if {![my define exists TCL_LOCAL_MAIN_HOOK]} { - my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook - } - set PROJECT [self] - set os [$PROJECT define get TEACUP_OS] - if {[my define get SHARED_BUILD]} { - puts [list BUILDING TCLSH FOR OS $os] - } else { - puts [list BUILDING KIT FOR OS $os] - } - set TCLOBJ [$PROJECT project TCLCORE] - set TCLSRCDIR [$TCLOBJ define get srcdir] - set PKG_OBJS {} - foreach item [$PROJECT link list core.library] { - if {[string is true [$item define get static]]} { - lappend PKG_OBJS $item - } - } - foreach item [$PROJECT link list package] { - if {[string is true [$item define get static]]} { - lappend PKG_OBJS $item - } - } - # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK - if {$os eq "windows"} { - set PLATFORM_SRC_DIR win - if {[my define get SHARED_BUILD]} { - my add class csource filename [file join $TCLSRCDIR win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.1 autoload 1 - my add class csource filename [file join $TCLSRCDIR win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 autoload 1 - } - my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] - } else { - set PLATFORM_SRC_DIR unix - my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] - } - - if {[my define get SHARED_BUILD]} { - ### - # Add local static Zlib implementation - ### - set cdir [file join $TCLSRCDIR compat zlib] - foreach file { - adler32.c compress.c crc32.c - deflate.c infback.c inffast.c - inflate.c inftrees.c trees.c - uncompr.c zutil.c - } { - my add [file join $cdir $file] - } - } - ### - # Pre 8.7, Tcl doesn't include a Zipfs implementation - # in the core. Grab the one from odielib - ### - set zipfs [file join $TCLSRCDIR generic tclZipfs.c] - if {![$PROJECT define exists ZIPFS_VOLUME]} { - $PROJECT define set ZIPFS_VOLUME "//zipfs:/" - } - $PROJECT code header "#define ZIPFS_VOLUME \"[$PROJECT define get ZIPFS_VOLUME]\"" - if {[file exists $zipfs]} { - $TCLOBJ define set tip_430 1 - my define set tip_430 1 - } else { - # The Tclconfig project maintains a mirror of the version - # released with the Tcl core - my define set tip_430 0 - ::practcl::LOCAL tool odie load - set COMPATSRCROOT [::practcl::LOCAL tool odie define get srcdir] - set cdir [file join $COMPATSRCROOT compat zipfs] - my define add include_dir $cdir - set zipfs [file join $cdir tclZipfs.c] - my add class csource filename $zipfs initfunc Tclzipfs_Init pkg_name zipfs pkg_vers 1.1 autoload 1 extra "-DZIPFS_VOLUME=\"[$PROJECT define get ZIPFS_VOLUME]\"" - } - - 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 - } - - ## Wrap an executable - # - 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] - set libsrcdir [$item define get srcdir] - if {[file exists [file join $libsrcdir library]]} { - ::practcl::copyDir [file join $libsrcdir library] [file join $vfspath boot $name] - } - } - # Assume the user will populate the VFS path - #if {[my define get installdir] ne {}} { - # ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib] - #} - foreach arg $args { - ::practcl::copyDir $arg $vfspath - } - - set fout [open [file join $vfspath packages.tcl] w] - puts $fout { - set ::PKGIDXFILE [info script] - set dir [file dirname $::PKGIDXFILE] - } - #set BASEVFS [my define get BASEVFS] - set EXEEXT [my define get EXEEXT] - - set tclkit_bare [my define get tclkit_bare] - - set buffer [::practcl::pkgindex_path $vfspath] - puts $fout $buffer - puts $fout { - # Advertise statically linked packages - foreach {pkg script} [array get ::kitpkg] { - eval $script - } - } - close $fout - ::practcl::mkzip ${exename}${EXEEXT} $tclkit_bare $vfspath - if { [my define get TEACUP_OS] ne "windows" } { - file attributes ${exename}${EXEEXT} -permissions a+x - } - } -} - -### -# Standalone class to manage code distribution -# This class is intended to be mixed into another class -# (Thus the lack of ancestors) -### -oo::class create ::practcl::distribution { - - 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 .. $pkg]] - 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 ScmSelect {} { - if {[my define exists scm]} { - return [my define get scm] - } - set srcdir [my SrcDir] - set classprefix ::practcl::distribution. - if {[file exists $srcdir]} { - foreach class [::info commands ${classprefix}*] { - if {[$class claim_path $srcdir]} { - oo::objdefine [self] mixin $class - my define set scm [string range $class [string length ::practcl::distribution.] end] - } - } - } - foreach class [::info commands ${classprefix}*] { - if {[$class claim_object [self]]} { - oo::objdefine [self] mixin $class - my define set scm [string range $class [string length ::practcl::distribution.] end] - } - } - if {[my define get scm] eq {} && [my define exists file_url]} { - set class - } - - if {[my define get scm] eq {}} { - error "No SCM selected" - } - return [my define get scm] - } - - method ScmTag {} {} - method ScmClone {} {} - method ScmUnpack {} {} - method ScmUpdate {} {} - - method unpack {} { - my ScmSelect - 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 - } - - method update {} { - my ScmSelect - my ScmUpdate - } -} - -oo::objdefine ::practcl::distribution { - method claim_path path { - return false - } - method claim_object object { - return false - } -} - -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] - set fname [file tail $url] - set archive [file join $dpath $fname] - if {![file exists $archive]} { - ::http::wget $url $archive - } - set CWD [pwd] - switch [file extension $fname] { - .zip { - # Zipfile - - } - .tar { - ::practcl::tcllib_require tar - } - .tgz - - .gz { - # Tarball - ::practcl::tcllib_require tcl::transform::zlib - ::practcl::tcllib_require tar - set fh [::open $archive] - fconfigure $fh -encoding binary -translation lf -eofchar {} - ::tcl::transform::zlib $fh - } - } - 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 - } -} - - -oo::class create ::practcl::distribution.fossil { - superclass ::practcl::distribution - - # Clone the source - method ScmClone {} { - set srcdir [my SrcDir] - if {[file exists [file join $srcdir .fslckout]]} { - return - } - if {[file exists [file join $srcdir _FOSSIL_]]} { - return - } - if {![::info exists ::practcl::fossil_dbs]} { - # Get a list of local fossil databases - set ::practcl::fossil_dbs [exec fossil all list] - } - set pkg [my define get name] - # Return an already downloaded fossil repo - foreach line [split $::practcl::fossil_dbs \n] { - set line [string trim $line] - if {[file rootname [file tail $line]] eq $pkg} { - return $line - } - } - set download [::practcl::LOCAL define get download] - set fosdb [file join $download $pkg.fos] - if {[file exists $fosdb]} { - return $fosdb - } - - file mkdir [file join $download fossil] - set fosdb [file join $download fossil $pkg.fos] - if {[file exists $fosdb]} { - return $fosdb - } - - set cloned 0 - # Attempt to clone from a local network mirror - if {[::practcl::LOCAL define exists fossil_mirror]} { - set localmirror [::practcl::LOCAL define get fossil_mirror] - catch { - ::practcl::doexec fossil clone $localmirror/$pkg $fosdb - set cloned 1 - } - if {$cloned} { - return $fosdb - } - } - # Attempt to clone from the canonical source - if {[my define get fossil_url] ne {}} { - catch { - ::practcl::doexec fossil clone [my define get fossil_url] $fosdb - set cloned 1 - } - if {$cloned} { - 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 - } - if {[file exists [file join $path _FOSSIL_]]} { - return true - } - return false - } - - # Check for markers in the metadata - method claim_object obj { - set path [$obj define get srcdir] - if {[my claim_path $path]} { - return true - } - if {[$obj define get fossil_url] ne {}} { - return true - } - return false - } -} - -oo::class create ::practcl::distribution.git { - - 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 srcdir [my SrcDir] - set tag [my ScmTag] - ::practcl::doexec_in $srcdir git pull $tag - cd $CWD - } - -} -oo::objdefine ::practcl::distribution.git { - method claim_path path { - if {[file exists [file join $path .git]]} { - return true - } - return false - } - method claim_object obj { - set path [$obj define get srcdir] - if {[my claim_path $path]} { - return true - } - if {[$obj define get git_url] ne {}} { - return true - } - return false - } -} - -### -# Meta repository -# The default is an inert source code block -### -oo::class create ::practcl::subproject { - superclass ::practcl::object ::practcl::distribution - - method compile {} {} - - method critcl args { - if {![info exists critcl]} { - ::pratcl::LOCAL tool critcl load - set critcl [file join [::pratcl::LOCAL tool critcl define get srcdir] main.tcl - } - set srcdir [my SourceRoot] - set PWD [pwd] - cd $srcdir - ::pratcl::dotclexec $critcl {*}$args - cd $PWD - } - - method go {} { - set name [my define get name] - set srcdir [my SrcDir] - my define set localsrcdir $srcdir - my define add include_dir [file join $srcdir generic] - my sources - } - - # Install project into the local build system - 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] - } - } - - method sources {} {} -} - -### -# A project which the kit compiles and integrates -# the source for itself -### -oo::class create ::practcl::subproject.source { - superclass ::practcl::subproject ::practcl::library - - method linktype {} { - return {subordinate package source} - } - -} - -# a copy from the teapot -oo::class create ::practcl::subproject.teapot { - superclass ::practcl::subproject - - method install-local {} { - my install-vfs - } - - 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 install-local {} { - my install-vfs - } - - method kettle {path args} { - my variable kettle - if {![info exists kettle]} { - ::pratcl::LOCAL tool kettle load - set kettle [file join [::pratcl::LOCAL tool kettle define get srcdir] kettle] - } - set srcdir [my SourceRoot] - ::pratcl::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-local {} { - my install-vfs - } - - method install DEST { - my critcl -pkg [my define get name] - set srcdir [my SourceRoot] - ::pratcl::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 install-local {} { - my install-vfs - } - - 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 - } -} - -### -# A binary package -### -oo::class create ::practcl::subproject.binary { - superclass ::practcl::subproject ::practcl::autoconf - - method compile-products {} {} - - 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 { - set PREFIX [my <project> define get prefix] - } - if {[my <project> define get CONFIG_SITE] != {}} { - lappend opts --host=[my <project> define get HOST] - lappend opts --with-tclsh=[info nameofexecutable] - } - if {[my <project> define exists tclsrcdir]} { - ### - # On Windows we are probably running under MSYS, which doesn't deal with - # spaces in filename well - ### - set TCLSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir]]]] - set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] .. generic]]] - lappend opts --with-tcl=$TCLSRCDIR --with-tclinclude=$TCLGENERIC - } - if {[my <project> define exists tksrcdir]} { - set TKSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir]]]] - set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] .. generic]]] - lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC - } - lappend opts {*}[my define get config_opts] - if {![regexp -- "--prefix" $opts]} { - lappend opts --prefix=$PREFIX - } - #--exec_prefix=$PREFIX - #if {$::tcl_platform(platform) eq "windows"} { - # lappend opts --disable-64bit - #} - if {[my define get static 1]} { - lappend opts --disable-shared --disable-stubs - # - } else { - lappend opts --enable-shared - } - return $opts - } - - method ComputeInstall {} { - if {[my define exists install]} { - switch [my define get install] { - static { - my define set static 1 - my define set autoload 0 - } - static-autoload { - my define set static 1 - my define set autoload 1 - } - vfs { - my define set static 0 - my define set autoload 0 - my define set vfsinstall 1 - } - null { - my define set static 0 - my define set autoload 0 - my define set vfsinstall 0 - } - default { - - } - } - } - } - - method go {} { - next - 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 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] - if {$initfunc ne {}} { - set pkg_name [my define get pkg_name] - if {$pkg_name ne {}} { - dict set result $pkg_name initfunc $initfunc - set version [my define get version] - if {$version eq {}} { - set info [my config.sh] - set version [dict get $info version] - set pl {} - if {[dict exists $info patch_level]} { - set pl [dict get $info patch_level] - append version $pl - } - my define set version $version - } - dict set result $pkg_name version $version - dict set result $pkg_name autoload [my define get autoload 0] - } - } - foreach item [my link list subordinate] { - foreach {pkg info} [$item static-packages] { - dict set result $pkg $info - } - } - return $result - } - - method BuildDir {PWD} { - set name [my define get name] - 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]] - my Collate_Source $PWD - - ### - # Build a starter VFS for both Tcl and wish - ### - set srcdir [my define get srcdir] - if {[my define get static 1]} { - puts "BUILDING Static $name $srcdir" - } else { - puts "BUILDING Dynamic $name $srcdir" - } - if {[my define get USEMSVC 0]} { - cd $srcdir - ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] release - } else { - cd $::CWD - set builddir [file normalize [my define get builddir]] - file mkdir $builddir - if {![file exists [file join $builddir Makefile]]} { - my Configure - } - if {[file exists [file join $builddir make.tcl]]} { - ::practcl::domake.tcl $builddir library - } else { - ::practcl::domake $builddir all - } - } - cd $PWD - } - - method Configure {} { - cd $::CWD - my unpack - set srcdir [file normalize [my define get srcdir]] - set builddir [file normalize [my define get builddir]] - file mkdir $builddir - if {[my define get USEMSVC 0]} { - return - } - if {[file exists [file join $builddir practcl.log]]} { - file delete [file join $builddir practcl.log] - } - if {![file exists [file join $srcdir configure]]} { - if {[file exists [file join $srcdir autogen.sh]]} { - cd $srcdir - catch {exec sh autogen.sh >>& [file join $builddir practcl.log]} - cd $::CWD - } - } - if {![file exists [file join $srcdir tclconfig install-sh]]} { - # ensure we have tclconfig with all of the trimmings - set teapath {} - if {[file exists [file join $srcdir .. tclconfig install-sh]]} { - set teapath [file join $srcdir .. tclconfig] - } else { - set tclConfigObj [::practcl::LOCAL tool tclconfig] - $tclConfigObj load - set teapath [$tclConfigObj define get srcdir] - } - set teapath [file normalize $teapath] - #file mkdir [file join $srcdir tclconfig] - if {[catch {file link -symbolic [file join $srcdir tclconfig] $teapath}]} { - ::practcl::copyDir [file join $teapath] [file join $srcdir tclconfig] - } - } - - set opts [my ConfigureOpts] - puts [list PKG [my define get name] CONFIGURE {*}$opts] - 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 $srcdir configure] {*}$opts >>& [file join $builddir practcl.log]} - cd $::CWD - } - - 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]] - if {[my <project> define get teapot] ne {}} { - set TEAPOT [my <project> define get teapot] - set found 0 - foreach ver [my define get pkg_vers [my define get version]] { - set teapath [file join $TEAPOT $pkg$ver] - if {[file exists $teapath]} { - set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]] - ::practcl::copyDir $teapath $dest - return - } - } - } - my compile - if {[my define get USEMSVC 0]} { - set srcdir [my define get srcdir] - cd $srcdir - puts "[self] VFS INSTALL $DEST" - ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST install - } else { - set builddir [my define get builddir] - if {[file exists [file join $builddir make.tcl]]} { - # Practcl builds can inject right to where we need them - puts "[self] VFS INSTALL $DEST (Practcl)" - ::practcl::domake.tcl $builddir install-package $DEST - } elseif {[my define get broken_destroot 0] == 0} { - # Most modern TEA projects understand DESTROOT in the makefile - puts "[self] VFS INSTALL $DEST (TEA)" - ::practcl::domake $builddir install DESTDIR=$DEST - } else { - # But some require us to do an install into a fictitious filesystem - # and then extract the gooey parts within. - # (*cough*) TkImg - set PREFIX [my <project> define get prefix] - set BROKENROOT [::practcl::msys_to_tclpath [my <project> define get prefix_broken_destdir]] - file delete -force $BROKENROOT - file mkdir $BROKENROOT - ::practcl::domake $builddir $install - ::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]] - file delete -force $BROKENROOT - } - } - cd $PWD - } - - 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 - } -} - -# An external library -oo::class create ::practcl::subproject.external { - superclass ::practcl::subproject.binary - method install DEST { - my compile - } -} - -oo::class create ::practcl::subproject.core { - superclass ::practcl::subproject.binary - - # On the windows platform MinGW must build - # from the platform directory in the source repo - method BuildDir {PWD} { - return [my define get localsrcdir] - } - - method Configure {} { - if {[my define get USEMSVC 0]} { - return - } - set opts [my ConfigureOpts] - set builddir [file normalize [my define get builddir]] - set localsrcdir [file normalize [my define get localsrcdir]] - puts [list PKG [my define get name] CONFIGURE {*}$opts] - cd $localsrcdir - 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 practcl.log]} - } - - method ConfigureOpts {} { - set opts {} - set builddir [file normalize [my define get builddir]] - set PREFIX [my <project> define get prefix] - if {[my <project> define get CONFIG_SITE] != {}} { - lappend opts --host=[my <project> define get HOST] - lappend opts --with-tclsh=[info nameofexecutable] - } - lappend opts {*}[my define get config_opts] - if {![regexp -- "--prefix" $opts]} { - lappend opts --prefix=$PREFIX - } - #--exec_prefix=$PREFIX - lappend opts --disable-shared - return $opts - } - - method go {} { - set name [my define get name] - set os [my <project> define get TEACUP_OS] - my ComputeInstall - set srcdir [my SrcDir] - my define add include_dir [file join $srcdir generic] - switch $os { - windows { - my define set localsrcdir [file join $srcdir win] - my define add include_dir [file join $srcdir win] - } - default { - my define set localsrcdir [file join $srcdir unix] - my define add include_dir [file join $srcdir $name unix] - } - } - my define set builddir [my BuildDir [my define get masterpath]] - } - - method linktype {} { - return {subordinate core.library} - } -} - - -### -# Classes to manage tools that needed in the local environment -# to compile and/or installed other packages -### -oo::class create ::practcl::tool { - superclass ::practcl::object ::practcl::distribution - - method critcl args { - if {![info exists critcl]} { - ::pratcl::LOCAL tool critcl load - set critcl [file join [::pratcl::LOCAL tool critcl define get srcdir] main.tcl - } - set srcdir [my SourceRoot] - set PWD [pwd] - cd $srcdir - ::pratcl::dotclexec $critcl {*}$args - cd $PWD - } - - method SourceRoot {} { - set info [my define dump] - set result $info - if {![my define exists srcdir]} { - if {[dict exists $info srcdir]} { - set srcdir [dict get $info srcdir] - } elseif {[dict exists $info sandbox]} { - set srcdir [file join [dict get $info sandbox] $pkg] - } else { - set srcdir [file join $::CWD .. $pkg] - } - dict set result srcdir $srcdir - my define set srcdir $srcdir - } - return [my define get srcdir] - } - - method linktype {} { - return tool - } - - # Return boolean if present - method present {} { - return 1 - } - - # Procedure to install in the local environment - method install {} { - my unpack - } - - # Procedure to load into the local interpreter - method load {} { - my variable loaded - if {[info exists loaded]} { - return 0 - } - if {![my present]} { - my install - } - my LocalLoad - set loaded 1 - } - - method LocalLoad {} {} -} - -oo::class create ::practcl::tool.source { - superclass ::practcl::tool - - method present {} { - return [file exists [my define get srcdir]] - } - - method toplevel_script {} { - my load - return [file join [my SourceRoot] [my define get toplevel_script]] - } - - method LocalLoad {} { - 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] - } - } -} - -### -# Create an object to represent the local environment -### -set ::practcl::MAIN ::practcl::LOCAL -# Defer the creation of the ::pratcl::LOCAL object until it is called -# in order to allow packages to -set ::auto_index(::practcl::LOCAL) { - puts "Building LOCAL" - ::practcl::project create ::practcl::LOCAL - ::practcl::LOCAL define set [::practcl::local_os] - # Until something better comes along, use ::practcl::LOCAL - # as our main project - # Add tclconfig as a project of record - ::practcl::LOCAL add_tool tclconfig { - tag trunk class tool.source fossil_url http://core.tcl.tk/tclconfig - } - # Add tcllib as a project of record - ::practcl::LOCAL add_tool tcllib { - tag trunk class tool.source fossil_url http://core.tcl.tk/tcllib - } - ::practcl::LOCAL add_tool kettle { - tag trunk class tool.source fossil_url http://fossil.etoyoc.com/fossil/kettle - } - ::practcl::LOCAL add_tool critcl { - tag trunk class tool.source - git_url http://github.com/andreas-kupries/critcl - } - ::practcl::LOCAL add_tool odie { - tag trunk class tool.source - fossil_url http://fossil.etoyoc.com/fossil/odie - } -} -package provide practcl 0.8a1 |