You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
289 lines
9.2 KiB
289 lines
9.2 KiB
#!/usr/bin/env tclsh |
|
|
|
#Создан: Ср 29 июн 2011 22:35:00 |
|
#Изменён: Пн 14 апр 2014 22:42:56 |
|
|
|
#****F* main/nprs ***************************************************** |
|
# |
|
# NAME |
|
# makeTclKit - script for building Tcl/Tk tclkits |
|
# |
|
# COPYRIGHT |
|
# Copyright (C) 2011-2014, Likhachev Maxim, mail@domain.com |
|
# |
|
# LICENSE |
|
# |
|
# This program is free software: you can redistribute it and/or modify it |
|
# under the terms of the GNU General Public License as published by the Free |
|
# Software Foundation, version 3. |
|
# |
|
# This program is distributed in the hope that it will be useful, |
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
# GNU General Public License for more details. |
|
# |
|
# You should have received a copy of the GNU General Public License |
|
# along with this program. If not, see <http://www.gnu.org/licenses/>. |
|
# |
|
# VERSION |
|
# 0.2 |
|
# |
|
# DESCRIPTION |
|
# makeTclKit is a script for building Tcl/Tk tclkits with the |
|
# dependencies checking. All tclkit wrappers can be found on tclkit web |
|
# page: http://equi4.com/pub/tk/downloads.html. |
|
# |
|
# Use the command 'makeTclKit.tcl --help' to get information about usage. |
|
# |
|
#****************************************************************************** |
|
|
|
package require fileutil |
|
package require textutil::tabify |
|
|
|
interp alias {} mkdir {} file mkdir |
|
interp alias {} rm-rf {} file delete -force -- |
|
interp alias {} cp {} file copy -force -- |
|
|
|
#Procedures for packages manipulating |
|
namespace eval package { |
|
#Find package in directory tree |
|
proc whereis? {package} { |
|
lindex [package ifneeded $package [package require $package]] 1 |
|
} |
|
|
|
#Copying package in local directory |
|
proc copy {package _to directory} { |
|
if {"$package" eq "sqlite3"} { |
|
return |
|
} |
|
set packageFile [package::whereis? $package] |
|
set packageDir [file dirname $packageFile] |
|
set packageRootDir [file tail $packageDir] |
|
set packageIndex [file join $packageDir pkgIndex.tcl] |
|
set destinationDir [file join $directory $packageRootDir] |
|
|
|
file mkdir $destinationDir |
|
catch {cp [string map {; {}} $packageFile] $destinationDir} code |
|
catch {cp $packageIndex $destinationDir} code |
|
} |
|
} |
|
|
|
namespace eval starkit { |
|
if 0 { |
|
if {\$tcl_platform(platform) eq {windows}} { |
|
package require Tk |
|
wm withdraw . |
|
console show |
|
} |
|
} |
|
|
|
#Creating starkit's startup file main.tcl |
|
proc makeMainStarkitFile {mainScript} { |
|
fileutil::writeFile main.tcl \ |
|
[textutil::tabify::untabify " |
|
package require starkit |
|
starkit::startup |
|
|
|
source \[file join \[file dirname \[info script\]\] \[file tail $mainScript\]\] |
|
" 2] |
|
} |
|
|
|
#Wraping starkit |
|
proc wrap {tclkit sdx bin runtime directory mainScript} { |
|
set execDirectory [pwd] |
|
cd $directory; makeMainStarkitFile $mainScript |
|
cd ..; eval exec $tclkit $sdx wrap $bin -runtime $runtime |
|
cp [file tail $bin] $execDirectory |
|
cd $execDirectory |
|
} |
|
} |
|
|
|
#Copying all dependences in local directory tree |
|
proc copyDepends {directory _to libdir {deps {}}} { |
|
set depends [getDepends $directory] |
|
|
|
if {$depends ne $deps} { |
|
foreach package $depends { |
|
#FIXME!!! |
|
catch {package::copy $package to $libdir} |
|
} |
|
copyDepends $libdir to $libdir $depends |
|
} |
|
} |
|
|
|
#TRYEVAL with reports: "ok" if success and "$ERRORCODE" if fail. |
|
proc tryEval {title code ? ok : fail {-> {}} {finally {}}} { |
|
puts -nonewline stderr [format " %-40s" $title] |
|
if {![catch $code err]} { |
|
puts $ok |
|
} else { |
|
puts stderr "$fail $err" |
|
eval $finally |
|
} |
|
} |
|
|
|
#Find dependences of built program |
|
proc getDepends {directory} { |
|
set packages {} |
|
|
|
foreach s [fileutil::grep {^[^#\{]*package[\t ]require} [fileutil::find $directory isTCL]] { |
|
regexp -- {package[\s]+require[\s]+([\w:]+)} $s -> package |
|
lappend packages $package |
|
} |
|
return [lsort -unique [string map {Tcl {} Tk {} http {} starkit {}} $packages]] |
|
} |
|
|
|
#Test for tcl source file |
|
proc isTCL {name} { |
|
return [string match *.tcl $name] |
|
} |
|
|
|
#Encoding cyrillic files |
|
proc iconv! {filename {encoding cp1251}} { |
|
fileutil::writeFile -encoding $encoding -- $filename [fileutil::cat $filename] |
|
} |
|
|
|
#Report about missing wrap of runtime file(s) |
|
proc fileNotFound {filetype directory filename} { |
|
set filename [file tail $filename] |
|
set posPlatform [string first {-} $filename 1] |
|
set posArch [string first {-} $filename [expr {$posPlatform + 1}]] |
|
set posUI [string first {-} $filename [expr {$posArch + 1}]] |
|
|
|
puts "ERROR: Following $filetype file not found in directory ${directory}/:\n" |
|
puts " $filename" |
|
puts " [string repeat { } $posPlatform] ^\ |
|
[string repeat { } [expr $posArch - $posPlatform - 3]] ^\ |
|
[string repeat { } [expr $posUI - $posArch - 3]] ^" |
|
puts " [string repeat { } $posPlatform] |\ |
|
[string repeat { } [expr $posArch - $posPlatform - 3]] |\ |
|
[string repeat { } [expr $posUI - $posArch - 3]] |" |
|
puts " Platform [string repeat {-} $posPlatform]--+\ |
|
[string repeat { } [expr $posArch - $posPlatform - 3]] |\ |
|
[string repeat { } [expr $posUI - $posArch - 3]] |" |
|
puts " Arch [string repeat {-} $posArch]--+\ |
|
[string repeat { } [expr $posUI - $posArch - 3]] |" |
|
puts " UI [string repeat {-} $posUI]--+\n" |
|
puts " All tclkit wrappers can be found on tclkit web page: http://equi4.com/pub/tk/downloads.html\n" |
|
|
|
exit 1 |
|
} |
|
|
|
|
|
#------------------------------------------------------------------------------ |
|
|
|
#Parsing command line options |
|
proc setArg {arg {val {}}} { |
|
if {$val eq ""} { |
|
set ::$arg [lindex $::argv [expr {$::i + 1}]] |
|
incr ::i |
|
} else { |
|
set ::$arg $val |
|
} |
|
} |
|
|
|
#Set default variable value |
|
proc setDefault {var value} { |
|
if {![info exists ::$var]} { |
|
set ::$var $value |
|
} |
|
} |
|
|
|
#Help message |
|
proc showHelp {{code 1}} { |
|
puts "\n \[Make TclKit v0.2\]\n\n Usage: [file tail [info script]] \[options\] |
|
-t, --target -- target operation system |
|
-a, --arch -- machine arch |
|
-d, --dir -- source directory |
|
-s, --source -- main script file |
|
-n, --name -- project name \[default value is directory name\] |
|
-c, --cli -- cli wrapper |
|
-g, --gui -- gui wrapper (for programs with using Tk) |
|
-h, --help -- show this help |
|
" |
|
exit $code |
|
} |
|
|
|
#Entry point |
|
if {$argc <= 0} { |
|
showHelp 0 |
|
} else { |
|
#Parsing command line arguments |
|
for {set i 0; set flag 0} {$i < $argc} {incr i} { |
|
switch -- [lindex $argv $i] { |
|
-t - --target { setArg PLATFORM } |
|
-a - --arch { setArg TCLKIT(TARGET_ARCH) } |
|
-c - --cli { setArg TCLKIT(UI) cli } |
|
-g - --gui { setArg TCLKIT(UI) gui } |
|
-d - --dir { setArg SOURCEDIR } |
|
-s - --source { setArg TCLKIT(MAIN_SCRIPT) } |
|
-n - --name { setArg TCLKIT(PROJECT) } |
|
-h - --help { showHelp 0 } |
|
default { puts "\n ERROR: Unknown argument \"[lindex $argv $i]\"" |
|
showHelp 1 |
|
} |
|
} |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------------------------------------- |
|
|
|
set TCLKIT(ROOT_DIR) [file join [file dirname [file normalize [info script]]] tclkit] |
|
set TCLKIT(SOURCEDIR) [file normalize $SOURCEDIR] |
|
set TCLKIT(CURRENT_PLATFORM) [string tolower $::tcl_platform(os)] |
|
set TCLKIT(CURRENT_ARCH) [string tolower $::tcl_platform(machine)] |
|
set TCLKIT(TARGET_PLATFORM) [string tolower $PLATFORM] |
|
|
|
setDefault TCLKIT(PROJECT) [file tail $TCLKIT(SOURCEDIR)] |
|
setDefault TCLKIT(TARGET_ARCH) $tcl_platform(machine) |
|
|
|
set TCLKIT(BUILD_DIR) [file join [fileutil::tempdir] TclKits $TCLKIT(PROJECT)_${TCLKIT(TARGET_PLATFORM)}.vfs] |
|
set TCLKIT(LIB_DIR) [file join $TCLKIT(BUILD_DIR) lib] |
|
set TCLKIT(BIN_FILE) [string map {vfs kit} [file tail $TCLKIT(BUILD_DIR)]] |
|
set TCLKIT(BIN_EXT) [expr { $TCLKIT(TARGET_PLATFORM) eq "WINDOWS" ? {exe} : {bin}}] |
|
set TCLKIT(STARKIT) [string map "kit $::TCLKIT(BIN_EXT)" $::TCLKIT(BIN_FILE)] |
|
|
|
set TCLKIT_FILE(SDX) [file join $TCLKIT(ROOT_DIR) sdx.kit] |
|
set TCLKIT_FILE(TCLKIT) [file join $TCLKIT(ROOT_DIR) \ |
|
tclkit-$TCLKIT(CURRENT_PLATFORM)-$TCLKIT(CURRENT_ARCH)-$TCLKIT(UI)_wrap] |
|
set TCLKIT_FILE(RUNTIME) [file join $TCLKIT(ROOT_DIR) \ |
|
tclkit-$TCLKIT(TARGET_PLATFORM)-$TCLKIT(TARGET_ARCH)-$TCLKIT(UI)] |
|
|
|
parray tcl_platform; puts "" |
|
parray TCLKIT_FILE; puts "" |
|
parray TCLKIT; puts "" |
|
|
|
if {![file exists $TCLKIT_FILE(TCLKIT)]} { |
|
fileNotFound wrapper tclkit $TCLKIT_FILE(TCLKIT) |
|
} |
|
|
|
if {![file exists $TCLKIT_FILE(RUNTIME)]} { |
|
fileNotFound runtime tclkit $TCLKIT_FILE(RUNTIME) |
|
} |
|
|
|
#------------------------------------------------------------------------------ |
|
|
|
set INIT_COMMAND(WINDOWS) {iconv!} |
|
|
|
tryEval "CLEAR BUILD DIRECTORY: " {rm-rf $::TCLKIT(BUILD_DIR)} ? {[OK]} : {[FAIL]} -> {exit 1} |
|
tryEval "MAKE BUILD DIRECTORY: " {mkdir $::TCLKIT(BUILD_DIR)} ? {[OK]} : {[FAIL]} -> {exit 1} |
|
tryEval "COPY SOURCES: " {cp {*}[glob -directory $::TCLKIT(SOURCEDIR) *] $::TCLKIT(BUILD_DIR)} ? {[OK]} : {[FAIL]} -> {exit 1} |
|
tryEval "DEPENDENS: " {copyDepends $::TCLKIT(SOURCEDIR) to $::TCLKIT(LIB_DIR)} ? {[OK]} : {[FAIL]} -> {exit 1} |
|
|
|
if {[info exists ::INIT_COMMAND($::TCLKIT(TARGET_PLATFORM))]} { |
|
foreach sourceFile [fileutil::find $::TCLKIT(BUILD_DIR) isTCL] { |
|
eval $::INIT_COMMAND($::TCLKIT(TARGET_PLATFORM)) $sourceFile |
|
} |
|
} |
|
|
|
tryEval "CREATE STARKIT: " {starkit::wrap $::TCLKIT_FILE(TCLKIT) \ |
|
$::TCLKIT_FILE(SDX) \ |
|
$::TCLKIT(STARKIT) \ |
|
$::TCLKIT_FILE(RUNTIME) \ |
|
$::TCLKIT(BUILD_DIR) \ |
|
$::TCLKIT(MAIN_SCRIPT) |
|
} ? {[OK]} : {[FAIL]} -> {exit 1} |
|
|
|
#Quit Tk |
|
exit |
|
|
|
|