Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Difference From 5eb576fc2d423f1d To 42e1f63ae401c9ea
|
2019-06-29
| ||
| 11:21 | Pulling in changes from yggdrasil branch check-in: 8c1eac0227 user: hypnotoad tags: trunk | |
|
2019-06-27
| ||
| 19:02 | Change in the clay-tk contact. Instead of declaring a tk path on object creation, Tk path is now given to a tkrender method which generates an ephermeral GUI while the object remains intact check-in: 1ae1cac113 user: hypnotoad tags: yggdrasil | |
| 09:56 | Cleanups from testing check-in: 42e1f63ae4 user: hypnotoad tags: yggdrasil | |
| 09:30 | Experimental branch to consolidata all of the tree-like interactions under the aegis of a new framework class "yggdrasil". Yggdrasil provides common access methods for links and children. It also provides option handling adapted from Tool. At the same time, each node in the yggdrasil also has parameters in parallel from a content style sheet. Adapted practcl to use the infrastructure of Yggdrasil rather than invent its own. Yggdrasil largely stole the link functions from Practcl, but what is "define" in practcl is really "config" in Yggdrail, so a shim is provided for already implemented practcl build systems. Cunieform has been adapted to use the new Yggdrasil infrastructure. Calls to the old xml/html method are now sent to "config". The css portion of Yggdrasil was largely stolen from cuneiform, so not changes there. Cuneiform tk is eventually going to be folded into the cuneiform-tk megawidget system because 99% of what it needed out of cuneiform was the option handling and tree functions which it no longer needs cuneform for check-in: 6d7b608d54 user: hypnotoad tags: yggdrasil | |
|
2019-06-26
| ||
| 21:13 | Adding a new Tk gui builder component to cuneiform Reformed how objects are cleaned up on cuneiform. Instead of an imperitive when the xml render is performed, objects are now cleaned up when the master objects starts a new document or if the master document is destroyed. subobject destruction still uses the refcounting mechanism from clay Added xml and html tests ,as well as a demo script for the new tk things check-in: 5eb576fc2d user: hypnotoad tags: trunk | |
| 20:22 | Fixing a bug in ::clay::cleanup that was blanking the list at the end of a process that cascading destroys could very well append to. check-in: e41d5380a9 user: hypnotoad tags: trunk | |
Changes to cmodules/kitcrypt.tcl.
1 2 3 4 5 | ## # Implementation of an rc4 codec for TCL, adapted for # source code encryption/decryption system ### set here [file dirname [info script]] | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
##
# Implementation of an rc4 codec for TCL, adapted for
# source code encryption/decryption system
###
set here [file dirname [info script]]
my Config_set pkg_name kitcrypt
my Config_set pkg_vers 1.0
my Config_set initfunc KitCrypt_Init
my Config_set output_c kitcrypt.c
my Config_set autoload 1
my Config_set static 1
my include {<stdio.h>}
my include {<string.h>}
my include {<stdlib.h>}
my include {<tcl.h>}
# Retrieve or generate a hard coded password for the crypt_eval function
# We write the code here so that a DLL and an EXE built from the same source
# checkout will have the same internal password
set pwdfile [file join [my Config_get builddir] password.txt]
if {![file exists $pwdfile]} {
set charset {*+-.0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_}
set maxpos [string length $charset]
set keylen [expr 8 + int(8 * rand())]
set curpwd {}
for {set idx 0} {$idx < $keylen} {incr idx} {
append curpwd [string index $charset [expr int($maxpos * rand())]]
|
| ︙ | ︙ |
Changes to example/gilgamesh/class/avatar.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
::clay::define ::gilgamesh::html {
superclass ::cuneiform::html ::cuneiform::element
constructor {} {
my variable html css
set html {}
set css {}
my cuneiform_structure
}
method cuneiform_structure {} {
my clay delegate <head> [my Tag head]
my clay delegate <title> [my <head> tag title]
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
::clay::define ::gilgamesh::html {
superclass ::cuneiform::html ::cuneiform::element
constructor {} {
my variable html css
set html {}
set css {}
my cuneiform_structure
}
method cuneiform_structure {} {
my clay delegate <head> [my Tag head]
my clay delegate <title> [my <head> tag title]
my <head> tag meta charset [my config get charset]
my clay delegate <stylesheet> [my <head> tag link rel stylesheet type text/css href /style.css]
set sheethref [my config get stylesheet]
if {$sheethref ne {}} {
my <stylesheet> html set href $sheethref
}
set styleobj [my <head> tag style]
my clay delegate <style> $styleobj
my clay delegate <style:screen> $styleobj
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
width 1000px
overflow-y auto
height 600px
}]
my clay delegate <bottom> [$bodyobj tag div id bottom]
my clay delegate <footer> [$bodyobj tag footer id footer]
| | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
width 1000px
overflow-y auto
height 600px
}]
my clay delegate <bottom> [$bodyobj tag div id bottom]
my clay delegate <footer> [$bodyobj tag footer id footer]
my <title> content [my config get title]
}
}
::clay::define ::gilgamesh::core/avatar {
superclass ::gilgamesh::core/actor
|
| ︙ | ︙ |
Changes to make.tcl.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
source [file join $::main::DIR scripts practcl.tcl]
set ::SRCDIR $::main::DIR
::practcl::library create PROJECT {
name clay
version 0.1
}
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
source [file join $::main::DIR scripts practcl.tcl]
set ::SRCDIR $::main::DIR
::practcl::library create PROJECT {
name clay
version 0.1
}
[::practcl::LOCAL tool tcllib] config set tag hypnotoad
::practcl::LOCAL add_tool clay {
tag trunk
class subproject.sak
install vfs
fossil_url http://fossil.etoyoc.com/clay
}
::practcl::LOCAL add_tool thread {
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
cmdline csv coroutine cron devtools dns
sha1 uri
}
} {
set obj [::practcl::LOCAL tool $project]
$obj unpack
$obj update
| | | | | | | | | | | | | | | | | | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
cmdline csv coroutine cron devtools dns
sha1 uri
}
} {
set obj [::practcl::LOCAL tool $project]
$obj unpack
$obj update
set lsrcdir [$obj config get srcdir]
foreach module $modules {
installModule [file join $lsrcdir modules $module] $DEST
}
}
}
claykit {
set dat [::practcl::config.tcl $CWD]
set object TCLKIT
::practcl::tclkit create $object $dat
$object config set name claykit
$object config set sandbox $::SANDBOX
$object config set srcdir $::SRCDIR
$object source [file join $::SRCDIR claykit.ini]
set INSTALLDIR [$object config get installdir]
if {![file exists [$object config get tclkit_bare]]} {
$object build-tclcore
$object implement $CWD
foreach item [$object link list package] {
if {![string is true [$item config get static 0]]} continue
puts [list GENERATING $item [$item config get srcdir]]
$item compile
}
$object build-tclsh [$object config get tclkit_bare] $object
}
set VFS [file join $CWD [$object config get vfs]]
file mkdir $VFS
foreach item [$object link list package] {
set modlist [$item config get module_list]
puts [list PACKAGE INSTALL [$item config get name] MODLIST $modlist]
if {[llength $modlist]} {
if {[catch {$item install-module [file join ${VFS} modules] {*}$modlist} error errdat]} {
puts stderr "BUILD FAILURE $item"
puts "FAILED TO INSTALL package $item"
puts [dict get $errdat -errorinfo]
exit 1
}
} elseif {[string is true [$item config get vfsinstall 1]]} {
puts [list GENERATING $item [$item config get srcdir]]
if {[catch {$item install $INSTALLDIR} error errdat]} {
puts stderr "BUILD FAILURE $item"
puts "FAILED TO INSTALL package $item"
puts [dict get $errdat -errorinfo]
exit 1
}
}
}
# Copy in our "secret squirrel" code
#set SCMCOPY [list ::exec [WISHKIT config get tclkit_bare] [file join $::SRCDIR scripts scm-copy.tcl]]
#set SCMCOPY ::practcl::copyDir
#{*}$SCMCOPY [file join $::SRCDIR src] ${VFS}
if {[$object config get debug 0]} {
$object wrap $CWD [$object config get exe] $VFS [file join $CWD PKGROOT]
} else {
$object wrap $CWD [$object config get exe] $VFS [file join $CWD PKGROOT]
}
}
modules {
set modules [modules]
puts $modules
exit 0
#return $result
|
| ︙ | ︙ |
Changes to modules/clay-tk-console/build/core.tcl.
1 2 3 4 5 6 7 8 9 10 |
package require clay-tk
###
# Implement a interactive command line for Tcl. This class
# contains the common plumbing for several languages.
###
namespace eval ::clay::tk::console {}
::clay::define ::clay::tk::hull.console {
Variable ismain 0
| | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
package require clay-tk
###
# Implement a interactive command line for Tcl. This class
# contains the common plumbing for several languages.
###
namespace eval ::clay::tk::console {}
::clay::define ::clay::tk::hull.console {
Variable ismain 0
Option language {
default tcl
class mixin
pattern ::clay::tk::console
}
Option title {
default {}
}
Option prompt {
default {tcl% }
}
set has_consolas [expr {"Consolas" in [font families]}]
if {$has_consolas} {
set font {Consolas 10}
switch $::clay::tk::platform {
macosx {
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
set font {system 10}
}
windows {
set font {systemfixed 9}
}
}
}
| | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
set font {system 10}
}
windows {
set font {systemfixed 9}
}
}
}
Option font [list \
widget font \
description {Font used on console widgets} \
default $font ]
clay set signal focus {
follows *
action {focus [my clay delegate text]}
|
| ︙ | ︙ |
Changes to modules/clay-tk-console/build/sqlshell.tcl.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
}
}
###
# Implement an interactive command line interface to an Sqlite database
###
::clay::define ::clay::tk::console::language.sqlite {
| | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
}
}
###
# Implement an interactive command line interface to an Sqlite database
###
::clay::define ::clay::tk::console::language.sqlite {
Option db {class organ}
Option prompt {default {sqlite-> }}
Option title {default {SQLite Console}}
Option header {datatype boolean default 1}
Option mode {widget select default column values {line list column csv multicolumn}}
###
# topic: 43e235cf3b612e95c590e5de400d4bcc39d622a4
# description:
# Execute a single SQL command. Pay special attention to control
# directives that begin with "."
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
set header [my Config_get header]
if {[regexp {^(\.[a-z]+)} $cmd all word]} {
if {$word==".tcl"} {
my tcl_console
return {}
} elseif {$word==".mode"} {
regexp {^.[a-z]+ +([a-z]+)} $cmd all newvalue
| | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
set header [my Config_get header]
if {[regexp {^(\.[a-z]+)} $cmd all word]} {
if {$word==".tcl"} {
my tcl_console
return {}
} elseif {$word==".mode"} {
regexp {^.[a-z]+ +([a-z]+)} $cmd all newvalue
my Config_set [list mode $newvalue]
return {}
} elseif {$word==".exit"} {
my destroy
return {}
} elseif {$word==".header"} {
regexp {^.[a-z]+ +([a-z]+)} $cmd all newvalue
my Config_set [list header $newvalue]
return {}
} elseif {$word==".tables"} {
set mode multicolumn
set cmd {SELECT name FROM sqlite_master WHERE type='table'
UNION ALL
SELECT name FROM sqlite_temp_master WHERE type='table'}
my <db> eval {PRAGMA database_list} {
|
| ︙ | ︙ |
Changes to modules/clay-tk/build/core.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
namespace eval ::clay::tk {}
set ::clay::tk::winsys [tk windowingsystem]
if {$::tcl_platform(platform) eq "windows"} {
set ::clay::tk::platform windows
catch {::ttk::style theme use xpnative}
} else {
if {$::tcl_platform(os) == "Darwin"} {
set ::clay::tk::platform macosx
} else {
set ::clay::tk::platform unix
}
catch {::ttk::style theme use clam}
}
::clay::define ::clay::tk::megawidget {
constructor {tkpath args} {
my Config_initialize $args
my Config_merge $args
my Hull_Construct $tkpath
my content
}
destructor {
my Hull_Destroy
}
| > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
namespace eval ::clay::tk {}
package require clay-yggdrasil
set ::clay::tk::winsys [tk windowingsystem]
if {$::tcl_platform(platform) eq "windows"} {
set ::clay::tk::platform windows
catch {::ttk::style theme use xpnative}
} else {
if {$::tcl_platform(os) == "Darwin"} {
set ::clay::tk::platform macosx
} else {
set ::clay::tk::platform unix
}
catch {::ttk::style theme use clam}
}
::clay::define ::clay::tk::megawidget {
superclass ::clay::yggdrasil
constructor {tkpath args} {
my Config_initialize $args
my Config_merge $args
my Hull_Construct $tkpath
my content
}
destructor {
my Hull_Destroy
}
method content {} {}
method event {submethod args} {
::clay::event::$submethod [self] {*}$args
}
method Hull_Bind {} {
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 |
method Hull_Unbind {} {
set tkpath [my clay delegate hull]
if {![winfo exists $tkpath]} return
bind $tkpath <Destroy> {}
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
method Hull_Unbind {} {
set tkpath [my clay delegate hull]
if {![winfo exists $tkpath]} return
bind $tkpath <Destroy> {}
}
method signal args {}
# Renames the tcl command that represents the widget to
# one that resides in the object's namespace. It then renames
# the object to catch calls to the tk path.
###
method tkalias tkname {
|
| ︙ | ︙ |
Changes to modules/clay-tk/build/hull.tcl.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
if {![winfo ismapped $h]} return
bind $h <Configure> {}
update idletasks
try {
set w [winfo parent $h]
set t [winfo toplevel $h]
set width [expr {[winfo width $w]-[winfo width $h.cy]-8}]
| | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
if {![winfo ismapped $h]} return
bind $h <Configure> {}
update idletasks
try {
set w [winfo parent $h]
set t [winfo toplevel $h]
set width [expr {[winfo width $w]-[winfo width $h.cy]-8}]
set minwidth [my Config_get minwidth]
if {$width < $minwidth} {
set width $minwidth
}
set oheight [winfo height $h.cx]
incr oheight 1
foreach child [winfo children $w] {
if {[winfo toplevel $child] ne $w} continue
if {![winfo ismapped $child]} return
if {$child eq $h} continue
puts [list $child [winfo height $child]]
incr oheight [winfo height $child]
}
set minheight [my Config_get minheight]
set height [expr {[winfo height $w] - $oheight}]
if {$height < $minheight} {
set height $minheight
}
puts [list [self] width $width height $height]
my <canvas> configure -width $width -height $height
my <canvas> configure -scrollregion [my <canvas> bbox all]
|
| ︙ | ︙ |
Changes to modules/clay-tktable/build/core.tcl.
1 2 3 4 5 6 |
package require clay-tk
package require Tktable
clay::define ::clay::tk::hull.tkable {
Array Data
| | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
package require clay-tk
package require Tktable
clay::define ::clay::tk::hull.tkable {
Array Data
Option titlerows {
default {1}
native -titlerows
}
Option titlecols {
default {1}
native -titlecols
}
Option cols {
default 0
native -cols
}
Option rows {
default 0
native -rows
}
Option height {
default {}
native -height
}
Option width {
default {}
native -width
}
Option maxheight {
default {}
native -maxheight
}
Option maxwidth {
default {}
native -maxwidth
}
Option multiline {
default 1
native -multiline
}
Option selectmode {
default browse
type select
values {single browse multiple extended}
native -selectmode
}
Option colstretchmode {
default none
type select
values {none unset all last}
native -colstretchmode
description {
Specifies one of the following stretch modes for columns to fill extra allocated window
space:
none Columns will not stretch to fill the assigned window space. If the columns are too
narrow, there will be a blank space at the right of the table. This is the default.
unset Only columns that do not have a specific width set will be stretched.
all All columns will be stretched by the same number of pixels to fill the window space
allocated to the table. This mode can interfere with interactive border resizing which
tries to force column width.last The last column will be stretched to fill the window
space allocated to the table.
}
}
Option rowstretchmode {
default none
type select
values {none unset all last fill}
native -rowstretchmode
description {
Specifies one of the following stretch modes for rows to fill extra allocated window
space:
|
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
space allocated to the table.
fill The table will get more or less columns
according to the window space allocated to the table. This mode has numerous quirks
and may disappear in the future.
}
}
| | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
space allocated to the table.
fill The table will get more or less columns
according to the window space allocated to the table. This mode has numerous quirks
and may disappear in the future.
}
}
Option multiline {
native -multiline
default 1
type boolean
}
method build_controls {controlframe} {
}
|
| ︙ | ︙ |
Changes to modules/clay-tktable/build/spreadsheet.tcl.
1 2 3 4 5 6 |
###
# Mimic the likes of Microsoft Excel(tm)
###
clay::define ::clay::tk::hull.spreadsheet {
superclass ::clay::tk::hull.tkable
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
###
# Mimic the likes of Microsoft Excel(tm)
###
clay::define ::clay::tk::hull.spreadsheet {
superclass ::clay::tk::hull.tkable
Option keycolumn {
default 0
}
method browse {row col} {
my variable prior Data
set TWidget [my clay delegate <widget>]
$TWidget tag configure $row,$col -foreground green
|
| ︙ | ︙ |
Changes to modules/clay-ui/build/baseclass.tcl.
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
###
Ensemble action::destroy {} {}
Ensemble action::revert_to_default {} {
set field [my clay get field]
set default [my clay get default]
if {$default in {{} default}} {
| | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
###
Ensemble action::destroy {} {}
Ensemble action::revert_to_default {} {
set field [my clay get field]
set default [my clay get default]
if {$default in {{} default}} {
set default [my <form> private Config_Default $field]
}
my Value_Store $default
}
method ApplySelectedValue newvalue {
if {[set command [my clay get post_command]] ne {}} {
set field [my clay get field]
|
| ︙ | ︙ |
Added modules/clay-yggdrasil/build/build.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
set here [file dirname [file normalize [file join [pwd] [info script]]]]
set version 0.1
set modpath [file dirname $here]
set module clay-yggdrasil
set filename [file tail $modpath]
set fout [open [file join $modpath ${filename}.tcl] w]
dict set map %module% $module
dict set map %version% $version
puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide %module% %version%
namespace eval ::%module% {}
set ::%module%::version %version%
}]
# Track what files we have included so far
set loaded {build.tcl}
# These files must be loaded in a particular order
foreach file {
core.tcl
} {
lappend loaded $file
set fin [open [file join $here $file] r]
puts $fout "###\n# START: [file tail $file]\n###"
puts $fout [read $fin]
close $fin
puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [glob [file join $here *.tcl]] {
if {[file tail $file] in $loaded} continue
lappend loaded $file
set fin [open [file join $here $file] r]
puts $fout "###\n# START: [file tail $file]\n###"
puts $fout [read $fin]
close $fin
puts $fout "###\n# END: [file tail $file]\n###"
}
# Provide some cleanup and our final package provide
puts $fout [string map $map {
namespace eval ::%module% {
namespace export *
}
}]
close $fout
###
# Build our pkgIndex.tcl file
###
#if {![package vsatisfies [package provide Tcl] 8.6]} {return}
set fout [open [file join $modpath pkgIndex.tcl] w]
puts $fout [string map $map {# Tcl package index file, version 1.1
# This file is generated by practcl
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout
|
Added modules/clay-yggdrasil/build/core.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
namespace eval ::clay::yggdrasil {}
clay::define ::clay::yggdrasil {
Dict css {}
clay branch css
method child {method args} {
tailcall my Child_${method} {*}$args
}
method Child_clear_all {} {
my variable children
foreach child $children {
catch {
$child child clear_all
$child clay refcount_decr
}
}
set children {}
}
method Child_count {} {
my variable children
if {![info exists children]} {
return {}
}
return [llength $children]
}
method Child_config {} {
return {}
}
method Child_delegate {} {
return [list parent [self]]
}
method Child_remove {args} {
my variable children
if {![info exists children]} {
return {}
}
set oldlist $children
set children {}
foreach item $oldlist {
if {$item in $args} continue
if {[info commands $item] eq {}} continue
lappend childrent $item
}
}
method Child_index {childidx args} {
my variable children
if {![info exists children]} {
return {}
}
set rowobj [lindex $children $childidx]
if {[llength $args] == 0} {
return $rowobj
}
return [$rowobj child index {*}$args]
}
method Child_last {} {
my variable children
return [lindex [my children] end]
}
method Child_list {} {
my variable children
if {![info exists children]} {
return {}
}
return $children
}
method config {method args} {
tailcall my Config_${method} {*}$args
}
method Config_Default field {
set info [my meta getnull option $field]
set getcmd [dict getnull $info default-command:]
if {$getcmd ne {}} {
return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
} else {
return [dict getnull $info default:]
}
}
method Config_add {field args} {
my variable config
set value [dict getnull $config $field]
foreach item $args {
if {$item ni $value} {
lappend value $item
}
}
dict set config $field $value
}
method Config_exists field {
my variable config
return [dict exists $config $field]
}
method Config_get {field args} {
my variable config option_canonical option_getcmd css
set field [string trimleft $field -]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
}
if {[info exists option_getcmd($field)]} {
return [eval $option_getcmd($field)]
}
if {[dict exists $config $field]} {
return [dict get $config $field]
}
if {[llength $args]} {
return [lindex $args 0]
}
return [my clay get option $field default]
}
###
# Data that tracks with the node itself
###
method Config_id args {
my variable config
if {[llength $args]} {
my Config_set id [lindex $args 0]
}
if {![dict exists $config id] || [dict get $config id] eq {}} {
dict set config id [::clay::uuid::short]
}
return [dict get $config id]
}
method Config_initialize args {
set mixinmap {}
dict for {opt optinfo} [my clay get option] {
if {[dict getnull $optinfo class] != "mixin"} continue
dict set mixinmap $opt [my Config_Mixin $opt [dict get $optinfo default]]
}
if {[dict size $mixinmap]} {
my clay mixinmap {*}$mixinmap
}
}
###
# topic: dc9fba12ec23a3ad000c66aea17135a5
###
method Config_merge dictargs {
my variable config option_canonical
set rawlist $dictargs
set dictargs {}
set mixinmap {}
foreach {field val} $rawlist {
set field [string trim $field -:/]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
}
if {$field eq "mixinmap"} {
my clay mixinmap {*}$val
} elseif {$field eq "delegate"} {
my clay delegate {*}$val
} else {
dict set dictargs $field $val
}
}
foreach {field val} $dictargs {
if {[my clay get option $field class] eq "mixin"} {
my clay mixinmap $field [my Config_Mixin $field $val]
}
}
#if {[dict size $mixinmap]} {
# my clay mixinmap {*}$mixinmap
#}
###
# Validate all inputs
###
foreach {field val} $dictargs {
set script [my clay get option $field validate-command]
if {$script ne {}} {
dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
}
}
###
# Apply all inputs with special rules
###
foreach {field val} $dictargs {
set script [my clay get option $field set-command]
dict set config $field $val
if {$script ne {}} {
{*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
}
}
return $dictargs
}
method Config_Mixin {field value} {
set pattern [my clay get option $field pattern]
set default [my clay get option $field default]
if {$value eq {}} {
return "${pattern}.${default}"
}
if {[string index $value 0] eq ":" && [info commands $value] ne {}} {
return $value
}
foreach trial {
{${pattern}.$value}
{${pattern}::$value}
{${pattern}::${field}.$value}
{${pattern}::${field}.${default}.$value}
{::clay::tk::${field}.$value}
{::clay::tk::$value}
} {
set str [subst $trial]
if {[info commands $str] ne {}} {
return $str
}
}
return "${pattern}.${default}"
}
method Config_remove {field args} {
my variable config
if {![dict exists $config field]} return
set olist [dict get $config $field]
set nlist {}
foreach arg $olist {
if {$arg in $args} continue
lappend nlist $arg
}
dict set config $field $nlist
return $nlist
}
method Config_set args {
set dictargs [::clay::args_to_options {*}$args]
set dat [my Config_merge $dictargs]
my Config_triggers $dat
}
###
# React to configuration changes
###
method Config_triggers dictargs {
foreach {field val} $dictargs {
set script [my clay get option $field post-command]
if {$script ne {}} {
{*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
}
}
}
method css {method args} {
tailcall my CSS_${method} {*}$args
}
###
# Content Style Sheet Data
# Moves in parallel with configuration data
###
method CSS_class args {
if {[llength $args]} {
my Config_set class [lindex $args 0]
}
return [my Config_get class]
}
method CSS_exists field {
my variable css
return [dict exists $css $field]
}
method CSS_get field {
my variable css
if {[dict exists $css $field]} {
return [dict get $css $field]
}
return [my clay get css $field]
}
method CSS_set args {
my variable css
dict for {f v} $args {
dict set css $f $v
}
}
method eval args {
eval {*}$args
}
method link {method args} {
tailcall my Link_$method {*}$args
}
method Link_add {linktype object} {
my variable links
if {[info exists links($linktype)] && $object in $links($linktype)} {
return
}
lappend links($linktype) $object
}
method Link_dump {} {
return [array get links]
}
method Link_list {{linktype *}} {
if {$linktype eq "*"} {
return [array get links]
}
if {![info exists links($linktype)]} {
return {}
}
return $links($linktype)
}
method Link_object args {
my variable links
foreach obj $args {
foreach linktype [$obj linktype] {
my link add $linktype $obj
}
}
}
method Link_remove {object {linktype *}} {
foreach {linktype elements} [array get links $linktype] {
if {$object in $elements} {
set nlist {}
foreach e $elements {
if { $object ne $e } { lappend nlist $e }
}
set links($linktype) $nlist
}
}
}
method source args {
source {*}$args
}
method uuid {} {
tailcall my Config_id
}
}
|
Changes to modules/cuneiform/build/core.tcl.
1 2 3 4 5 6 7 8 |
namespace eval cuneiform {}
proc ::cuneiform::markdown real_filename {
set fin [open $real_filename r]
while {[gets $fin line]>=0} {
if {[string range $line 0 2] eq "---" && [string range $line end-2 end] eq "---"} {
dict set dat body [read $fin]
break
| > > | 1 2 3 4 5 6 7 8 9 10 |
namespace eval cuneiform {}
package require clay-yggdrasil
proc ::cuneiform::markdown real_filename {
set fin [open $real_filename r]
while {[gets $fin line]>=0} {
if {[string range $line 0 2] eq "---" && [string range $line end-2 end] eq "---"} {
dict set dat body [read $fin]
break
|
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
dict set record format subst
}
}
return $record
}
clay::define ::cuneiform::object {
Variable cuneiform_content {}
Variable children {}
Variable tag_namespace {}
destructor {
# Clean up children on exit
my child clear_all
}
###
# Build basic layout
###
method cuneiform_structure {} {}
| > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
dict set record format subst
}
}
return $record
}
clay::define ::cuneiform::object {
superclass ::clay::yggdrasil
Variable cuneiform_content {}
Variable children {}
Variable tag_namespace {}
destructor {
# Clean up children on exit
my child clear_all
}
###
# Build basic layout
###
method cuneiform_structure {} {}
method tag {type args} {
my variable children
set output {}
if {[llength $args]==1} {
set args [list content [lindex $args 0]]
}
set nspace [my tag_namespace]
|
| ︙ | ︙ | |||
141 142 143 144 145 146 147 |
set tag_namespace ::cuneiform
return $tag_namespace
}
}
clay::define ::cuneiform::element {
superclass object
| < < < < < < | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
set tag_namespace ::cuneiform
return $tag_namespace
}
}
clay::define ::cuneiform::element {
superclass object
clay set xml_tag ""
clay set xml_paired 1
Variable xml_element {}
constructor {type args} {
my variable xml_element
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
set xml_flags [my clay get xml_flag]
dict for {f v} $args {
switch $f {
parent {
my clay delegate parent $v
}
id {
| | | | | | | | | | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
set xml_flags [my clay get xml_flag]
dict for {f v} $args {
switch $f {
parent {
my clay delegate parent $v
}
id {
my Config_id $v
}
css_class -
class {
my CSS_class $v
}
css -
css_style -
style {
my CSS_set {*}$v
}
tk -
html -
html_option -
html_options -
xml -
xml_option -
xml_options -
options -
option {
my Config_set {*}$v
}
namespace {
my variable tag_namespace
set tag_namespace $v
}
content {
my content $v
}
default {
if {[string range $f 0 4] eq "html:"} {
# If the user explicitly tells us this is xml, this is xml
my Config_set [string range $f 5 end] $v
} elseif {[string range $f 0 3] eq "css:"} {
my CSS_set [string range $f 4 end] $v
} else {
# Otherwise assume its an xml option
my Config_set $f $v
}
}
}
}
}
}
|
Changes to modules/cuneiform/build/html.tcl.
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
my clay delegate parent $v
}
namespace {
my variable tag_namespace
set tag_namespace $v
}
default {
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
my clay delegate parent $v
}
namespace {
my variable tag_namespace
set tag_namespace $v
}
default {
my config set $f $v
}
}
}
}
}
clay::define ::cuneiform::html::meta {
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
method item {content args} {
my tag LI content $content {*}$args
}
}
clay::define ::cuneiform::html::a {
clay set xml_tag "A"
| | | | | | | | | | | | | | | | | | | | | | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
method item {content args} {
my tag LI content $content {*}$args
}
}
clay::define ::cuneiform::html::a {
clay set xml_tag "A"
Option href {}
Option target {}
}
# Tk names that will confuse the parser
clay::define ::cuneiform::html::label {
clay set xml_tag LABEL
}
clay::define ::cuneiform::html::text {
clay set xml_tag TEXT
}
clay::define ::cuneiform::html::button {
clay set xml_tag "BUTTON"
Option href {}
Option target {}
Option type {}
Option name {}
Option value {}
}
clay::define ::cuneiform::html::img {
superclass nonpaired
clay set xml_paired 0
clay set xml_tag "IMG"
Option src {}
Option alt {}
Option width {}
Option height {}
}
clay::define ::cuneiform::html::image {
superclass nonpaired
clay set xml_paired 0
clay set xml_tag "IMG"
Option src {}
Option alt {}
Option width {}
Option height {}
}
clay::define ::cuneiform::html::form {
clay set xml_tag "FORM"
Option action {}
Option method {default POST}
}
clay::define ::cuneiform::html::label {
clay set xml_tag "LABEL"
Option for {}
}
clay::define ::cuneiform::html::option {
clay set xml_tag "OPTION"
Option value {}
clay set xml_flag disabled 0
clay set xml_flag selected 0
}
clay::define ::cuneiform::html::input {
clay set xml_tag "INPUT"
Option type {}
Option name {}
Option value {}
}
clay::define ::cuneiform::html::table {
clay set xml_tag "TABLE"
method rowcount {} {
my variable children
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
return $cols
}
method listrow {opts args} {
set rowojb [my tag tr]
set result {}
foreach value $args {
| | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
return $cols
}
method listrow {opts args} {
set rowojb [my tag tr]
set result {}
foreach value $args {
lappend result [$rowojb tag td {*}$opts content $value]
}
return $result
}
method row args {
return [my tag tr {*}$args]
}
|
| ︙ | ︙ | |||
315 316 317 318 319 320 321 |
set obj [my tag td]
return [$obj tag input {*}$args]
}
}
clay::define ::cuneiform::html::th {
clay set xml_tag "TH"
| | | | | | | | 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 |
set obj [my tag td]
return [$obj tag input {*}$args]
}
}
clay::define ::cuneiform::html::th {
clay set xml_tag "TH"
Option colspan {}
Option rowspan {}
Option headers {}
}
clay::define ::cuneiform::html::td {
clay set xml_tag "TD"
Option colspan {}
Option rowspan {}
Option headers {}
}
clay::define ::cuneiform::html::page_break {
superclass para
clay set css style {
page-break-before always
}
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
# Intended for the httpd engine in tcllib
###
clay::define ::cuneiform::document.html {
superclass ::cuneiform::buffer.html ::cuneiform::html::nocss
clay set stylesheet {}
clay set xml_tag "HTML"
| | | | | | | | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
# Intended for the httpd engine in tcllib
###
clay::define ::cuneiform::document.html {
superclass ::cuneiform::buffer.html ::cuneiform::html::nocss
clay set stylesheet {}
clay set xml_tag "HTML"
Option title {}
Option charset {default UTF-8}
method cuneiform_syntax {} {
next
proc stylesheet url {
my <stylesheet> config set href $url
}
proc title string {
my <title> content $string
}
}
method cuneiform_structure {} {
my clay flush
my variable xml css
set xml {}
set css {}
my clay delegate <head> [my Tag head]
my clay delegate <title> [my <head> tag title]
my <head> tag meta charset [my config get charset]
set sheethref [my clay get xml stylesheet]
if {$sheethref eq {}} {
set sheethref /style.css
}
my clay delegate <stylesheet> [my <head> tag link rel stylesheet type text/css href $sheethref]
set styleobj [my <head> tag style]
my clay delegate <style> $styleobj
my clay delegate <style:screen> $styleobj
my clay delegate <style:print> [my <head> tag style]
my <style> config set media screen type text/css
my <style:print> config set media print type text/css
set bodyobj [my Tag body]
my clay delegate <body> $bodyobj
my clay delegate <header> [$bodyobj tag header id header]
my clay delegate <top> [$bodyobj tag div id top]
my clay delegate <content> [$bodyobj tag div id output css {}]
my clay delegate <sideimg> [$bodyobj tag div id sideimg]
|
| ︙ | ︙ |
Changes to modules/cuneiform/build/svg.tcl.
1 2 3 4 5 6 7 8 9 |
namespace eval ::cuneiform::svg {
namespace import ::cuneiform::xml::*
}
###
# SVG Tags
###
clay::define ::cuneiform::svg {
clay set xml_tag "SVG"
| | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
namespace eval ::cuneiform::svg {
namespace import ::cuneiform::xml::*
}
###
# SVG Tags
###
clay::define ::cuneiform::svg {
clay set xml_tag "SVG"
Option colspan {}
Option viewBox {}
Option xmlns {}
Option width {}
Option height {}
}
clay::define ::cuneiform::svg::g {
clay set xml_tag "G"
Option id {}
}
clay::define ::cuneiform::svg::text {
clay set xml_tag "TEXT"
Option x {}
Option y {}
Option fill {}
Option font-size {}
}
clay::define ::cuneiform::svg::polygon {
superclass nonpaired
clay set xml_tag "POLYGON"
Option points {}
}
|
Changes to modules/cuneiform/build/tk.tcl.
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
}
::clay::define ::cuneiform::tk::label {
method Cuneiform_Tk_Hull {window args} {
set w $window.uuid[my uuid]
puts [list [self] [self class] [self method] $window $w]
set opts {}
| | | | | | | | | | | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
}
::clay::define ::cuneiform::tk::label {
method Cuneiform_Tk_Hull {window args} {
set w $window.uuid[my uuid]
puts [list [self] [self class] [self method] $window $w]
set opts {}
if {[my config get text] ne {}} {
lappend opts -text [my config get text]
}
if {[my config get variable] ne {}} {
lappend opts -textvariable [my config get text]
}
puts [list ttk::label $w {*}$opts]
ttk::label $w {*}$opts
return $w
}
}
::clay::define ::cuneiform::tk::button {
method Cuneiform_Tk_Hull {window args} {
set w $window.uuid[my uuid]
puts [list [self] [self class] [self method] $window $w]
set opts {}
if {[my config get text] ne {}} {
lappend opts -text [my config get text]
}
if {[my config get variable] ne {}} {
lappend opts -textvariable [my config get text]
}
if {[my config get command] ne {}} {
lappend opts -command [my config get command]
}
puts [list ttk::button $w {*}$opts]
ttk::button $w {*}$opts
return $w
}
}
|
| ︙ | ︙ |
Changes to modules/cuneiform/build/xml.tcl.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
set xml_options [my clay get xml]
dict for {f v} $args {
switch $f {
parent {
my clay delegate parent $v
}
default {
| | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
set xml_options [my clay get xml]
dict for {f v} $args {
switch $f {
parent {
my clay delegate parent $v
}
default {
my config set $f $v
}
}
}
}
}
clay::define ::cuneiform::xml::nonpaired {
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
# Intended for the httpd engine in tcllib
###
clay::define ::cuneiform::document.xml {
superclass ::cuneiform::buffer.xml ::cuneiform::xml::nocss
clay set stylesheet {}
clay set xml_tag "xml"
| | | | | | | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
# Intended for the httpd engine in tcllib
###
clay::define ::cuneiform::document.xml {
superclass ::cuneiform::buffer.xml ::cuneiform::xml::nocss
clay set stylesheet {}
clay set xml_tag "xml"
Option title {}
Option encoding {default UTF-8}
Option version {default 1.0}
Option headerline {type boolean default 1}
method cuneiform_syntax {} {
next
proc stylesheet url {
my <stylesheet> config set href $url
}
proc title string {
my <title> content $string
}
}
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
method xml_footer args {
my <footer> append {*}$args
}
method xml_output {} {
set output {}
| | | | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
method xml_footer args {
my <footer> append {*}$args
}
method xml_output {} {
set output {}
if {[my config get headerline]} {
append output "<?xml version=\"[my config get version]\" encoding=\"[my config get encoding]\" standalone=\"yes\" ?>" \n
}
append output [my xml_format_content]
return $output
}
}
namespace eval ::cuneiform::xml {
namespace export *
}
|
Changes to modules/cuneiform/cuneiform-tk.test.
1 2 3 4 5 6 7 8 9 10 | set here [file dirname [file normalize [info script]]] source [file join $here .. clay clay.tcl] exec tclsh [file join $here build build.tcl] source [file join $here cuneiform.tcl] package require Tk frame .c ::cuneiform::tkframe create APP | > > | 1 2 3 4 5 6 7 8 9 10 11 12 | set here [file dirname [file normalize [info script]]] source [file join $here .. clay clay.tcl] source [file join $here .. clay-yggdrasil clay-yggdrasil.tcl] exec tclsh [file join $here build build.tcl] source [file join $here cuneiform.tcl] package require Tk frame .c ::cuneiform::tkframe create APP |
| ︙ | ︙ |
Changes to modules/cuneiform/cuneiform.test.
1 2 3 4 5 6 7 8 9 10 |
set here [file dirname [file normalize [info script]]]
source [file join $here .. clay clay.tcl]
exec tclsh [file join $here build build.tcl]
source [file join $here cuneiform.tcl]
::cuneiform::document.html create HTML html title {Hello World!} stylesheet /style.css
clay::define test_html {
method content {} {
my <title> content {What a lovely day}
| > > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
set here [file dirname [file normalize [info script]]]
source [file join $here .. clay clay.tcl]
source [file join $here .. clay-yggdrasil clay-yggdrasil.tcl]
exec tclsh [file join $here build build.tcl]
source [file join $here cuneiform.tcl]
::cuneiform::document.html create HTML html title {Hello World!} stylesheet /style.css
clay::define test_html {
method content {} {
my <title> content {What a lovely day}
my tag H1 {Hello World}
set t [my tag table]
$t listrow {} {Test} Right
set obj [$t child index 0 0]
$obj css set border 1
set r [$t tag TR]
$r tag TD content {Test 2}
$r tag TD content {Right 2}
}
}
###
# Inject content
###
HTML tag h1 [HTML config get title]
###
# Mixin a behavior hand have that behavior inject content
###
HTML clay mixinmap content test_html
HTML content
set fout [open test.html w]
puts $fout [HTML html_output]
|
| ︙ | ︙ |
Changes to modules/practcl/build/build.tcl.
1 2 3 4 5 6 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] source [file join $srcdir doctool.tcl] ::practcl::doctool create AutoDoc | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] source [file join $srcdir doctool.tcl] ::practcl::doctool create AutoDoc set version 0.17 set tclversion 8.6 set module [file tail $moddir] set filename $module set fout [open [file join $moddir $filename.tcl] w] fconfigure $fout -translation lf dict set modmap %module% $module |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
###
# Load other module code that this module will need
###
foreach {omod files} {
httpwget wget.tcl
clay {clay.tcl}
} {
foreach fname $files {
set file [file join $moddir .. $omod $fname]
puts $fout "###\n# START: [file join $omod $fname]\n###"
set content [::practcl::cat [file join $moddir .. $omod $fname]]
#AutoDoc scan_text $content
puts $fout [::practcl::docstrip $content]
| > | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
###
# Load other module code that this module will need
###
foreach {omod files} {
httpwget wget.tcl
clay {clay.tcl}
clay-yggdrasil {clay-yggdrasil.tcl}
} {
foreach fname $files {
set file [file join $moddir .. $omod $fname]
puts $fout "###\n# START: [file join $omod $fname]\n###"
set content [::practcl::cat [file join $moddir .. $omod $fname]]
#AutoDoc scan_text $content
puts $fout [::practcl::docstrip $content]
|
| ︙ | ︙ |
Changes to modules/practcl/build/buildutil.tcl.
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
}
}
set ::fosdat($dir) $result
return $result
}
proc ::practcl::os {} {
| | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
}
}
set ::fosdat($dir) $result
return $result
}
proc ::practcl::os {} {
return [${::practcl::MAIN} config get TEACUP_OS]
}
###
# Build a zipfile. On tcl8.6 this invokes the native Zip implementation
# on older interpreters this invokes zip via exec
###
proc ::practcl::mkzip {exename barekit vfspath} {
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/distro/baseclass.tcl.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
maxdate {}
tags {}
isodate {}
}
}
method DistroMixIn {} {
| | | | | | | | | | | | | | | | | | | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
maxdate {}
tags {}
isodate {}
}
}
method DistroMixIn {} {
my Config_set scm none
}
method Sandbox {} {
if {[my define exists sandbox]} {
return [my Config_get sandbox]
}
if {[my clay delegate project] ni {::noop {}}} {
set sandbox [my <project> config get sandbox]
if {$sandbox ne {}} {
my Config_set sandbox $sandbox
return $sandbox
}
}
set sandbox [file normalize [file join $::CWD ..]]
my Config_set sandbox $sandbox
return $sandbox
}
method SrcDir {} {
set pkg [my Config_get name]
if {[my define exists srcdir]} {
return [my Config_get srcdir]
}
set sandbox [my Sandbox]
set srcdir [file join [my Sandbox] $pkg]
my Config_set srcdir $srcdir
return $srcdir
}
method ScmTag {} {}
method ScmClone {} {}
method ScmUnpack {} {}
method ScmUpdate {} {}
method Unpack {} {
set srcdir [my SrcDir]
if {[file exists $srcdir]} {
return
}
set pkg [my Config_get name]
if {[my define exists download]} {
# Utilize a staged download
set download [my Config_get download]
if {[file exists [file join $download $pkg.zip]]} {
::practcl::tcllib_require zipfile::decode
::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir
return
}
}
my ScmUnpack
}
}
oo::objdefine ::practcl::distribution {
method Sandbox {object} {
if {[$object define exists sandbox]} {
return [$object config get sandbox]
}
if {[$object clay delegate project] ni {::noop {}}} {
set sandbox [$object <project> config get sandbox]
if {$sandbox ne {}} {
$object config set sandbox $sandbox
return $sandbox
}
}
set pkg [$object config get name]
set sandbox [file normalize [file join $::CWD ..]]
$object config set sandbox $sandbox
return $sandbox
}
method select object {
if {[$object define exists scm]} {
return [$object config get scm]
}
set pkg [$object config get name]
if {[$object config get srcdir] ne {}} {
set srcdir [$object config get srcdir]
} else {
set srcdir [file join [my Sandbox $object] $pkg]
$object config set srcdir $srcdir
}
set classprefix ::practcl::distribution.
if {[file exists $srcdir]} {
foreach class [::info commands ${classprefix}*] {
if {[$class claim_path $srcdir]} {
$object clay mixinmap distribution $class
set name [$class claim_option]
$object config set scm $name
return $name
}
}
}
foreach class [::info commands ${classprefix}*] {
if {[$class claim_object $object]} {
$object clay mixinmap distribution $class
set name [$class claim_option]
$object config set scm $name
return $name
}
}
if {[$object config get scm] eq {} && [$object define exists file_url]} {
set class ::practcl::distribution.snapshot
set name [$class claim_option]
$object config set scm $name
$object clay mixinmap distribution $class
return $name
}
error "Cannot determine source distribution method"
}
method claim_option {} {
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/distro/fossil.tcl.
1 2 3 4 5 6 7 8 9 |
###
# A file distribution based on fossil
###
::clay::define ::practcl::distribution.fossil {
superclass ::practcl::distribution
method scm_info {} {
set info [next]
dict set info scm fossil
| | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
###
# A file distribution based on fossil
###
::clay::define ::practcl::distribution.fossil {
superclass ::practcl::distribution
method scm_info {} {
set info [next]
dict set info scm fossil
foreach {field value} [::practcl::fossil_status [my Config_get srcdir]] {
dict set info $field $value
}
return $info
}
# 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 Config_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 config 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 config 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 Config_get fossil_url] ne {}} {
catch {
::practcl::doexec fossil clone [my Config_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 Config_get scm_tag]
}
if {[my define exists tag]} {
set tag [my Config_get tag]
} else {
set tag trunk
}
my Config_set scm_tag $tag
return $tag
}
method ScmUnpack {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .fslckout]]} {
return 0
|
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
}
}
oo::objdefine ::practcl::distribution.fossil {
# Check for markers in the metadata
method claim_object obj {
| | | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
}
}
oo::objdefine ::practcl::distribution.fossil {
# Check for markers in the metadata
method claim_object obj {
set path [$obj config get srcdir]
if {[my claim_path $path]} {
return true
}
if {[$obj config get fossil_url] ne {}} {
return true
}
return false
}
method claim_option {} {
return fossil
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/distro/git.tcl.
1 2 3 4 5 6 7 8 |
###
# A file distribution based on git
###
::clay::define ::practcl::distribution.git {
superclass ::practcl::distribution
method ScmTag {} {
if {[my define exists scm_tag]} {
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
###
# A file distribution based on git
###
::clay::define ::practcl::distribution.git {
superclass ::practcl::distribution
method ScmTag {} {
if {[my define exists scm_tag]} {
return [my Config_get scm_tag]
}
if {[my define exists tag]} {
set tag [my Config_get tag]
} else {
set tag master
}
my Config_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 Config_get name]
if {[my define exists git_url]} {
::practcl::doexec git clone --branch $tag [my Config_get git_url] $srcdir
} else {
::practcl::doexec git clone --branch $tag https://github.com/eviltwinskippy/$pkg $srcdir
}
return 1
}
method ScmUpdate {} {
|
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
cd $CWD
}
}
oo::objdefine ::practcl::distribution.git {
method claim_object obj {
| | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
cd $CWD
}
}
oo::objdefine ::practcl::distribution.git {
method claim_object obj {
set path [$obj config get srcdir]
if {[my claim_path $path]} {
return true
}
if {[$obj config get git_url] ne {}} {
return true
}
return false
}
method claim_option {} {
return git
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/distro/snapshot.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
###
# A file distribution from zip, tarball, or other non-scm archive format
###
::clay::define ::practcl::distribution.snapshot {
superclass ::practcl::distribution
method ScmUnpack {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .download]]} {
return 0
}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
###
# A file distribution from zip, tarball, or other non-scm archive format
###
::clay::define ::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 config get download]
set url [my Config_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] {
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/dynamic.tcl.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
}
if {![dict exists $cstruct $name public]} {
dict set cstruct $name public 1
}
}
method include header {
| | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
}
if {![dict exists $cstruct $name public]} {
dict set cstruct $name public 1
}
}
method include header {
my Config_add include $header
}
method include_dir args {
my Config_add include_dir {*}$args
}
method include_directory args {
my Config_add include_dir {*}$args
}
method c_header body {
my variable code
::practcl::cputs code(header) $body
}
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 |
}
}
###
# Module interactions
###
method project-compile-products {} {
| | | | | | | | | | | | | | | | | | | | | | | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
}
}
###
# Module interactions
###
method project-compile-products {} {
set filename [my Config_get output_c]
set result {}
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
if {[my define exists ofile]} {
set ofile [my Config_get ofile]
} else {
set ofile [my Ofile $filename]
my Config_set ofile $ofile
}
lappend result $ofile [list cfile $filename extra [my Config_get extra] external [string is true -strict [my Config_get external]]]
} else {
set filename [my Config_get cfile]
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
if {[my define exists ofile]} {
set ofile [my Config_get ofile]
} else {
set ofile [my Ofile $filename]
my Config_set ofile $ofile
}
lappend result $ofile [list cfile $filename extra [my Config_get extra] external [string is true -strict [my Config_get external]]]
}
}
foreach item [my link list subordinate] {
lappend result {*}[$item project-compile-products]
}
return $result
}
method implement path {
my go
my Collate_Source $path
if {[my Config_get output_c] eq {}} return
set filename [file join $path [my Config_get output_c]]
::practcl::debug [self] [my Config_get filename] WANTS TO GENERATE $filename
my Config_set cfile $filename
set fout [open $filename w]
puts $fout [my generate-c]
if {[my Config_get initfunc] ne {}} {
puts $fout "extern int DLLEXPORT [my Config_get initfunc]( Tcl_Interp *interp ) \x7B"
puts $fout [my generate-loader-module]
if {[my Config_get pkg_name] ne {}} {
puts $fout " Tcl_PkgProvide(interp, \"[my Config_get pkg_name]\", \"[my Config_get pkg_vers]\");"
}
puts $fout " return TCL_OK\;"
puts $fout "\x7D"
}
close $fout
}
###
# Practcl internals
###
method initialize {} {
set filename [my Config_get filename]
if {$filename eq {}} {
return
}
if {[my Config_get name] eq {}} {
my Config_set name [file tail [file rootname $filename]]
}
if {[my Config_get localpath] eq {}} {
my Config_set localpath [my <module> config get localpath]_[my Config_get name]
}
::source $filename
}
method linktype {} {
return {subordinate product dynamic}
}
method generate-cfile-constant {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result {}
my variable code cstruct methods tcltype
if {[info exists code(constant)]} {
::practcl::cputs result "/* [my Config_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]
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
::practcl::cputs result " .cloneProc = NULL\n\}\;"
}
dict set methods $name methodtype $methodtype
}
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
| | | | | | | | | | | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
::practcl::cputs result " .cloneProc = NULL\n\}\;"
}
dict set methods $name methodtype $methodtype
}
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-constant]
}
return $result
}
method generate-cfile-header {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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)
}
::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 Config_get cclass]]
if {[info exists methods]} {
set thisclass [my Config_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)\;"
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
set dat [$obj generate-cfile-header]
if {[string length [string trim $dat]]} {
::practcl::cputs result "/* BEGIN [$obj config get filename] generate-cfile-header */"
::practcl::cputs result $dat
::practcl::cputs result "/* END [$obj config get filename] generate-cfile-header */"
}
}
return $result
}
###
# Generate code that provides implements Tcl API
# calls
###
method generate-cfile-tclapi {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_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 Config_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 */
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
}
}
}
::practcl::cputs result " return TCL_OK\;\n\}\n"
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
| | | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 |
}
}
}
::practcl::cputs result " return TCL_OK\;\n\}\n"
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-tclapi]
}
return $result
}
###
# Generate code that runs when the package/module is
# initialized into the interpreter
###
method generate-loader-module {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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);
|
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
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 " \}"
}
| | | | | | | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 |
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 Config_get filename]]
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} {
::practcl::cputs result [$obj generate-loader-external]
} else {
::practcl::cputs result [$obj generate-loader-module]
}
}
return $result
}
method Collate_Source CWD {
my variable methods code cstruct tclprocs
if {[info exists methods]} {
::practcl::debug [self] methods [my Config_get cclass]
set thisclass [my Config_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 Config_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
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/metaclass.tcl.
1 2 3 4 5 6 7 8 9 |
###
# The metaclass for all practcl objects
###
::clay::define ::practcl::metaclass {
method _MorphPatterns {} {
return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}}
}
| > < < | < < < < < < < < < < < < < < < < < < | | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
###
# The metaclass for all practcl objects
###
::clay::define ::practcl::metaclass {
superclass ::clay::yggdrasil
method _MorphPatterns {} {
return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}}
}
method Child_define {} {
return {}
}
method define {method args} {
tailcall my Config_$method {*}$args
}
method graft args {
return [my clay delegate {*}$args]
}
method initialize {} {}
method morph classname {
my variable define
if {$classname ne {}} {
set map [list @name@ $classname]
foreach pattern [string map $map [my _MorphPatterns]] {
set pattern [string trim $pattern]
set matches [info commands $pattern]
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 |
}
if {$mixinslot ne {}} {
my clay mixinmap $mixinslot $class
} elseif {[info command $class] ne {}} {
if {[info object class [self]] ne $class} {
::oo::objdefine [self] class $class
::practcl::debug [self] morph $class
| | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
}
if {$mixinslot ne {}} {
my clay mixinmap $mixinslot $class
} elseif {[info command $class] ne {}} {
if {[info object class [self]] ne $class} {
::oo::objdefine [self] class $class
::practcl::debug [self] morph $class
my Config_set class $class
}
} else {
error "[self] Could not detect class for $classname"
}
}
if {[::info exists define(oodefine)]} {
::oo::objdefine [self] $define(oodefine)
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/module.tcl.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
}
Ensemble make::pkginfo {} {
###
# Build local variables needed for install
###
package require platform
set result {}
| | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
}
Ensemble make::pkginfo {} {
###
# Build local variables needed for install
###
package require platform
set result {}
set dat [my Config_dump]
set PKG_DIR [dict get $dat name][dict get $dat version]
dict set result PKG_DIR $PKG_DIR
dict with dat {}
if {![info exists DESTDIR]} {
set DESTDIR {}
}
dict set result profile [::platform::identify]
|
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
}
}
# Return the file name of the build product for the listed
# handle
Ensemble make::filename name {
if {[dict exists $make_object $name]} {
| | | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
}
}
# Return the file name of the build product for the listed
# handle
Ensemble make::filename name {
if {[dict exists $make_object $name]} {
return [[dict get $make_object $name] config get filename]
}
}
Ensemble make::target {name Info body} {
set info [uplevel #0 [list subst $Info]]
set nspace [namespace current]
if {[dict exist $make_object $name]} {
|
| ︙ | ︙ | |||
162 163 164 165 166 167 168 |
# For each target exercise the action specified in the [emph action]
# definition if the [emph do] method returns true
Ensemble make::do {} {
global CWD SRCDIR project SANDBOX
foreach {name obj} $make_object {
if {[$obj do]} {
| | < < | < | | < > > | | | | | | | | | | | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 |
# For each target exercise the action specified in the [emph action]
# definition if the [emph do] method returns true
Ensemble make::do {} {
global CWD SRCDIR project SANDBOX
foreach {name obj} $make_object {
if {[$obj do]} {
eval [$obj config get action]
}
}
}
method Child_delegate {} {
return [list project [my Config_get project] module [self]]
}
method Child_organs {} {
return [list project [my Config_get project] module [self]]
}
###
# 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 Config_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 Config_get tk 0]} {
my IncludeAdd headers <tk.h>
}
if {[my Config_get output_h] ne {}} {
my IncludeAdd headers [my Config_get output_h]
}
my IncludeAdd headers {*}[my Config_get include]
foreach mod [my link list dynamic] {
my IncludeAdd headers {*}[$mod config get include]
}
foreach inc $headers {
::practcl::cputs result "#include $inc"
}
foreach {method} {
generate-cfile-header
generate-cfile-private-typedef
generate-cfile-private-structure
generate-cfile-public-structure
generate-cfile-constant
generate-cfile-global
generate-cfile-functions
generate-cfile-tclapi
} {
set dat [my $method]
if {[string length [string trim $dat]]} {
::practcl::cputs result "/* BEGIN $method [my Config_get filename] */"
::practcl::cputs result $dat
::practcl::cputs result "/* END $method [my Config_get filename] */"
}
}
::practcl::debug [list /[self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
return $result
}
###
# 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 Config_get filename] [info object class [self]]]
set result {}
foreach method {
generate-hfile-public-define
generate-hfile-public-macro
} {
::practcl::cputs result "/* BEGIN SECTION $method */"
::practcl::cputs result [my $method]
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
::practcl::cputs result [my $method]
::practcl::cputs result "/* END SECTION $method */"
}
return $result
}
method generate-loader {} {
| | | | | | | | | | | | | | | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
::practcl::cputs result [my $method]
::practcl::cputs result "/* END SECTION $method */"
}
return $result
}
method generate-loader {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result {}
if {[my Config_get initfunc] eq {}} return
::practcl::cputs result "
extern int DLLEXPORT [my Config_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 Config_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 [string trim $TCLINIT]]} {
::practcl::cputs result " if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }"
}
::practcl::cputs result [my generate-loader-module]
set TCLINIT [my generate-tcl-post]
if {[string length [string trim $TCLINIT]]} {
::practcl::cputs result " if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }"
}
if {[my define exists pkg_name]} {
::practcl::cputs result " if (Tcl_PkgProvide(interp, \"[my Config_get pkg_name [my Config_get name]]\" , \"[my Config_get pkg_vers [my Config_get version]]\" )) return TCL_ERROR\;"
}
::practcl::cputs result " return TCL_OK\;\n\}\n"
return $result
}
method initialize {} {
set filename [my Config_get filename]
if {$filename eq {}} {
return
}
if {[my Config_get name] eq {}} {
my Config_set name [file tail [file dirname $filename]]
}
if {[my Config_get localpath] eq {}} {
my Config_set localpath [my <project> config get name]_[my Config_get name]
}
my graft module [self]
::practcl::debug [self] SOURCE $filename
my source $filename
}
method implement path {
my go
my Collate_Source $path
set errs {}
foreach item [my link list dynamic] {
if {[catch {$item implement $path} err errdat]} {
lappend errs "Skipped $item: [$item config get filename] $err"
if {[dict exists $errdat -errorinfo]} {
lappend errs [dict get $errdat -errorinfo]
} else {
lappend errs $errdat
}
}
}
foreach item [my link list module] {
if {[catch {$item implement $path} err errdat]} {
lappend errs "Skipped $item: [$item config get filename] $err"
if {[dict exists $errdat -errorinfo]} {
lappend errs [dict get $errdat -errorinfo]
} else {
lappend errs $errdat
}
}
}
if {[llength $errs]} {
set logfile [file join $::CWD practcl.log]
::practcl::log $logfile "*** ERRORS ***"
foreach {item trace} $errs {
::practcl::log $logfile "###\n# ERROR\n###\n$item"
::practcl::log $logfile "###\n# TRACE\n###\n$trace"
}
::practcl::log $logfile "*** DEBUG INFO ***"
::practcl::log $logfile $::DEBUG_INFO
puts stderr "Errors saved to $logfile"
exit 1
}
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set filename [my Config_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
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/object.tcl.
1 2 3 4 5 6 7 |
###
# A generic Practcl object
###
::clay::define ::practcl::object {
superclass ::practcl::metaclass
constructor {parent args} {
| | | | | | | > > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
###
# A generic Practcl object
###
::clay::define ::practcl::object {
superclass ::practcl::metaclass
constructor {parent args} {
my variable links
set organs [$parent child organs]
my clay delegate {*}$organs
my Config_merge $organs
my Config_merge [$parent child define]
array set links {}
if {[llength $args]==1 && [file exists [lindex $args 0]]} {
my Config_set filename [lindex $args 0]
::practcl::product select [self]
} elseif {[llength $args] == 1} {
set data [uplevel 1 [list subst [lindex $args 0]]]
my Config_merge $data
my select
} else {
my Config_merge [uplevel 1 [list subst $args]]
my select
}
my initialize
}
method Child_delegate {} {
return {}
}
method Child_organs {} {
return {}
}
method go {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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]]
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/product.tcl.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
}
method Collate_Source CWD {}
method project-compile-products {} {
set result {}
noop {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
}
method Collate_Source CWD {}
method project-compile-products {} {
set result {}
noop {
set filename [my Config_get filename]
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
if {[my define exists ofile]} {
set ofile [my Config_get ofile]
} else {
set ofile [my Ofile $filename]
my Config_set ofile $ofile
}
lappend result $ofile [list cfile $filename include [my Config_get include] extra [my Config_get extra] external [string is true -strict [my Config_get external]] object [self]]
}
}
foreach item [my link list subordinate] {
lappend result {*}[$item project-compile-products]
}
return $result
}
method generate-debug {{spaces {}}} {
set result {}
::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my Config_get filename]] links [my link list]]"
foreach item [my link list subordinate] {
practcl::cputs result [$item generate-debug "$spaces "]
}
return $result
}
method generate-cfile-constant {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result {}
my variable code cstruct methods tcltype
if {[info exists code(constant)]} {
::practcl::cputs result "/* [my Config_get filename] CONSTANT */"
::practcl::cputs result $code(constant)
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-constant]
}
return $result
}
###
# Populate const static data structures
###
method generate-cfile-public-structure {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code cstruct methods tcltype
set result {}
if {[info exists code(struct)]} {
::practcl::cputs result $code(struct)
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-public-structure]
}
return $result
}
method generate-cfile-header {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 config get output_c] ne {}} continue
set dat [$obj generate-cfile-header]
if {[string length [string trim $dat]]} {
::practcl::cputs result "/* BEGIN [$obj config get filename] generate-cfile-header */"
::practcl::cputs result $dat
::practcl::cputs result "/* END [$obj config get filename] generate-cfile-header */"
}
}
return $result
}
method generate-cfile-global {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code cfunct cstruct methods tcltype tclprocs
set result {}
if {[info exists code(global)]} {
::practcl::cputs result $code(global)
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
set dat [$obj generate-cfile-global]
if {[string length [string trim $dat]]} {
::practcl::cputs result "/* BEGIN [$obj config get filename] generate-cfile-global */"
::practcl::cputs result $dat
::practcl::cputs result "/* END [$obj config get filename] generate-cfile-global */"
}
}
return $result
}
method generate-cfile-private-typedef {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-cfile-private-typedef]
}
return $result
}
method generate-cfile-private-structure {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-cfile-private-structure]
}
return $result
}
###
# Generate code that provides subroutines called by
# Tcl API methods
###
method generate-cfile-functions {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 */"
if {[dict get $info inline] && [dict get $info public]} {
::practcl::cputs result "\ninline [dict get $info header]\{[dict get $info body]\}"
} else {
::practcl::cputs result "\n[dict get $info header]\{[dict get $info body]\}"
}
}
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} {
continue
}
::practcl::cputs result [$obj generate-cfile-functions]
}
return $result
}
###
# Generate code that provides implements Tcl API
# calls
###
method generate-cfile-tclapi {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code methods tclprocs
set result {}
if {[info exists code(method)]} {
::practcl::cputs result $code(method)
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-tclapi]
}
return $result
}
method generate-hfile-public-define {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-define]
}
return $result
}
method generate-hfile-public-macro {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-macro]
}
return $result
}
method generate-hfile-public-typedef {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-typedef]
}
return $result
}
method generate-hfile-public-structure {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-structure]
}
return $result
}
method generate-hfile-public-headers {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-headers]
}
return $result
}
method generate-hfile-public-function {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code cfunct tcltype
set result {}
if {[my Config_get initfunc] ne {}} {
::practcl::cputs result "int [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-function]
}
return $result
}
method generate-hfile-public-includes {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set includes {}
foreach item [my Config_get public-include] {
if {$item ni $includes} {
lappend includes $item
}
}
foreach mod [my link list product] {
foreach item [$mod generate-hfile-public-includes] {
if {$item ni $includes} {
lappend includes $item
}
}
}
return $includes
}
method generate-hfile-public-verbatim {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set includes {}
foreach item [my Config_get public-verbatim] {
if {$item ni $includes} {
lappend includes $item
}
}
foreach mod [my link list subordinate] {
foreach item [$mod generate-hfile-public-verbatim] {
if {$item ni $includes} {
lappend includes $item
}
}
}
return $includes
}
method generate-loader-external {} {
if {[my Config_get initfunc] eq {}} {
return "/* [my Config_get filename] declared not initfunc */"
}
return " if([my Config_get initfunc](interp)) return TCL_ERROR\;"
}
method generate-loader-module {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code
set result {}
if {[info exists code(cinit)]} {
::practcl::cputs result $code(cinit)
}
if {[my Config_get initfunc] ne {}} {
::practcl::cputs result " if([my Config_get initfunc](interp)!=TCL_OK) return TCL_ERROR\;"
}
set result [::practcl::_tagblock $result c [my Config_get filename]]
foreach item [my link list product] {
if {[$item config get output_c] ne {}} {
::practcl::cputs result [$item generate-loader-external]
} else {
::practcl::cputs result [$item generate-loader-module]
}
}
return $result
}
method generate-stub-function {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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
}
}
|
| ︙ | ︙ | |||
434 435 436 437 438 439 440 |
lappend headers $inc
}
}
}
method generate-tcl-loader {} {
set result {}
| | | | | | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 |
lappend headers $inc
}
}
}
method generate-tcl-loader {} {
set result {}
set PKGINIT [my Config_get pkginit]
set PKG_NAME [my Config_get name [my Config_get pkg_name]]
set PKG_VERSION [my Config_get pkg_vers [my Config_get version]]
if {[string is true [my Config_get SHARED_BUILD 0]]} {
set LIBFILE [my Config_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 {
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
}
###
# This methods generates any Tcl script file
# which is required to pre-initialize the C library
###
method generate-tcl-pre {} {
| | | | | | | | | | | | | | | | | | | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
}
###
# 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 Config_get filename] [info object class [self]]]
set result {}
my variable code
if {[info exists code(tcl)]} {
set result [::practcl::_tagblock $code(tcl) tcl [my Config_get filename]]
}
if {[info exists code(tcl-pre)]} {
set result [::practcl::_tagblock $code(tcl) tcl [my Config_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 Config_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 Config_get filename]]
}
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-tcl-post]
}
return $result
}
method linktype {} {
return {subordinate product}
}
method Ofile filename {
set lpath [my <module> config get localpath]
if {$lpath eq {}} {
set lpath [my <module> config get name]
}
return ${lpath}_[file rootname [file tail $filename]]
}
###
# Methods called by the master project
###
method project-static-packages {} {
set result [my Config_get static_packages]
set initfunc [my Config_get initfunc]
if {$initfunc ne {}} {
set pkg_name [my Config_get pkg_name]
if {$pkg_name ne {}} {
dict set result $pkg_name initfunc $initfunc
dict set result $pkg_name version [my Config_get version [my Config_get pkg_vers]]
dict set result $pkg_name autoload [my Config_get autoload 0]
}
}
foreach item [my link list subordinate] {
foreach {pkg info} [$item project-static-packages] {
dict set result $pkg $info
}
}
return $result
}
###
# Methods called by the toolset
###
method toolset-include-directory {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result [my Config_get include_dir]
foreach obj [my link list product] {
foreach path [$obj toolset-include-directory] {
lappend result $path
}
}
return $result
}
method target {method args} {
switch $method {
is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] }
}
}
}
oo::objdefine ::practcl::product {
method select {object} {
set class [$object config get class]
set mixin [$object config get product]
if {$class eq {} && $mixin eq {}} {
set filename [$object config get filename]
if {$filename ne {} && [file exists $filename]} {
switch [file extension $filename] {
.tcl {
set mixin ::practcl::product.dynamic
}
.h {
set mixin ::practcl::product.cheader
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 |
# A product which generated from a C source file. Normally an object (.o) file.
###
::clay::define ::practcl::product.csource {
superclass ::practcl::product
method project-compile-products {} {
set result {}
| | | | | | | | | | | | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
# A product which generated from a C source file. Normally an object (.o) file.
###
::clay::define ::practcl::product.csource {
superclass ::practcl::product
method project-compile-products {} {
set result {}
set filename [my Config_get filename]
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
if {[my define exists ofile]} {
set ofile [my Config_get ofile]
} else {
set ofile [my Ofile $filename]
my Config_set ofile $ofile
}
lappend result $ofile [list cfile $filename extra [my Config_get extra] external [string is true -strict [my Config_get external]] object [self]]
}
foreach item [my link list subordinate] {
lappend result {*}[$item project-compile-products]
}
return $result
}
}
###
# A product which is generated from a compiled C library.
# Usually a .a or a .dylib file, but in complex cases may
# actually just be a conduit for one project to integrate the
# source code of another
###
::clay::define ::practcl::product.clibrary {
superclass ::practcl::product
method linker-products {configdict} {
return [my Config_get filename]
}
}
###
# A product which is generated from C code that itself is generated
# by practcl or some other means. This C file may or may not produce
# its own .o file, depending on whether it is eligible to become part
# of an amalgamation
###
::clay::define ::practcl::product.dynamic {
superclass ::practcl::dynamic ::practcl::product
method initialize {} {
set filename [my Config_get filename]
if {$filename eq {}} {
return
}
if {[my Config_get name] eq {}} {
my Config_set name [file tail [file rootname $filename]]
}
if {[my Config_get localpath] eq {}} {
my Config_set localpath [my <module> config get localpath]_[my Config_get name]
}
# Future Development:
# Scan source file to see if it is encoded in criticl or practcl notation
#set thisline {}
#foreach line [split [::practcl::cat $filename] \n] {
#
#}
::source $filename
if {[my Config_get output_c] ne {}} {
# Turn into a module if we have an output_c file
my morph ::practcl::module
}
}
}
###
# A binary product produced by critcl. Note: The implementation is not
# written yet, this class does nothing.
::clay::define ::practcl::product.critcl {
superclass ::practcl::dynamic ::practcl::product
}
|
Changes to modules/practcl/build/class/project/baseclass.tcl.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 |
# 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]
}
}
my graft module [self]
| | | | | | | | | | | | | | | | | | | | | | | | < < < < > | | < > > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
# 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]
}
}
my graft module [self]
my Config_merge $contents
::practcl::toolset select [self]
my initialize
}
method add_object object {
my link object $object
}
method add_project {pkg info {oodefine {}}} {
::practcl::debug [self] add_project $pkg $info
set os [my Config_get TEACUP_OS]
if {$os eq {}} {
set os [::practcl::os]
my Config_set os $os
}
set fossilinfo [list download [my Config_get download] tag trunk sandbox [my Config_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 Config_get profile release]:
if {[dict exists $info profile $profile]} {
dict set info tag [dict get $info profile $profile]
}
dict set info USEMSVC [my Config_get USEMSVC 0]
dict set info debug [my Config_get debug 0]
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 config set masterpath $::CWD
$obj go
return $obj
}
method add_tool {pkg info {oodefine {}}} {
::practcl::debug [self] add_tool $pkg $info
set info [dict merge [::practcl::local_os] $info]
set os [dict get $info TEACUP_OS]
set fossilinfo [list download [my Config_get download] tag trunk sandbox [my Config_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 Config_get profile release]:
if {[dict exists $info profile $profile]} {
dict set info tag [dict get $info profile $profile]
}
set obj ::practcl::OBJECT::TOOL.$pkg
if {[info command $obj] eq {}} {
set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0] $info]]
}
my link add tool $obj
oo::objdefine $obj $oodefine
$obj config set masterpath $::CWD
$obj go
return $obj
}
###
# Compile the Tcl core. If the define [emph tk] is true, compile the
# Tk core as well
###
method build-tclcore {} {
set os [my Config_get TEACUP_OS]
set tcl_config_opts [::practcl::platform::tcl_core_options $os]
set tk_config_opts [::practcl::platform::tk_core_options $os]
lappend tcl_config_opts --prefix [my Config_get prefix] --exec-prefix [my Config_get prefix]
set tclobj [my tclcore]
if {[my Config_get debug 0]} {
$tclobj config set debug 1
lappend tcl_config_opts --enable-symbols=true
}
$tclobj config set config_opts $tcl_config_opts
$tclobj go
$tclobj compile
set _TclSrcDir [$tclobj config get localsrcdir]
my Config_set tclsrcdir $_TclSrcDir
if {[my Config_get tk 0]} {
set tkobj [my tkcore]
lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj config get builddir] [$tclobj config get builddir]]
if {[my Config_get debug 0]} {
$tkobj config set debug 1
lappend tk_config_opts --enable-symbols=true
}
$tkobj config set config_opts $tk_config_opts
$tkobj compile
}
}
# A library can be a project, it can be a module. Any
# subordinate modules will indicate their existance
method Child_delegate {} {
return [list project [self] module [self]]
}
method Child_organs {} {
return [list project [self] module [self]]
}
method linktype {} {
return project
}
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/project/library.tcl.
1 2 3 4 5 6 7 8 |
###
# A toplevel project that produces a library
###
::clay::define ::practcl::library {
superclass ::practcl::project
method clean {PATH} {
| | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
###
# A toplevel project that produces a library
###
::clay::define ::practcl::library {
superclass ::practcl::project
method clean {PATH} {
set objext [my Config_get OBJEXT o]
foreach {ofile info} [my project-compile-products] {
if {[file exists [file join $PATH objs $ofile].${objext}]} {
file delete [file join $PATH objs $ofile].${objext}
}
}
foreach ofile [glob -nocomplain [file join $PATH *.${objext}]] {
file delete $ofile
}
foreach ofile [glob -nocomplain [file join $PATH objs *]] {
file delete $ofile
}
set libfile [my Config_get libfile]
if {[file exists [file join $PATH $libfile]]} {
file delete [file join $PATH $libfile]
}
my implement $PATH
}
method project-compile-products {} {
set result {}
foreach item [my link list subordinate] {
lappend result {*}[$item project-compile-products]
}
set filename [my Config_get output_c]
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
set ofile [file rootname [file tail $filename]]_main
lappend result $ofile [list cfile $filename extra [my Config_get extra] external [string is true -strict [my Config_get external]]]
}
return $result
}
method go {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set name [my Config_get name]
if {$name eq {}} {
set name generic
my define name generic
}
if {[my Config_get tk] eq {@TEA_TK_EXTENSION@}} {
my Config_set tk 0
}
set output_c [my Config_get output_c]
if {$output_c eq {}} {
set output_c [file rootname $name].c
my Config_set output_c $output_c
}
set output_h [my Config_get output_h]
if {$output_h eq {}} {
set output_h [file rootname $output_c].h
my Config_set output_h $output_h
}
set output_tcl [my Config_get output_tcl]
#if {$output_tcl eq {}} {
# set output_tcl [file rootname $output_c].tcl
# my Config_set output_tcl $output_tcl
#}
#set output_mk [my Config_get output_mk]
#if {$output_mk eq {}} {
# set output_mk [file rootname $output_c].mk
# my Config_set output_mk $output_mk
#}
set initfunc [my Config_get initfunc]
if {$initfunc eq {}} {
set initfunc [string totitle $name]_Init
my Config_set initfunc $initfunc
}
set output_decls [my Config_get output_decls]
if {$output_decls eq {}} {
set output_decls [file rootname $output_c].decls
my Config_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 Config_get filename] [info object class [self]]]
}
method generate-decls {pkgname path} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 {###
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
###
set stubfuncts [my generate-stub-function]
set thisline {}
set functcount 0
foreach {func header} $stubfuncts {
puts $fout [list declare [incr functcount] $header]
}
| | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
###
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 Config_get initfunc](Tcl_Inter *interp)"]
puts $fout [list export "char *[string totitle [my Config_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]
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
method implement path {
my go
my Collate_Source $path
set errs {}
foreach item [my link list dynamic] {
if {[catch {$item implement $path} err errdat]} {
| | | | | | | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
method implement path {
my go
my Collate_Source $path
set errs {}
foreach item [my link list dynamic] {
if {[catch {$item implement $path} err errdat]} {
lappend errs "Skipped $item: [$item config get filename] $err"
if {[dict exists $errdat -errorinfo]} {
lappend errs [dict get $errdat -errorinfo]
} else {
lappend errs $errdat
}
}
}
foreach item [my link list module] {
if {[catch {$item implement $path} err errdat]} {
lappend errs "Skipped $item: [$item config get filename] $err"
if {[dict exists $errdat -errorinfo]} {
lappend errs [dict get $errdat -errorinfo]
} else {
lappend errs $errdat
}
}
}
if {[llength $errs]} {
set logfile [file join $::CWD practcl.log]
::practcl::log $logfile "*** ERRORS ***"
foreach {item trace} $errs {
::practcl::log $logfile "###\n# ERROR\n###$item"
::practcl::log $logfile "###\n# TRACE\n###$trace"
}
::practcl::log $logfile "*** DEBUG INFO ***"
::practcl::log $logfile $::DEBUG_INFO
puts stderr "Errors saved to $logfile"
exit 1
}
set cout [open [file join $path [my Config_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 Config_get output_h]]]_H
set hout [open [file join $path [my Config_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} 1"
puts $hout [my generate-h]
puts $hout "#endif"
close $hout
set output_tcl [my Config_get output_tcl]
if {$output_tcl ne {}} {
set tclout [open [file join $path [my Config_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]
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
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 {}
| | | | | | | | | | | | | | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
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 Config_get pkg_name [my Config_get name]]
set version [my Config_get pkg_vers [my Config_get version]]
if {$version eq {}} {
set version 0.1a
}
set output_tcl [my Config_get output_tcl]
if {$output_tcl ne {}} {
set script "\[list source \[file join \$dir $output_tcl\]\]"
} elseif {[my Config_get SHARED_BUILD 0]} {
set script "\[list load \[file join \$dir [my Config_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 {{filename {}}} {
set name [string tolower [my Config_get name [my Config_get pkg_name]]]
set NAME [string toupper $name]
set version [my Config_get version [my Config_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 Config_get libprefix]
set outfile [string map $map [my Config_get PRACTCL_NAME_LIBRARY]][my Config_get SHLIB_SUFFIX]
return $outfile
}
method static_library {{filename {}}} {
set name [string tolower [my Config_get name [my Config_get pkg_name]]]
set NAME [string toupper $name]
set version [my Config_get version [my Config_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 Config_get libprefix]
set outfile [string map $map [my Config_get PRACTCL_NAME_LIBRARY]].a
return $outfile
}
}
|
Changes to modules/practcl/build/class/project/tclkit.tcl.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
#undef Tk_MainEx
#undef Tk_SafeInit
}
# Build an area of the file for #define directives and
# function declarations
set define {}
| | | | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
#undef Tk_MainEx
#undef Tk_SafeInit
}
# Build an area of the file for #define directives and
# function declarations
set define {}
set mainhook [$PROJECT config get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook]
set mainfunc [$PROJECT config get TCL_LOCAL_APPINIT Tclkit_AppInit]
set mainscript [$PROJECT config get main.tcl main.tcl]
set vfsroot [$PROJECT config get vfsroot "[$PROJECT config get ZIPFS_VOLUME]app"]
set vfs_main "${vfsroot}/${mainscript}"
set map {}
foreach var {
vfsroot mainhook mainfunc vfs_main
} {
dict set map %${var}% [set $var]
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
# then no user-specific startup file will be run under any conditions.
}
append main_init_script \n {if {[file exists [file join $::starkit::topdir pkgIndex.tcl]]} {
#In a wrapped exe, we don't go out to the environment
set dir $::starkit::topdir
source [file join $::starkit::topdir pkgIndex.tcl]
}}
| | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
# then no user-specific startup file will be run under any conditions.
}
append main_init_script \n {if {[file exists [file join $::starkit::topdir pkgIndex.tcl]]} {
#In a wrapped exe, we don't go out to the environment
set dir $::starkit::topdir
source [file join $::starkit::topdir pkgIndex.tcl]
}}
append main_init_script \n [list set tcl_rcFileName [$PROJECT config get tcl_rcFileName ~/.tclshrc]]
append preinitscript \n [list set ::starkit::thread_init $thread_init_script]
append preinitscript \n {eval $::starkit::thread_init}
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 config get tip_430 0]} {
# Add declarations of functions that tip430 puts in the stub files
$PROJECT code public-header {
int TclZipfs_Init(Tcl_Interp *interp);
int TclZipfs_Mount(
Tcl_Interp *interp,
const char *mntpt,
const char *zipname,
|
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
break
}
}
}])\;"
::practcl::cputs zvfsboot " \x7D"
::practcl::cputs zvfsboot " return TCL_OK;"
| | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
break
}
}
}])\;"
::practcl::cputs zvfsboot " \x7D"
::practcl::cputs zvfsboot " return TCL_OK;"
if {[$PROJECT config 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;
}
}
if {![$PROJECT config get tip_430 0]} {
::practcl::cputs appinit { TclZipfs_Init(interp);}
}
foreach {statpkg info} $statpkglist {
set initfunc {}
if {[dict exists $info initfunc]} {
set initfunc [dict get $info initfunc]
}
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);"
practcl::cputs appinit { return TCL_OK;}
$PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit]
}
method Collate_Source CWD {
next $CWD
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);"
practcl::cputs appinit { return TCL_OK;}
$PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit]
}
method Collate_Source CWD {
next $CWD
set name [my Config_get name]
# Assume a static shell
if {[my define exists SHARED_BUILD]} {
my Config_set SHARED_BUILD 0
}
if {![my define exists TCL_LOCAL_APPINIT]} {
my Config_set TCL_LOCAL_APPINIT Tclkit_AppInit
}
if {![my define exists TCL_LOCAL_MAIN_HOOK]} {
my Config_set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook
}
set PROJECT [self]
set os [$PROJECT config get TEACUP_OS]
if {[my Config_get SHARED_BUILD 0]} {
puts [list BUILDING TCLSH FOR OS $os]
} else {
puts [list BUILDING KIT FOR OS $os]
}
set TCLOBJ [$PROJECT tclcore]
::practcl::toolset select $TCLOBJ
set TCLSRCDIR [$TCLOBJ config get srcdir]
set PKG_OBJS {}
foreach item [$PROJECT link list core.library] {
if {[string is true [$item config get static]]} {
lappend PKG_OBJS $item
}
}
foreach item [$PROJECT link list package] {
if {[string is true [$item config 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 Config_get SHARED_BUILD 0]} {
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 Config_get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my Config_get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my Config_get TCL_LOCAL_APPINIT Tclkit_AppInit]]
} else {
set PLATFORM_SRC_DIR unix
my add class csource ofile [my Config_get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my Config_get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my Config_get TCL_LOCAL_APPINIT Tclkit_AppInit]]
}
if {![my Config_get SHARED_BUILD 0]} {
###
# 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 config set ZIPFS_VOLUME "zipfs:/"
}
$PROJECT code header "#define ZIPFS_VOLUME \"[$PROJECT config get ZIPFS_VOLUME]\""
if {[file exists $zipfs]} {
$TCLOBJ config set tip_430 1
my Config_set tip_430 1
} else {
# The Tclconfig project maintains a mirror of the version
# released with the Tcl core
my Config_set tip_430 0
set tclzipfs_c [my Config_get tclzipfs_c]
if {![file exists $tclzipfs_c]} {
::practcl::LOCAL tool tclconfig unpack
set COMPATSRCROOT [::practcl::LOCAL tool tclconfig config get srcdir]
set tclzipfs_c [file join $COMPATSRCROOT compat tclZipfs.c]
}
my add class csource ofile tclZipfs.o filename $tclzipfs_c \
extra -I[::practcl::file_relative $CWD [file join $TCLSRCDIR compat zlib contrib minizip]]
}
my Config_add include_dir [file join $TCLSRCDIR generic]
my Config_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 config get name]
set libsrcdir [$item config get srcdir]
if {[file exists [file join $libsrcdir library]]} {
::practcl::copyDir [file join $libsrcdir library] [file join $vfspath ${name}_library]
}
}
# Assume the user will populate the VFS path
#if {[my Config_get installdir] ne {}} {
# ::practcl::copyDir [file join [my Config_get installdir] [string trimleft [my Config_get prefix] /] lib] [file join $vfspath lib]
#}
foreach arg $args {
::practcl::copyDir $arg $vfspath
}
set fout [open [file join $vfspath pkgIndex.tcl] w]
puts $fout [string map [list %platform% [my Config_get TEACUP_PROFILE]] {set ::tcl_teapot_profile {%platform%}}]
puts $fout {
namespace eval ::starkit {}
set ::PKGIDXFILE [info script]
set dir [file dirname $::PKGIDXFILE]
if {$::tcl_platform(platform) eq "windows"} {
set ::starkit::localHome [file join [file normalize $::env(LOCALAPPDATA)] tcl]
} else {
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
if {![file exists $pkginstall]} {
installDir $teapath $pkginstall
}
}
}
close $fout
| | | | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
if {![file exists $pkginstall]} {
installDir $teapath $pkginstall
}
}
}
close $fout
set EXEEXT [my Config_get EXEEXT]
set tclkit_bare [my Config_get tclkit_bare]
::practcl::mkzip ${exename}${EXEEXT} $tclkit_bare $vfspath
if { [my Config_get TEACUP_OS] ne "windows" } {
file attributes ${exename}${EXEEXT} -permissions a+x
}
}
}
|
Changes to modules/practcl/build/class/subproject/baseclass.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 |
###
# A subordinate project
###
::clay::define ::practcl::subproject {
superclass ::practcl::module
method _MorphPatterns {} {
return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
}
method BuildDir {PWD} {
| | < < < < > | | < > > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
###
# A subordinate project
###
::clay::define ::practcl::subproject {
superclass ::practcl::module
method _MorphPatterns {} {
return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
}
method BuildDir {PWD} {
return [my Config_get srcdir]
}
# A library can be a project, it can be a module. Any
# subordinate modules will indicate their existance
method Child_delegate {} {
return [list project [self] module [self]]
}
method Child_organs {} {
return [list project [self] module [self]]
}
method compile {} {}
method go {} {
::practcl::distribution select [self]
set name [my Config_get name]
my Config_set builddir [my BuildDir [my Config_get masterpath]]
my Config_set builddir [my BuildDir [my Config_get masterpath]]
my sources
}
# Install project into the local build system
method install args {}
method linktype {} {
|
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
# process
###
###
# Load the facility into the interpreter
###
method env-bootstrap {} {
| | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
# process
###
###
# Load the facility into the interpreter
###
method env-bootstrap {} {
set pkg [my Config_get pkg_name [my Config_get name]]
package require $pkg
}
###
# Return a file path that exec can call
###
method env-exec {} {}
|
| ︙ | ︙ | |||
102 103 104 105 106 107 108 |
set loaded 1
}
###
# Check if tool is available for load/already loaded
###
method env-present {} {
| | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
set loaded 1
}
###
# Check if tool is available for load/already loaded
###
method env-present {} {
set pkg [my Config_get pkg_name [my Config_get name]]
if {[catch [list package require $pkg]]} {
return 0
}
return 1
}
method sources {} {}
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
# A project which the kit compiles and integrates
# the source for itself
###
::clay::define ::practcl::subproject.source {
superclass ::practcl::subproject ::practcl::library
method env-bootstrap {} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
# A project which the kit compiles and integrates
# the source for itself
###
::clay::define ::practcl::subproject.source {
superclass ::practcl::subproject ::practcl::library
method env-bootstrap {} {
set LibraryRoot [file join [my Config_get srcdir] [my Config_get module_root modules]]
if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
}
}
method env-present {} {
set path [my Config_get srcdir]
return [file exists $path]
}
method linktype {} {
return {subordinate package source}
}
}
# a copy from the teapot
::clay::define ::practcl::subproject.teapot {
superclass ::practcl::subproject
method env-bootstrap {} {
set pkg [my Config_get pkg_name [my Config_get name]]
package require $pkg
}
method env-install {} {
set pkg [my Config_get pkg_name [my Config_get name]]
set download [my <project> config get download]
my unpack
set prefix [string trimleft [my <project> config get prefix] /]
::practcl::tcllib_require zipfile::decode
::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $prefix lib $pkg]
}
method env-present {} {
set pkg [my Config_get pkg_name [my Config_get name]]
if {[catch [list package require $pkg]]} {
return 0
}
return 1
}
method install DEST {
set pkg [my Config_get pkg_name [my Config_get name]]
set download [my <project> config get download]
my unpack
set prefix [string trimleft [my <project> config get prefix] /]
::practcl::tcllib_require zipfile::decode
::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg]
}
}
::clay::define ::practcl::subproject.kettle {
superclass ::practcl::subproject
method kettle {path args} {
my variable kettle
if {![info exists kettle]} {
::practcl::LOCAL tool kettle env-load
set kettle [file join [::practcl::LOCAL tool kettle config get srcdir] kettle]
}
set srcdir [my SourceRoot]
::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args
}
method install DEST {
my kettle reinstall --prefix $DEST
}
}
::clay::define ::practcl::subproject.critcl {
superclass ::practcl::subproject
method install DEST {
my critcl -pkg [my Config_get name]
set srcdir [my SourceRoot]
::practcl::copyDir [file join $srcdir [my Config_get name]] [file join $DEST lib [my Config_get name]]
}
}
::clay::define ::practcl::subproject.sak {
superclass ::practcl::subproject
method env-bootstrap {} {
set LibraryRoot [file join [my Config_get srcdir] [my Config_get module_root modules]]
if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
}
}
method env-install {} {
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
my unpack
set prefix [my <project> config get prefix [file normalize [file join ~ tcl]]]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir installer.tcl] \
-apps -app-path [file join $prefix apps] \
-html -html-path [file join $prefix doc html $pkg] \
-pkg-path [file join $prefix lib $pkg] \
-no-nroff -no-wait -no-gui
}
method env-present {} {
set path [my Config_get srcdir]
return [file exists $path]
}
method install DEST {
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
my unpack
set prefix [string trimleft [my <project> config get prefix] /]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir installer.tcl] \
-pkg-path [file join $DEST $prefix lib $pkg] \
-no-examples -no-html -no-nroff \
-no-wait -no-gui -no-apps
}
method install-module {DEST args} {
set srcdir [my Config_get srcdir]
if {[llength $args]==1 && [lindex $args 0] in {* all}} {
set pkg [my Config_get pkg_name [my Config_get name]]
::practcl::dotclexec [file join $srcdir installer.tcl] \
-pkg-path [file join $DEST $pkg] \
-no-examples -no-html -no-nroff \
-no-wait -no-gui -no-apps
} else {
foreach module $args {
::practcl::installModule [file join $srcdir modules $module] [file join $DEST $module]
}
}
}
}
::clay::define ::practcl::subproject.practcl {
superclass ::practcl::subproject
method env-bootstrap {} {
set LibraryRoot [file join [my Config_get srcdir] [my Config_get module_root modules]]
if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
}
}
method env-install {} {
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
my unpack
set prefix [my <project> config get prefix [file normalize [file join ~ tcl]]]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir make.tcl] install [file join $prefix lib $pkg]
}
method install DEST {
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
my unpack
set prefix [string trimleft [my <project> config get prefix] /]
set srcdir [my Config_get srcdir]
puts [list INSTALLING [my Config_get name] to [file join $DEST $prefix lib $pkg]]
::practcl::dotclexec [file join $srcdir make.tcl] install [file join $DEST $prefix lib $pkg]
}
method install-module {DEST args} {
set pkg [my Config_get pkg_name [my Config_get name]]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir make.tcl] install-module $DEST {*}$args
}
}
|
Changes to modules/practcl/build/class/subproject/binary.tcl.
1 2 3 4 5 6 7 |
###
# A subordinate binary package
###
::clay::define ::practcl::subproject.binary {
superclass ::practcl::subproject
method clean {} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
###
# A subordinate binary package
###
::clay::define ::practcl::subproject.binary {
superclass ::practcl::subproject
method clean {} {
set builddir [file normalize [my Config_get builddir]]
if {![file exists $builddir]} return
if {[file exists [file join $builddir make.tcl]]} {
::practcl::domake.tcl $builddir clean
} else {
catch {::practcl::domake $builddir clean}
}
}
method env-install {} {
###
# Handle tea installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
set os [::practcl::local_os]
my Config_set os $os
my unpack
set prefix [my <project> config get prefix [file normalize [file join ~ tcl]]]
set srcdir [my Config_get srcdir]
lappend options --prefix $prefix --exec-prefix $prefix
my Config_set config_opts $options
my go
my clean
my compile
my make install {}
}
method project-compile-products {} {}
method ComputeInstall {} {
if {[my define exists install]} {
switch [my Config_get install] {
static {
my Config_set static 1
my Config_set autoload 0
}
static-autoload {
my Config_set static 1
my Config_set autoload 1
}
vfs {
my Config_set static 0
my Config_set autoload 0
my Config_set vfsinstall 1
}
null {
my Config_set static 0
my Config_set autoload 0
my Config_set vfsinstall 0
}
default {
}
}
}
}
method go {} {
next
::practcl::distribution select [self]
my ComputeInstall
my Config_set builddir [my BuildDir [my Config_get masterpath]]
}
method linker-products {configdict} {
if {![my Config_get static 0]} {
return {}
}
set srcdir [my Config_get builddir]
if {[dict exists $configdict libfile]} {
return " [file join $srcdir [dict get $configdict libfile]]"
}
}
method project-static-packages {} {
if {![my Config_get static 0]} {
return {}
}
set result [my Config_get static_packages]
set statpkg [my Config_get static_pkg]
set initfunc [my Config_get initfunc]
if {$initfunc ne {}} {
set pkg_name [my Config_get pkg_name]
if {$pkg_name ne {}} {
dict set result $pkg_name initfunc $initfunc
set version [my Config_get version]
if {$version eq {}} {
my unpack
set info [my read_configuration]
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 Config_set version $version
}
dict set result $pkg_name version $version
dict set result $pkg_name autoload [my Config_get autoload 0]
}
}
foreach item [my link list subordinate] {
foreach {pkg info} [$item project-static-packages] {
dict set result $pkg $info
}
}
return $result
}
method BuildDir {PWD} {
set name [my Config_get name]
set debug [my Config_get debug 0]
if {[my <project> config get LOCAL 0]} {
return [my Config_get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my Config_get builddir [file join $PWD debug $name]]
} else {
return [my Config_get builddir [file join $PWD pkg $name]]
}
}
method compile {} {
set name [my Config_get name]
set PWD $::CWD
cd $PWD
my unpack
set srcdir [file normalize [my SrcDir]]
set localsrcdir [my MakeDir $srcdir]
my Config_set localsrcdir $localsrcdir
my Collate_Source $PWD
###
# Build a starter VFS for both Tcl and wish
###
set srcdir [my Config_get srcdir]
if {[my Config_get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
my make compile
cd $PWD
}
method Configure {} {
cd $::CWD
my unpack
::practcl::toolset select [self]
set srcdir [file normalize [my Config_get srcdir]]
set builddir [file normalize [my Config_get builddir]]
file mkdir $builddir
my make autodetect
}
method install DEST {
set PWD [pwd]
set PREFIX [my <project> config get prefix]
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
if {[my <project> config get teapot] ne {}} {
set TEAPOT [my <project> config get teapot]
set found 0
foreach ver [my Config_get pkg_vers [my Config_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
}
}
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/subproject/core.tcl.
1 2 3 4 5 6 7 |
::clay::define ::practcl::subproject.core {
superclass ::practcl::subproject.binary
method env-bootstrap {} {}
method env-present {} {
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
::clay::define ::practcl::subproject.core {
superclass ::practcl::subproject.binary
method env-bootstrap {} {}
method env-present {} {
set PREFIX [my <project> config get prefix]
set name [my Config_get name]
set fname [file join $PREFIX lib ${name}Config.sh]
return [file exists $fname]
}
method env-install {} {
my unpack
set os [::practcl::local_os]
set prefix [my <project> config get prefix [file normalize [file join ~ tcl]]]
lappend options --prefix $prefix --exec-prefix $prefix
my Config_set config_opts $options
puts [list [self] OS [dict get $os TEACUP_OS] options $options]
my go
my compile
my make install {}
}
method go {} {
my Config_set core_binary 1
next
}
method linktype {} {
return {subordinate core.library}
}
}
|
Changes to modules/practcl/build/class/target.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
###
# A build deliverable object. Normally an object file, header, or tcl script
# which must be compiled or generated in some way
###
::clay::define ::practcl::make_obj {
superclass ::practcl::metaclass
constructor {module_object name info {action_body {}}} {
my variable define triggered domake
set triggered 0
set domake 0
| < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
###
# A build deliverable object. Normally an object file, header, or tcl script
# which must be compiled or generated in some way
###
::clay::define ::practcl::make_obj {
superclass ::practcl::metaclass
constructor {module_object name info {action_body {}}} {
my variable define triggered domake
set triggered 0
set domake 0
my Config_set name $name action {}
my Config_merge $info
my select
my initialize
foreach {stub obj} [$module_object child organs] {
my graft $stub $obj
}
if {$action_body ne {}} {
my Config_set action $action_body
}
}
method do {} {
my variable domake
return $domake
}
method check {} {
my variable needs_make domake
if {$domake} {
return 1
}
if {[info exists needs_make]} {
return $needs_make
}
set make_objects [my <module> make objects]
set needs_make 0
foreach item [my Config_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]} {
|
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
}
}
return $needs_make
}
method output {} {
set result {}
| | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
}
}
return $needs_make
}
method output {} {
set result {}
set filename [my Config_get filename]
if {$filename ne {}} {
lappend result $filename
}
foreach filename [my Config_get files] {
if {$filename ne {}} {
lappend result $filename
}
}
return $result
}
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
my variable triggered domake define
if {$triggered} {
return $domake
}
set triggered 1
set make_objects [my <module> make objects]
| | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
my variable triggered domake define
if {$triggered} {
return $domake
}
set triggered 1
set make_objects [my <module> make objects]
foreach item [my Config_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
}
}
}
set domake 1
my <module> make trigger {*}[my Config_get triggers]
}
}
|
Changes to modules/practcl/build/class/tool.tcl.
1 2 3 4 5 6 7 8 |
###
# Create an object to represent the local environment
###
set ::practcl::MAIN ::practcl::LOCAL
# Defer the creation of the ::practcl::LOCAL object until it is called
# in order to allow packages to
set ::auto_index(::practcl::LOCAL) {
::practcl::project create ::practcl::LOCAL
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
###
# Create an object to represent the local environment
###
set ::practcl::MAIN ::practcl::LOCAL
# Defer the creation of the ::practcl::LOCAL object until it is called
# in order to allow packages to
set ::auto_index(::practcl::LOCAL) {
::practcl::project create ::practcl::LOCAL
::practcl::LOCAL config set [::practcl::local_os]
::practcl::LOCAL config set LOCAL 1
# Until something better comes along, use ::practcl::LOCAL
# as our main project
# Add tclconfig as a project of record
::practcl::LOCAL add_tool tclconfig {
name tclconfig tag practcl class subproject.source fossil_url http://core.tcl.tk/tclconfig
}
|
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
modules lib
} {
method env-bootstrap {} {
package require critcl::app
}
method env-install {} {
my unpack
| | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
modules lib
} {
method env-bootstrap {} {
package require critcl::app
}
method env-install {} {
my unpack
set prefix [my <project> config get prefix [file join [file normalize ~] tcl]]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir build.tcl] install [file join $prefix lib]
}
}
::practcl::LOCAL add_tool odie {
tag trunk class subproject.source
fossil_url http://fossil.etoyoc.com/fossil/odie
}
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/toolset/baseclass.tcl.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
###
method config.sh {} {
return [my read_configuration]
}
# Compute the location where the product will be built
method BuildDir {PWD} {
| | | | | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
###
method config.sh {} {
return [my read_configuration]
}
# Compute the location where the product will be built
method BuildDir {PWD} {
set name [my Config_get name]
set debug [my Config_get debug 0]
if {[my <project> config get LOCAL 0]} {
return [my Config_get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my Config_get builddir [file join $PWD debug $name]]
} else {
return [my Config_get builddir [file join $PWD pkg $name]]
}
}
# Return where the Makefile is located relative to [emph srcdir].
# For this implementation the MakeDir is always srcdir.
method MakeDir {srcdir} {
return $srcdir
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
# Configure method is invoked
method read_configuration {} {
my variable conf_result
if {[info exists conf_result]} {
return $conf_result
}
set result {}
| | | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
# Configure method is invoked
method read_configuration {} {
my variable conf_result
if {[info exists conf_result]} {
return $conf_result
}
set result {}
set name [my Config_get name]
set PWD $::CWD
set builddir [my Config_get builddir]
my unpack
set srcdir [my Config_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::read_configuration $builddir]
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
# 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
| | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
# 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} config get name [${PROJECT} config get pkg_name]]]
set NAME [string toupper $name]
set version [${PROJECT} config get version [${PROJECT} config get pkg_vers]]
if {$version eq {}} {
set version 0.1a
}
set defs $DEFS
foreach flag {
-DPACKAGE_NAME
-DPACKAGE_VERSION
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 |
return $defs
}
# Invoke critcl in an external process
method critcl args {
if {![info exists critcl]} {
::practcl::LOCAL tool critcl env-load
| | | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
return $defs
}
# Invoke critcl in an external process
method critcl args {
if {![info exists critcl]} {
::practcl::LOCAL tool critcl env-load
set critcl [file join [::practcl::LOCAL tool critcl config get srcdir] main.tcl
}
set srcdir [my SourceRoot]
set PWD [pwd]
cd $srcdir
::practcl::dotclexec $critcl {*}$args
cd $PWD
}
}
oo::objdefine ::practcl::toolset {
# Perform the selection for the toolset mixin
method select object {
###
# Select the toolset to use for this project
###
if {[$object define exists toolset]} {
return [$object config get toolset]
}
set class [$object config get toolset]
if {$class ne {}} {
$object clay mixinmap toolset $class
} else {
if {[info exists ::env(VisualStudioVersion)]} {
$object clay mixinmap toolset ::practcl::toolset.msvc
} else {
$object clay mixinmap toolset ::practcl::toolset.gcc
}
}
}
}
|
Changes to modules/practcl/build/class/toolset/gcc.tcl.
1 2 3 4 5 6 7 8 9 10 |
::clay::define ::practcl::toolset.gcc {
superclass ::practcl::toolset
method Autoconf {} {
###
# Re-run autoconf for this project
# Not a good idea in practice... but in the right hands it can be useful
###
set pwd [pwd]
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
::clay::define ::practcl::toolset.gcc {
superclass ::practcl::toolset
method Autoconf {} {
###
# Re-run autoconf for this project
# Not a good idea in practice... but in the right hands it can be useful
###
set pwd [pwd]
set srcdir [file normalize [my Config_get srcdir]]
set localsrcdir [my MakeDir $srcdir]
cd $localsrcdir
foreach template {configure.ac configure.in} {
set input [file join $srcdir $template]
if {[file exists $input]} {
puts "autoconf -f $input > [file join $srcdir configure]"
exec autoconf -f $input > [file join $srcdir configure]
}
}
cd $pwd
}
method BuildDir {PWD} {
set name [my Config_get name]
set debug [my Config_get debug 0]
if {[my <project> config get LOCAL 0]} {
return [my Config_get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my Config_get builddir [file join $PWD debug $name]]
} else {
return [my Config_get builddir [file join $PWD pkg $name]]
}
}
method ConfigureOpts {} {
set opts {}
set builddir [my Config_get builddir]
if {[my Config_get broken_destroot 0]} {
set PREFIX [my <project> config get prefix_broken_destdir]
} else {
set PREFIX [my <project> config get prefix]
}
switch [my Config_get name] {
tcl {
set opts [::practcl::platform::tcl_core_options [my <project> config get TEACUP_OS]]
}
tk {
set opts [::practcl::platform::tk_core_options [my <project> config get TEACUP_OS]]
}
}
if {[my <project> config get CONFIG_SITE] != {}} {
lappend opts --host=[my <project> config get HOST]
}
set inside_msys [string is true -strict [my <project> config get MSYS_ENV 0]]
lappend opts --with-tclsh=[info nameofexecutable]
if {[my Config_get tk 0]} {
if {![my <project> config get LOCAL 0]} {
set obj [my <project> tclcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj config get builddir]]
} else {
lappend opts --with-tcl=[file normalize [$obj config get builddir]]
}
}
set obj [my <project> tkcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj config get builddir]]
} else {
lappend opts --with-tk=[file normalize [$obj config get builddir]]
}
}
} else {
lappend opts --with-tcl=[file join $PREFIX lib]
lappend opts --with-tk=[file join $PREFIX lib]
}
} else {
if {![my <project> config get LOCAL 0]} {
set obj [my <project> tclcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj config get builddir]]
} else {
lappend opts --with-tcl=[file normalize [$obj config get builddir]]
}
}
} else {
lappend opts --with-tcl=[file join $PREFIX lib]
}
}
lappend opts {*}[my Config_get config_opts]
if {![regexp -- "--prefix" $opts]} {
lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX
}
if {[my Config_get debug 0]} {
lappend opts --enable-symbols=true
}
#--exec_prefix=$PREFIX
#if {$::tcl_platform(platform) eq "windows"} {
# lappend opts --disable-64bit
#}
if {[my Config_get static 1]} {
lappend opts --disable-shared
#--disable-stubs
#
} else {
lappend opts --enable-shared
}
return $opts
}
# Detect what directory contains the Makefile template
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
my Config_add include_dir [file join $srcdir generic]
}
set os [my <project> config get TEACUP_OS]
switch $os {
windows {
if {[file exists [file join $srcdir win]]} {
my Config_add include_dir [file join $srcdir win]
}
if {[file exists [file join $srcdir win Makefile.in]]} {
set localsrcdir [file join $srcdir win]
}
}
macosx {
if {[file exists [file join $srcdir unix Makefile.in]]} {
set localsrcdir [file join $srcdir unix]
}
}
default {
if {[file exists [file join $srcdir $os]]} {
my Config_add include_dir [file join $srcdir $os]
}
if {[file exists [file join $srcdir unix]]} {
my Config_add include_dir [file join $srcdir unix]
}
if {[file exists [file join $srcdir $os Makefile.in]]} {
set localsrcdir [file join $srcdir $os]
} elseif {[file exists [file join $srcdir unix Makefile.in]]} {
set localsrcdir [file join $srcdir unix]
}
}
}
return $localsrcdir
}
Ensemble make::autodetect {} {
set srcdir [my Config_get srcdir]
set localsrcdir [my MakeDir $srcdir]
if {$localsrcdir eq {}} {
set localsrcdir $srcdir
}
if {$srcdir eq $localsrcdir} {
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 config 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 builddir [my Config_get builddir]
file mkdir $builddir
if {![file exists [file join $localsrcdir configure]]} {
if {[file exists [file join $localsrcdir autogen.sh]]} {
cd $localsrcdir
catch {exec sh autogen.sh >>& [file join $builddir autoconf.log]}
cd $::CWD
}
}
set opts [my ConfigureOpts]
if {[file exists [file join $builddir autoconf.log]]} {
file delete [file join $builddir autoconf.log]
}
::practcl::debug [list PKG [my Config_get name] CONFIGURE {*}$opts]
::practcl::log [file join $builddir autoconf.log] [list CONFIGURE {*}$opts]
cd $builddir
if {[my <project> config get CONFIG_SITE] ne {}} {
set ::env(CONFIG_SITE) [my <project> config get CONFIG_SITE]
}
catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]}
cd $::CWD
}
Ensemble make::clean {} {
set builddir [file normalize [my Config_get builddir]]
catch {::practcl::domake $builddir clean}
}
Ensemble make::compile {} {
set name [my Config_get name]
set srcdir [my Config_get srcdir]
if {[my Config_get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
cd $::CWD
set builddir [file normalize [my Config_get builddir]]
file mkdir $builddir
if {![file exists [file join $builddir Makefile]]} {
my Configure
}
if {[file exists [file join $builddir make.tcl]]} {
if {[my Config_get debug 0]} {
::practcl::domake.tcl $builddir debug all
} else {
::practcl::domake.tcl $builddir all
}
} else {
::practcl::domake $builddir all
}
}
Ensemble make::install DEST {
set PWD [pwd]
set builddir [my Config_get builddir]
if {[my <project> config get LOCAL 0] || $DEST eq {}} {
if {[file exists [file join $builddir make.tcl]]} {
puts "[self] Local INSTALL (Practcl)"
::practcl::domake.tcl $builddir install
} elseif {[my Config_get broken_destroot 0] == 0} {
puts "[self] Local INSTALL (TEA)"
::practcl::domake $builddir install
}
} else {
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 Config_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=[::practcl::file_relative $builddir $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> config get prefix]
set BROKENROOT [::practcl::msys_to_tclpath [my <project> config 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 build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} {
set objext [my Config_get OBJEXT o]
set EXTERN_OBJS {}
set OBJECTS {}
set result {}
set builddir [$PROJECT config get builddir]
file mkdir [file join $builddir objs]
set debug [$PROJECT config get debug 0]
set task {}
###
# Compile the C sources
###
::practcl::debug ### COMPILE PRODUCTS
foreach {ofile info} [${PROJECT} project-compile-products] {
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 |
error "Failed to produce $filename"
}
}
return $result
}
method build-Makefile {path PROJECT} {
| | | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
error "Failed to produce $filename"
}
}
return $result
}
method build-Makefile {path PROJECT} {
array set proj [$PROJECT config dump]
set path $proj(builddir)
cd $path
set includedir .
set objext [my Config_get OBJEXT o]
#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 toolset-include-directory] {
set cpath [::practcl::file_relative $path [file normalize $include]]
if {$cpath ni $includedir} {
|
| ︙ | ︙ | |||
415 416 417 418 419 420 421 |
::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)]
| | | | | | | | | | | | | | | | | | | | | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
::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 config get libprefix]
if {[string is true [$PROJECT config get SHARED_BUILD]]} {
set outfile [$PROJECT config get libfile]
} else {
set outfile [$PROJECT shared_library]
}
$PROJECT config 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 config get PRACTCL_SHARED_LIB]]"
if {[$PROJECT config get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} {
::practcl::cputs result "\t[string map $map [$PROJECT config get PRACTCL_VC_MANIFEST_EMBED_DLL]]"
}
::practcl::cputs result {}
if {[string is true [$PROJECT config get SHARED_BUILD]]} {
#set outfile [$PROJECT static_library]
set outfile $proj(name).a
} else {
set outfile [$PROJECT config get libfile]
}
$PROJECT config set static_library $outfile
dict set map %OUTFILE% $outfile
::practcl::cputs result "$outfile: \$(${NAME}_OBJS)"
::practcl::cputs result "\t[string map $map [$PROJECT config get PRACTCL_STATIC_LIB]]"
::practcl::cputs result {}
return $result
}
###
# Produce a static or dynamic library
###
method build-library {outfile PROJECT} {
array set proj [$PROJECT config 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]]]
if {[$PROJECT config get TEA_PRIVATE_TCL_HEADERS 0]} {
if {[$PROJECT config get TEA_PLATFORM] eq "windows"} {
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) win]]]
} else {
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) unix]]]
}
}
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]]
if {[$PROJECT config 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]]]
if {[$PROJECT config get TEA_PRIVATE_TK_HEADERS 0]} {
if {[$PROJECT config get TEA_PLATFORM] eq "windows"} {
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) win]]]
} else {
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) unix]]]
}
}
lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]]
}
foreach include [$PROJECT toolset-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 config get debug 0]
set os [$PROJECT config 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)]} {
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 |
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)"
| | | | | | | | | | | | | | | | | | | | | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
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 config get SHARED_BUILD 1]]} {
set cmd [$PROJECT config get PRACTCL_SHARED_LIB]
append cmd " [$PROJECT config get PRACTCL_LIBS]"
set cmd [string map $map $cmd]
puts $cmd
exec {*}$cmd >&@ stdout
if {[$PROJECT config get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} {
set cmd [string map $map [$PROJECT config get PRACTCL_VC_MANIFEST_EMBED_DLL]]
puts $cmd
exec {*}$cmd >&@ stdout
}
} else {
set cmd [string map $map [$PROJECT config get PRACTCL_STATIC_LIB]]
puts $cmd
exec {*}$cmd >&@ stdout
}
set ranlib [$PROJECT config get RANLIB]
if {$ranlib ni {{} :}} {
catch {exec $ranlib $outfile}
}
}
###
# Produce a static executable
###
method build-tclsh {outfile PROJECT {path {auto}}} {
if {[my Config_get tk 0] && [my Config_get static_tk 0]} {
puts " BUILDING STATIC TCL/TK EXE $PROJECT"
set TKOBJ [$PROJECT tkcore]
if {[info command $TKOBJ] eq {}} {
set TKOBJ ::noop
$PROJECT config set static_tk 0
} else {
::practcl::toolset select $TKOBJ
array set TK [$TKOBJ read_configuration]
set do_tk [$TKOBJ config get static]
$PROJECT config set static_tk $do_tk
$PROJECT config set tk $do_tk
set TKSRCDIR [$TKOBJ config get srcdir]
}
} else {
puts " BUILDING STATIC TCL EXE $PROJECT"
set TKOBJ ::noop
my Config_set static_tk 0
}
set TCLOBJ [$PROJECT tclcore]
::practcl::toolset select $TCLOBJ
set PKG_OBJS {}
foreach item [$PROJECT link list core.library] {
if {[string is true [$item config get static]]} {
lappend PKG_OBJS $item
}
}
foreach item [$PROJECT link list package] {
if {[string is true [$item config get static]]} {
lappend PKG_OBJS $item
}
}
array set TCL [$TCLOBJ read_configuration]
if {$path in {{} auto}} {
set path [file dirname [file normalize $outfile]]
}
if {$path eq "."} {
set path [pwd]
}
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 config 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 read_configuration]
}
set os [$PROJECT config get TEACUP_OS]
set TCLSRCDIR [$TCLOBJ config get srcdir]
set includedir .
foreach include [$TCLOBJ toolset-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]]
if {[$PROJECT config get static_tk]} {
lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR generic]]]
lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR ttk]]]
lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR xlib]]]
lappend includedir [::practcl::file_relative $path [file normalize $TKSRCDIR]]
}
foreach include [$PROJECT toolset-include-directory] {
|
| ︙ | ︙ | |||
648 649 650 651 652 653 654 |
$TCL(cflags_warning) $TCL(extra_cflags)"
}
append COMPILE " " $defs
lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES]
set TCLSRC [file normalize $TCLSRCDIR]
| | | | | | | | | | | 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
$TCL(cflags_warning) $TCL(extra_cflags)"
}
append COMPILE " " $defs
lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES]
set TCLSRC [file normalize $TCLSRCDIR]
if {[${PROJECT} config get TEACUP_OS] eq "windows"} {
set windres [$PROJECT config get RC windres]
set RSOBJ [file join $path objs tclkit.res.o]
set RCSRC [${PROJECT} config get kit_resource_file]
set RCMAN [${PROJECT} config get kit_manifest_file]
set RCICO [${PROJECT} config get kit_icon_file]
set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]]
if {[$PROJECT config get static_tk]} {
if {$RCSRC eq {} || ![file exists $RCSRC]} {
set RCSRC [file join $TKSRCDIR win rc wish.rc]
}
if {$RCMAN eq {} || ![file exists $RCMAN]} {
set RCMAN [file join [$TKOBJ config get builddir] wish.exe.manifest]
}
if {$RCICO eq {} || ![file exists $RCICO]} {
set RCICO [file join $TKSRCDIR win rc wish.ico]
}
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 win tclsh.rc]
}
if {$RCMAN eq {} || ![file exists $RCMAN]} {
set RCMAN [file join [$TCLOBJ config get builddir] tclsh.exe.manifest]
}
if {$RCICO eq {} || ![file exists $RCICO]} {
set RCICO [file join $TCLSRCDIR win tclsh.ico]
}
}
foreach item [${PROJECT} config get resource_include] {
lappend cmd --include [::practcl::file_relative $path [file normalize $item]]
}
lappend cmd [file tail $RCSRC]
if {![file exists [file join $path [file tail $RCSRC]]]} {
file copy -force $RCSRC [file join $path [file tail $RCSRC]]
}
if {![file exists [file join $path [file tail $RCMAN]]]} {
|
| ︙ | ︙ | |||
719 720 721 722 723 724 725 |
append cmd " $EXTERN_OBJS"
if {$debug && $os eq "windows"} {
###
# There is bug in the core's autoconf and the value for
# tcl_build_lib_spec does not have the 'g' suffix
###
append cmd " -L[file dirname $TCL(build_stub_lib_path)] -ltcl86g"
| | | | | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
append cmd " $EXTERN_OBJS"
if {$debug && $os eq "windows"} {
###
# There is bug in the core's autoconf and the value for
# tcl_build_lib_spec does not have the 'g' suffix
###
append cmd " -L[file dirname $TCL(build_stub_lib_path)] -ltcl86g"
if {[$PROJECT config get static_tk]} {
append cmd " -L[file dirname $TK(build_stub_lib_path)] -ltk86g"
}
} else {
append cmd " $TCL(build_lib_spec)"
if {[$PROJECT config get static_tk]} {
append cmd " $TK(build_lib_spec)"
}
}
foreach obj $PKG_OBJS {
append cmd " [$obj linker-products $config($obj)]"
}
set LIBS {}
foreach item $TCL(libs) {
if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
lappend LIBS $item
}
if {[$PROJECT config get static_tk]} {
foreach item $TK(libs) {
if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
lappend LIBS $item
}
}
if {[info exists TCL(extra_libs)]} {
foreach item $TCL(extra_libs) {
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 |
puts [list Checking $obj for additional link items]
foreach item [$obj linker-extra $config($obj)] {
append cmd $item
}
}
if {$debug && $os eq "windows"} {
append cmd " -L[file dirname $TCL(build_stub_lib_path)] ${TCL(stub_lib_flag)}"
| | | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
puts [list Checking $obj for additional link items]
foreach item [$obj linker-extra $config($obj)] {
append cmd $item
}
}
if {$debug && $os eq "windows"} {
append cmd " -L[file dirname $TCL(build_stub_lib_path)] ${TCL(stub_lib_flag)}"
if {[$PROJECT config get static_tk]} {
append cmd " -L[file dirname $TK(build_stub_lib_path)] ${TK(stub_lib_flag)}"
}
} else {
append cmd " $TCL(build_stub_lib_spec)"
if {[$PROJECT config get static_tk]} {
append cmd " $TK(build_stub_lib_spec)"
}
}
if {[info exists TCL(cc_search_flags)]} {
append cmd " $TCL(cc_search_flags)"
}
append cmd " -o $outfile "
|
| ︙ | ︙ |
Changes to modules/practcl/build/class/toolset/msvc.tcl.
1 2 3 4 5 |
::clay::define ::practcl::toolset.msvc {
superclass ::practcl::toolset
# MSVC always builds in the source directory
method BuildDir {PWD} {
| | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
::clay::define ::practcl::toolset.msvc {
superclass ::practcl::toolset
# MSVC always builds in the source directory
method BuildDir {PWD} {
set srcdir [my Config_get srcdir]
return $srcdir
}
# Do nothing
Ensemble make::autodetect {} {
}
Ensemble make::clean {} {
set PWD [pwd]
set srcdir [my Config_get srcdir]
cd $srcdir
catch {::practcl::doexec nmake -f makefile.vc clean}
cd $PWD
}
Ensemble make::compile {} {
set srcdir [my Config_get srcdir]
if {[my Config_get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
cd $srcdir
if {[file exists [file join $srcdir make.tcl]]} {
if {[my Config_get debug 0]} {
::practcl::domake.tcl $srcdir debug all
} else {
::practcl::domake.tcl $srcdir all
}
} else {
if {[file exists [file join $srcdir makefile.vc]]} {
::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> config get installdir] {*}[my NmakeOpts] release
} elseif {[file exists [file join $srcdir win makefile.vc]]} {
cd [file join $srcdir win]
::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> config get installdir] {*}[my NmakeOpts] release
} else {
error "No make.tcl or makefile.vc found for project $name"
}
}
}
Ensemble make::install DEST {
set PWD [pwd]
set srcdir [my Config_get srcdir]
cd $srcdir
if {$DEST eq {}} {
error "No destination given"
}
if {[my <project> config get LOCAL 0] || $DEST eq {}} {
if {[file exists [file join $srcdir make.tcl]]} {
# Practcl builds can inject right to where we need them
puts "[self] Local Install (Practcl)"
::practcl::domake.tcl $srcdir install
} else {
puts "[self] Local Install (Nmake)"
::practcl::doexec nmake -f makefile.vc {*}[my NmakeOpts] install
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
cd $PWD
}
# Detect what directory contains the Makefile template
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
| | | | | | | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
cd $PWD
}
# Detect what directory contains the Makefile template
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
my Config_add include_dir [file join $srcdir generic]
}
if {[file exists [file join $srcdir win]]} {
my Config_add include_dir [file join $srcdir win]
}
if {[file exists [file join $srcdir makefile.vc]]} {
set localsrcdir [file join $srcdir win]
}
return $localsrcdir
}
method NmakeOpts {} {
set opts {}
set builddir [file normalize [my Config_get builddir]]
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> config get tclsrcdir] ..]]]
set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> config get tclsrcdir] .. generic]]]
lappend opts TCLDIR=[file normalize $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> config get tksrcdir] ..]]]
set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> config get tksrcdir] .. generic]]]
#lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC
lappend opts TKDIR=[file normalize $TKSRCDIR]
}
return $opts
}
}
|
Changes to modules/practcl/build/makeutil.tcl.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
# Registering a build product with this command will create
# an entry in the global [variable make] array, and populate
# a value in the global [variable target] array.
###
proc ::practcl::target {name info {action {}}} {
set obj [::practcl::LOCAL make task $name $info $action]
set ::make($name) 0
| | | 28 29 30 31 32 33 34 35 36 37 38 39 |
# Registering a build product with this command will create
# an entry in the global [variable make] array, and populate
# a value in the global [variable target] array.
###
proc ::practcl::target {name info {action {}}} {
set obj [::practcl::LOCAL make task $name $info $action]
set ::make($name) 0
set filename [$obj config get filename]
if {$filename ne {}} {
set ::target($name) $filename
}
}
|
Changes to scripts/practcl.tcl.
1 2 3 4 5 6 | ### # Amalgamated package for practcl # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### package require Tcl 8.6 | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
###
# Amalgamated package for practcl
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.6
package provide practcl 0.17
namespace eval ::practcl {}
###
# START: httpwget/wget.tcl
###
###
# END: httpwget/wget.tcl
###
###
# START: clay/clay.tcl
###
package provide clay 0.8.1
namespace eval ::clay {
}
namespace eval ::clay {
}
set ::clay::trace 0
proc ::clay::PROC {name arglist body {ninja {}}} {
if {[info commands $name] ne {}} return
|
| ︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 |
}
branch {
set path [::clay::tree::storage $args]
if {![dict exists $clay {*}$path .]} {
dict set clay {*}$path . {}
}
}
cget {
# Leaf searches return one data field at a time
# Search in our local dict
if {[llength $args]==1} {
set field [string trim [lindex $args 0] -:/]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
| > > > > > | 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 |
}
branch {
set path [::clay::tree::storage $args]
if {![dict exists $clay {*}$path .]} {
dict set clay {*}$path . {}
}
}
cache {
set path [lindex $args 0]
set value [lindex $args 1]
dict set claycache $path $value
}
cget {
# Leaf searches return one data field at a time
# Search in our local dict
if {[llength $args]==1} {
set field [string trim [lindex $args 0] -:/]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
|
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 |
::clay::tree::dictmerge result [$class clay dump]
}
::clay::tree::dictmerge result $clay
return $result
}
ensemble_map {
set ensemble [lindex $args 0]
| < | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 |
::clay::tree::dictmerge result [$class clay dump]
}
::clay::tree::dictmerge result $clay
return $result
}
ensemble_map {
set ensemble [lindex $args 0]
set mensemble [string trim $ensemble :/]
if {[dict exists $claycache method_ensemble $mensemble]} {
return [clay::tree::sanitize [dict get $claycache method_ensemble $mensemble]]
}
set emap [my clay dget method_ensemble $mensemble]
dict set claycache method_ensemble $mensemble $emap
return [clay::tree::sanitize $emap]
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
# Search in the in our list of classes for an answer
foreach class $clayorder {
::clay::tree::dictmerge result [$class clay dump]
}
::clay::tree::dictmerge result $clay
return $result
}
| < < < < < < < > > > > > | | < < < < < < < > > > > > > > > | | | > | > > | < < | > | 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 |
# Search in the in our list of classes for an answer
foreach class $clayorder {
::clay::tree::dictmerge result [$class clay dump]
}
::clay::tree::dictmerge result $clay
return $result
}
if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
# Path is a leaf
return [dict get $clay {*}$path]
}
# Search in our local cache
if {[my clay search $path value isleaf]} {
return $value
}
set found 0
set branch [dict exists $clay {*}$path .]
foreach class $clayorder {
if {[$class clay exists {*}$path .]} {
set found 1
break
}
if {!$branch && [$class clay exists {*}$path]} {
set result [$class clay dget {*}$path]
my clay cache $path $result
return $result
}
}
# Path is a branch
set result [dict getnull $clay {*}$path]
foreach class $clayorder {
if {![$class clay exists {*}$path .]} continue
::clay::tree::dictmerge result [$class clay dget {*}$path]
}
#if {[dict exists $clay {*}$path .]} {
# ::clay::tree::dictmerge result
#}
my clay cache $path $result
return $result
}
getnull -
get {
set path [::clay::tree::storage $args]
if {[llength $path]==0} {
# Do a full dump of clay data
set result {}
# Search in the in our list of classes for an answer
foreach class $clayorder {
::clay::tree::dictmerge result [$class clay dump]
}
::clay::tree::dictmerge result $clay
return [::clay::tree::sanitize $result]
}
if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
# Path is a leaf
return [dict get $clay {*}$path]
}
# Search in our local cache
if {[my clay search $path value isleaf]} {
if {!$isleaf} {
return [clay::tree::sanitize $value]
} else {
return $value
}
}
set found 0
set branch [dict exists $clay {*}$path .]
foreach class $clayorder {
if {[$class clay exists {*}$path .]} {
set found 1
break
}
if {!$branch && [$class clay exists {*}$path]} {
set result [$class clay dget {*}$path]
my clay cache $path $result
return $result
}
}
# Path is a branch
set result [dict getnull $clay {*}$path]
#foreach class [lreverse $clayorder] {
# if {![$class clay exists {*}$path .]} continue
# ::clay::tree::dictmerge result [$class clay dget {*}$path]
#}
foreach class $clayorder {
if {![$class clay exists {*}$path .]} continue
::clay::tree::dictmerge result [$class clay dget {*}$path]
}
#if {[dict exists $clay {*}$path .]} {
# ::clay::tree::dictmerge result [dict get $clay {*}$path]
#}
my clay cache $path $result
return [clay::tree::sanitize $result]
}
leaf {
# Leaf searches return one data field at a time
# Search in our local dict
set path [::clay::tree::storage $args]
if {[dict exists $clay {*}$path .]} {
return [clay::tree::sanitize [dict get $clay {*}$path]]
}
if {[dict exists $clay {*}$path]} {
return [dict get $clay {*}$path]
}
# Search in our local cache
if {[my clay search $path value isleaf]} {
if {!$isleaf} {
return [clay::tree::sanitize $value]
} else {
return $value
}
}
# Search in the in our list of classes for an answer
foreach class $clayorder {
if {[$class clay exists {*}$path]} {
set value [$class clay get {*}$path]
my clay cache $path $value
return $value
}
}
}
merge {
foreach arg $args {
::clay::tree::dictmerge clay {*}$arg
}
}
mixin {
###
# Mix in the class
###
my clay flush
set prior [info object mixins [self]]
set newmixin {}
foreach item $args {
lappend newmixin ::[string trimleft $item :]
}
set newmap $args
foreach class $prior {
|
| ︙ | ︙ | |||
1642 1643 1644 1645 1646 1647 1648 |
puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
}
break
}
}
}
mixinmap {
| < | 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 |
puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
}
break
}
}
}
mixinmap {
if {![dict exists $clay .mixin]} {
dict set clay .mixin {}
}
if {[llength $args]==0} {
return [dict get $clay .mixin]
} elseif {[llength $args]==1} {
return [dict getnull $clay .mixin [lindex $args 0]]
|
| ︙ | ︙ | |||
1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 |
if {$refcount <= 0} {
::clay::object_destroy [self]
}
}
replace {
set clay [lindex $args 0]
}
source {
source [lindex $args 0]
}
set {
#puts [list [self] clay SET {*}$args]
| > > > > > > > > > > < | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 |
if {$refcount <= 0} {
::clay::object_destroy [self]
}
}
replace {
set clay [lindex $args 0]
}
search {
set path [lindex $args 0]
upvar 1 [lindex $args 1] value [lindex $args 2] isleaf
set isleaf [expr {![dict exists $claycache $path .]}]
if {[dict exists $claycache $path]} {
set value [dict get $claycache $path]
return 1
}
return 0
}
source {
source [lindex $args 0]
}
set {
#puts [list [self] clay SET {*}$args]
::clay::tree::dictset clay {*}$args
}
default {
dict $submethod clay {*}$args
}
}
}
|
| ︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 |
}
dict set config $field $value
set setcmd [dict getnull $info set-command]
if {$setcmd ne {}} {
{*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
}
}
| < | 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 |
}
dict set config $field $value
set setcmd [dict getnull $info set-command]
if {$setcmd ne {}} {
{*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
}
}
if {[info exists clay]} {
set emap [dict getnull $clay method_ensemble]
} else {
set emap {}
}
foreach class [lreverse $clayorder] {
###
|
| ︙ | ︙ | |||
1828 1829 1830 1831 1832 1833 1834 1835 |
# Provide a noop if we aren't running with the cron scheduler
namespace eval ::cron {}
proc ::cron::object_destroy args {}
}
::namespace eval ::clay::event {
}
proc ::clay::cleanup {} {
if {![info exists ::clay::idle_destroy]} return
| > > | | | > | | 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 |
# Provide a noop if we aren't running with the cron scheduler
namespace eval ::cron {}
proc ::cron::object_destroy args {}
}
::namespace eval ::clay::event {
}
proc ::clay::cleanup {} {
set count 0
if {![info exists ::clay::idle_destroy]} return
set objlist $::clay::idle_destroy
set ::clay::idle_destroy {}
foreach obj $objlist {
if {![catch {$obj destroy}]} {
incr count
}
}
return $count
}
proc ::clay::object_create {objname {class {}}} {
#if {$::clay::trace>0} {
# puts [list $objname CREATE]
#}
}
proc ::clay::object_rename {object newname} {
|
| ︙ | ︙ | |||
2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 |
namespace eval ::clay {
namespace export *
}
###
# END: clay/clay.tcl
###
###
# START: setup.tcl
###
package require TclOO
set tcllib_path {}
foreach path {.. ../.. ../../..} {
foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 |
namespace eval ::clay {
namespace export *
}
###
# END: clay/clay.tcl
###
###
# START: clay-yggdrasil/clay-yggdrasil.tcl
###
package provide clay-yggdrasil 0.1
namespace eval ::clay-yggdrasil {
}
set ::clay-yggdrasil::version 0.1
namespace eval ::clay::yggdrasil {
}
clay::define ::clay::yggdrasil {
method child {method args} {
tailcall my Child_${method} {*}$args
}
method Child_clear_all {} {
my variable children
foreach child $children {
catch {
$child child clear_all
$child clay refcount_decr
}
}
set children {}
}
method Child_count {} {
my variable children
if {![info exists children]} {
return {}
}
return [llength $children]
}
method Child_remove {args} {
my variable children
if {![info exists children]} {
return {}
}
set oldlist $children
set children {}
foreach item $oldlist {
if {$item in $args} continue
if {[info commands $item] eq {}} continue
lappend childrent $item
}
}
method Child_index {childidx args} {
my variable children
if {![info exists children]} {
return {}
}
set rowobj [lindex $children $childidx]
if {[llength $args] == 0} {
return $rowobj
}
return [$rowobj child index {*}$args]
}
method Child_last {} {
my variable children
return [lindex [my children] end]
}
method Child_list {} {
my variable children
if {![info exists children]} {
return {}
}
return $children
}
method config {method args} {
tailcall my Config_${method} {*}$args
}
method Config_Default field {
set info [my meta getnull option $field]
set getcmd [dict getnull $info default-command:]
if {$getcmd ne {}} {
return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
} else {
return [dict getnull $info default:]
}
}
method Config_add {field args} {
my variable config
set value [dict getnull $config $field]
foreach item $args {
if {$item ni $value} {
lappend value $item
}
}
dict set config $field $value
}
method Config_exists field {
my variable config
return [dict exists $config $field]
}
method Config_get {field args} {
my variable config option_canonical option_getcmd css
set field [string trimleft $field -]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
}
if {[info exists option_getcmd($field)]} {
return [eval $option_getcmd($field)]
}
if {[dict exists $config $field]} {
return [dict get $config $field]
}
if {[llength $args]} {
return [lindex $args 0]
}
return [my clay get option $field default]
}
method Config_id args {
my variable config
if {[llength $args]} {
my Config_set id [lindex $args 0]
}
if {![dict exists $config id] || [dict get $config id] eq {}} {
dict set config id [::clay::uuid::short]
}
return [dict get $config id]
}
method Config_initialize args {
set mixinmap {}
dict for {opt optinfo} [my clay get option] {
if {[dict getnull $optinfo class] != "mixin"} continue
dict set mixinmap $opt [my Config_Mixin $opt [dict get $optinfo default]]
}
if {[dict size $mixinmap]} {
my clay mixinmap {*}$mixinmap
}
}
method Config_merge dictargs {
my variable config option_canonical
set rawlist $dictargs
set dictargs {}
set mixinmap {}
foreach {field val} $rawlist {
set field [string trim $field -:/]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
}
if {$field eq "mixinmap"} {
my clay mixinmap {*}$val
} elseif {$field eq "delegate"} {
my clay delegate {*}$val
} else {
dict set dictargs $field $val
}
}
foreach {field val} $dictargs {
if {[my clay get option $field class] eq "mixin"} {
my clay mixinmap $field [my Config_Mixin $field $val]
}
}
#if {[dict size $mixinmap]} {
# my clay mixinmap {*}$mixinmap
#}
###
# Validate all inputs
###
foreach {field val} $dictargs {
set script [my clay get option $field validate-command]
if {$script ne {}} {
dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
}
}
###
# Apply all inputs with special rules
###
foreach {field val} $dictargs {
set script [my clay get option $field set-command]
dict set config $field $val
if {$script ne {}} {
{*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
}
}
return $dictargs
}
method Config_Mixin {field value} {
set pattern [my clay get option $field pattern]
set default [my clay get option $field default]
if {$value eq {}} {
return "${pattern}.${default}"
}
if {[string index $value 0] eq ":" && [info commands $value] ne {}} {
return $value
}
foreach trial {
{${pattern}.$value}
{${pattern}::$value}
{${pattern}::${field}.$value}
{${pattern}::${field}.${default}.$value}
{::clay::tk::${field}.$value}
{::clay::tk::$value}
} {
set str [subst $trial]
if {[info commands $str] ne {}} {
return $str
}
}
return "${pattern}.${default}"
}
method Config_remove {field args} {
my variable config
if {![dict exists $config field]} return
set olist [dict get $config $field]
set nlist {}
foreach arg $olist {
if {$arg in $args} continue
lappend nlist $arg
}
dict set config $field $nlist
return $nlist
}
method Config_set args {
set dictargs [::clay::args_to_options {*}$args]
set dat [my Config_merge $dictargs]
my Config_triggers $dat
}
method Config_triggers dictargs {
foreach {field val} $dictargs {
set script [my clay get option $field post-command]
if {$script ne {}} {
{*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
}
}
}
method css {method args} {
tailcall my CSS_${method} {*}$args
}
method CSS_class args {
if {[llength $args]} {
my Config_set class [lindex $args 0]
}
return [my Config_get class]
}
method CSS_exists field {
my variable css
return [dict exists $css $field]
}
method CSS_get field {
my variable css
if {[dict exists $css $field]} {
return [dict get $css $field]
}
return [my clay get css $field]
}
method CSS_set args {
my variable css
dict for {f v} $args {
dict set css $f $v
}
}
method eval args {
eval {*}$args
}
method link {method args} {
tailcall my Link_$method {*}$args
}
method Link_add {linktype object} {
my variable links
if {[info exists links($linktype)] && $object in $links($linktype)} {
return
}
lappend links($linktype) $object
}
method Link_dump {} {
return [array get links]
}
method Link_list {{linktype *}} {
if {$linktype eq "*"} {
return [array get links]
}
if {![info exists links($linktype)]} {
return {}
}
return $links($linktype)
}
method Link_object args {
my variable links
foreach obj $args {
foreach linktype [$obj linktype] {
my link add $linktype $obj
}
}
}
method Link_remove {object {linktype *}} {
foreach {linktype elements} [array get links $linktype] {
if {$object in $elements} {
set nlist {}
foreach e $elements {
if { $object ne $e } { lappend nlist $e }
}
set links($linktype) $nlist
}
}
}
method source args {
source {*}$args
}
method uuid {} {
tailcall my Config_id
}
}
namespace eval ::clay-yggdrasil {
namespace export *
}
###
# END: clay-yggdrasil/clay-yggdrasil.tcl
###
###
# START: setup.tcl
###
package require TclOO
set tcllib_path {}
foreach path {.. ../.. ../../..} {
foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] {
|
| ︙ | ︙ | |||
2726 2727 2728 2729 2730 2731 2732 |
break
}
}
set ::fosdat($dir) $result
return $result
}
proc ::practcl::os {} {
| | | 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 |
break
}
}
set ::fosdat($dir) $result
return $result
}
proc ::practcl::os {} {
return [${::practcl::MAIN} config get TEACUP_OS]
}
proc ::practcl::mkzip {exename barekit vfspath} {
::practcl::tcllib_require zipfile::mkzip
::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath
}
proc ::practcl::sort_dict list {
return [::lsort -stride 2 -dictionary $list]
|
| ︙ | ︙ | |||
3796 3797 3798 3799 3800 3801 3802 |
}
proc ::practcl::depends {args} {
::practcl::LOCAL make depends {*}$args
}
proc ::practcl::target {name info {action {}}} {
set obj [::practcl::LOCAL make task $name $info $action]
set ::make($name) 0
| | > < < | < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 |
}
proc ::practcl::depends {args} {
::practcl::LOCAL make depends {*}$args
}
proc ::practcl::target {name info {action {}}} {
set obj [::practcl::LOCAL make task $name $info $action]
set ::make($name) 0
set filename [$obj config get filename]
if {$filename ne {}} {
set ::target($name) $filename
}
}
###
# END: makeutil.tcl
###
###
# START: class metaclass.tcl
###
::clay::define ::practcl::metaclass {
superclass ::clay::yggdrasil
method _MorphPatterns {} {
return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}}
}
method Child_define {} {
return {}
}
method define {method args} {
tailcall my Config_$method {*}$args
}
method graft args {
return [my clay delegate {*}$args]
}
method initialize {} {}
method morph classname {
my variable define
if {$classname ne {}} {
set map [list @name@ $classname]
foreach pattern [string map $map [my _MorphPatterns]] {
set pattern [string trim $pattern]
set matches [info commands $pattern]
|
| ︙ | ︙ | |||
3960 3961 3962 3963 3964 3965 3966 |
}
if {$mixinslot ne {}} {
my clay mixinmap $mixinslot $class
} elseif {[info command $class] ne {}} {
if {[info object class [self]] ne $class} {
::oo::objdefine [self] class $class
::practcl::debug [self] morph $class
| | | 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 |
}
if {$mixinslot ne {}} {
my clay mixinmap $mixinslot $class
} elseif {[info command $class] ne {}} {
if {[info object class [self]] ne $class} {
::oo::objdefine [self] class $class
::practcl::debug [self] morph $class
my Config_set class $class
}
} else {
error "[self] Could not detect class for $classname"
}
}
if {[::info exists define(oodefine)]} {
::oo::objdefine [self] $define(oodefine)
|
| ︙ | ︙ | |||
4001 4002 4003 4004 4005 4006 4007 |
# START: class toolset baseclass.tcl
###
::clay::define ::practcl::toolset {
method config.sh {} {
return [my read_configuration]
}
method BuildDir {PWD} {
| | | | | | | | | | | 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 |
# START: class toolset baseclass.tcl
###
::clay::define ::practcl::toolset {
method config.sh {} {
return [my read_configuration]
}
method BuildDir {PWD} {
set name [my Config_get name]
set debug [my Config_get debug 0]
if {[my <project> config get LOCAL 0]} {
return [my Config_get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my Config_get builddir [file join $PWD debug $name]]
} else {
return [my Config_get builddir [file join $PWD pkg $name]]
}
}
method MakeDir {srcdir} {
return $srcdir
}
method read_configuration {} {
my variable conf_result
if {[info exists conf_result]} {
return $conf_result
}
set result {}
set name [my Config_get name]
set PWD $::CWD
set builddir [my Config_get builddir]
my unpack
set srcdir [my Config_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::read_configuration $builddir]
|
| ︙ | ︙ | |||
4082 4083 4084 4085 4086 4087 4088 |
}
set conf_result $result
cd $PWD
return $result
}
method build-cflags {PROJECT DEFS namevar versionvar defsvar} {
upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs
| | | | 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 |
}
set conf_result $result
cd $PWD
return $result
}
method build-cflags {PROJECT DEFS namevar versionvar defsvar} {
upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs
set name [string tolower [${PROJECT} config get name [${PROJECT} config get pkg_name]]]
set NAME [string toupper $name]
set version [${PROJECT} config get version [${PROJECT} config get pkg_vers]]
if {$version eq {}} {
set version 0.1a
}
set defs $DEFS
foreach flag {
-DPACKAGE_NAME
-DPACKAGE_VERSION
|
| ︙ | ︙ | |||
4109 4110 4111 4112 4113 4114 4115 |
append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\""
append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\""
return $defs
}
method critcl args {
if {![info exists critcl]} {
::practcl::LOCAL tool critcl env-load
| | | | | 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 |
append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\""
append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\""
return $defs
}
method critcl args {
if {![info exists critcl]} {
::practcl::LOCAL tool critcl env-load
set critcl [file join [::practcl::LOCAL tool critcl config get srcdir] main.tcl
}
set srcdir [my SourceRoot]
set PWD [pwd]
cd $srcdir
::practcl::dotclexec $critcl {*}$args
cd $PWD
}
}
oo::objdefine ::practcl::toolset {
# Perform the selection for the toolset mixin
method select object {
###
# Select the toolset to use for this project
###
if {[$object define exists toolset]} {
return [$object config get toolset]
}
set class [$object config get toolset]
if {$class ne {}} {
$object clay mixinmap toolset $class
} else {
if {[info exists ::env(VisualStudioVersion)]} {
$object clay mixinmap toolset ::practcl::toolset.msvc
} else {
$object clay mixinmap toolset ::practcl::toolset.gcc
|
| ︙ | ︙ | |||
4154 4155 4156 4157 4158 4159 4160 |
superclass ::practcl::toolset
method Autoconf {} {
###
# Re-run autoconf for this project
# Not a good idea in practice... but in the right hands it can be useful
###
set pwd [pwd]
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 |
superclass ::practcl::toolset
method Autoconf {} {
###
# Re-run autoconf for this project
# Not a good idea in practice... but in the right hands it can be useful
###
set pwd [pwd]
set srcdir [file normalize [my Config_get srcdir]]
set localsrcdir [my MakeDir $srcdir]
cd $localsrcdir
foreach template {configure.ac configure.in} {
set input [file join $srcdir $template]
if {[file exists $input]} {
puts "autoconf -f $input > [file join $srcdir configure]"
exec autoconf -f $input > [file join $srcdir configure]
}
}
cd $pwd
}
method BuildDir {PWD} {
set name [my Config_get name]
set debug [my Config_get debug 0]
if {[my <project> config get LOCAL 0]} {
return [my Config_get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my Config_get builddir [file join $PWD debug $name]]
} else {
return [my Config_get builddir [file join $PWD pkg $name]]
}
}
method ConfigureOpts {} {
set opts {}
set builddir [my Config_get builddir]
if {[my Config_get broken_destroot 0]} {
set PREFIX [my <project> config get prefix_broken_destdir]
} else {
set PREFIX [my <project> config get prefix]
}
switch [my Config_get name] {
tcl {
set opts [::practcl::platform::tcl_core_options [my <project> config get TEACUP_OS]]
}
tk {
set opts [::practcl::platform::tk_core_options [my <project> config get TEACUP_OS]]
}
}
if {[my <project> config get CONFIG_SITE] != {}} {
lappend opts --host=[my <project> config get HOST]
}
set inside_msys [string is true -strict [my <project> config get MSYS_ENV 0]]
lappend opts --with-tclsh=[info nameofexecutable]
if {[my Config_get tk 0]} {
if {![my <project> config get LOCAL 0]} {
set obj [my <project> tclcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj config get builddir]]
} else {
lappend opts --with-tcl=[file normalize [$obj config get builddir]]
}
}
set obj [my <project> tkcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj config get builddir]]
} else {
lappend opts --with-tk=[file normalize [$obj config get builddir]]
}
}
} else {
lappend opts --with-tcl=[file join $PREFIX lib]
lappend opts --with-tk=[file join $PREFIX lib]
}
} else {
if {![my <project> config get LOCAL 0]} {
set obj [my <project> tclcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj config get builddir]]
} else {
lappend opts --with-tcl=[file normalize [$obj config get builddir]]
}
}
} else {
lappend opts --with-tcl=[file join $PREFIX lib]
}
}
lappend opts {*}[my Config_get config_opts]
if {![regexp -- "--prefix" $opts]} {
lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX
}
if {[my Config_get debug 0]} {
lappend opts --enable-symbols=true
}
#--exec_prefix=$PREFIX
#if {$::tcl_platform(platform) eq "windows"} {
# lappend opts --disable-64bit
#}
if {[my Config_get static 1]} {
lappend opts --disable-shared
#--disable-stubs
#
} else {
lappend opts --enable-shared
}
return $opts
}
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
my Config_add include_dir [file join $srcdir generic]
}
set os [my <project> config get TEACUP_OS]
switch $os {
windows {
if {[file exists [file join $srcdir win]]} {
my Config_add include_dir [file join $srcdir win]
}
if {[file exists [file join $srcdir win Makefile.in]]} {
set localsrcdir [file join $srcdir win]
}
}
macosx {
if {[file exists [file join $srcdir unix Makefile.in]]} {
set localsrcdir [file join $srcdir unix]
}
}
default {
if {[file exists [file join $srcdir $os]]} {
my Config_add include_dir [file join $srcdir $os]
}
if {[file exists [file join $srcdir unix]]} {
my Config_add include_dir [file join $srcdir unix]
}
if {[file exists [file join $srcdir $os Makefile.in]]} {
set localsrcdir [file join $srcdir $os]
} elseif {[file exists [file join $srcdir unix Makefile.in]]} {
set localsrcdir [file join $srcdir unix]
}
}
}
return $localsrcdir
}
Ensemble make::autodetect {} {
set srcdir [my Config_get srcdir]
set localsrcdir [my MakeDir $srcdir]
if {$localsrcdir eq {}} {
set localsrcdir $srcdir
}
if {$srcdir eq $localsrcdir} {
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 config 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 builddir [my Config_get builddir]
file mkdir $builddir
if {![file exists [file join $localsrcdir configure]]} {
if {[file exists [file join $localsrcdir autogen.sh]]} {
cd $localsrcdir
catch {exec sh autogen.sh >>& [file join $builddir autoconf.log]}
cd $::CWD
}
}
set opts [my ConfigureOpts]
if {[file exists [file join $builddir autoconf.log]]} {
file delete [file join $builddir autoconf.log]
}
::practcl::debug [list PKG [my Config_get name] CONFIGURE {*}$opts]
::practcl::log [file join $builddir autoconf.log] [list CONFIGURE {*}$opts]
cd $builddir
if {[my <project> config get CONFIG_SITE] ne {}} {
set ::env(CONFIG_SITE) [my <project> config get CONFIG_SITE]
}
catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]}
cd $::CWD
}
Ensemble make::clean {} {
set builddir [file normalize [my Config_get builddir]]
catch {::practcl::domake $builddir clean}
}
Ensemble make::compile {} {
set name [my Config_get name]
set srcdir [my Config_get srcdir]
if {[my Config_get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
cd $::CWD
set builddir [file normalize [my Config_get builddir]]
file mkdir $builddir
if {![file exists [file join $builddir Makefile]]} {
my Configure
}
if {[file exists [file join $builddir make.tcl]]} {
if {[my Config_get debug 0]} {
::practcl::domake.tcl $builddir debug all
} else {
::practcl::domake.tcl $builddir all
}
} else {
::practcl::domake $builddir all
}
}
Ensemble make::install DEST {
set PWD [pwd]
set builddir [my Config_get builddir]
if {[my <project> config get LOCAL 0] || $DEST eq {}} {
if {[file exists [file join $builddir make.tcl]]} {
puts "[self] Local INSTALL (Practcl)"
::practcl::domake.tcl $builddir install
} elseif {[my Config_get broken_destroot 0] == 0} {
puts "[self] Local INSTALL (TEA)"
::practcl::domake $builddir install
}
} else {
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 Config_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=[::practcl::file_relative $builddir $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> config get prefix]
set BROKENROOT [::practcl::msys_to_tclpath [my <project> config 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 build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} {
set objext [my Config_get OBJEXT o]
set EXTERN_OBJS {}
set OBJECTS {}
set result {}
set builddir [$PROJECT config get builddir]
file mkdir [file join $builddir objs]
set debug [$PROJECT config get debug 0]
set task {}
###
# Compile the C sources
###
::practcl::debug ### COMPILE PRODUCTS
foreach {ofile info} [${PROJECT} project-compile-products] {
|
| ︙ | ︙ | |||
4500 4501 4502 4503 4504 4505 4506 |
}
error "Failed to produce $filename"
}
}
return $result
}
method build-Makefile {path PROJECT} {
| | | | 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 |
}
error "Failed to produce $filename"
}
}
return $result
}
method build-Makefile {path PROJECT} {
array set proj [$PROJECT config dump]
set path $proj(builddir)
cd $path
set includedir .
set objext [my Config_get OBJEXT o]
#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 toolset-include-directory] {
set cpath [::practcl::file_relative $path [file normalize $include]]
if {$cpath ni $includedir} {
|
| ︙ | ︙ | |||
4555 4556 4557 4558 4559 4560 4561 |
::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)]
| | | | | | | | | | | | | | | | | | | | | 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 |
::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 config get libprefix]
if {[string is true [$PROJECT config get SHARED_BUILD]]} {
set outfile [$PROJECT config get libfile]
} else {
set outfile [$PROJECT shared_library]
}
$PROJECT config 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 config get PRACTCL_SHARED_LIB]]"
if {[$PROJECT config get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} {
::practcl::cputs result "\t[string map $map [$PROJECT config get PRACTCL_VC_MANIFEST_EMBED_DLL]]"
}
::practcl::cputs result {}
if {[string is true [$PROJECT config get SHARED_BUILD]]} {
#set outfile [$PROJECT static_library]
set outfile $proj(name).a
} else {
set outfile [$PROJECT config get libfile]
}
$PROJECT config set static_library $outfile
dict set map %OUTFILE% $outfile
::practcl::cputs result "$outfile: \$(${NAME}_OBJS)"
::practcl::cputs result "\t[string map $map [$PROJECT config get PRACTCL_STATIC_LIB]]"
::practcl::cputs result {}
return $result
}
method build-library {outfile PROJECT} {
array set proj [$PROJECT config 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]]]
if {[$PROJECT config get TEA_PRIVATE_TCL_HEADERS 0]} {
if {[$PROJECT config get TEA_PLATFORM] eq "windows"} {
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) win]]]
} else {
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) unix]]]
}
}
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]]
if {[$PROJECT config 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]]]
if {[$PROJECT config get TEA_PRIVATE_TK_HEADERS 0]} {
if {[$PROJECT config get TEA_PLATFORM] eq "windows"} {
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) win]]]
} else {
lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) unix]]]
}
}
lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]]
}
foreach include [$PROJECT toolset-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 config get debug 0]
set os [$PROJECT config 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)]} {
|
| ︙ | ︙ | |||
4662 4663 4664 4665 4666 4667 4668 |
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)"
| | | | | | | | | | | | | | | | | | | | | | 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 |
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 config get SHARED_BUILD 1]]} {
set cmd [$PROJECT config get PRACTCL_SHARED_LIB]
append cmd " [$PROJECT config get PRACTCL_LIBS]"
set cmd [string map $map $cmd]
puts $cmd
exec {*}$cmd >&@ stdout
if {[$PROJECT config get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} {
set cmd [string map $map [$PROJECT config get PRACTCL_VC_MANIFEST_EMBED_DLL]]
puts $cmd
exec {*}$cmd >&@ stdout
}
} else {
set cmd [string map $map [$PROJECT config get PRACTCL_STATIC_LIB]]
puts $cmd
exec {*}$cmd >&@ stdout
}
set ranlib [$PROJECT config get RANLIB]
if {$ranlib ni {{} :}} {
catch {exec $ranlib $outfile}
}
}
method build-tclsh {outfile PROJECT {path {auto}}} {
if {[my Config_get tk 0] && [my Config_get static_tk 0]} {
puts " BUILDING STATIC TCL/TK EXE $PROJECT"
set TKOBJ [$PROJECT tkcore]
if {[info command $TKOBJ] eq {}} {
set TKOBJ ::noop
$PROJECT config set static_tk 0
} else {
::practcl::toolset select $TKOBJ
array set TK [$TKOBJ read_configuration]
set do_tk [$TKOBJ config get static]
$PROJECT config set static_tk $do_tk
$PROJECT config set tk $do_tk
set TKSRCDIR [$TKOBJ config get srcdir]
}
} else {
puts " BUILDING STATIC TCL EXE $PROJECT"
set TKOBJ ::noop
my Config_set static_tk 0
}
set TCLOBJ [$PROJECT tclcore]
::practcl::toolset select $TCLOBJ
set PKG_OBJS {}
foreach item [$PROJECT link list core.library] {
if {[string is true [$item config get static]]} {
lappend PKG_OBJS $item
}
}
foreach item [$PROJECT link list package] {
if {[string is true [$item config get static]]} {
lappend PKG_OBJS $item
}
}
array set TCL [$TCLOBJ read_configuration]
if {$path in {{} auto}} {
set path [file dirname [file normalize $outfile]]
}
if {$path eq "."} {
set path [pwd]
}
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 config 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 read_configuration]
}
set os [$PROJECT config get TEACUP_OS]
set TCLSRCDIR [$TCLOBJ config get srcdir]
set includedir .
foreach include [$TCLOBJ toolset-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]]
if {[$PROJECT config get static_tk]} {
lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR generic]]]
lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR ttk]]]
lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR xlib]]]
lappend includedir [::practcl::file_relative $path [file normalize $TKSRCDIR]]
}
foreach include [$PROJECT toolset-include-directory] {
|
| ︙ | ︙ | |||
4780 4781 4782 4783 4784 4785 4786 |
$TCL(cflags_warning) $TCL(extra_cflags)"
}
append COMPILE " " $defs
lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES]
set TCLSRC [file normalize $TCLSRCDIR]
| | | | | | | | | | | 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 |
$TCL(cflags_warning) $TCL(extra_cflags)"
}
append COMPILE " " $defs
lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES]
set TCLSRC [file normalize $TCLSRCDIR]
if {[${PROJECT} config get TEACUP_OS] eq "windows"} {
set windres [$PROJECT config get RC windres]
set RSOBJ [file join $path objs tclkit.res.o]
set RCSRC [${PROJECT} config get kit_resource_file]
set RCMAN [${PROJECT} config get kit_manifest_file]
set RCICO [${PROJECT} config get kit_icon_file]
set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]]
if {[$PROJECT config get static_tk]} {
if {$RCSRC eq {} || ![file exists $RCSRC]} {
set RCSRC [file join $TKSRCDIR win rc wish.rc]
}
if {$RCMAN eq {} || ![file exists $RCMAN]} {
set RCMAN [file join [$TKOBJ config get builddir] wish.exe.manifest]
}
if {$RCICO eq {} || ![file exists $RCICO]} {
set RCICO [file join $TKSRCDIR win rc wish.ico]
}
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 win tclsh.rc]
}
if {$RCMAN eq {} || ![file exists $RCMAN]} {
set RCMAN [file join [$TCLOBJ config get builddir] tclsh.exe.manifest]
}
if {$RCICO eq {} || ![file exists $RCICO]} {
set RCICO [file join $TCLSRCDIR win tclsh.ico]
}
}
foreach item [${PROJECT} config get resource_include] {
lappend cmd --include [::practcl::file_relative $path [file normalize $item]]
}
lappend cmd [file tail $RCSRC]
if {![file exists [file join $path [file tail $RCSRC]]]} {
file copy -force $RCSRC [file join $path [file tail $RCSRC]]
}
if {![file exists [file join $path [file tail $RCMAN]]]} {
|
| ︙ | ︙ | |||
4851 4852 4853 4854 4855 4856 4857 |
append cmd " $EXTERN_OBJS"
if {$debug && $os eq "windows"} {
###
# There is bug in the core's autoconf and the value for
# tcl_build_lib_spec does not have the 'g' suffix
###
append cmd " -L[file dirname $TCL(build_stub_lib_path)] -ltcl86g"
| | | | | 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 |
append cmd " $EXTERN_OBJS"
if {$debug && $os eq "windows"} {
###
# There is bug in the core's autoconf and the value for
# tcl_build_lib_spec does not have the 'g' suffix
###
append cmd " -L[file dirname $TCL(build_stub_lib_path)] -ltcl86g"
if {[$PROJECT config get static_tk]} {
append cmd " -L[file dirname $TK(build_stub_lib_path)] -ltk86g"
}
} else {
append cmd " $TCL(build_lib_spec)"
if {[$PROJECT config get static_tk]} {
append cmd " $TK(build_lib_spec)"
}
}
foreach obj $PKG_OBJS {
append cmd " [$obj linker-products $config($obj)]"
}
set LIBS {}
foreach item $TCL(libs) {
if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
lappend LIBS $item
}
if {[$PROJECT config get static_tk]} {
foreach item $TK(libs) {
if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
lappend LIBS $item
}
}
if {[info exists TCL(extra_libs)]} {
foreach item $TCL(extra_libs) {
|
| ︙ | ︙ | |||
4897 4898 4899 4900 4901 4902 4903 |
puts [list Checking $obj for additional link items]
foreach item [$obj linker-extra $config($obj)] {
append cmd $item
}
}
if {$debug && $os eq "windows"} {
append cmd " -L[file dirname $TCL(build_stub_lib_path)] ${TCL(stub_lib_flag)}"
| | | | 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 |
puts [list Checking $obj for additional link items]
foreach item [$obj linker-extra $config($obj)] {
append cmd $item
}
}
if {$debug && $os eq "windows"} {
append cmd " -L[file dirname $TCL(build_stub_lib_path)] ${TCL(stub_lib_flag)}"
if {[$PROJECT config get static_tk]} {
append cmd " -L[file dirname $TK(build_stub_lib_path)] ${TK(stub_lib_flag)}"
}
} else {
append cmd " $TCL(build_stub_lib_spec)"
if {[$PROJECT config get static_tk]} {
append cmd " $TK(build_stub_lib_spec)"
}
}
if {[info exists TCL(cc_search_flags)]} {
append cmd " $TCL(cc_search_flags)"
}
append cmd " -o $outfile "
|
| ︙ | ︙ | |||
4929 4930 4931 4932 4933 4934 4935 |
###
###
# START: class toolset msvc.tcl
###
::clay::define ::practcl::toolset.msvc {
superclass ::practcl::toolset
method BuildDir {PWD} {
| | | | | | | | | | | 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 |
###
###
# START: class toolset msvc.tcl
###
::clay::define ::practcl::toolset.msvc {
superclass ::practcl::toolset
method BuildDir {PWD} {
set srcdir [my Config_get srcdir]
return $srcdir
}
Ensemble make::autodetect {} {
}
Ensemble make::clean {} {
set PWD [pwd]
set srcdir [my Config_get srcdir]
cd $srcdir
catch {::practcl::doexec nmake -f makefile.vc clean}
cd $PWD
}
Ensemble make::compile {} {
set srcdir [my Config_get srcdir]
if {[my Config_get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
cd $srcdir
if {[file exists [file join $srcdir make.tcl]]} {
if {[my Config_get debug 0]} {
::practcl::domake.tcl $srcdir debug all
} else {
::practcl::domake.tcl $srcdir all
}
} else {
if {[file exists [file join $srcdir makefile.vc]]} {
::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> config get installdir] {*}[my NmakeOpts] release
} elseif {[file exists [file join $srcdir win makefile.vc]]} {
cd [file join $srcdir win]
::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> config get installdir] {*}[my NmakeOpts] release
} else {
error "No make.tcl or makefile.vc found for project $name"
}
}
}
Ensemble make::install DEST {
set PWD [pwd]
set srcdir [my Config_get srcdir]
cd $srcdir
if {$DEST eq {}} {
error "No destination given"
}
if {[my <project> config get LOCAL 0] || $DEST eq {}} {
if {[file exists [file join $srcdir make.tcl]]} {
# Practcl builds can inject right to where we need them
puts "[self] Local Install (Practcl)"
::practcl::domake.tcl $srcdir install
} else {
puts "[self] Local Install (Nmake)"
::practcl::doexec nmake -f makefile.vc {*}[my NmakeOpts] install
|
| ︙ | ︙ | |||
4997 4998 4999 5000 5001 5002 5003 |
}
}
cd $PWD
}
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
| | | | | | | | < | | | | | 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 |
}
}
cd $PWD
}
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
my Config_add include_dir [file join $srcdir generic]
}
if {[file exists [file join $srcdir win]]} {
my Config_add include_dir [file join $srcdir win]
}
if {[file exists [file join $srcdir makefile.vc]]} {
set localsrcdir [file join $srcdir win]
}
return $localsrcdir
}
method NmakeOpts {} {
set opts {}
set builddir [file normalize [my Config_get builddir]]
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> config get tclsrcdir] ..]]]
set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> config get tclsrcdir] .. generic]]]
lappend opts TCLDIR=[file normalize $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> config get tksrcdir] ..]]]
set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> config get tksrcdir] .. generic]]]
#lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC
lappend opts TKDIR=[file normalize $TKSRCDIR]
}
return $opts
}
}
###
# END: class toolset msvc.tcl
###
###
# START: class target.tcl
###
::clay::define ::practcl::make_obj {
superclass ::practcl::metaclass
constructor {module_object name info {action_body {}}} {
my variable define triggered domake
set triggered 0
set domake 0
my Config_set name $name action {}
my Config_merge $info
my select
my initialize
foreach {stub obj} [$module_object child organs] {
my graft $stub $obj
}
if {$action_body ne {}} {
my Config_set action $action_body
}
}
method do {} {
my variable domake
return $domake
}
method check {} {
my variable needs_make domake
if {$domake} {
return 1
}
if {[info exists needs_make]} {
return $needs_make
}
set make_objects [my <module> make objects]
set needs_make 0
foreach item [my Config_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]} {
|
| ︙ | ︙ | |||
5091 5092 5093 5094 5095 5096 5097 |
}
}
}
return $needs_make
}
method output {} {
set result {}
| | | | | | | | | | | > > > | | | 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 |
}
}
}
return $needs_make
}
method output {} {
set result {}
set filename [my Config_get filename]
if {$filename ne {}} {
lappend result $filename
}
foreach filename [my Config_get files] {
if {$filename ne {}} {
lappend result $filename
}
}
return $result
}
method reset {} {
my variable triggered domake needs_make
set triggerd 0
set domake 0
set needs_make 0
}
method triggers {} {
my variable triggered domake define
if {$triggered} {
return $domake
}
set triggered 1
set make_objects [my <module> make objects]
foreach item [my Config_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
}
}
}
set domake 1
my <module> make trigger {*}[my Config_get triggers]
}
}
###
# END: class target.tcl
###
###
# START: class object.tcl
###
::clay::define ::practcl::object {
superclass ::practcl::metaclass
constructor {parent args} {
my variable links
set organs [$parent child organs]
my clay delegate {*}$organs
my Config_merge $organs
my Config_merge [$parent child define]
array set links {}
if {[llength $args]==1 && [file exists [lindex $args 0]]} {
my Config_set filename [lindex $args 0]
::practcl::product select [self]
} elseif {[llength $args] == 1} {
set data [uplevel 1 [list subst [lindex $args 0]]]
my Config_merge $data
my select
} else {
my Config_merge [uplevel 1 [list subst $args]]
my select
}
my initialize
}
method Child_delegate {} {
return {}
}
method Child_organs {} {
return {}
}
method go {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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]]
|
| ︙ | ︙ | |||
5196 5197 5198 5199 5200 5201 5202 |
dict set cstruct $name $f $v
}
if {![dict exists $cstruct $name public]} {
dict set cstruct $name public 1
}
}
method include header {
| | | | | 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 |
dict set cstruct $name $f $v
}
if {![dict exists $cstruct $name public]} {
dict set cstruct $name public 1
}
}
method include header {
my Config_add include $header
}
method include_dir args {
my Config_add include_dir {*}$args
}
method include_directory args {
my Config_add include_dir {*}$args
}
method c_header body {
my variable code
::practcl::cputs code(header) $body
}
method c_code body {
my variable code
|
| ︙ | ︙ | |||
5331 5332 5333 5334 5335 5336 5337 |
if {[llength $body] eq 1} continue
set fname [string map [list @Name@ [string totitle $name]] $fpat]
my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body]
dict set tcltype $name $func $fname
}
}
method project-compile-products {} {
| | | | | | | | | | | | | | | | | | | | | | | | | 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 |
if {[llength $body] eq 1} continue
set fname [string map [list @Name@ [string totitle $name]] $fpat]
my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body]
dict set tcltype $name $func $fname
}
}
method project-compile-products {} {
set filename [my Config_get output_c]
set result {}
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
if {[my define exists ofile]} {
set ofile [my Config_get ofile]
} else {
set ofile [my Ofile $filename]
my Config_set ofile $ofile
}
lappend result $ofile [list cfile $filename extra [my Config_get extra] external [string is true -strict [my Config_get external]]]
} else {
set filename [my Config_get cfile]
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
if {[my define exists ofile]} {
set ofile [my Config_get ofile]
} else {
set ofile [my Ofile $filename]
my Config_set ofile $ofile
}
lappend result $ofile [list cfile $filename extra [my Config_get extra] external [string is true -strict [my Config_get external]]]
}
}
foreach item [my link list subordinate] {
lappend result {*}[$item project-compile-products]
}
return $result
}
method implement path {
my go
my Collate_Source $path
if {[my Config_get output_c] eq {}} return
set filename [file join $path [my Config_get output_c]]
::practcl::debug [self] [my Config_get filename] WANTS TO GENERATE $filename
my Config_set cfile $filename
set fout [open $filename w]
puts $fout [my generate-c]
if {[my Config_get initfunc] ne {}} {
puts $fout "extern int DLLEXPORT [my Config_get initfunc]( Tcl_Interp *interp ) \x7B"
puts $fout [my generate-loader-module]
if {[my Config_get pkg_name] ne {}} {
puts $fout " Tcl_PkgProvide(interp, \"[my Config_get pkg_name]\", \"[my Config_get pkg_vers]\");"
}
puts $fout " return TCL_OK\;"
puts $fout "\x7D"
}
close $fout
}
method initialize {} {
set filename [my Config_get filename]
if {$filename eq {}} {
return
}
if {[my Config_get name] eq {}} {
my Config_set name [file tail [file rootname $filename]]
}
if {[my Config_get localpath] eq {}} {
my Config_set localpath [my <module> config get localpath]_[my Config_get name]
}
::source $filename
}
method linktype {} {
return {subordinate product dynamic}
}
method generate-cfile-constant {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result {}
my variable code cstruct methods tcltype
if {[info exists code(constant)]} {
::practcl::cputs result "/* [my Config_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]
|
| ︙ | ︙ | |||
5476 5477 5478 5479 5480 5481 5482 |
::practcl::cputs result " .cloneProc = NULL\n\}\;"
}
dict set methods $name methodtype $methodtype
}
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
| | | | | | | | | | | | 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 |
::practcl::cputs result " .cloneProc = NULL\n\}\;"
}
dict set methods $name methodtype $methodtype
}
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-constant]
}
return $result
}
method generate-cfile-header {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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)
}
::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 Config_get cclass]]
if {[info exists methods]} {
set thisclass [my Config_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)\;"
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
set dat [$obj generate-cfile-header]
if {[string length [string trim $dat]]} {
::practcl::cputs result "/* BEGIN [$obj config get filename] generate-cfile-header */"
::practcl::cputs result $dat
::practcl::cputs result "/* END [$obj config get filename] generate-cfile-header */"
}
}
return $result
}
method generate-cfile-tclapi {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_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 Config_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 */
|
| ︙ | ︙ | |||
5610 5611 5612 5613 5614 5615 5616 |
}
}
}
::practcl::cputs result " return TCL_OK\;\n\}\n"
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
| | | | 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 |
}
}
}
::practcl::cputs result " return TCL_OK\;\n\}\n"
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-tclapi]
}
return $result
}
method generate-loader-module {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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);
|
| ︙ | ︙ | |||
5666 5667 5668 5669 5670 5671 5672 |
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 " \}"
}
| | | | | | | 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 |
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 Config_get filename]]
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} {
::practcl::cputs result [$obj generate-loader-external]
} else {
::practcl::cputs result [$obj generate-loader-module]
}
}
return $result
}
method Collate_Source CWD {
my variable methods code cstruct tclprocs
if {[info exists methods]} {
::practcl::debug [self] methods [my Config_get cclass]
set thisclass [my Config_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 Config_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
|
| ︙ | ︙ | |||
5737 5738 5739 5740 5741 5742 5743 |
my variable code
::practcl::cputs code($section) $body
}
method Collate_Source CWD {}
method project-compile-products {} {
set result {}
noop {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 |
my variable code
::practcl::cputs code($section) $body
}
method Collate_Source CWD {}
method project-compile-products {} {
set result {}
noop {
set filename [my Config_get filename]
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
if {[my define exists ofile]} {
set ofile [my Config_get ofile]
} else {
set ofile [my Ofile $filename]
my Config_set ofile $ofile
}
lappend result $ofile [list cfile $filename include [my Config_get include] extra [my Config_get extra] external [string is true -strict [my Config_get external]] object [self]]
}
}
foreach item [my link list subordinate] {
lappend result {*}[$item project-compile-products]
}
return $result
}
method generate-debug {{spaces {}}} {
set result {}
::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my Config_get filename]] links [my link list]]"
foreach item [my link list subordinate] {
practcl::cputs result [$item generate-debug "$spaces "]
}
return $result
}
method generate-cfile-constant {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result {}
my variable code cstruct methods tcltype
if {[info exists code(constant)]} {
::practcl::cputs result "/* [my Config_get filename] CONSTANT */"
::practcl::cputs result $code(constant)
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-constant]
}
return $result
}
method generate-cfile-public-structure {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code cstruct methods tcltype
set result {}
if {[info exists code(struct)]} {
::practcl::cputs result $code(struct)
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-public-structure]
}
return $result
}
method generate-cfile-header {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 config get output_c] ne {}} continue
set dat [$obj generate-cfile-header]
if {[string length [string trim $dat]]} {
::practcl::cputs result "/* BEGIN [$obj config get filename] generate-cfile-header */"
::practcl::cputs result $dat
::practcl::cputs result "/* END [$obj config get filename] generate-cfile-header */"
}
}
return $result
}
method generate-cfile-global {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code cfunct cstruct methods tcltype tclprocs
set result {}
if {[info exists code(global)]} {
::practcl::cputs result $code(global)
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
set dat [$obj generate-cfile-global]
if {[string length [string trim $dat]]} {
::practcl::cputs result "/* BEGIN [$obj config get filename] generate-cfile-global */"
::practcl::cputs result $dat
::practcl::cputs result "/* END [$obj config get filename] generate-cfile-global */"
}
}
return $result
}
method generate-cfile-private-typedef {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-cfile-private-typedef]
}
return $result
}
method generate-cfile-private-structure {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-cfile-private-structure]
}
return $result
}
method generate-cfile-functions {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 */"
if {[dict get $info inline] && [dict get $info public]} {
::practcl::cputs result "\ninline [dict get $info header]\{[dict get $info body]\}"
} else {
::practcl::cputs result "\n[dict get $info header]\{[dict get $info body]\}"
}
}
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} {
continue
}
::practcl::cputs result [$obj generate-cfile-functions]
}
return $result
}
method generate-cfile-tclapi {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code methods tclprocs
set result {}
if {[info exists code(method)]} {
::practcl::cputs result $code(method)
}
foreach obj [my link list product] {
# Exclude products that will generate their own C files
if {[$obj config get output_c] ne {}} continue
::practcl::cputs result [$obj generate-cfile-tclapi]
}
return $result
}
method generate-hfile-public-define {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-define]
}
return $result
}
method generate-hfile-public-macro {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-macro]
}
return $result
}
method generate-hfile-public-typedef {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-typedef]
}
return $result
}
method generate-hfile-public-structure {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-structure]
}
return $result
}
method generate-hfile-public-headers {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-headers]
}
return $result
}
method generate-hfile-public-function {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code cfunct tcltype
set result {}
if {[my Config_get initfunc] ne {}} {
::practcl::cputs result "int [my Config_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 Config_get filename]]
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-hfile-public-function]
}
return $result
}
method generate-hfile-public-includes {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set includes {}
foreach item [my Config_get public-include] {
if {$item ni $includes} {
lappend includes $item
}
}
foreach mod [my link list product] {
foreach item [$mod generate-hfile-public-includes] {
if {$item ni $includes} {
lappend includes $item
}
}
}
return $includes
}
method generate-hfile-public-verbatim {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set includes {}
foreach item [my Config_get public-verbatim] {
if {$item ni $includes} {
lappend includes $item
}
}
foreach mod [my link list subordinate] {
foreach item [$mod generate-hfile-public-verbatim] {
if {$item ni $includes} {
lappend includes $item
}
}
}
return $includes
}
method generate-loader-external {} {
if {[my Config_get initfunc] eq {}} {
return "/* [my Config_get filename] declared not initfunc */"
}
return " if([my Config_get initfunc](interp)) return TCL_ERROR\;"
}
method generate-loader-module {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
my variable code
set result {}
if {[info exists code(cinit)]} {
::practcl::cputs result $code(cinit)
}
if {[my Config_get initfunc] ne {}} {
::practcl::cputs result " if([my Config_get initfunc](interp)!=TCL_OK) return TCL_ERROR\;"
}
set result [::practcl::_tagblock $result c [my Config_get filename]]
foreach item [my link list product] {
if {[$item config get output_c] ne {}} {
::practcl::cputs result [$item generate-loader-external]
} else {
::practcl::cputs result [$item generate-loader-module]
}
}
return $result
}
method generate-stub-function {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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
}
}
|
| ︙ | ︙ | |||
6126 6127 6128 6129 6130 6131 6132 |
if {$inc ni $headers} {
lappend headers $inc
}
}
}
method generate-tcl-loader {} {
set result {}
| | | | | | | | | | | | | | | | | | | | | | | | 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 |
if {$inc ni $headers} {
lappend headers $inc
}
}
}
method generate-tcl-loader {} {
set result {}
set PKGINIT [my Config_get pkginit]
set PKG_NAME [my Config_get name [my Config_get pkg_name]]
set PKG_VERSION [my Config_get pkg_vers [my Config_get version]]
if {[string is true [my Config_get SHARED_BUILD 0]]} {
set LIBFILE [my Config_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 generate-tcl-pre {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result {}
my variable code
if {[info exists code(tcl)]} {
set result [::practcl::_tagblock $code(tcl) tcl [my Config_get filename]]
}
if {[info exists code(tcl-pre)]} {
set result [::practcl::_tagblock $code(tcl) tcl [my Config_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 Config_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 Config_get filename]]
}
foreach mod [my link list product] {
::practcl::cputs result [$mod generate-tcl-post]
}
return $result
}
method linktype {} {
return {subordinate product}
}
method Ofile filename {
set lpath [my <module> config get localpath]
if {$lpath eq {}} {
set lpath [my <module> config get name]
}
return ${lpath}_[file rootname [file tail $filename]]
}
method project-static-packages {} {
set result [my Config_get static_packages]
set initfunc [my Config_get initfunc]
if {$initfunc ne {}} {
set pkg_name [my Config_get pkg_name]
if {$pkg_name ne {}} {
dict set result $pkg_name initfunc $initfunc
dict set result $pkg_name version [my Config_get version [my Config_get pkg_vers]]
dict set result $pkg_name autoload [my Config_get autoload 0]
}
}
foreach item [my link list subordinate] {
foreach {pkg info} [$item project-static-packages] {
dict set result $pkg $info
}
}
return $result
}
method toolset-include-directory {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result [my Config_get include_dir]
foreach obj [my link list product] {
foreach path [$obj toolset-include-directory] {
lappend result $path
}
}
return $result
}
method target {method args} {
switch $method {
is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] }
}
}
}
oo::objdefine ::practcl::product {
method select {object} {
set class [$object config get class]
set mixin [$object config get product]
if {$class eq {} && $mixin eq {}} {
set filename [$object config get filename]
if {$filename ne {} && [file exists $filename]} {
switch [file extension $filename] {
.tcl {
set mixin ::practcl::product.dynamic
}
.h {
set mixin ::practcl::product.cheader
|
| ︙ | ︙ | |||
6272 6273 6274 6275 6276 6277 6278 |
method project-compile-products {} {}
method generate-loader-module {} {}
}
::clay::define ::practcl::product.csource {
superclass ::practcl::product
method project-compile-products {} {
set result {}
| | | | | | | | | | | | | 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 |
method project-compile-products {} {}
method generate-loader-module {} {}
}
::clay::define ::practcl::product.csource {
superclass ::practcl::product
method project-compile-products {} {
set result {}
set filename [my Config_get filename]
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
if {[my define exists ofile]} {
set ofile [my Config_get ofile]
} else {
set ofile [my Ofile $filename]
my Config_set ofile $ofile
}
lappend result $ofile [list cfile $filename extra [my Config_get extra] external [string is true -strict [my Config_get external]] object [self]]
}
foreach item [my link list subordinate] {
lappend result {*}[$item project-compile-products]
}
return $result
}
}
::clay::define ::practcl::product.clibrary {
superclass ::practcl::product
method linker-products {configdict} {
return [my Config_get filename]
}
}
::clay::define ::practcl::product.dynamic {
superclass ::practcl::dynamic ::practcl::product
method initialize {} {
set filename [my Config_get filename]
if {$filename eq {}} {
return
}
if {[my Config_get name] eq {}} {
my Config_set name [file tail [file rootname $filename]]
}
if {[my Config_get localpath] eq {}} {
my Config_set localpath [my <module> config get localpath]_[my Config_get name]
}
# Future Development:
# Scan source file to see if it is encoded in criticl or practcl notation
#set thisline {}
#foreach line [split [::practcl::cat $filename] \n] {
#
#}
::source $filename
if {[my Config_get output_c] ne {}} {
# Turn into a module if we have an output_c file
my morph ::practcl::module
}
}
}
::clay::define ::practcl::product.critcl {
superclass ::practcl::dynamic ::practcl::product
|
| ︙ | ︙ | |||
6358 6359 6360 6361 6362 6363 6364 |
}
Ensemble make::pkginfo {} {
###
# Build local variables needed for install
###
package require platform
set result {}
| | | 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 |
}
Ensemble make::pkginfo {} {
###
# Build local variables needed for install
###
package require platform
set result {}
set dat [my Config_dump]
set PKG_DIR [dict get $dat name][dict get $dat version]
dict set result PKG_DIR $PKG_DIR
dict with dat {}
if {![info exists DESTDIR]} {
set DESTDIR {}
}
dict set result profile [::platform::identify]
|
| ︙ | ︙ | |||
6432 6433 6434 6435 6436 6437 6438 |
if {$name in $args} {
$obj check
}
}
}
Ensemble make::filename name {
if {[dict exists $make_object $name]} {
| | | 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 |
if {$name in $args} {
$obj check
}
}
}
Ensemble make::filename name {
if {[dict exists $make_object $name]} {
return [[dict get $make_object $name] config get filename]
}
}
Ensemble make::target {name Info body} {
set info [uplevel #0 [list subst $Info]]
set nspace [namespace current]
if {[dict exist $make_object $name]} {
set obj [dict get $$make_object $name]
|
| ︙ | ︙ | |||
6468 6469 6470 6471 6472 6473 6474 |
}
return $result
}
Ensemble make::do {} {
global CWD SRCDIR project SANDBOX
foreach {name obj} $make_object {
if {[$obj do]} {
| | < < | < | | > > | < | | | | | | | | | | | 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 |
}
return $result
}
Ensemble make::do {} {
global CWD SRCDIR project SANDBOX
foreach {name obj} $make_object {
if {[$obj do]} {
eval [$obj config get action]
}
}
}
method Child_delegate {} {
return [list project [my Config_get project] module [self]]
}
method Child_organs {} {
return [list project [my Config_get project] module [self]]
}
method generate-c {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 Config_get tk 0]} {
my IncludeAdd headers <tk.h>
}
if {[my Config_get output_h] ne {}} {
my IncludeAdd headers [my Config_get output_h]
}
my IncludeAdd headers {*}[my Config_get include]
foreach mod [my link list dynamic] {
my IncludeAdd headers {*}[$mod config get include]
}
foreach inc $headers {
::practcl::cputs result "#include $inc"
}
foreach {method} {
generate-cfile-header
generate-cfile-private-typedef
generate-cfile-private-structure
generate-cfile-public-structure
generate-cfile-constant
generate-cfile-global
generate-cfile-functions
generate-cfile-tclapi
} {
set dat [my $method]
if {[string length [string trim $dat]]} {
::practcl::cputs result "/* BEGIN $method [my Config_get filename] */"
::practcl::cputs result $dat
::practcl::cputs result "/* END $method [my Config_get filename] */"
}
}
::practcl::debug [list /[self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
return $result
}
method generate-h {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result {}
foreach method {
generate-hfile-public-define
generate-hfile-public-macro
} {
::practcl::cputs result "/* BEGIN SECTION $method */"
::practcl::cputs result [my $method]
|
| ︙ | ︙ | |||
6573 6574 6575 6576 6577 6578 6579 |
::practcl::cputs result "/* BEGIN SECTION $method */"
::practcl::cputs result [my $method]
::practcl::cputs result "/* END SECTION $method */"
}
return $result
}
method generate-loader {} {
| | | | | | | | | | | | | | | | 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 |
::practcl::cputs result "/* BEGIN SECTION $method */"
::practcl::cputs result [my $method]
::practcl::cputs result "/* END SECTION $method */"
}
return $result
}
method generate-loader {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set result {}
if {[my Config_get initfunc] eq {}} return
::practcl::cputs result "
extern int DLLEXPORT [my Config_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 Config_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 [string trim $TCLINIT]]} {
::practcl::cputs result " if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }"
}
::practcl::cputs result [my generate-loader-module]
set TCLINIT [my generate-tcl-post]
if {[string length [string trim $TCLINIT]]} {
::practcl::cputs result " if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }"
}
if {[my define exists pkg_name]} {
::practcl::cputs result " if (Tcl_PkgProvide(interp, \"[my Config_get pkg_name [my Config_get name]]\" , \"[my Config_get pkg_vers [my Config_get version]]\" )) return TCL_ERROR\;"
}
::practcl::cputs result " return TCL_OK\;\n\}\n"
return $result
}
method initialize {} {
set filename [my Config_get filename]
if {$filename eq {}} {
return
}
if {[my Config_get name] eq {}} {
my Config_set name [file tail [file dirname $filename]]
}
if {[my Config_get localpath] eq {}} {
my Config_set localpath [my <project> config get name]_[my Config_get name]
}
my graft module [self]
::practcl::debug [self] SOURCE $filename
my source $filename
}
method implement path {
my go
my Collate_Source $path
set errs {}
foreach item [my link list dynamic] {
if {[catch {$item implement $path} err errdat]} {
lappend errs "Skipped $item: [$item config get filename] $err"
if {[dict exists $errdat -errorinfo]} {
lappend errs [dict get $errdat -errorinfo]
} else {
lappend errs $errdat
}
}
}
foreach item [my link list module] {
if {[catch {$item implement $path} err errdat]} {
lappend errs "Skipped $item: [$item config get filename] $err"
if {[dict exists $errdat -errorinfo]} {
lappend errs [dict get $errdat -errorinfo]
} else {
lappend errs $errdat
}
}
}
if {[llength $errs]} {
set logfile [file join $::CWD practcl.log]
::practcl::log $logfile "*** ERRORS ***"
foreach {item trace} $errs {
::practcl::log $logfile "###\n# ERROR\n###\n$item"
::practcl::log $logfile "###\n# TRACE\n###\n$trace"
}
::practcl::log $logfile "*** DEBUG INFO ***"
::practcl::log $logfile $::DEBUG_INFO
puts stderr "Errors saved to $logfile"
exit 1
}
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set filename [my Config_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
|
| ︙ | ︙ | |||
6714 6715 6716 6717 6718 6719 6720 |
# 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]
}
}
my graft module [self]
| | | | | | | | | | | | | | | | | | | | | | | | < < | < < < | | < > > | 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 |
# 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]
}
}
my graft module [self]
my Config_merge $contents
::practcl::toolset select [self]
my initialize
}
method add_object object {
my link object $object
}
method add_project {pkg info {oodefine {}}} {
::practcl::debug [self] add_project $pkg $info
set os [my Config_get TEACUP_OS]
if {$os eq {}} {
set os [::practcl::os]
my Config_set os $os
}
set fossilinfo [list download [my Config_get download] tag trunk sandbox [my Config_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 Config_get profile release]:
if {[dict exists $info profile $profile]} {
dict set info tag [dict get $info profile $profile]
}
dict set info USEMSVC [my Config_get USEMSVC 0]
dict set info debug [my Config_get debug 0]
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 config set masterpath $::CWD
$obj go
return $obj
}
method add_tool {pkg info {oodefine {}}} {
::practcl::debug [self] add_tool $pkg $info
set info [dict merge [::practcl::local_os] $info]
set os [dict get $info TEACUP_OS]
set fossilinfo [list download [my Config_get download] tag trunk sandbox [my Config_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 Config_get profile release]:
if {[dict exists $info profile $profile]} {
dict set info tag [dict get $info profile $profile]
}
set obj ::practcl::OBJECT::TOOL.$pkg
if {[info command $obj] eq {}} {
set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0] $info]]
}
my link add tool $obj
oo::objdefine $obj $oodefine
$obj config set masterpath $::CWD
$obj go
return $obj
}
method build-tclcore {} {
set os [my Config_get TEACUP_OS]
set tcl_config_opts [::practcl::platform::tcl_core_options $os]
set tk_config_opts [::practcl::platform::tk_core_options $os]
lappend tcl_config_opts --prefix [my Config_get prefix] --exec-prefix [my Config_get prefix]
set tclobj [my tclcore]
if {[my Config_get debug 0]} {
$tclobj config set debug 1
lappend tcl_config_opts --enable-symbols=true
}
$tclobj config set config_opts $tcl_config_opts
$tclobj go
$tclobj compile
set _TclSrcDir [$tclobj config get localsrcdir]
my Config_set tclsrcdir $_TclSrcDir
if {[my Config_get tk 0]} {
set tkobj [my tkcore]
lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj config get builddir] [$tclobj config get builddir]]
if {[my Config_get debug 0]} {
$tkobj config set debug 1
lappend tk_config_opts --enable-symbols=true
}
$tkobj config set config_opts $tk_config_opts
$tkobj compile
}
}
method Child_delegate {} {
return [list project [self] module [self]]
}
method Child_organs {} {
return [list project [self] module [self]]
}
method linktype {} {
return project
}
method project {pkg args} {
set obj [namespace current]::PROJECT.$pkg
if {[llength $args]==0} {
|
| ︙ | ︙ | |||
6881 6882 6883 6884 6885 6886 6887 |
###
###
# START: class project library.tcl
###
::clay::define ::practcl::library {
superclass ::practcl::project
method clean {PATH} {
| | | | | | | | | | | | | | | | | | | | | | | | 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 |
###
###
# START: class project library.tcl
###
::clay::define ::practcl::library {
superclass ::practcl::project
method clean {PATH} {
set objext [my Config_get OBJEXT o]
foreach {ofile info} [my project-compile-products] {
if {[file exists [file join $PATH objs $ofile].${objext}]} {
file delete [file join $PATH objs $ofile].${objext}
}
}
foreach ofile [glob -nocomplain [file join $PATH *.${objext}]] {
file delete $ofile
}
foreach ofile [glob -nocomplain [file join $PATH objs *]] {
file delete $ofile
}
set libfile [my Config_get libfile]
if {[file exists [file join $PATH $libfile]]} {
file delete [file join $PATH $libfile]
}
my implement $PATH
}
method project-compile-products {} {
set result {}
foreach item [my link list subordinate] {
lappend result {*}[$item project-compile-products]
}
set filename [my Config_get output_c]
if {$filename ne {}} {
::practcl::debug [self] [self class] [self method] project-compile-products $filename
set ofile [file rootname [file tail $filename]]_main
lappend result $ofile [list cfile $filename extra [my Config_get extra] external [string is true -strict [my Config_get external]]]
}
return $result
}
method go {} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_get filename] [info object class [self]]]
set name [my Config_get name]
if {$name eq {}} {
set name generic
my define name generic
}
if {[my Config_get tk] eq {@TEA_TK_EXTENSION@}} {
my Config_set tk 0
}
set output_c [my Config_get output_c]
if {$output_c eq {}} {
set output_c [file rootname $name].c
my Config_set output_c $output_c
}
set output_h [my Config_get output_h]
if {$output_h eq {}} {
set output_h [file rootname $output_c].h
my Config_set output_h $output_h
}
set output_tcl [my Config_get output_tcl]
#if {$output_tcl eq {}} {
# set output_tcl [file rootname $output_c].tcl
# my Config_set output_tcl $output_tcl
#}
#set output_mk [my Config_get output_mk]
#if {$output_mk eq {}} {
# set output_mk [file rootname $output_c].mk
# my Config_set output_mk $output_mk
#}
set initfunc [my Config_get initfunc]
if {$initfunc eq {}} {
set initfunc [string totitle $name]_Init
my Config_set initfunc $initfunc
}
set output_decls [my Config_get output_decls]
if {$output_decls eq {}} {
set output_decls [file rootname $output_c].decls
my Config_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 Config_get filename] [info object class [self]]]
}
method generate-decls {pkgname path} {
::practcl::debug [list [self] [self method] [self class] -- [my Config_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 {###
|
| ︙ | ︙ | |||
6987 6988 6989 6990 6991 6992 6993 |
###
set stubfuncts [my generate-stub-function]
set thisline {}
set functcount 0
foreach {func header} $stubfuncts {
puts $fout [list declare [incr functcount] $header]
}
| | | | 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 |
###
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 Config_get initfunc](Tcl_Inter *interp)"]
puts $fout [list export "char *[string totitle [my Config_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]
|
| ︙ | ︙ | |||
7059 7060 7061 7062 7063 7064 7065 |
}
method implement path {
my go
my Collate_Source $path
set errs {}
foreach item [my link list dynamic] {
if {[catch {$item implement $path} err errdat]} {
| | | | | | | | | | | | | | | | | | | | | | 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 |
}
method implement path {
my go
my Collate_Source $path
set errs {}
foreach item [my link list dynamic] {
if {[catch {$item implement $path} err errdat]} {
lappend errs "Skipped $item: [$item config get filename] $err"
if {[dict exists $errdat -errorinfo]} {
lappend errs [dict get $errdat -errorinfo]
} else {
lappend errs $errdat
}
}
}
foreach item [my link list module] {
if {[catch {$item implement $path} err errdat]} {
lappend errs "Skipped $item: [$item config get filename] $err"
if {[dict exists $errdat -errorinfo]} {
lappend errs [dict get $errdat -errorinfo]
} else {
lappend errs $errdat
}
}
}
if {[llength $errs]} {
set logfile [file join $::CWD practcl.log]
::practcl::log $logfile "*** ERRORS ***"
foreach {item trace} $errs {
::practcl::log $logfile "###\n# ERROR\n###$item"
::practcl::log $logfile "###\n# TRACE\n###$trace"
}
::practcl::log $logfile "*** DEBUG INFO ***"
::practcl::log $logfile $::DEBUG_INFO
puts stderr "Errors saved to $logfile"
exit 1
}
set cout [open [file join $path [my Config_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 Config_get output_h]]]_H
set hout [open [file join $path [my Config_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} 1"
puts $hout [my generate-h]
puts $hout "#endif"
close $hout
set output_tcl [my Config_get output_tcl]
if {$output_tcl ne {}} {
set tclout [open [file join $path [my Config_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-make path {
my build-Makefile $path [self]
}
method linktype {} {
return library
}
method package-ifneeded {args} {
set result {}
set name [my Config_get pkg_name [my Config_get name]]
set version [my Config_get pkg_vers [my Config_get version]]
if {$version eq {}} {
set version 0.1a
}
set output_tcl [my Config_get output_tcl]
if {$output_tcl ne {}} {
set script "\[list source \[file join \$dir $output_tcl\]\]"
} elseif {[my Config_get SHARED_BUILD 0]} {
set script "\[list load \[file join \$dir [my Config_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 {{filename {}}} {
set name [string tolower [my Config_get name [my Config_get pkg_name]]]
set NAME [string toupper $name]
set version [my Config_get version [my Config_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 Config_get libprefix]
set outfile [string map $map [my Config_get PRACTCL_NAME_LIBRARY]][my Config_get SHLIB_SUFFIX]
return $outfile
}
method static_library {{filename {}}} {
set name [string tolower [my Config_get name [my Config_get pkg_name]]]
set NAME [string toupper $name]
set version [my Config_get version [my Config_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 Config_get libprefix]
set outfile [string map $map [my Config_get PRACTCL_NAME_LIBRARY]].a
return $outfile
}
}
###
# END: class project library.tcl
###
|
| ︙ | ︙ | |||
7241 7242 7243 7244 7245 7246 7247 |
#undef Tk_MainEx
#undef Tk_SafeInit
}
# Build an area of the file for #define directives and
# function declarations
set define {}
| | | | | | 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 |
#undef Tk_MainEx
#undef Tk_SafeInit
}
# Build an area of the file for #define directives and
# function declarations
set define {}
set mainhook [$PROJECT config get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook]
set mainfunc [$PROJECT config get TCL_LOCAL_APPINIT Tclkit_AppInit]
set mainscript [$PROJECT config get main.tcl main.tcl]
set vfsroot [$PROJECT config get vfsroot "[$PROJECT config get ZIPFS_VOLUME]app"]
set vfs_main "${vfsroot}/${mainscript}"
set map {}
foreach var {
vfsroot mainhook mainfunc vfs_main
} {
dict set map %${var}% [set $var]
|
| ︙ | ︙ | |||
7280 7281 7282 7283 7284 7285 7286 |
foreach {statpkg info} $statpkglist {
set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]]
append preinitscript \n $script
if {[dict get $info autoload]} {
append main_init_script \n [list ::load {} $statpkg]
}
}
| < < < < < < > > > > > | | | 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 |
foreach {statpkg info} $statpkglist {
set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]]
append preinitscript \n $script
if {[dict get $info autoload]} {
append main_init_script \n [list ::load {} $statpkg]
}
}
append main_init_script \n {
# 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 {if {[file exists [file join $::starkit::topdir pkgIndex.tcl]]} {
#In a wrapped exe, we don't go out to the environment
set dir $::starkit::topdir
source [file join $::starkit::topdir pkgIndex.tcl]
}}
append main_init_script \n [list set tcl_rcFileName [$PROJECT config get tcl_rcFileName ~/.tclshrc]]
append preinitscript \n [list set ::starkit::thread_init $thread_init_script]
append preinitscript \n {eval $::starkit::thread_init}
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 config get tip_430 0]} {
# Add declarations of functions that tip430 puts in the stub files
$PROJECT code public-header {
int TclZipfs_Init(Tcl_Interp *interp);
int TclZipfs_Mount(
Tcl_Interp *interp,
const char *mntpt,
const char *zipname,
|
| ︙ | ︙ | |||
7361 7362 7363 7364 7365 7366 7367 |
break
}
}
}])\;"
::practcl::cputs zvfsboot " \x7D"
::practcl::cputs zvfsboot " return TCL_OK;"
| | | | 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 |
break
}
}
}])\;"
::practcl::cputs zvfsboot " \x7D"
::practcl::cputs zvfsboot " return TCL_OK;"
if {[$PROJECT config 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;
}
}
if {![$PROJECT config get tip_430 0]} {
::practcl::cputs appinit { TclZipfs_Init(interp);}
}
foreach {statpkg info} $statpkglist {
set initfunc {}
if {[dict exists $info initfunc]} {
set initfunc [dict get $info initfunc]
}
|
| ︙ | ︙ | |||
7409 7410 7411 7412 7413 7414 7415 |
practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);"
practcl::cputs appinit { return TCL_OK;}
$PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit]
}
method Collate_Source CWD {
next $CWD
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 |
practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);"
practcl::cputs appinit { return TCL_OK;}
$PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit]
}
method Collate_Source CWD {
next $CWD
set name [my Config_get name]
# Assume a static shell
if {[my define exists SHARED_BUILD]} {
my Config_set SHARED_BUILD 0
}
if {![my define exists TCL_LOCAL_APPINIT]} {
my Config_set TCL_LOCAL_APPINIT Tclkit_AppInit
}
if {![my define exists TCL_LOCAL_MAIN_HOOK]} {
my Config_set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook
}
set PROJECT [self]
set os [$PROJECT config get TEACUP_OS]
if {[my Config_get SHARED_BUILD 0]} {
puts [list BUILDING TCLSH FOR OS $os]
} else {
puts [list BUILDING KIT FOR OS $os]
}
set TCLOBJ [$PROJECT tclcore]
::practcl::toolset select $TCLOBJ
set TCLSRCDIR [$TCLOBJ config get srcdir]
set PKG_OBJS {}
foreach item [$PROJECT link list core.library] {
if {[string is true [$item config get static]]} {
lappend PKG_OBJS $item
}
}
foreach item [$PROJECT link list package] {
if {[string is true [$item config 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 Config_get SHARED_BUILD 0]} {
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 Config_get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my Config_get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my Config_get TCL_LOCAL_APPINIT Tclkit_AppInit]]
} else {
set PLATFORM_SRC_DIR unix
my add class csource ofile [my Config_get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my Config_get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my Config_get TCL_LOCAL_APPINIT Tclkit_AppInit]]
}
if {![my Config_get SHARED_BUILD 0]} {
###
# 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 config set ZIPFS_VOLUME "zipfs:/"
}
$PROJECT code header "#define ZIPFS_VOLUME \"[$PROJECT config get ZIPFS_VOLUME]\""
if {[file exists $zipfs]} {
$TCLOBJ config set tip_430 1
my Config_set tip_430 1
} else {
# The Tclconfig project maintains a mirror of the version
# released with the Tcl core
my Config_set tip_430 0
set tclzipfs_c [my Config_get tclzipfs_c]
if {![file exists $tclzipfs_c]} {
::practcl::LOCAL tool tclconfig unpack
set COMPATSRCROOT [::practcl::LOCAL tool tclconfig config get srcdir]
set tclzipfs_c [file join $COMPATSRCROOT compat tclZipfs.c]
}
my add class csource ofile tclZipfs.o filename $tclzipfs_c \
extra -I[::practcl::file_relative $CWD [file join $TCLSRCDIR compat zlib contrib minizip]]
}
my Config_add include_dir [file join $TCLSRCDIR generic]
my Config_add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR]
# This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK
my build-tclkit_main $PROJECT $PKG_OBJS
}
method wrap {PWD exename vfspath args} {
cd $PWD
if {![file exists $vfspath]} {
file mkdir $vfspath
}
foreach item [my link list core.library] {
set name [$item config get name]
set libsrcdir [$item config get srcdir]
if {[file exists [file join $libsrcdir library]]} {
::practcl::copyDir [file join $libsrcdir library] [file join $vfspath ${name}_library]
}
}
# Assume the user will populate the VFS path
#if {[my Config_get installdir] ne {}} {
# ::practcl::copyDir [file join [my Config_get installdir] [string trimleft [my Config_get prefix] /] lib] [file join $vfspath lib]
#}
foreach arg $args {
::practcl::copyDir $arg $vfspath
}
set fout [open [file join $vfspath pkgIndex.tcl] w]
puts $fout [string map [list %platform% [my Config_get TEACUP_PROFILE]] {set ::tcl_teapot_profile {%platform%}}]
puts $fout {
namespace eval ::starkit {}
set ::PKGIDXFILE [info script]
set dir [file dirname $::PKGIDXFILE]
if {$::tcl_platform(platform) eq "windows"} {
set ::starkit::localHome [file join [file normalize $::env(LOCALAPPDATA)] tcl]
} else {
|
| ︙ | ︙ | |||
7557 7558 7559 7560 7561 7562 7563 |
if {![file exists $pkginstall]} {
installDir $teapath $pkginstall
}
}
}
close $fout
| | | | | 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 |
if {![file exists $pkginstall]} {
installDir $teapath $pkginstall
}
}
}
close $fout
set EXEEXT [my Config_get EXEEXT]
set tclkit_bare [my Config_get tclkit_bare]
::practcl::mkzip ${exename}${EXEEXT} $tclkit_bare $vfspath
if { [my Config_get TEACUP_OS] ne "windows" } {
file attributes ${exename}${EXEEXT} -permissions a+x
}
}
}
###
# END: class project tclkit.tcl
|
| ︙ | ︙ | |||
7583 7584 7585 7586 7587 7588 7589 |
hash {}
maxdate {}
tags {}
isodate {}
}
}
method DistroMixIn {} {
| | | | | | | | | | | | | | | | | | | | | | | | | | 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 |
hash {}
maxdate {}
tags {}
isodate {}
}
}
method DistroMixIn {} {
my Config_set scm none
}
method Sandbox {} {
if {[my define exists sandbox]} {
return [my Config_get sandbox]
}
if {[my clay delegate project] ni {::noop {}}} {
set sandbox [my <project> config get sandbox]
if {$sandbox ne {}} {
my Config_set sandbox $sandbox
return $sandbox
}
}
set sandbox [file normalize [file join $::CWD ..]]
my Config_set sandbox $sandbox
return $sandbox
}
method SrcDir {} {
set pkg [my Config_get name]
if {[my define exists srcdir]} {
return [my Config_get srcdir]
}
set sandbox [my Sandbox]
set srcdir [file join [my Sandbox] $pkg]
my Config_set srcdir $srcdir
return $srcdir
}
method ScmTag {} {}
method ScmClone {} {}
method ScmUnpack {} {}
method ScmUpdate {} {}
method Unpack {} {
set srcdir [my SrcDir]
if {[file exists $srcdir]} {
return
}
set pkg [my Config_get name]
if {[my define exists download]} {
# Utilize a staged download
set download [my Config_get download]
if {[file exists [file join $download $pkg.zip]]} {
::practcl::tcllib_require zipfile::decode
::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir
return
}
}
my ScmUnpack
}
}
oo::objdefine ::practcl::distribution {
method Sandbox {object} {
if {[$object define exists sandbox]} {
return [$object config get sandbox]
}
if {[$object clay delegate project] ni {::noop {}}} {
set sandbox [$object <project> config get sandbox]
if {$sandbox ne {}} {
$object config set sandbox $sandbox
return $sandbox
}
}
set pkg [$object config get name]
set sandbox [file normalize [file join $::CWD ..]]
$object config set sandbox $sandbox
return $sandbox
}
method select object {
if {[$object define exists scm]} {
return [$object config get scm]
}
set pkg [$object config get name]
if {[$object config get srcdir] ne {}} {
set srcdir [$object config get srcdir]
} else {
set srcdir [file join [my Sandbox $object] $pkg]
$object config set srcdir $srcdir
}
set classprefix ::practcl::distribution.
if {[file exists $srcdir]} {
foreach class [::info commands ${classprefix}*] {
if {[$class claim_path $srcdir]} {
$object clay mixinmap distribution $class
set name [$class claim_option]
$object config set scm $name
return $name
}
}
}
foreach class [::info commands ${classprefix}*] {
if {[$class claim_object $object]} {
$object clay mixinmap distribution $class
set name [$class claim_option]
$object config set scm $name
return $name
}
}
if {[$object config get scm] eq {} && [$object define exists file_url]} {
set class ::practcl::distribution.snapshot
set name [$class claim_option]
$object config set scm $name
$object clay mixinmap distribution $class
return $name
}
error "Cannot determine source distribution method"
}
method claim_option {} {
|
| ︙ | ︙ | |||
7718 7719 7720 7721 7722 7723 7724 |
::clay::define ::practcl::distribution.snapshot {
superclass ::practcl::distribution
method ScmUnpack {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .download]]} {
return 0
}
| | | | 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 |
::clay::define ::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 config get download]
set url [my Config_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] {
|
| ︙ | ︙ | |||
7780 7781 7782 7783 7784 7785 7786 |
# START: class distro fossil.tcl
###
::clay::define ::practcl::distribution.fossil {
superclass ::practcl::distribution
method scm_info {} {
set info [next]
dict set info scm fossil
| | | | | | | | | | | 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 |
# START: class distro fossil.tcl
###
::clay::define ::practcl::distribution.fossil {
superclass ::practcl::distribution
method scm_info {} {
set info [next]
dict set info scm fossil
foreach {field value} [::practcl::fossil_status [my Config_get srcdir]] {
dict set info $field $value
}
return $info
}
method ScmClone {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .fslckout]]} {
return
}
if {[file exists [file join $srcdir _FOSSIL_]]} {
return
}
if {![::info exists ::practcl::fossil_dbs]} {
# Get a list of local fossil databases
set ::practcl::fossil_dbs [exec fossil all list]
}
set pkg [my Config_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 config 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 config 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 Config_get fossil_url] ne {}} {
catch {
::practcl::doexec fossil clone [my Config_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 Config_get scm_tag]
}
if {[my define exists tag]} {
set tag [my Config_get tag]
} else {
set tag trunk
}
my Config_set scm_tag $tag
return $tag
}
method ScmUnpack {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .fslckout]]} {
return 0
}
|
| ︙ | ︙ | |||
7883 7884 7885 7886 7887 7888 7889 |
::practcl::fossil $srcdir update $tag
}
}
oo::objdefine ::practcl::distribution.fossil {
# Check for markers in the metadata
method claim_object obj {
| | | | 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 |
::practcl::fossil $srcdir update $tag
}
}
oo::objdefine ::practcl::distribution.fossil {
# Check for markers in the metadata
method claim_object obj {
set path [$obj config get srcdir]
if {[my claim_path $path]} {
return true
}
if {[$obj config get fossil_url] ne {}} {
return true
}
return false
}
method claim_option {} {
return fossil
|
| ︙ | ︙ | |||
7919 7920 7921 7922 7923 7924 7925 |
###
# START: class distro git.tcl
###
::clay::define ::practcl::distribution.git {
superclass ::practcl::distribution
method ScmTag {} {
if {[my define exists scm_tag]} {
| | | | | | | | | 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 |
###
# START: class distro git.tcl
###
::clay::define ::practcl::distribution.git {
superclass ::practcl::distribution
method ScmTag {} {
if {[my define exists scm_tag]} {
return [my Config_get scm_tag]
}
if {[my define exists tag]} {
set tag [my Config_get tag]
} else {
set tag master
}
my Config_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 Config_get name]
if {[my define exists git_url]} {
::practcl::doexec git clone --branch $tag [my Config_get git_url] $srcdir
} else {
::practcl::doexec git clone --branch $tag https://github.com/eviltwinskippy/$pkg $srcdir
}
return 1
}
method ScmUpdate {} {
if {[my ScmUnpack]} {
return
}
set CWD [pwd]
set srcdir [my SrcDir]
set tag [my ScmTag]
::practcl::doexec_in $srcdir git pull
cd $CWD
}
}
oo::objdefine ::practcl::distribution.git {
method claim_object obj {
set path [$obj config get srcdir]
if {[my claim_path $path]} {
return true
}
if {[$obj config get git_url] ne {}} {
return true
}
return false
}
method claim_option {} {
return git
|
| ︙ | ︙ | |||
7992 7993 7994 7995 7996 7997 7998 |
###
::clay::define ::practcl::subproject {
superclass ::practcl::module
method _MorphPatterns {} {
return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
}
method BuildDir {PWD} {
| | < < | < < < | | < > > | | | | 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 |
###
::clay::define ::practcl::subproject {
superclass ::practcl::module
method _MorphPatterns {} {
return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
}
method BuildDir {PWD} {
return [my Config_get srcdir]
}
method Child_delegate {} {
return [list project [self] module [self]]
}
method Child_organs {} {
return [list project [self] module [self]]
}
method compile {} {}
method go {} {
::practcl::distribution select [self]
set name [my Config_get name]
my Config_set builddir [my BuildDir [my Config_get masterpath]]
my Config_set builddir [my BuildDir [my Config_get masterpath]]
my sources
}
method install args {}
method linktype {} {
return {subordinate package}
}
method linker-products {configdict} {}
|
| ︙ | ︙ | |||
8032 8033 8034 8035 8036 8037 8038 |
method linker-extra {configdict} {
if {[dict exists $configdict PRACTCL_LINKER_EXTRA]} {
return [dict get $configdict PRACTCL_LINKER_EXTRA]
}
return {}
}
method env-bootstrap {} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 |
method linker-extra {configdict} {
if {[dict exists $configdict PRACTCL_LINKER_EXTRA]} {
return [dict get $configdict PRACTCL_LINKER_EXTRA]
}
return {}
}
method env-bootstrap {} {
set pkg [my Config_get pkg_name [my Config_get name]]
package require $pkg
}
method env-exec {} {}
method env-install {} {
my unpack
}
method env-load {} {
my variable loaded
if {[info exists loaded]} {
return 0
}
if {![my env-present]} {
my env-install
}
my env-bootstrap
set loaded 1
}
method env-present {} {
set pkg [my Config_get pkg_name [my Config_get name]]
if {[catch [list package require $pkg]]} {
return 0
}
return 1
}
method sources {} {}
method update {} {
my ScmUpdate
}
method unpack {} {
cd $::CWD
::practcl::distribution select [self]
my Unpack
::practcl::toolset select [self]
cd $::CWD
}
}
::clay::define ::practcl::subproject.source {
superclass ::practcl::subproject ::practcl::library
method env-bootstrap {} {
set LibraryRoot [file join [my Config_get srcdir] [my Config_get module_root modules]]
if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
}
}
method env-present {} {
set path [my Config_get srcdir]
return [file exists $path]
}
method linktype {} {
return {subordinate package source}
}
}
::clay::define ::practcl::subproject.teapot {
superclass ::practcl::subproject
method env-bootstrap {} {
set pkg [my Config_get pkg_name [my Config_get name]]
package require $pkg
}
method env-install {} {
set pkg [my Config_get pkg_name [my Config_get name]]
set download [my <project> config get download]
my unpack
set prefix [string trimleft [my <project> config get prefix] /]
::practcl::tcllib_require zipfile::decode
::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $prefix lib $pkg]
}
method env-present {} {
set pkg [my Config_get pkg_name [my Config_get name]]
if {[catch [list package require $pkg]]} {
return 0
}
return 1
}
method install DEST {
set pkg [my Config_get pkg_name [my Config_get name]]
set download [my <project> config get download]
my unpack
set prefix [string trimleft [my <project> config get prefix] /]
::practcl::tcllib_require zipfile::decode
::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg]
}
}
::clay::define ::practcl::subproject.kettle {
superclass ::practcl::subproject
method kettle {path args} {
my variable kettle
if {![info exists kettle]} {
::practcl::LOCAL tool kettle env-load
set kettle [file join [::practcl::LOCAL tool kettle config get srcdir] kettle]
}
set srcdir [my SourceRoot]
::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args
}
method install DEST {
my kettle reinstall --prefix $DEST
}
}
::clay::define ::practcl::subproject.critcl {
superclass ::practcl::subproject
method install DEST {
my critcl -pkg [my Config_get name]
set srcdir [my SourceRoot]
::practcl::copyDir [file join $srcdir [my Config_get name]] [file join $DEST lib [my Config_get name]]
}
}
::clay::define ::practcl::subproject.sak {
superclass ::practcl::subproject
method env-bootstrap {} {
set LibraryRoot [file join [my Config_get srcdir] [my Config_get module_root modules]]
if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
}
}
method env-install {} {
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
my unpack
set prefix [my <project> config get prefix [file normalize [file join ~ tcl]]]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir installer.tcl] \
-apps -app-path [file join $prefix apps] \
-html -html-path [file join $prefix doc html $pkg] \
-pkg-path [file join $prefix lib $pkg] \
-no-nroff -no-wait -no-gui
}
method env-present {} {
set path [my Config_get srcdir]
return [file exists $path]
}
method install DEST {
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
my unpack
set prefix [string trimleft [my <project> config get prefix] /]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir installer.tcl] \
-pkg-path [file join $DEST $prefix lib $pkg] \
-no-examples -no-html -no-nroff \
-no-wait -no-gui -no-apps
}
method install-module {DEST args} {
set srcdir [my Config_get srcdir]
if {[llength $args]==1 && [lindex $args 0] in {* all}} {
set pkg [my Config_get pkg_name [my Config_get name]]
::practcl::dotclexec [file join $srcdir installer.tcl] \
-pkg-path [file join $DEST $pkg] \
-no-examples -no-html -no-nroff \
-no-wait -no-gui -no-apps
} else {
foreach module $args {
::practcl::installModule [file join $srcdir modules $module] [file join $DEST $module]
}
}
}
}
::clay::define ::practcl::subproject.practcl {
superclass ::practcl::subproject
method env-bootstrap {} {
set LibraryRoot [file join [my Config_get srcdir] [my Config_get module_root modules]]
if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
}
}
method env-install {} {
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
my unpack
set prefix [my <project> config get prefix [file normalize [file join ~ tcl]]]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir make.tcl] install [file join $prefix lib $pkg]
}
method install DEST {
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
my unpack
set prefix [string trimleft [my <project> config get prefix] /]
set srcdir [my Config_get srcdir]
puts [list INSTALLING [my Config_get name] to [file join $DEST $prefix lib $pkg]]
::practcl::dotclexec [file join $srcdir make.tcl] install [file join $DEST $prefix lib $pkg]
}
method install-module {DEST args} {
set pkg [my Config_get pkg_name [my Config_get name]]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir make.tcl] install-module $DEST {*}$args
}
}
###
# END: class subproject baseclass.tcl
###
###
# START: class subproject binary.tcl
###
::clay::define ::practcl::subproject.binary {
superclass ::practcl::subproject
method clean {} {
set builddir [file normalize [my Config_get builddir]]
if {![file exists $builddir]} return
if {[file exists [file join $builddir make.tcl]]} {
::practcl::domake.tcl $builddir clean
} else {
catch {::practcl::domake $builddir clean}
}
}
method env-install {} {
###
# Handle tea installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
set os [::practcl::local_os]
my Config_set os $os
my unpack
set prefix [my <project> config get prefix [file normalize [file join ~ tcl]]]
set srcdir [my Config_get srcdir]
lappend options --prefix $prefix --exec-prefix $prefix
my Config_set config_opts $options
my go
my clean
my compile
my make install {}
}
method project-compile-products {} {}
method ComputeInstall {} {
if {[my define exists install]} {
switch [my Config_get install] {
static {
my Config_set static 1
my Config_set autoload 0
}
static-autoload {
my Config_set static 1
my Config_set autoload 1
}
vfs {
my Config_set static 0
my Config_set autoload 0
my Config_set vfsinstall 1
}
null {
my Config_set static 0
my Config_set autoload 0
my Config_set vfsinstall 0
}
default {
}
}
}
}
method go {} {
next
::practcl::distribution select [self]
my ComputeInstall
my Config_set builddir [my BuildDir [my Config_get masterpath]]
}
method linker-products {configdict} {
if {![my Config_get static 0]} {
return {}
}
set srcdir [my Config_get builddir]
if {[dict exists $configdict libfile]} {
return " [file join $srcdir [dict get $configdict libfile]]"
}
}
method project-static-packages {} {
if {![my Config_get static 0]} {
return {}
}
set result [my Config_get static_packages]
set statpkg [my Config_get static_pkg]
set initfunc [my Config_get initfunc]
if {$initfunc ne {}} {
set pkg_name [my Config_get pkg_name]
if {$pkg_name ne {}} {
dict set result $pkg_name initfunc $initfunc
set version [my Config_get version]
if {$version eq {}} {
my unpack
set info [my read_configuration]
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 Config_set version $version
}
dict set result $pkg_name version $version
dict set result $pkg_name autoload [my Config_get autoload 0]
}
}
foreach item [my link list subordinate] {
foreach {pkg info} [$item project-static-packages] {
dict set result $pkg $info
}
}
return $result
}
method BuildDir {PWD} {
set name [my Config_get name]
set debug [my Config_get debug 0]
if {[my <project> config get LOCAL 0]} {
return [my Config_get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my Config_get builddir [file join $PWD debug $name]]
} else {
return [my Config_get builddir [file join $PWD pkg $name]]
}
}
method compile {} {
set name [my Config_get name]
set PWD $::CWD
cd $PWD
my unpack
set srcdir [file normalize [my SrcDir]]
set localsrcdir [my MakeDir $srcdir]
my Config_set localsrcdir $localsrcdir
my Collate_Source $PWD
###
# Build a starter VFS for both Tcl and wish
###
set srcdir [my Config_get srcdir]
if {[my Config_get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
my make compile
cd $PWD
}
method Configure {} {
cd $::CWD
my unpack
::practcl::toolset select [self]
set srcdir [file normalize [my Config_get srcdir]]
set builddir [file normalize [my Config_get builddir]]
file mkdir $builddir
my make autodetect
}
method install DEST {
set PWD [pwd]
set PREFIX [my <project> config get prefix]
###
# Handle teapot installs
###
set pkg [my Config_get pkg_name [my Config_get name]]
if {[my <project> config get teapot] ne {}} {
set TEAPOT [my <project> config get teapot]
set found 0
foreach ver [my Config_get pkg_vers [my Config_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
}
}
|
| ︙ | ︙ | |||
8431 8432 8433 8434 8435 8436 8437 |
###
# START: class subproject core.tcl
###
::clay::define ::practcl::subproject.core {
superclass ::practcl::subproject.binary
method env-bootstrap {} {}
method env-present {} {
| | | | | | | | | 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 8677 8678 8679 8680 8681 8682 8683 8684 8685 8686 8687 |
###
# START: class subproject core.tcl
###
::clay::define ::practcl::subproject.core {
superclass ::practcl::subproject.binary
method env-bootstrap {} {}
method env-present {} {
set PREFIX [my <project> config get prefix]
set name [my Config_get name]
set fname [file join $PREFIX lib ${name}Config.sh]
return [file exists $fname]
}
method env-install {} {
my unpack
set os [::practcl::local_os]
set prefix [my <project> config get prefix [file normalize [file join ~ tcl]]]
lappend options --prefix $prefix --exec-prefix $prefix
my Config_set config_opts $options
puts [list [self] OS [dict get $os TEACUP_OS] options $options]
my go
my compile
my make install {}
}
method go {} {
my Config_set core_binary 1
next
}
method linktype {} {
return {subordinate core.library}
}
}
###
# END: class subproject core.tcl
###
###
# START: class tool.tcl
###
set ::practcl::MAIN ::practcl::LOCAL
set ::auto_index(::practcl::LOCAL) {
::practcl::project create ::practcl::LOCAL
::practcl::LOCAL config set [::practcl::local_os]
::practcl::LOCAL config set LOCAL 1
# Until something better comes along, use ::practcl::LOCAL
# as our main project
# Add tclconfig as a project of record
::practcl::LOCAL add_tool tclconfig {
name tclconfig tag practcl class subproject.source fossil_url http://core.tcl.tk/tclconfig
}
|
| ︙ | ︙ | |||
8496 8497 8498 8499 8500 8501 8502 |
modules lib
} {
method env-bootstrap {} {
package require critcl::app
}
method env-install {} {
my unpack
| | | | 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 |
modules lib
} {
method env-bootstrap {} {
package require critcl::app
}
method env-install {} {
my unpack
set prefix [my <project> config get prefix [file join [file normalize ~] tcl]]
set srcdir [my Config_get srcdir]
::practcl::dotclexec [file join $srcdir build.tcl] install [file join $prefix lib]
}
}
::practcl::LOCAL add_tool odie {
tag trunk class subproject.source
fossil_url http://fossil.etoyoc.com/fossil/odie
}
|
| ︙ | ︙ |