Index: README ================================================================== --- README +++ README @@ -5,11 +5,12 @@ Toadkit utilizes Tcl whereever possible for build automation, thus allowing for a more consistant (and infinately more portable) build experience. - -Layout: +To build: -pkgs/ - Each file is a module, written in Practcl, which describes a major - module for the basekit +mkdir ../build +cd ../build +tclsh ../odie/make.tcl tcltk +tclsh ../odie/make.tcl basekit + DELETED aclocal.m4 Index: aclocal.m4 ================================================================== --- aclocal.m4 +++ /dev/null @@ -1,5 +0,0 @@ -# -# Include the TEA standard macro set -# - -builtin(include,tclconfig/tcl.m4) DELETED auto.def Index: auto.def ================================================================== --- auto.def +++ /dev/null @@ -1,283 +0,0 @@ -### -# Odie autosetup script -### -use system - -options { - sandbox: with-sandbox: => {Writable location for builds} - download: with-download => {Writable location for downloading source} - tclbranch:release => {Branch of the Tcl core to build against} - tkbranch: => {Branch of the Tk core to build against - * defaults to tclbranch - * if "none" is specified, Tk is disabled} - windowsystem:native => {For platforms with multiple windowing systems, which system to target. -native - The native window system -x11 - An x11 emulation environment -none - Disable Tk support (equivilent to tkbranch=none) -} - msvpath: => {On Windows, Path to MS Visual Studio} - 64bit:detect => {Enable 64 bit support (default detect)} - fossil: => {Location of native fossil executable (default detect)} - tclsh: => {Location of native tcl shell (default detect)} -} - -set ::odie(src_dir) [file dirname [file-normalize [info script]]] -use odie - -switch [opt-val 64bit] { - amd64 - - x64 - - x86_64 { - set ::odie(64bit) 1 - } - {} - - detect { - } - default { - set ::odie(64bit) [opt-bool 64bit] - } -} -set ::odie_config(64bit) $::odie(64bit) -set ::odie(host) [get-define host] -set ::odie(target) [get-define target] - -#-------------------------------------------------------------------- -# Determines the correct executable file extension (.exe) -#-------------------------------------------------------------------- -define EXE $::odie(exe_suffix) -define EXE_SUFFIX $::odie(exe_suffix) -define target [get-define target] - -set ::odie(sandbox) [opt-val sandbox] -if {$::odie(sandbox) eq {}} { - set ::odie(sandbox) [file join $::odie(prefix) sandbox] -} else { - set ::odie_config(sandbox) $::odie(sandbox) -} -set ::odie(sandbox_path) $::odie(sandbox) -set ::odie(download) [opt-val download] -if {$::odie(download) eq {}} { - set ::odie(download) [file join $::odie(prefix) download] -} else { - set ::odie_config(download) $::odie(download) -} -set ::odie(download_path) $::odie(download) - -set ::odie(fossil) [lindex [opt-val fossil] end] -if {$::odie(fossil) eq {}} { - set ::odie(fossil) [lindex [find-an-executable -required fossil] 0] -} else { - set ::odie_config(fossil) $::odie(fossil) -} -set ::odie_prog(fossil) $::odie(fossil) -define FOSSIL_PROG $::odie(fossil) - -set ::odie(build_tclsh) [lindex [opt-val tclsh] end] -if {$::odie(build_tclsh) eq {}} { - set ::odie(build_tclsh) [info nameofexecutable] -} else { - set ::odie_config(tclsh) $::odie(build_tclsh) -} -set ::odie_prog(tclsh) $::odie(build_tclsh) -define ODIE_BUILD_TCLSH $::odie(build_tclsh) - -use cc cc-lib odie - -foreach {program required domake} { - zip 1 0 - unzip 1 0 - tar 1 0 - git 0 1 - strip 0 0 - mkhdr 0 1 - gort 0 1 -} { - if {$required} { - set exename [lindex [find-an-executable -required $program] 0] - } else { - set exename [lindex [find-an-executable $program] 0] - } - if {$domake && $exename eq {}} { - set prog_build($program) 1 - set exename [file join $::odie(prefix) bin ${program}$::odie(exe_suffix)] - } else { - set prog_build($program) 0 - } - set odie_prog($program) [::realpath $exename] - define [string toupper ${program}_prog] [::cygpath $exename] -} - -# XXX SC_ODIE -# XXX SC_ENABLE_SHARED -# XXX ODIE_PROG_TCLSH -# XXX ODIE_PROG_WISH - -### -# Build Tcl/Tk -### - -set ::odie_tcl(fossil_branch) [opt-val tclbranch] -if {$::odie_tcl(fossil_branch) eq {}} { - set ::odie_tcl(fossil_branch) release -} -set ::odie_config(tclbranch) $::odie_tcl(fossil_branch) - - -if {$::odie(64bit)} { - lappend ::odie_tcl(config_flags) --enable-64bit -} else { - lappend ::odie_tcl(config_flags) --enable-64bit=no -} - -switch $::odie(teacup_os) { - "macosx" { - lappend ::odie_tcl(config_flags) --enable-corefoundation=no --enable-framework=no - } - "macosx10.5" { - lappend ::odie_tcl(config_flags) --enable-corefoundation=yes --enable-framework=no - } -} - -set ::odie(window_system) [opt-val windowsystem] -set ::odie_tk(fossil_branch) [opt-val tkbranch] -if { $::odie(window_system) eq "none" || $::odie_tk(fossil_branch) eq "none"} { - ### - # Tk support disabled - ### - set ::odie_tk(fossil_branch) none - set ::odie(window_system) none - set ::odie(tk_binary_platform) none -} else { - set ::odie_tk(config_flags) $::odie_tcl(config_flags) - if {$::odie_tk(fossil_branch) eq {}} { - set ::odie_tk(fossil_branch) $::odie_tcl(fossil_branch) - } - switch $::odie(os) { - "linux" { - set ::odie(window_system) x11 - lappend ::odie_tk(config_flags) --enable-xft=no --enable-xss=no - } - "macosx" { - ### - # Window system only matters on OSX - ### - if { [string compare "10.5" $::odie(os_version)] < 0 } { - # Pre 10.5 systems don't use a compadible cocoa - set ::odie(window_system) x11 - } - switch $::odie(window_system) { - windows { - set ::odie(window_system) windows - } - x11 { - set ::odie(window_system) x11 - set ::odie(teacup_profile) $::odie(teacup_os)-x11-$::odie(cpu) - lappend ::odie_tk(config_flags) --enable-aqua=no --x-includes=/opt/X11/include - } - default { - set ::odie(window_system) cocoa - set ::odie(teacup_profile_tk) $::odie(teacup_profile) - lappend ::odie_tk(config_flags) --enable-aqua=yes - } - } - } - } -} -set ::odie_config(tkbranch) $::odie_tk(fossil_branch) -set ::odie_config(windowsystem) $::odie(window_system) - -### -# Detect a CC to use -### -if {![info exists ::odie(cc)]} { - set ::odie(cc) [get-define CC] -} - -foreach {field value} [array get ::odie] { - define [string toupper ODIE_$field] $value -} -foreach {field value} [array get ::odie_tcl] { - define [string toupper TCL_$field] $value -} -foreach {field value} [array get ::odie_tk] { - define [string toupper TK_$field] $value -} -foreach {field value} [array get ::odie_prog] { - define [string toupper ODIE_PROG_$field] $value - define [string toupper ${field}_PROG] $value -} -define FOSSIL_CHECKOUT $::odie(fossil_checkout) -make-template odieConfig.sh.in odieConfig.sh -make-template odieConfig.tcl.in odieConfig.tcl - -set fout [open [file join $::odie(src_dir) odieConfig.tcl] a] -puts $fout "array set ::odie_config \{" -foreach {field} [lsort [array names ::odie_config]] { - puts $fout " [list $field $::odie_config($field)]" -} -puts $fout "\}" - -puts $fout "array set ::odie \{" -foreach {field} [lsort [array names ::odie]] { - puts $fout " [list $field $::odie($field)]" -} -puts $fout "\}" - -puts $fout "array set ::odie_tcl \{" -foreach {field} [lsort [array names ::odie_tcl]] { - puts $fout " [list $field $::odie_tcl($field)]" -} -puts $fout "\}" - -puts $fout "array set ::odie_tk \{" -foreach {field} [lsort [array names ::odie_tk]] { - puts $fout " [list $field $::odie_tk($field)]" -} -puts $fout "\}" - -puts $fout "array set ::odie_prog \{" -foreach {field} [lsort [array names ::odie_prog]] { - puts $fout " [list $field $::odie_prog($field)]" -} -puts $fout "\}" - -close $fout - -set fout [open [file join $::odie(src_dir) odieConfig.sh] a] -set opts {} -foreach {field} [lsort [array names ::odie_config]] { - set value $::odie_config($field) - lappend opts --${field}=$value - if {[llength $value]!=1} { - set value '$value' - } - puts $fout "ODIE_CONFIG_[string toupper $field]=$value" -} -puts $fout "ODIE_RECONFIG_OPTS=" -foreach opt $opts { - puts $fout "ODIE_RECONFIG_OPTS+=$opt" -} - -foreach {field} [lsort [array names ::odie]] { - set value $::odie($field) - if {[llength $value]!=1} { - set value '$value' - } - puts $fout "ODIE_[string toupper $field]=$value" -} -foreach {field} [lsort [array names ::odie_tcl]] { - set value $::odie_tcl($field) - if {[llength $value]!=1} { - set value '$value' - } - puts $fout "TCL_[string toupper $field]=$value" -} -foreach {field} [lsort [array names ::odie_tk]] { - set value $::odie_tk($field) - if {[llength $value]!=1} { - set value '$value' - } - puts $fout "TK_[string toupper $field]=$value" -} - -close $fout Index: basekit.ini ================================================================== --- basekit.ini +++ basekit.ini @@ -1,225 +1,184 @@ ### # This script implements a basic TclTkit with statically linked # Tk, sqlite, threads, udp, and mmtk (which includes canvas3d and tkhtml) ### - -set CWD [pwd] - -my define set [array get ::project] -set os [::practcl::os] -my define set os $os - -my define set platform $::project(TEA_PLATFORM) -my define set prefix /zvfs -my define set sandbox $::project(sandbox) -my define set installdir [file join $::project(sandbox) pkg] -my define set teapot [file join $::project(sandbox) teapot] -my define set USEMSVC [info exists env(VisualStudioVersion)] -my define set prefix_broken_destdir [file join $::project(sandbox) tmp] - -my define set HOST $os -my define set TARGET $os -my define set tclkit_bare [file join $CWD tclkit_bare$::project(EXEEXT)] - -::practcl::subproject.core create [self].TCLCORE [self] { +my define set SHARED_BUILD 0 + +my add_project TCLCORE { + class subproject.core name tcl tag release static 1 -} -::practcl::subproject.core create [self].TKCORE [self] { - name tk - tag release - static 1 - pkg_name Tk - initfunc Tk_Init -} - -my link object [self].TCLCORE [self].TKCORE - -my SUBPACKAGE tclconfig { - profile { - release: b19812c359fc450e404bc66c4a02697591159eaf - devel: practcl - } - class subproject - preload 1 - vfsinstall 0 -} - -my SUBPACKAGE thread { - profile { - release: 1c554d1eb1975caabd8aaa22563fda69985b63a4 - devel: practcl - } - class subproject.staticlib - pkg_name thread - autoload 1 - initfunc Thread_Init - static 1 -} - -my SUBPACKAGE sqlite { + fossil_url http://fossil.etoyoc.com/fossil/tcl +} +my add_project tk { + class subproject.core + name tk + tag release + install static + pkg_name Tk + initfunc Tk_Init + fossil_url http://fossil.etoyoc.com/fossil/tk +} + +my add_project thread { + profile { + release: 2a36d0a6c31569bfb3562e3d58e9e8204f447a7e + devel: practcl + } + class subproject.binary + install static + pkg_name Thread + initfunc Thread_Init + fossil_url http://fossil.etoyoc.com/fossil/thread +} +my add_project odielib { + class subproject.binary + fossil_url http://fossil.etoyoc.com/fossil/odielib + tag trunk + install static + vfsinstall 1 +} + +my add_project sqlite { profile { release: 40ffdfb26af3e7443b2912e1039c06bf9ed75846 devel: practcl } - class subproject.staticlib + class subproject.binary pkg_name sqlite3 - autoload 1 + install static-autoload initfunc Sqlite3_Init - static 1 - vfsinstall 0 + fossil_url http://fossil.etoyoc.com/fossil/sqlite } -my SUBPACKAGE udp { +my add_project udp { profile { release: 7c396e1a767db57b07b48daa8e0cfc0ea622bbe9 devel: practcl } - class subproject.staticlib - static 1 - autoload 1 + class subproject.binary + install static initfunc Udp_Init pkg_name udp - vfsinstall 0 -} - -my SUBPACKAGE mmtk { - profile { - release: 573367c56a0d47227bdb61dd9b22b3c58437be01 - devel: trunk - } - vfsinstall 1 - class subproject.staticlib - static 1 - tk 1 - initfunc Mmtk_Init - pkg_name Mmtk -} { -# Ignored for now - method install-vfs {} { - ### - # Modified to copy the pure-tcl modules, and compile the - # binaries, but DON'T include the binaries in the VFS install + fossil_url http://fossil.etoyoc.com/fossil/udp +} +my add_project canvas3d { + tag trunk + class subproject.binary + install static + initfunc Canvas3d_Init + pkg_name Canvas3d + fossil_url http://fossil.etoyoc.com/fossil/canvas3d +} +my add_project tkhtml { + profile { + release: b7796b111ce53c0ed432b239335e0505324b4ed8 + devel: trunk + } + class subproject.binary + install static + initfunc Tkhtml_Init + pkg_name Tkhtml + fossil_url http://fossil.etoyoc.com/fossil/tkhtml +} + +my add_project tdom { + class subproject.binary + fossil_url http://core.tcl.tk/tdom + pkg_name tdom + install static +} + +my add_project libressl { + class subproject.external + install static + tag master + #git_url https://github.com/libressl-portable/portable + file_url http://ftp.openbsd.org/pub/OpenBSD/LibreSSL/libressl-2.5.0.tar.gz +} { + +} + +my add_project tcltls { + class subproject.binary + install static + fossil_url http://fossil.etoyoc.com/fossil/tcltls +} + +my add_project rl_json { + class subproject.binary + git_url https://github.com/RubyLane/rl_json + tag master + install static +} + +# Not ready for prime time yet... +noop my add_project tkpath { + tag trunk + class subproject.binary + install static + initfunc Tkpath_Init + pkg_name tkpath +} + +noop my add_project tkimg { + profile { + release: c2fcb74d748b268483ed055492a956d89dc0bbd7 + devel: trunk + } + install vfs + class subproject.binary + tk 1 + fossil_url http://fossil.etoyoc.com/fossil/tkimg +} { + method install DEST { + set PWD [pwd] + ### + # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my compile - my unpack - set DEST [my define get installdir] - set prefix [string trimleft [my define get prefix] /] - set builddir [my define get builddir] - puts [list BUILD DIR $builddir] - file mkdir [file join $DEST $prefix lib $pkg] - file copy -force [file join $builddir $pkg.tcl] [file join $DEST $prefix lib $pkg $pkg.tcl] - } -} - -if {$::project(TEA_PLATFORM) == "windows"} { - # Having trouble building TWAPI from source... - # And once built there is a problem in the latest - # that prevents nettool in tcllib from working properly - if 0 { - my SUBPACKAGE twapi { - profile { - release: undroid - devel: undroid - } - class subproject.staticlib - static_pkg twapi_base - initfunc Twapi_base_Init - static 1 - os windows - } - } else { - my SUBPACKAGE twapi { - version {3.0.32 4.1.27} - os windows - class subproject.teapot - } - } -} -### -# Add local files -### - -[self].TCLCORE go -[self].TKCORE go + set localsrcdir [my define get localsrcdir] + cd $localsrcdir + set prefix [string trimleft [my define get prefix] /] + ::practcl::domake collate + ::practcl::copyDir [file join $localsrcdir Img exec_prefix] [file join $DEST $prefix] + cd $PWD + } +} ### # Add a local Zlib implementation ### -set TCLSRCDIR [[self].TCLCORE define get srcroot] -set TKSRCDIR [[self].TKCORE define get srcroot] +set TCLSRCDIR [my project TCLCORE define get srcdir] +set TKSRCDIR [my project tk define get srcdir] -my define set tclsrcdir [[self].TCLCORE define get builddir] -my define set tksrcdir [[self].TKCORE define get builddir] +my define set tclsrcdir [my project TCLCORE define get builddir] +my define set tksrcdir [my project tk define get builddir] # Handle cases where we haven't downloaded our dependencies yet -if {$os eq "windows"} { +if {[my define get TEACUP_OS] eq "windows"} { set PLATFORM_SRC_DIR win - my define set kit_resource_file [file join $CWD tclkit.rc] - my define add resource_include [file join $::project(srcdir) win rc] + my define set kit_resource_file [file join [my define get builddir] tclkit.rc] + my define add resource_include [file join [my define get srcdir] win rc] my define set teapot c:/Tcl/lib/teapot/package/win32-ix86/lib } else { - -} - -if {![file exists $TCLSRCDIR]} return - -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] -} - -my define add include_dir [file join $TKSRCDIR generic] -my define add include_dir [file join $TKSRCDIR $PLATFORM_SRC_DIR] -my define add include_dir [file join $TKSRCDIR bitmaps] -my define add include_dir [file join $TKSRCDIR xlib] -my define add include_dir [file join $TCLSRCDIR generic] -my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] -my define add include_dir [file join $TCLSRCDIR compat zlib] + set PLATFORM_SRC_DIR unix +} ### # Pull kit sources from ODIE ### set ODIESRCROOT [file dirname [file normalize [info script]]] ### # Add the zvfs implementation to the tcl core if it doesn't already have it ### -if {![file exists [file join $TCLSRCDIR generic zvfs.c]]} { - set cdir [file join $ODIESRCROOT compat zipfs] - my define add include_dir $cdir - my add class csource filename [file join $cdir zvfs.c] initfunc Tclzipfs_Init pkg_name zipfs pkg_vers 1.0 autoload 1 -} + set cdir [file join $ODIESRCROOT generic] # password.c {} -foreach {file info} { - tclkit_Init.c {} - zvfsboot.c {} -} { - my add class csource filename [file join $cdir $file] {*}$info -} if {[my define get has_rc4 0]==0} { my define set has_rc4 1 my add [file join $cdir rc4.tcl] } - -if {$os eq "windows"} { - set PLATFORM_SRC_DIR win - my add class csource filename [file join $ODIESRCROOT win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.2 - my add class csource filename [file join $ODIESRCROOT win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 - my add class csource filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=Toadkit_MainHook -DTCL_LOCAL_APPINIT=Toadkit_AppInit] -} else { - set PLATFORM_SRC_DIR unix - my add class csource filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=Toadkit_MainHook -DTCL_LOCAL_APPINIT=Toadkit_AppInit] -} - -my define add include_dir [file join $ODIESRCROOT generic] -my define add include_dir [file join $ODIESRCROOT $PLATFORM_SRC_DIR] - DELETED build.tcl Index: build.tcl ================================================================== --- build.tcl +++ /dev/null @@ -1,541 +0,0 @@ -### -# script to build a tclkit -### - - -######################################### -# -# BUILD THE INTERPRETER ENVIRONMENT -# -######################################### - -set HERE [file dirname [file normalize [info script]]] -set PWD [pwd] - -package ifneeded practcl 0.3 [list source [file join $HERE .. odielib modules practcl practcl.tcl]] -package require practcl 0.3 - -##### -# Define procedures -##### - -namespace eval ::practcl {} - -######################################### -# -# BEGIN THE KITBUILDING PROCESS HERE -# -######################################### -set _search_paths {} -lappend _search_paths [file dirname [file normalize $PWD]] - -if {[file exists [file join $PWD project.rc]]} { - ### - # For existing PRACTCL projects, we can steal all of the - # information we need from the project.rc file - ### - source [file join $PWD project.rc] - set ::KIT(platform) $::project(TEA_PLATFORM) - set ::KIT(ORIG_TCL_SRC_DIR) $::project(TCL_SRC_DIR) - set ::KIT(ORIG_TK_SRC_DIR) $::project(TK_SRC_DIR) - set ::KIT(TARGET) $::project(TEA_PLATFORM) - set ::KIT(HOST) $::project(TEA_PLATFORM) - set ::KIT(TCL_VERSION) $::project(TCL_VERSION) - set ::KIT(TK_VERSION) $::project(TK_VERSION) - set ::KIT(TCL_PATCH_LEVEL) $::project(TCL_PATCH_LEVEL) - # Most TEA projects don't substitute TK_PATCH_LEVEL, so - # assume it's the same as Tcl - set ::KIT(TK_PATCH_LEVEL) $::project(TCL_PATCH_LEVEL) - set ::KIT(TCL_BUILD_OPTS) {} - set ::KIT(TK_BUILD_OPTS) {} - switch $::project(TEACUP_OS) { - linux { - # Voodoo, bit maintains compatibility with ActiveState binaries - lappend ::KIT(TK_BUILD_OPTS) --enable-xft=no --enable-xss=no - } - macosx { - lappend ::KIT(TCL_BUILD_OPTS) --enable-corefoundation=yes --enable-framework=no - # For pre 10.5 use: - # lappend ::KIT(TCL_BUILD_OPTS) --enable-corefoundation=no --enable-framework=no - lappend ::KIT(TK_BUILD_OPTS) --enable-aqua=yes - # IF doing X11 builds: - #lappend ::KIT(TK_BUILD_OPTS) --enable-aqua=no --x-includes=/opt/X11/include - } - } - if {[info exists ::project(sandbox)] && $::project(sandbox) ne {}} { - lappend _search_paths $::project(sandbox) - } -} else { - if {![file exists [file join $::HERE odieConfig.tcl]]} { - # Build the local toolset - cd $HERE - exec [info nameofexecutable] [file join $HERE autosetup autosetup] - cd $PWD - } - source [file join $::HERE odieConfig.tcl] - set ::KIT(platform) $::odie(platform) - set ::KIT(ORIG_TCL_SRC_DIR) $::odie_tcl(src_dir) - set ::KIT(ORIG_TK_SRC_DIR) $::odie_tk(src_dir) - set ::KIT(TARGET) $::odie(target) - set ::KIT(TCL_VERSION) $::odie_tcl(version) - set ::KIT(TK_VERSION) $::odie_tk(version) - set ::KIT(TCL_PATCH_LEVEL) $::odie_tcl(patch_level) - set ::KIT(TK_PATCH_LEVEL) $::odie_tk(patch_level) - - set ::KIT(TCL_BUILD_OPTS) $::odie_tcl(config_flags) - set ::KIT(TK_BUILD_OPTS) $::odie_tk(config_flags) - set ::KIT(HOST) $::odie(host) - lappend _search_paths $::odie(sandbox) -} - - -### -# TkImg is a project of projects which needs -# special handling -### -oo::class create ::practcl::subproject.tkimg { - superclass ::practcl::subproject - - method install {} { - set PWD [pwd] - ### - # Handle teapot installs - ### - set pkg [my define get pkg_name [my define get name]] - if {[my define get teapot] ne {}} { - set TEAPOT [my define get teapot] - set found 0 - foreach ver [my define get info version] { - set teapath [file join $TEAPOT $pkg$ver] - if {[file exists $teapath]} { - set dest [file join $::KIT(PKGROOT) [string trimleft $::KIT(PKGPREFIX) /] lib [file tail $teapath]] - puts [list Copying $pkg from teapot to $dest] - ::practcl::copyDir $teapath $dest - return - } - } - } - my compile - set localsrcdir [my define get localsrcdir] - cd $localsrcdir - set DEST [my define get installdir] - set prefix [string trimleft [my define get prefix] /] - - domake collate - ::practcl::copyDir [file join $localsrcdir Img exec_prefix] [file join $DEST $prefix] - cd $PWD - } -} - - -### -# Can *almost* get it working, but the broken installer -# leads to chaos under MinGW -### -# tcllibc {version 0.3.14} -set ::KIT(TEAPOT) {} -set ::KIT(PACKAGES) { - thread {tag release} - udp {tag trunk} - canvas3d {tag trunk tk 1} - tkimg {tag trunk tk 1 class ::practcl::subproject.tkimg} - sqlite {tag release} -} -if {$::KIT(platform) eq "windows"} { - set ::KIT(TEAPOT) C:/Tcl/lib/teapot/package/win32-ix86/lib - dict set ::KIT(PACKAGES) twapi {tag twapi-3.0.29 version {3.0.32 4.1.27}} - set ::KIT(EXEEXT) .exe - set ::KIT(platform_src_dir) win - set USEMSVC [info exists env(VisualStudioVersion)] -} else { - set ::KIT(EXEEXT) {} - set ::KIT(platform_src_dir) unix - set USEMSVC 0 -} -set ::KIT(PKGPREFIX) /zvfs - -array set build { - tcl 0 - tk 0 - packages 0 - basekitvfs 0 - toadkit.rc 0 - toadkit 0 - tclkit_bare 0 - libtoadkit.a 0 -} - -### -# Begin processing our arguments -### -set COMMAND [lindex $argv 0] -switch $COMMAND { - barekit { - set build(tclkit_bare) 1 - set build(libtoadkit.a) 1 - } - localtcl { - - } - libtoadkit.a { - set build(libtoadkit.a) 1 - } - toadkit { - set build(toadkit) 1 - } - basekit { - set build(toadkit) 1 - } - packages { - set build(packages) 1 - set build(packages) 1 - } - wrap { - - } - clean { - } - default { - error "Unknown command $COMMAND. Valid: clean tcl toadkit wrap" - } -} - -foreach dpath $_search_paths { - set path [file normalize [file join {*}[subst $dpath] toadkit$::KIT(TCL_VERSION)$::KIT(TCL_PATCH_LEVEL)]] - set ::KIT(TCLSRCDIR) [file join $path tcl] - set ::KIT(TKSRCDIR) [file join $path tk] - set ::KIT(PKGROOT) [file join $path pkg] - set ::KIT(BASEVFS) [file join $path vfs] - set ::KIT(SANDBOX) [file join $path jni] - set ::KIT(DOWNLOAD) [file join $path download] - - if {[file exists $::KIT(TCLSRCDIR)]} { - break - } -} - -### -# Sort out our various build products -### -set _TclSrcDir [file join $::KIT(TCLSRCDIR) $::KIT(platform_src_dir)] -set _TkSrcDir [file join $::KIT(TKSRCDIR) $::KIT(platform_src_dir)] - -set ::TARGET(tclConfig.sh) [file join $_TclSrcDir tclConfig.sh] -set ::TARGET(tkConfig.sh) [file join $_TkSrcDir tkConfig.sh] -set ::TARGET(libtoadkit.a) [file join $PWD libtoadkit.a] -set ::TARGET(tclkit_bare) [file join $PWD tclkit_bare$::KIT(EXEEXT)] -set ::TARGET(toadkit.rc) [file join $PWD toadkit.rc] - - -if {![file exists $::TARGET(tclkit_bare)]} { - set build(tclkit_bare) 1 -} -if {![file exists $::TARGET(tclConfig.sh)]} { - set build(tcl) 1 - set build(tk) 1 -} -if {![file exists $::TARGET(tkConfig.sh)]} { - set build(tk) 1 -} -if {![file exists $::TARGET(libtoadkit.a)]} { - set build(libtoadkit.a) 1 -} -if {![file exists $::KIT(PKGROOT)]} { - set build(packages) 1 -} -if {![file exists $::KIT(BASEVFS)]} { - set build(basekitvfs) 1 -} -if {$build(packages)} { - set build(basekitvfs) 1 -} -if {$build(tcl) || $build(tk) || $build(toadkit)} { - set build(packages) 1 - set build(basekitvfs) 1 - set build(toadkit.rc) 1 - set build(tclkit_bare) 1 - set build(libtoadkit.a) 1 -} -if {$build(libtoadkit.a)} { - set build(tclkit_bare) 1 -} -if {$build(packages)} { - set build(basekitvfs) 1 -} -if {![file exists $::TARGET(toadkit.rc)]} { - set build(toadkit.rc) 1 -} -file mkdir build - - -puts "*** -::KIT(TCLSRCDIR): [file exists $::KIT(TCLSRCDIR)] $::KIT(TCLSRCDIR) -::KIT(TKSRCDIR): [file exists $::KIT(TKSRCDIR)] $::KIT(TKSRCDIR) -::KIT(PKGROOT): [file exists $::KIT(PKGROOT)] $::KIT(PKGROOT) -::KIT(BASEVFS): [file exists $::KIT(BASEVFS)] $::KIT(BASEVFS) -toadkit.rc: [file exists $::TARGET(toadkit.rc)] $::TARGET(toadkit.rc) -***" -parray build - -if {$COMMAND eq "clean"} { - file delete -force $path - file delete -force build/ - foreach file [glob -nocomplain *.a] { - file delete $file - } - exit -} -file mkdir build -file mkdir [file join $::KIT(BASEVFS) boot] - -::practcl::tclkit create TOADKIT { - name toadkit - pkg_name toadkit - pkg_version 8.6.5 - platform $::KIT(platform) - HOST $::KIT(HOST) - TARGET $::KIT(TARGET) - USEMSVC $USEMSVC - teapot [list $::KIT(TEAPOT)] - download [list $::KIT(DOWNLOAD)] - sandbox [list $::KIT(SANDBOX)] - tclsrdir [list $::KIT(TCLSRCDIR)] - prefix [list $::KIT(PKGPREFIX)] - installdir [list $::KIT(PKGROOT)] - PRACTCL_NAME_LIBRARY $::project(PRACTCL_NAME_LIBRARY) - SHLIB_SUFFIX $::project(SHLIB_SUFFIX) - PRACTCL_STATIC_LIB $::project(PRACTCL_STATIC_LIB) - prefix_broken_destdir $::KIT(SANDBOX)/TEMP.PKG -} -::practcl::subproject.core create TCLCORE TOADKIT { - name tcl - config_opts "$::KIT(TCL_BUILD_OPTS) --with-tzdata" - srcroot "$::KIT(TCLSRCDIR)" - tag release - static 1 -} -TCLCORE go -set _TclSrcDir [TCLCORE define get localsrcdir] -TOADKIT define set tclsrcdir $_TclSrcDir -::practcl::subproject.core create TKCORE TOADKIT { - name tk - config_opts "$::KIT(TK_BUILD_OPTS)" - srcroot "$::KIT(TKSRCDIR)" - tag release - static 0 -} -TKCORE go -set _TkSrcDir [TKCORE define get localsrcdir] -TOADKIT define set tksrcdir $_TkSrcDir - -puts "PLATFORM: $::KIT(platform)" -puts [list TCLSRCDIR: $_TclSrcDir] -puts [list TKSRCDIR: $_TkSrcDir] - -if {$build(tcl)} { - TCLCORE compile -} -if {$build(tk)} { - TKCORE compile -} - -if {$build(packages)} { - foreach {pkg info} $::KIT(PACKAGES) { - set obj [::practcl::subproject create PKG.$pkg TOADKIT [dict merge [list name $pkg pkg_name $pkg static 0] $info]] - $obj install - } -} - -if {$build(toadkit.rc)} { - set ::KIT(OBJS) {} - set ::KIT(INCLUDES) {} - ### - # Read tclConfig.sh and tkConfig.sh - ### - foreach {array pre file} [list ::TCL tcl $::TARGET(tclConfig.sh) ::TK tk $::TARGET(tkConfig.sh)] { - set l [expr {[string length $pre]+1}] - foreach {field dat} [::practcl::read_Config.sh $file] { - set field [string tolower $field] - if {[string match ${pre}_* $field]} { - set field [string range $field $l end] - } - set ${array}($field) $dat - if {[info exists ::KIT($field)]} { - if {$::KIT($field) ne $dat} { - unset ::KIT($field) - } - } else { - set ::KIT($field) $dat - } - } - } - - ### - # Add/synthesize bits - ### - lappend ::KIT(INCLUDES) [file join $::KIT(TKSRCDIR) generic] - lappend ::KIT(INCLUDES) [file join $::KIT(TKSRCDIR) $::KIT(platform_src_dir)] - lappend ::KIT(INCLUDES) [file join $::KIT(TKSRCDIR) bitmaps] - lappend ::KIT(INCLUDES) [file join $::KIT(TKSRCDIR) xlib] - - lappend ::KIT(INCLUDES) [file join $::KIT(TCLSRCDIR) generic] - lappend ::KIT(INCLUDES) [file join $::KIT(TCLSRCDIR) $::KIT(platform_src_dir)] - #lappend ::KIT(INCLUDES) [file join $$::KIT(TCLSRCDIR) compat] - lappend ::KIT(INCLUDES) [file join $::KIT(TCLSRCDIR) compat zlib] - - lappend ::KIT(INCLUDES) [file join $::HERE generic] - lappend ::KIT(INCLUDES) [file join $::HERE $::KIT(platform_src_dir)] - - if { $::KIT(platform) eq "windows" } { - set ::KIT(EXEEXT) .exe - } else { - set ::KIT(EXEEXT) {} - } - - set ::KIT(LIBS) {} - set ::KIT(defs) $::TK(defs) - - set fout [open $::TARGET(toadkit.rc) w] - puts $fout "array set ::TCL \{" - foreach {field value} [lsort -stride 2 [array get ::TCL]] { - puts $fout " [list $field $value]" - } - puts $fout "\}" - puts $fout "array set ::TK \{" - foreach {field value} [lsort -stride 2 [array get ::TK]] { - puts $fout " [list $field $value]" - } - puts $fout "\}" - puts $fout "array set ::TARGET \{" - foreach {field value} [lsort -stride 2 [array get ::TARGET]] { - puts $fout " [list $field $value]" - } - puts $fout "\}" - puts $fout "array set ::KIT \{" - foreach {field value} [lsort -stride 2 [array get ::KIT]] { - puts $fout " [list $field $value]" - } - puts $fout "\}" - close $fout -} else { - source $::TARGET(toadkit.rc) -} -if { $::KIT(platform) eq "windows" } { - if {[file exists [file join $PWD tclkit.rc]]} { - TOADKIT define set kit_resource_file [file join $PWD tclkit.rc] - } else { - TOADKIT define set kit_resource_file [file join $_TkSrcDir rc wish.rc] - } -} -# These values are not known until our static Tcl is built -TOADKIT define set EXEEXT $::KIT(EXEEXT) -TOADKIT define set BASEVFS $::KIT(BASEVFS) -TOADKIT define set tclkit_bare $::TARGET(tclkit_bare) - -if {$build(libtoadkit.a) || $build(tclkit_bare)} { - ### - # Compile our resident static C library - ### - cd $PWD - if {[file exists $::TARGET(tclkit_bare)]} { - file delete $::TARGET(tclkit_bare) - } - TOADKIT define set include_dir $::KIT(INCLUDES) - TOADKIT define add include_dir ../odie/generic - if { $::KIT(platform) eq "windows" } { - TOADKIT define add include_dir ../odie/win - } else { - TOADKIT define add include_dir ../odie/unix - } - ### - # Rig ourselves to statically build the bits of - # zlib we need - ### - set cdir [file join $::KIT(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 - } { - TOADKIT add [file join $cdir $file] - } - - set cdir [file join $::HERE generic] - foreach file { - password.c rc4.c tclkit_init.c zvfs.c zvfsboot.c - } { - TOADKIT add [file join $cdir $file] - } - - set cdir [file join $::HERE $::KIT(platform_src_dir)] - foreach file { - tclsh_packages.c - } { - TOADKIT add [file join $cdir $file] - } - - if { $::KIT(platform) eq "windows" } { - # tkwinico.c tlink32.c - TOADKIT add class csource filename [file join $_TclSrcDir tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=Toadkit_MainHook -DTCL_LOCAL_APPINIT=Toadkit_AppInit] - } else { - TOADKIT add class csource filename [file join $_TclSrcDir tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=Toadkit_MainHook -DTCL_LOCAL_APPINIT=Toadkit_AppInit] - } - # Link together our executable - TOADKIT generate-static-tclsh $::TARGET(tclkit_bare) [array get ::TCL] [array get ::KIT] -} -TOADKIT define set EXEEXT $::KIT(EXEEXT) -TOADKIT define set BASEVFS $::KIT(BASEVFS) -TOADKIT define set tclkit_bare $::TARGET(tclkit_bare) - -if {$build(basekitvfs)} { - cd $PWD - if {[file exists $::KIT(BASEVFS)]} { - file delete -force $::KIT(BASEVFS) - } - puts "*** -*** BASE KIT VFS PACKAGES -***" - puts [list COPY [file join $::KIT(PKGROOT) [string trimleft $::KIT(PKGPREFIX) /] lib]] - ::practcl::copyDir [file join $::KIT(PKGROOT) [string trimleft $::KIT(PKGPREFIX) /] lib] [file join $::KIT(BASEVFS) boot pkgs] - ::practcl::copyDir [file join $::KIT(TCLSRCDIR) library] [file join $::KIT(BASEVFS) boot tcl] - if { $::KIT(platform) eq "windows" } { - set ddedll [glob -nocomplain [file join $_TclSrcDir tcldde*.dll]] - if {$ddedll != {}} { - file copy $ddedll [file join $::KIT(BASEVFS) boot tcl dde] - } - set regdll [glob -nocomplain [file join $_TclSrcDir tclreg*.dll]] - if {$regdll != {}} { - file copy $regdll [file join $::KIT(BASEVFS) boot tcl reg] - } - } else { - file delete -force [file join $::KIT(BASEVFS) boot tcl dde] - file delete -force [file join $::KIT(BASEVFS) boot tcl reg] - } - - ::practcl::copyDir [file join $::KIT(TKSRCDIR) library] $::KIT(BASEVFS)/boot/tk - if { $::KIT(platform) eq "windows" } { - set dllsrc [file join $_TkSrcDir [string trim $::TK(dll_file) \"]] - } else { - set dllsrc [file join $_TkSrcDir [string trim $::TK(lib_file) \"]] - } - file copy -force $dllsrc [file join $::KIT(BASEVFS) boot tk] - set fout [open [file join $::KIT(BASEVFS) boot tk pkgIndex.tcl] w] - set map [list @TKVERSION@ $::TK(version)$::TK(patch_level)] - if { $::KIT(platform) eq "windows" } { - lappend map @TKDLL@ [string trim $::TK(dll_file) \"] - } else { - lappend map @TKDLL@ [string trim $::TK(lib_file) \"] - } - puts $fout [string map $map { -package ifneeded Tk @TKVERSION@ [list load $::tk_library/@TKDLL@ Tk] - }] - close $fout -} -if {$COMMAND eq "toadkit"} { - TOADKIT wrap $::PWD toadkit toadkit-vfs -} - -if {$COMMAND eq "wrap"} { - TOADKIT wrap $::PWD {*}[lrange $argv 1 end] -} ADDED compat/zipfs/tclZipfs.c Index: compat/zipfs/tclZipfs.c ================================================================== --- /dev/null +++ compat/zipfs/tclZipfs.c @@ -0,0 +1,4050 @@ +/* + * zipfs.c -- + * + * Implementation of the ZIP filesystem used in AndroWish. + * + * Copyright (c) 2013-2015 Christian Werner + * Copyright (c) 2016 Sean Woods + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclFileSystem.h" +#include "tclInt.h" +#include "tclZipfs.h" + +#if !defined(_WIN32) && !defined(_WIN64) +#include +#endif +#include +#include +#include +#include +#include +#include + +#ifdef HAVE_ZLIB +#include "zlib.h" +#include "zcrypt.h" + +/* Define the mount volume for zipfs */ +#ifndef ZIPFS_VOLUME +#define ZIPFS_VOLUME "//zipfs:/" +#endif + +/* + * Various constants and offsets found in ZIP archive files + */ + +#define ZIP_SIG_LEN 4 + +/* Local header of ZIP archive member (at very beginning of each member). */ +#define ZIP_LOCAL_HEADER_SIG 0x04034b50 +#define ZIP_LOCAL_HEADER_LEN 30 +#define ZIP_LOCAL_SIG_OFFS 0 +#define ZIP_LOCAL_VERSION_OFFS 4 +#define ZIP_LOCAL_FLAGS_OFFS 6 +#define ZIP_LOCAL_COMPMETH_OFFS 8 +#define ZIP_LOCAL_MTIME_OFFS 10 +#define ZIP_LOCAL_MDATE_OFFS 12 +#define ZIP_LOCAL_CRC32_OFFS 14 +#define ZIP_LOCAL_COMPLEN_OFFS 18 +#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 +#define ZIP_LOCAL_PATHLEN_OFFS 26 +#define ZIP_LOCAL_EXTRALEN_OFFS 28 + +/* Central header of ZIP archive member at end of ZIP file. */ +#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 +#define ZIP_CENTRAL_HEADER_LEN 46 +#define ZIP_CENTRAL_SIG_OFFS 0 +#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 +#define ZIP_CENTRAL_VERSION_OFFS 6 +#define ZIP_CENTRAL_FLAGS_OFFS 8 +#define ZIP_CENTRAL_COMPMETH_OFFS 10 +#define ZIP_CENTRAL_MTIME_OFFS 12 +#define ZIP_CENTRAL_MDATE_OFFS 14 +#define ZIP_CENTRAL_CRC32_OFFS 16 +#define ZIP_CENTRAL_COMPLEN_OFFS 20 +#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 +#define ZIP_CENTRAL_PATHLEN_OFFS 28 +#define ZIP_CENTRAL_EXTRALEN_OFFS 30 +#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 +#define ZIP_CENTRAL_DISKFILE_OFFS 34 +#define ZIP_CENTRAL_IATTR_OFFS 36 +#define ZIP_CENTRAL_EATTR_OFFS 38 +#define ZIP_CENTRAL_LOCALHDR_OFFS 42 + +/* Central end signature at very end of ZIP file. */ +#define ZIP_CENTRAL_END_SIG 0x06054b50 +#define ZIP_CENTRAL_END_LEN 22 +#define ZIP_CENTRAL_END_SIG_OFFS 0 +#define ZIP_CENTRAL_DISKNO_OFFS 4 +#define ZIP_CENTRAL_DISKDIR_OFFS 6 +#define ZIP_CENTRAL_ENTS_OFFS 8 +#define ZIP_CENTRAL_TOTALENTS_OFFS 10 +#define ZIP_CENTRAL_DIRSIZE_OFFS 12 +#define ZIP_CENTRAL_DIRSTART_OFFS 16 +#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 + +#define ZIP_MIN_VERSION 20 +#define ZIP_COMPMETH_STORED 0 +#define ZIP_COMPMETH_DEFLATED 8 + +#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 + +/* + * Macros to read and write 16 and 32 bit integers from/to ZIP archives. + */ + +#define zip_read_int(p) \ + ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) +#define zip_read_short(p) \ + ((p)[0] | ((p)[1] << 8)) + +#define zip_write_int(p, v) \ + (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; \ + (p)[2] = ((v) >> 16) & 0xff; (p)[3] = ((v) >> 24) & 0xff; +#define zip_write_short(p, v) \ + (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; + +/* + * Windows drive letters. + */ + +#if defined(_WIN32) || defined(_WIN64) +#define HAS_DRIVES 1 +static const char drvletters[] = + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; +#else +#define HAS_DRIVES 0 +#endif + +/* + * Mutex to protect localtime(3) when no reentrant version available. + */ + +#if !defined(_WIN32) && !defined(_WIN64) +#ifndef HAVE_LOCALTIME_R +#ifdef TCL_THREADS +TCL_DECLARE_MUTEX(localtimeMutex) +#endif +#endif +#endif + +/* + * In-core description of mounted ZIP archive file. + */ + +typedef struct ZipFile { + char *name; /* Archive name */ + Tcl_Channel chan; /* Channel handle or NULL */ + unsigned char *data; /* Memory mapped or malloc'ed file */ + long length; /* Length of memory mapped file */ + unsigned char *tofree; /* Non-NULL if malloc'ed file */ + int nfiles; /* Number of files in archive */ + int baseoffs; /* Archive start */ + int baseoffsp; /* Password start */ + int centoffs; /* Archive directory start */ + char pwbuf[264]; /* Password buffer */ +#if defined(_WIN32) || defined(_WIN64) + HANDLE mh; +#endif + int nopen; /* Number of open files on archive */ + struct ZipEntry *entries; /* List of files in archive */ + struct ZipEntry *topents; /* List of top-level dirs in archive */ + int mntptlen; /* Length of mount point */ + char mntpt[1]; /* Mount point */ +} ZipFile; + +/* + * In-core description of file contained in mounted ZIP archive. + */ + +typedef struct ZipEntry { + char *name; /* The full pathname of the virtual file */ + ZipFile *zipfile; /* The ZIP file holding this virtual file */ + long offset; /* Data offset into memory mapped ZIP file */ + int nbyte; /* Uncompressed size of the virtual file */ + int nbytecompr; /* Compressed size of the virtual file */ + int cmeth; /* Compress method */ + int isdir; /* Set to 1 if directory */ + int depth; /* Number of slashes in path. */ + int crc32; /* CRC-32 */ + int timestamp; /* Modification time */ + int isenc; /* True if data is encrypted */ + unsigned char *data; /* File data if written */ + struct ZipEntry *next; /* Next file in the same archive */ + struct ZipEntry *tnext; /* Next top-level dir in archive */ +} ZipEntry; + +/* + * File channel for file contained in mounted ZIP archive. + */ + +typedef struct ZipChannel { + ZipFile *zipfile; /* The ZIP file holding this channel */ + ZipEntry *zipentry; /* Pointer back to virtual file */ + unsigned long nmax; /* Max. size for write */ + unsigned long nbyte; /* Number of bytes of uncompressed data */ + unsigned long nread; /* Pos of next byte to be read from the channel */ + unsigned char *ubuf; /* Pointer to the uncompressed data */ + int iscompr; /* True if data is compressed */ + int isdir; /* Set to 1 if directory */ + int isenc; /* True if data is encrypted */ + int iswr; /* True if open for writing */ + unsigned long keys[3]; /* Key for decryption */ +} ZipChannel; + +/* + * Global variables. + * + * Most are kept in single ZipFS struct. When build with threading + * support this struct is protected by the ZipFSMutex (see below). + * + * The "fileHash" component is the process wide global table of all known + * ZIP archive members in all mounted ZIP archives. + * + * The "zipHash" components is the process wide global table of all mounted + * ZIP archive files. + */ + +static struct { + int initialized; /* True when initialized */ + int lock; /* RW lock, see below */ + int waiters; /* RW lock, see below */ + int wrmax; /* Maximum write size of a file */ + int idCount; /* Counter for channel names */ + Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ + Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ +} ZipFS = { + 0, 0, 0, 0, 0, +}; + +/* + * For password rotation. + */ + +static const char pwrot[16] = { + 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0, + 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0 +}; + +/* + * Table to compute CRC32. + */ + +static const unsigned int crc32tab[256] = { + 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, + 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, + 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, + 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, + 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, + 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, + 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, + 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, + 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, + 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, + 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, + 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, + 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, + 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, + 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, + 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, + 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, + 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, + 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, + 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, + 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, + 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, + 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, + 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, + 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, + 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, + 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, + 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, + 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, + 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, + 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, + 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, + 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, + 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, + 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, + 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, + 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, + 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, + 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, + 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, + 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, + 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, + 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, + 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, + 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, + 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, + 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, + 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, + 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, + 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, + 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, + 0x2d02ef8d, +}; + +/* Set to the length of ZIPFS_VOLUME during initialization */ +static int ZIPFS_VOLUME_LEN; + + +/* + *------------------------------------------------------------------------- + * + * ReadLock, WriteLock, Unlock -- + * + * POSIX like rwlock functions to support multiple readers + * and single writer on internal structs. + * + * Limitations: + * - a read lock cannot be promoted to a write lock + * - a write lock may not be nested + * + *------------------------------------------------------------------------- + */ + +TCL_DECLARE_MUTEX(ZipFSMutex) + +#ifdef TCL_THREADS + +static Tcl_Condition ZipFSCond; + +static void +ReadLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock < 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock++; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +WriteLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock != 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock = -1; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +Unlock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + if (ZipFS.lock > 0) { + --ZipFS.lock; + } else if (ZipFS.lock < 0) { + ZipFS.lock = 0; + } + if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { + Tcl_ConditionNotify(&ZipFSCond); + } + Tcl_MutexUnlock(&ZipFSMutex); +} + +#else + +#define ReadLock() do {} while (0) +#define WriteLock() do {} while (0) +#define Unlock() do {} while (0) + +#endif + +/* + *------------------------------------------------------------------------- + * + * DosTimeDate, ToDosTime, ToDosDate -- + * + * Functions to perform conversions between DOS time stamps + * and POSIX time_t. + * + *------------------------------------------------------------------------- + */ + +static time_t +DosTimeDate(int dosDate, int dosTime) +{ + struct tm tm; + time_t ret; + + memset(&tm, 0, sizeof (tm)); + tm.tm_year = (((dosDate & 0xfe00) >> 9) + 80); + tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1; + tm.tm_mday = dosDate & 0x1f; + tm.tm_hour = (dosTime & 0xf800) >> 11; + tm.tm_min = (dosTime & 0x7e) >> 5; + tm.tm_sec = (dosTime & 0x1f) << 1; + ret = mktime(&tm); + if (ret == (time_t) -1) { + /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ + ret = (time_t) 315532800; + } + return ret; +} + +static int +ToDosTime(time_t when) +{ + struct tm *tmp, tm; + +#ifdef TCL_THREADS +#if defined(_WIN32) || defined(_WIN64) + /* Win32 uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#else +#ifdef HAVE_LOCALTIME_R + tmp = &tm; + localtime_r(&when, tmp); +#else + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif +#endif +#else + tmp = localtime(&when); + tm = *tmp; +#endif + return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); +} + +static int +ToDosDate(time_t when) +{ + struct tm *tmp, tm; + +#ifdef TCL_THREADS +#if defined(_WIN32) || defined(_WIN64) + /* Win32 uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#else +#ifdef HAVE_LOCALTIME_R + tmp = &tm; + localtime_r(&when, tmp); +#else + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif +#endif +#else + tmp = localtime(&when); + tm = *tmp; +#endif + return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; +} + +/* + *------------------------------------------------------------------------- + * + * CountSlashes -- + * + * This function counts the number of slashes in a pathname string. + * + * Results: + * Number of slashes found in string. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +CountSlashes(const char *string) +{ + int count = 0; + const char *p = string; + + while (*p != '\0') { + if (*p == '/') { + count++; + } + p++; + } + return count; +} + +/* + *------------------------------------------------------------------------- + * + * CanonicalPath -- + * + * This function computes the canonical path from a directory + * and file name components into the specified Tcl_DString. + * + * Results: + * Returns the pointer to the canonical path contained in the + * specified Tcl_DString. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *------------------------------------------------------------------------- + */ + +static char * +CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr,int ZIPFSPATH) +{ + char *path; + char *result; + int zipfspath=1; + int i, j, c, isunc = 0, isvfs=0, n=0; +#if HAS_DRIVES + if ((tail[0] != '\0') && (strchr(drvletters, tail[0]) != NULL) && + (tail[1] == ':')) { + tail += 2; + zipfspath=0; + } + /* UNC style path */ + if (tail[0] == '\\') { + root = ""; + ++tail; + zipfspath=0; + } + if (tail[0] == '\\') { + root = "/"; + ++tail; + zipfspath=0; + } + if(zipfspath) { +#endif + /* UNC style path */ + if(root && strncmp(root,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)==0) { + isvfs=1; + } else if (tail && strncmp(tail,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN) == 0) { + isvfs=2; + } + if(isvfs!=1) { + if ((root[0] == '/') && (root[1] == '/')) { + isunc = 1; + } + } +#if HAS_DRIVES + } +#endif + if(isvfs!=2) { + if (tail[0] == '/') { + if(isvfs!=1) { + root = ""; + } + ++tail; + isunc = 0; + } + if (tail[0] == '/') { + if(isvfs!=1) { + root = "/"; + } + ++tail; + isunc = 1; + } + } + i = strlen(root); + j = strlen(tail); + if(isvfs==1) { + if(i>ZIPFS_VOLUME_LEN) { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + memcpy(path + i, tail, j); + } + } else if(isvfs==2) { + Tcl_DStringSetLength(dsPtr, j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, tail, j); + } else { + if (ZIPFSPATH) { + Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN); + path = Tcl_DStringValue(dsPtr); + memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); + memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } + } +#if HAS_DRIVES + for (i = 0; path[i] != '\0'; i++) { + if (path[i] == '\\') { + path[i] = '/'; + } + } +#endif + if(ZIPFSPATH) { + n=ZIPFS_VOLUME_LEN; + } else { + n=0; + } + for (i = j = n; (c = path[i]) != '\0'; i++) { + if (c == '/') { + int c2 = path[i + 1]; + if (c2 == '/') { + continue; + } + if (c2 == '.') { + int c3 = path[i + 2]; + if ((c3 == '/') || (c3 == '\0')) { + i++; + continue; + } + if ((c3 == '.') && + ((path[i + 3] == '/') || (path [i + 3] == '\0'))) { + i += 2; + while ((j > 0) && (path[j - 1] != '/')) { + j--; + } + if (j > isunc) { + --j; + while ((j > 1 + isunc) && (path[j - 2] == '/')) { + j--; + } + } + continue; + } + } + } + path[j++] = c; + } + if (j == 0) { + path[j++] = '/'; + } + path[j] = 0; + Tcl_DStringSetLength(dsPtr, j); + result=Tcl_DStringValue(dsPtr); + return result; +} + + + +/* + *------------------------------------------------------------------------- + * + * AbsolutePath -- + * + * This function computes the absolute path from a given + * (relative) path name into the specified Tcl_DString. + * + * Results: + * Returns the pointer to the absolute path contained in the + * specified Tcl_DString. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *------------------------------------------------------------------------- + */ + +static char * +AbsolutePath(const char *path, + Tcl_DString *dsPtr, + int ZIPFSPATH) +{ + char *result; + if (*path == '~') { + Tcl_DStringAppend(dsPtr, path, -1); + return Tcl_DStringValue(dsPtr); + } + if (*path != '/') { + Tcl_DString pwd; + + /* relative path */ + Tcl_DStringInit(&pwd); + Tcl_GetCwd(NULL, &pwd); + result = Tcl_DStringValue(&pwd); + result = CanonicalPath(result, path, dsPtr,ZIPFSPATH); + Tcl_DStringFree(&pwd); + } else { + /* absolute path */ + result = CanonicalPath("", path, dsPtr,ZIPFSPATH); + } + return result; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookup -- + * + * This function returns the ZIP entry struct corresponding to + * the ZIP archive member of the given file name. + * + * Results: + * Returns the pointer to ZIP entry struct or NULL if the + * the given file name could not be found in the global list + * of ZIP archive members. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static ZipEntry * +ZipFSLookup(char *filename) +{ + char *realname; + + Tcl_HashEntry *hPtr; + ZipEntry *z; + Tcl_DString ds; + Tcl_DStringInit(&ds); + realname = AbsolutePath(filename, &ds, 1); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, realname); + z = hPtr ? (ZipEntry *) Tcl_GetHashValue(hPtr) : NULL; + Tcl_DStringFree(&ds); + return z; +} + +#ifdef NEVER_USED + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookupMount -- + * + * This function returns an indication if the given file name + * corresponds to a mounted ZIP archive file. + * + * Results: + * Returns true, if the given file name is a mounted ZIP archive file. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSLookupMount(char *filename) +{ + char *realname; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + Tcl_DString ds; + int match = 0; + Tcl_DStringInit(&ds); + realname = AbsolutePath(filename, &ds, 1); + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { + if (strcmp(zf->mntpt, realname) == 0) { + match = 1; + break; + } + } + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_DStringFree(&ds); + return match; +} +#endif + +/* + *------------------------------------------------------------------------- + * + * ZipFSCloseArchive -- + * + * This function closes a mounted ZIP archive file. + * + * Results: + * None. + * + * Side effects: + * A memory mapped ZIP archive is unmapped, allocated memory is + * released. + * + *------------------------------------------------------------------------- + */ + +static void +ZipFSCloseArchive(Tcl_Interp *interp, ZipFile *zf) +{ +#if defined(_WIN32) || defined(_WIN64) + if ((zf->data != NULL) && (zf->tofree == NULL)) { + UnmapViewOfFile(zf->data); + zf->data = NULL; + } + if (zf->mh != INVALID_HANDLE_VALUE) { + CloseHandle(zf->mh); + } +#else + if ((zf->data != MAP_FAILED) && (zf->tofree == NULL)) { + munmap(zf->data, zf->length); + zf->data = MAP_FAILED; + } +#endif + if (zf->tofree != NULL) { + Tcl_Free((char *) zf->tofree); + zf->tofree = NULL; + } + Tcl_Close(interp, zf->chan); + zf->chan = NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSOpenArchive -- + * + * This function opens a ZIP archive file for reading. An attempt + * is made to memory map that file. Otherwise it is read into + * an allocated memory buffer. The ZIP archive header is verified + * and must be valid for the function to succeed. When "needZip" + * is zero an embedded ZIP archive in an executable file is accepted. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message + * placed into the given "interp" if it is not NULL. + * + * Side effects: + * ZIP archive is memory mapped or read into allocated memory, + * the given ZipFile struct is filled with information about + * the ZIP archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, + ZipFile *zf) +{ + int i; + ClientData handle; + unsigned char *p, *q; + +#if defined(_WIN32) || defined(_WIN64) + zf->data = NULL; + zf->mh = INVALID_HANDLE_VALUE; +#else + zf->data = MAP_FAILED; +#endif + zf->length = 0; + zf->nfiles = 0; + zf->baseoffs = zf->baseoffsp = 0; + zf->tofree = NULL; + zf->pwbuf[0] = 0; + zf->chan = Tcl_OpenFileChannel(interp, zipname, "r", 0); + if (zf->chan == NULL) { + return TCL_ERROR; + } + if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { + if (Tcl_SetChannelOption(interp, zf->chan, "-translation", "binary") + != TCL_OK) { + goto error; + } + if (Tcl_SetChannelOption(interp, zf->chan, "-encoding", "binary") + != TCL_OK) { + goto error; + } + zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); + if ((zf->length <= 0) || (zf->length > 64 * 1024 * 1024)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal file size", -1)); + } + goto error; + } + Tcl_Seek(zf->chan, 0, SEEK_SET); + zf->tofree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length); + if (zf->tofree == NULL) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); + if (i != zf->length) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file read error", -1)); + } + goto error; + } + Tcl_Close(interp, zf->chan); + zf->chan = NULL; + } else { +#if defined(_WIN32) || defined(_WIN64) + zf->length = GetFileSize((HANDLE) handle, 0); + if ((zf->length == INVALID_FILE_SIZE) || + (zf->length < ZIP_CENTRAL_END_LEN)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid file size", -1)); + } + goto error; + } + zf->mh = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, 0, + zf->length, 0); + if (zf->mh == INVALID_HANDLE_VALUE) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } + zf->data = MapViewOfFile(zf->mh, FILE_MAP_READ, 0, 0, zf->length); + if (zf->data == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } +#else + zf->length = lseek((int) (long) handle, 0, SEEK_END); + if ((zf->length == -1) || (zf->length < ZIP_CENTRAL_END_LEN)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid file size", -1)); + } + goto error; + } + lseek((int) (long) handle, 0, SEEK_SET); + zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, + MAP_FILE | MAP_PRIVATE, + (int) (long) handle, 0); + if (zf->data == MAP_FAILED) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } +#endif + } + p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; + while (p >= zf->data) { + if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { + if (zip_read_int(p) == ZIP_CENTRAL_END_SIG) { + break; + } + p -= ZIP_SIG_LEN; + } else { + --p; + } + } + if (p < zf->data) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong end signature", -1)); + } + goto error; + } + zf->nfiles = zip_read_short(p + ZIP_CENTRAL_ENTS_OFFS); + if (zf->nfiles == 0) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("empty archive", -1)); + } + goto error; + } + q = zf->data + zip_read_int(p + ZIP_CENTRAL_DIRSTART_OFFS); + p -= zip_read_int(p + ZIP_CENTRAL_DIRSIZE_OFFS); + if ((p < zf->data) || (p > (zf->data + zf->length)) || + (q < zf->data) || (q > (zf->data + zf->length))) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("archive directory not found", -1)); + } + goto error; + } + zf->baseoffs = zf->baseoffsp = p - q; + zf->centoffs = p - zf->data; + q = p; + for (i = 0; i < zf->nfiles; i++) { + int pathlen, comlen, extra; + + if ((q + ZIP_CENTRAL_HEADER_LEN) > (zf->data + zf->length)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong header length", -1)); + } + goto error; + } + if (zip_read_int(q) != ZIP_CENTRAL_HEADER_SIG) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong header signature", -1)); + } + goto error; + } + pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + q = zf->data + zf->baseoffs; + if ((zf->baseoffs >= 6) && + (zip_read_int(q - 4) == ZIP_PASSWORD_END_SIG)) { + i = q[-5]; + if (q - 5 - i > zf->data) { + zf->pwbuf[0] = i; + memcpy(zf->pwbuf + 1, q - 5 - i, i); + zf->baseoffsp -= i ? (5 + i) : 0; + } + } + return TCL_OK; + +error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * Tclzipfs_Mount -- + * + * This procedure is invoked to mount a given ZIP archive file on + * a given mountpoint with optional ZIP password. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is read, analyzed and mounted, resources are + * allocated. + * + *------------------------------------------------------------------------- + */ + +int +Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, + const char *passwd) +{ + char *realname, *p; + int i, pwlen, isNew; + ZipFile *zf, zf0; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_DString ds, dsm, fpBuf; + unsigned char *q; + + ReadLock(); + if (!ZipFS.initialized) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("not initialized", -1)); + } + Unlock(); + return TCL_ERROR; + } + if (zipname == NULL) { + Tcl_HashSearch search; + int ret = TCL_OK; + + i = 0; + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { + if (interp != NULL) { + Tcl_AppendElement(interp, zf->mntpt); + Tcl_AppendElement(interp, zf->name); + } + ++i; + } + hPtr = Tcl_NextHashEntry(&search); + } + if (interp == NULL) { + ret = (i > 0) ? TCL_OK : TCL_BREAK; + } + Unlock(); + return ret; + } + if (mntpt == NULL) { + if (interp == NULL) { + Unlock(); + return TCL_OK; + } + Tcl_DStringInit(&ds); + p = AbsolutePath(zipname, &ds, 0); + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, p); + if (hPtr != NULL) { + if ((zf = Tcl_GetHashValue(hPtr)) != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); + } + } + Unlock(); + Tcl_DStringFree(&ds); + return TCL_OK; + } + Unlock(); + pwlen = 0; + if (passwd != NULL) { + pwlen = strlen(passwd); + if ((pwlen > 255) || (strchr(passwd, 0xff) != NULL)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + } + return TCL_ERROR; + } + } + if (ZipFSOpenArchive(interp, zipname, 1, &zf0) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringInit(&ds); + realname = AbsolutePath(zipname, &ds, 0); + /* + * Mount point can come from Tcl_GetNameOfExecutable() + * which sometimes is a relative or otherwise denormalized path. + * But an absolute name is needed as mount point here. + */ + Tcl_DStringInit(&dsm); + mntpt = CanonicalPath("", mntpt, &dsm, 1); + WriteLock(); + hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, realname, &isNew); + Tcl_DStringSetLength(&ds, 0); + if (!isNew) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (interp != NULL) { + Tcl_AppendResult(interp, "already mounted on \"", zf->mntptlen ? + zf->mntpt : "/", "\"", (char *) NULL); + } + Unlock(); + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsm); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + if (strcmp(mntpt, "/") == 0) { + mntpt = ""; + } + zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1); + if (zf == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + } + Unlock(); + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsm); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + *zf = zf0; + zf->name = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + strcpy(zf->mntpt, mntpt); + zf->mntptlen = strlen(zf->mntpt); + zf->entries = NULL; + zf->topents = NULL; + zf->nopen = 0; + Tcl_SetHashValue(hPtr, (ClientData) zf); + if ((zf->pwbuf[0] == 0) && pwlen) { + int k = 0; + i = pwlen; + zf->pwbuf[k++] = i; + while (i > 0) { + zf->pwbuf[k] = (passwd[i - 1] & 0x0f) | + pwrot[(passwd[i - 1] >> 4) & 0x0f]; + k++; + i--; + } + zf->pwbuf[k] = '\0'; + } + if (mntpt[0] != '\0') { + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = CountSlashes(mntpt); + z->zipfile = zf; + z->isdir = 1; + z->isenc = 0; + z->offset = zf->baseoffs; + z->crc32 = 0; + z->timestamp = 0; + z->nbyte = z->nbytecompr = 0; + z->cmeth = ZIP_COMPMETH_STORED; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mntpt, &isNew); + if (!isNew) { + /* skip it */ + Tcl_Free((char *) z); + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + } + } + q = zf->data + zf->centoffs; + Tcl_DStringInit(&fpBuf); + for (i = 0; i < zf->nfiles; i++) { + int pathlen, comlen, extra, isdir = 0, dosTime, dosDate, nbcompr, offs; + unsigned char *lq, *gq = NULL; + char *fullpath, *path; + + pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); + path = Tcl_DStringValue(&ds); + if ((pathlen > 0) && (path[pathlen - 1] == '/')) { + Tcl_DStringSetLength(&ds, pathlen - 1); + path = Tcl_DStringValue(&ds); + isdir = 1; + } + if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { + goto nextent; + } + lq = zf->data + zf->baseoffs + + zip_read_int(q + ZIP_CENTRAL_LOCALHDR_OFFS); + if ((lq < zf->data) || (lq > (zf->data + zf->length))) { + goto nextent; + } + nbcompr = zip_read_int(lq + ZIP_LOCAL_COMPLEN_OFFS); + if (!isdir && (nbcompr == 0) && + (zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) && + (zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { + gq = q; + nbcompr = zip_read_int(gq + ZIP_CENTRAL_COMPLEN_OFFS); + } + offs = (lq - zf->data) + + ZIP_LOCAL_HEADER_LEN + + zip_read_short(lq + ZIP_LOCAL_PATHLEN_OFFS) + + zip_read_short(lq + ZIP_LOCAL_EXTRALEN_OFFS); + if ((offs + nbcompr) > zf->length) { + goto nextent; + } + if (!isdir && (mntpt[0] == '\0') && !CountSlashes(path)) { +#ifdef ANDROID + /* + * When mounting the ZIP archive on the root directory try + * to remap top level regular files of the archive to + * /assets/.root/... since this directory should not be + * in a valid APK due to the leading dot in the file name + * component. This trick should make the files + * AndroidManifest.xml, resources.arsc, and classes.dex + * visible to Tcl. + */ + Tcl_DString ds2; + + Tcl_DStringInit(&ds2); + Tcl_DStringAppend(&ds2, "assets/.root/", -1); + Tcl_DStringAppend(&ds2, path, -1); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); + if (hPtr != NULL) { + /* should not happen but skip it anyway */ + Tcl_DStringFree(&ds2); + goto nextent; + } + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), + Tcl_DStringLength(&ds2)); + path = Tcl_DStringValue(&ds); + Tcl_DStringFree(&ds2); +#else + /* + * Regular files skipped when mounting on root. + */ + goto nextent; +#endif + } + Tcl_DStringSetLength(&fpBuf, 0); + fullpath = CanonicalPath(mntpt, path, &fpBuf, 1); + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = CountSlashes(fullpath); + z->zipfile = zf; + z->isdir = isdir; + z->isenc = (zip_read_short(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) + && (nbcompr > 12); + z->offset = offs; + if (gq != NULL) { + z->crc32 = zip_read_int(gq + ZIP_CENTRAL_CRC32_OFFS); + dosDate = zip_read_short(gq + ZIP_CENTRAL_MDATE_OFFS); + dosTime = zip_read_short(gq + ZIP_CENTRAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->nbyte = zip_read_int(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); + z->cmeth = zip_read_short(gq + ZIP_CENTRAL_COMPMETH_OFFS); + } else { + z->crc32 = zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS); + dosDate = zip_read_short(lq + ZIP_LOCAL_MDATE_OFFS); + dosTime = zip_read_short(lq + ZIP_LOCAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->nbyte = zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); + z->cmeth = zip_read_short(lq + ZIP_LOCAL_COMPMETH_OFFS); + } + z->nbytecompr = nbcompr; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); + if (!isNew) { + /* should not happen but skip it anyway */ + Tcl_Free((char *) z); + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + if (isdir && (mntpt[0] == '\0') && (z->depth == 1)) { + z->tnext = zf->topents; + zf->topents = z; + } + if (!z->isdir && (z->depth > 1)) { + char *dir, *end; + ZipEntry *zd; + + Tcl_DStringSetLength(&ds, strlen(z->name) + 8); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, z->name, -1); + dir = Tcl_DStringValue(&ds); + end = strrchr(dir, '/'); + while ((end != NULL) && (end != dir)) { + Tcl_DStringSetLength(&ds, end - dir); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, dir); + if (hPtr != NULL) { + break; + } + zd = (ZipEntry *) Tcl_Alloc(sizeof (*zd)); + zd->name = NULL; + zd->tnext = NULL; + zd->depth = CountSlashes(dir); + zd->zipfile = zf; + zd->isdir = 1; + zd->isenc = 0; + zd->offset = z->offset; + zd->crc32 = 0; + zd->timestamp = z->timestamp; + zd->nbyte = zd->nbytecompr = 0; + zd->cmeth = ZIP_COMPMETH_STORED; + zd->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); + if (!isNew) { + /* should not happen but skip it anyway */ + Tcl_Free((char *) zd); + } else { + Tcl_SetHashValue(hPtr, (ClientData) zd); + zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + zd->next = zf->entries; + zf->entries = zd; + if ((mntpt[0] == '\0') && (zd->depth == 1)) { + zd->tnext = zf->topents; + zf->topents = zd; + } + } + end = strrchr(dir, '/'); + } + } + } +nextent: + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + Unlock(); + Tcl_DStringFree(&fpBuf); + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsm); + Tcl_FSMountsChanged(NULL); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * Tclzipfs_Unmount -- + * + * This procedure is invoked to unmount a given ZIP archive. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +int +Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname) +{ + char *realname; + ZipFile *zf; + ZipEntry *z, *znext; + Tcl_HashEntry *hPtr; + Tcl_DString ds; + int ret = TCL_OK, unmounted = 0; + + Tcl_DStringInit(&ds); + realname = AbsolutePath(zipname, &ds, 0); + WriteLock(); + if (!ZipFS.initialized) { + goto done; + } + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, realname); + if (hPtr == NULL) { + /* don't report error */ + goto done; + } + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (zf->nopen > 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("filesystem is busy", -1)); + } + ret = TCL_ERROR; + goto done; + } + Tcl_DeleteHashEntry(hPtr); + for (z = zf->entries; z; z = znext) { + znext = z->next; + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } + if (z->data != NULL) { + Tcl_Free((char *) z->data); + } + Tcl_Free((char *) z); + } + ZipFSCloseArchive(interp, zf); + Tcl_Free((char *) zf); + unmounted = 1; +done: + Unlock(); + Tcl_DStringFree(&ds); + if (unmounted) { + Tcl_FSMountsChanged(NULL); + } + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMountObjCmd -- + * + * This procedure is invoked to process the "zipfs::mount" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is mounted, resources are allocated. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMountObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + if (objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "?zipfile? ?mountpoint? ?password?"); + return TCL_ERROR; + } + return Tclzipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, + (objc > 2) ? Tcl_GetString(objv[2]) : NULL, + (objc > 3) ? Tcl_GetString(objv[3]) : NULL); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSUnmountObjCmd -- + * + * This procedure is invoked to process the "zipfs::unmount" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSUnmountObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); + return TCL_ERROR; + } + return Tclzipfs_Unmount(interp, Tcl_GetString(objv[1])); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkKeyObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkkey" command. + * It produces a rotated password to be embedded into an image file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkKeyObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + int len, i = 0; + char *pw, pwbuf[264]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "password"); + return TCL_ERROR; + } + pw = Tcl_GetString(objv[1]); + len = strlen(pw); + if (len == 0) { + return TCL_OK; + } + if ((len > 255) || (strchr(pw, 0xff) != NULL)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + return TCL_ERROR; + } + while (len > 0) { + int ch = pw[len - 1]; + + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + len--; + } + pwbuf[i] = i; + ++i; + pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + pwbuf[i] = '\0'; + Tcl_AppendResult(interp, pwbuf, (char *) NULL); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipAddFile -- + * + * This procedure is used by ZipFSMkZipOrImgCmd() to add a single + * file to the output ZIP archive file being written. A ZipEntry + * struct about the input file is added to the given fileHash table + * for later creation of the central ZIP directory. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Input file is read and (compressed and) written to the output + * ZIP archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipAddFile(Tcl_Interp *interp, const char *path, const char *name, + Tcl_Channel out, const char *passwd, + char *buf, int bufsize, Tcl_HashTable *fileHash) +{ + Tcl_Channel in; + Tcl_HashEntry *hPtr; + ZipEntry *z; + z_stream stream; + const char *zpath; + int nbyte, nbytecompr, len, crc, flush, pos[3], zpathlen, olen; + int mtime = 0, isNew, align = 0, cmeth; + unsigned long keys[3], keys0[3]; + char obuf[4096]; + + zpath = name; + while (zpath != NULL && zpath[0] == '/') { + zpath++; + } + if ((zpath == NULL) || (zpath[0] == '\0')) { + return TCL_OK; + } + zpathlen = strlen(zpath); + if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { + Tcl_AppendResult(interp, "path too long for \"", path, "\"", + (char *) NULL); + return TCL_ERROR; + } + in = Tcl_OpenFileChannel(interp, path, "r", 0); + if ((in == NULL) || + (Tcl_SetChannelOption(interp, in, "-translation", "binary") + != TCL_OK) || + (Tcl_SetChannelOption(interp, in, "-encoding", "binary") + != TCL_OK)) { +#if defined(_WIN32) || defined(_WIN64) + /* hopefully a directory */ + if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { + Tcl_Close(interp, in); + return TCL_OK; + } +#endif + Tcl_Close(interp, in); + return TCL_ERROR; + } else { + Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); + Tcl_StatBuf statBuf; + + Tcl_IncrRefCount(pathObj); + if (Tcl_FSStat(pathObj, &statBuf) != -1) { + mtime = statBuf.st_mtime; + } + Tcl_DecrRefCount(pathObj); + } + Tcl_ResetResult(interp); + crc = 0; + nbyte = nbytecompr = 0; + while ((len = Tcl_Read(in, buf, bufsize)) > 0) { + crc = crc32(crc, (unsigned char *) buf, len); + nbyte += len; + } + if (len == -1) { + if (nbyte == 0) { + if (strcmp("illegal operation on a directory", + Tcl_PosixError(interp)) == 0) { + Tcl_Close(interp, in); + return TCL_OK; + } + } + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if (Tcl_Seek(in, 0, SEEK_SET) == -1) { + Tcl_AppendResult(interp, "seek error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + pos[0] = Tcl_Tell(out); + memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); + memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); + len = zpathlen + ZIP_LOCAL_HEADER_LEN; + if (Tcl_Write(out, buf, len) != len) { +wrerr: + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if ((len + pos[0]) & 3) { + char abuf[8]; + + /* + * Align payload to next 4-byte boundary using a dummy extra + * entry similar to the zipalign tool from Android's SDK. + */ + align = 4 + ((len + pos[0]) & 3); + zip_write_short(abuf, 0xffff); + zip_write_short(abuf + 2, align - 4); + zip_write_int(abuf + 4, 0x03020100); + if (Tcl_Write(out, abuf, align) != align) { + goto wrerr; + } + } + if (passwd != NULL) { + int i, ch, tmp; + unsigned char kvbuf[24]; + Tcl_Obj *ret; + + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + if (Tcl_EvalEx(interp, "expr int(rand() * 256) % 256", -1, 0) != TCL_OK) { + Tcl_AppendResult(interp, "PRNG error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + ret = Tcl_GetObjResult(interp); + if (Tcl_GetIntFromObj(interp, ret, &ch) != TCL_OK) { + Tcl_Close(interp, in); + return TCL_ERROR; + } + kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp); + } + Tcl_ResetResult(interp); + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + kvbuf[i] = (unsigned char) zencode(keys, crc32tab, + kvbuf[i + 12], tmp); + } + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp); + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp); + len = Tcl_Write(out, (char *) kvbuf, 12); + memset(kvbuf, 0, 24); + if (len != 12) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + memcpy(keys0, keys, sizeof (keys0)); + nbytecompr += 12; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + cmeth = ZIP_COMPMETH_DEFLATED; + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) + != Z_OK) { + Tcl_AppendResult(interp, "compression init error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + do { + len = Tcl_Read(in, buf, bufsize); + if (len == -1) { + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + stream.avail_in = len; + stream.next_in = (unsigned char *) buf; + flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; + do { + stream.avail_out = sizeof (obuf); + stream.next_out = (unsigned char *) obuf; + len = deflate(&stream, flush); + if (len == Z_STREAM_ERROR) { + Tcl_AppendResult(interp, "deflate error on \"", path, "\"", + (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + olen = sizeof (obuf) - stream.avail_out; + if (passwd != NULL) { + int i, tmp; + + for (i = 0; i < olen; i++) { + obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); + } + } + if (olen && (Tcl_Write(out, obuf, olen) != olen)) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += olen; + } while (stream.avail_out == 0); + } while (flush != Z_FINISH); + deflateEnd(&stream); + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + if (nbyte - nbytecompr <= 0) { + /* + * Compressed file larger than input, + * write it again uncompressed. + */ + if ((int) Tcl_Seek(in, 0, SEEK_SET) != 0) { + goto seekErr; + } + if ((int) Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { +seekErr: + Tcl_Close(interp, in); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + nbytecompr = (passwd != NULL) ? 12 : 0; + while (1) { + len = Tcl_Read(in, buf, bufsize); + if (len == -1) { + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } else if (len == 0) { + break; + } + if (passwd != NULL) { + int i, tmp; + + for (i = 0; i < len; i++) { + buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); + } + } + if (Tcl_Write(out, buf, len) != len) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += len; + } + cmeth = ZIP_COMPMETH_STORED; + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + Tcl_TruncateChannel(out, pos[1]); + } + Tcl_Close(interp, in); + + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = 0; + z->zipfile = NULL; + z->isdir = 0; + z->isenc = (passwd != NULL) ? 1 : 0; + z->offset = pos[0]; + z->crc32 = crc; + z->timestamp = mtime; + z->nbyte = nbyte; + z->nbytecompr = nbytecompr; + z->cmeth = cmeth; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); + if (!isNew) { + Tcl_AppendResult(interp, "non-unique path name \"", path, "\"", + (char *) NULL); + Tcl_Free((char *) z); + return TCL_ERROR; + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(fileHash, hPtr); + z->next = NULL; + } + + /* + * Write final local header information. + */ + zip_write_int(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); + zip_write_short(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_LOCAL_FLAGS_OFFS, z->isenc); + zip_write_short(buf + ZIP_LOCAL_COMPMETH_OFFS, z->cmeth); + zip_write_short(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); + zip_write_short(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); + zip_write_int(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); + zip_write_int(buf + ZIP_LOCAL_COMPLEN_OFFS, z->nbytecompr); + zip_write_int(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->nbyte); + zip_write_short(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); + zip_write_short(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); + if ((int) Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "write error", (char *) NULL); + return TCL_ERROR; + } + Tcl_Flush(out); + if ((int) Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipOrImgObjCmd -- + * + * This procedure is creates a new ZIP archive file or image file + * given output filename, input directory of files to be archived, + * optional password, and optional image to be prepended to the + * output ZIP archive file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A new ZIP archive file or image file is written. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipOrImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int isImg, int isList, int objc, Tcl_Obj *const objv[]) +{ + Tcl_Channel out; + int len = 0, pwlen = 0, slen = 0, i, count, ret = TCL_ERROR, lobjc, pos[3]; + Tcl_Obj **lobjv, *list = NULL; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable fileHash; + char *strip = NULL, *pw = NULL, pwbuf[264], buf[4096]; + + if (isList) { + if ((objc < 3) || (objc > (isImg ? 5 : 4))) { + Tcl_WrongNumArgs(interp, 1, objv, isImg ? + "outfile inlist ?password infile?" : + "outfile inlist ?password?"); + return TCL_ERROR; + } + } else { + if ((objc < 3) || (objc > (isImg ? 6 : 5))) { + Tcl_WrongNumArgs(interp, 1, objv, isImg ? + "outfile indir ?strip? ?password? ?infile?" : + "outfile indir ?strip? ?password?"); + return TCL_ERROR; + } + } + pwbuf[0] = 0; + if (objc > (isList ? 3 : 4)) { + pw = Tcl_GetString(objv[isList ? 3 : 4]); + pwlen = strlen(pw); + if ((pwlen > 255) || (strchr(pw, 0xff) != NULL)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + return TCL_ERROR; + } + } + if (isList) { + list = objv[2]; + Tcl_IncrRefCount(list); + } else { + Tcl_Obj *cmd[3]; + + cmd[1] = Tcl_NewStringObj("::zipfs::find", -1); + cmd[2] = objv[2]; + cmd[0] = Tcl_NewListObj(2, cmd + 1); + Tcl_IncrRefCount(cmd[0]); + if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { + Tcl_DecrRefCount(cmd[0]); + return TCL_ERROR; + } + Tcl_DecrRefCount(cmd[0]); + list = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(list); + } + if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + if (isList && (lobjc % 2)) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("need even number of elements", -1)); + return TCL_ERROR; + } + if (lobjc == 0) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); + return TCL_ERROR; + } + out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "w", 0755); + if ((out == NULL) || + (Tcl_SetChannelOption(interp, out, "-translation", "binary") + != TCL_OK) || + (Tcl_SetChannelOption(interp, out, "-encoding", "binary") + != TCL_OK)) { + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + if (isImg) { + ZipFile zf0; + const char *imgName; + + if (isList) { + imgName = (objc > 4) ? Tcl_GetString(objv[4]) : + Tcl_GetNameOfExecutable(); + } else { + imgName = (objc > 5) ? Tcl_GetString(objv[5]) : + Tcl_GetNameOfExecutable(); + } + if (ZipFSOpenArchive(interp, imgName, 0, &zf0) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + if ((pw != NULL) && pwlen) { + i = 0; + len = pwlen; + while (len > 0) { + int ch = pw[len - 1]; + + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + len--; + } + pwbuf[i] = i; + ++i; + pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + pwbuf[i] = '\0'; + } + i = Tcl_Write(out, (char *) zf0.data, zf0.baseoffsp); + if (i != zf0.baseoffsp) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + Tcl_Close(interp, out); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + ZipFSCloseArchive(interp, &zf0); + len = strlen(pwbuf); + if (len > 0) { + i = Tcl_Write(out, pwbuf, len); + if (i != len) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + Tcl_Close(interp, out); + return TCL_ERROR; + } + } + memset(pwbuf, 0, sizeof (pwbuf)); + Tcl_Flush(out); + } + Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); + pos[0] = Tcl_Tell(out); + if (!isList && (objc > 3)) { + strip = Tcl_GetString(objv[3]); + slen = strlen(strip); + } + for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + if (ZipAddFile(interp, path, name, out, pw, buf, sizeof (buf), + &fileHash) != TCL_OK) { + goto done; + } + } + pos[1] = Tcl_Tell(out); + count = 0; + for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + hPtr = Tcl_FindHashEntry(&fileHash, name); + if (hPtr == NULL) { + continue; + } + z = (ZipEntry *) Tcl_GetHashValue(hPtr); + len = strlen(z->name); + zip_write_int(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); + zip_write_short(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isenc ? 1 : 0); + zip_write_short(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->cmeth); + zip_write_short(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); + zip_write_short(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); + zip_write_int(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); + zip_write_int(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->nbytecompr); + zip_write_int(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->nbyte); + zip_write_short(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); + zip_write_short(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_IATTR_OFFS, 0); + zip_write_int(buf + ZIP_CENTRAL_EATTR_OFFS, 0); + zip_write_int(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); + if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != + ZIP_CENTRAL_HEADER_LEN) || + (Tcl_Write(out, z->name, len) != len)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + goto done; + } + count++; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + zip_write_int(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); + zip_write_short(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_ENTS_OFFS, count); + zip_write_short(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); + zip_write_int(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); + zip_write_int(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); + zip_write_short(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); + if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + goto done; + } + Tcl_Flush(out); + ret = TCL_OK; +done: + if (ret == TCL_OK) { + ret = Tcl_Close(interp, out); + } else { + Tcl_Close(interp, out); + } + Tcl_DecrRefCount(list); + hPtr = Tcl_FirstHashEntry(&fileHash, &search); + while (hPtr != NULL) { + z = (ZipEntry *) Tcl_GetHashValue(hPtr); + Tcl_Free((char *) z); + Tcl_DeleteHashEntry(hPtr); + hPtr = Tcl_FirstHashEntry(&fileHash, &search); + } + Tcl_DeleteHashTable(&fileHash); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkzip" command. + * See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 0, objc, objv); +} + +static int +ZipFSLMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkImgObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkimg" command. + * See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 0, objc, objv); +} + +static int +ZipFSLMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSExistsObjCmd -- + * + * This procedure is invoked to process the "zipfs::exists" command. + * It tests for the existence of a file in the ZIP filesystem and + * places a boolean into the interp's result. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSCanonicalObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *mntpoint=NULL; + char *filename=NULL; + char *result; + Tcl_DString dPath; + + if (objc != 2 && objc != 3 && objc!=4) { + Tcl_WrongNumArgs(interp, 1, objv, "?mntpnt? filename ?ZIPFS?"); + return TCL_ERROR; + } + Tcl_DStringInit(&dPath); + if(objc==2) { + filename = Tcl_GetString(objv[1]); + result=CanonicalPath("",filename,&dPath,1); + } else if (objc==3) { + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result=CanonicalPath(mntpoint,filename,&dPath,1); + } else { + int zipfs=0; + if(Tcl_GetBooleanFromObj(interp,objv[3],&zipfs)) { + return TCL_ERROR; + } + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result=CanonicalPath(mntpoint,filename,&dPath,zipfs); + } + Tcl_SetObjResult(interp,Tcl_NewStringObj(result,-1)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSExistsObjCmd -- + * + * This procedure is invoked to process the "zipfs::exists" command. + * It tests for the existence of a file in the ZIP filesystem and + * places a boolean into the interp's result. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSExistsObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *filename; + int exists; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + filename = Tcl_GetStringFromObj(objv[1], 0); + ReadLock(); + exists = ZipFSLookup(filename) != NULL; + Unlock(); + Tcl_SetObjResult(interp,Tcl_NewBooleanObj(exists)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSInfoObjCmd -- + * + * This procedure is invoked to process the "zipfs::info" command. + * On success, it returns a Tcl list made up of name of ZIP archive + * file, size uncompressed, size compressed, and archive offset of + * a file in the ZIP filesystem. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSInfoObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *filename; + ZipEntry *z; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + filename = Tcl_GetStringFromObj(objv[1], 0); + ReadLock(); + z = ZipFSLookup(filename); + if (z != NULL) { + Tcl_Obj *result = Tcl_GetObjResult(interp); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->zipfile->name, -1)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbyte)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbytecompr)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->offset)); + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSListObjCmd -- + * + * This procedure is invoked to process the "zipfs::list" command. + * On success, it returns a Tcl list of files of the ZIP filesystem + * which match a search pattern (glob or regexp). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSListObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *pattern = NULL; + Tcl_RegExp regexp = NULL; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *result = Tcl_GetObjResult(interp); + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); + return TCL_ERROR; + } + if (objc == 3) { + int n; + char *what = Tcl_GetStringFromObj(objv[1], &n); + + if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { + pattern = Tcl_GetString(objv[2]); + } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { + regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); + if (regexp == NULL) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "unknown option \"", what, + "\"", (char *) NULL); + return TCL_ERROR; + } + } else if (objc == 2) { + pattern = Tcl_GetStringFromObj(objv[1], 0); + } + ReadLock(); + if (pattern != NULL) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if (Tcl_StringMatch(z->name, pattern)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else if (regexp != NULL) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelClose -- + * + * This function is called to close a channel. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * Resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelClose(ClientData instanceData, Tcl_Interp *interp) +{ + ZipChannel *info = (ZipChannel *) instanceData; + + if (info->iscompr && (info->ubuf != NULL)) { + Tcl_Free((char *) info->ubuf); + info->ubuf = NULL; + } + if (info->isenc) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + } + if (info->iswr) { + ZipEntry *z = info->zipentry; + unsigned char *newdata; + + newdata = (unsigned char *) + Tcl_AttemptRealloc((char *) info->ubuf, info->nread); + if (newdata != NULL) { + if (z->data != NULL) { + Tcl_Free((char *) z->data); + } + z->data = newdata; + z->nbyte = z->nbytecompr = info->nbyte; + z->cmeth = ZIP_COMPMETH_STORED; + z->timestamp = time(NULL); + z->isdir = 0; + z->isenc = 0; + z->offset = 0; + z->crc32 = 0; + } else { + Tcl_Free((char *) info->ubuf); + } + } + WriteLock(); + info->zipfile->nopen--; + Unlock(); + Tcl_Free((char *) info); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelRead -- + * + * This function is called to read data from channel. + * + * Results: + * Number of bytes read or -1 on error with error number set. + * + * Side effects: + * Data is read and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelRead(ClientData instanceData, char *buf, int toRead, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (info->isdir) { + *errloc = EISDIR; + return -1; + } + nextpos = info->nread + toRead; + if (nextpos > info->nbyte) { + toRead = info->nbyte - info->nread; + nextpos = info->nbyte; + } + if (toRead == 0) { + return 0; + } + if (info->isenc) { + int i, ch; + + for (i = 0; i < toRead; i++) { + ch = info->ubuf[i + info->nread]; + buf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(buf, info->ubuf + info->nread, toRead); + } + info->nread = nextpos; + *errloc = 0; + return toRead; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWrite -- + * + * This function is called to write data into channel. + * + * Results: + * Number of bytes written or -1 on error with error number set. + * + * Side effects: + * Data is written and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelWrite(ClientData instanceData, const char *buf, + int toWrite, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (!info->iswr) { + *errloc = EINVAL; + return -1; + } + nextpos = info->nread + toWrite; + if (nextpos > info->nmax) { + toWrite = info->nmax - info->nread; + nextpos = info->nmax; + } + if (toWrite == 0) { + return 0; + } + memcpy(info->ubuf + info->nread, buf, toWrite); + info->nread = nextpos; + if (info->nread > info->nbyte) { + info->nbyte = info->nread; + } + *errloc = 0; + return toWrite; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelSeek -- + * + * This function is called to position file pointer of channel. + * + * Results: + * New file position or -1 on error with error number set. + * + * Side effects: + * File pointer is repositioned according to offset and mode. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelSeek(ClientData instanceData, long offset, int mode, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + + if (info->isdir) { + *errloc = EINVAL; + return -1; + } + switch (mode) { + case SEEK_CUR: + offset += info->nread; + break; + case SEEK_END: + offset += info->nbyte; + break; + case SEEK_SET: + break; + default: + *errloc = EINVAL; + return -1; + } + if (offset < 0) { + *errloc = EINVAL; + return -1; + } + if (info->iswr) { + if ((unsigned long) offset > info->nmax) { + *errloc = EINVAL; + return -1; + } + if ((unsigned long) offset > info->nbyte) { + info->nbyte = offset; + } + } else if ((unsigned long) offset > info->nbyte) { + *errloc = EINVAL; + return -1; + } + info->nread = (unsigned long) offset; + return info->nread; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWatchChannel -- + * + * This function is called for event notifications on channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static void +ZipChannelWatchChannel(ClientData instanceData, int mask) +{ + return; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelGetFile -- + * + * This function is called to retrieve OS handle for channel. + * + * Results: + * Always TCL_ERROR since there's never an OS handle for a + * file within a ZIP archive. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelGetFile(ClientData instanceData, int direction, + ClientData *handlePtr) +{ + return TCL_ERROR; +} + +/* + * The channel type/driver definition used for ZIP archive members. + */ + +static Tcl_ChannelType ZipChannelType = { + "zip", /* Type name. */ +#ifdef TCL_CHANNEL_VERSION_4 + TCL_CHANNEL_VERSION_4, + ZipChannelClose, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ + ZipChannelSeek, /* Move location of access point, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ + NULL, /* 2nd version of close channel, NULL'able */ + NULL, /* Set blocking mode for raw channel, NULL'able */ + NULL, /* Function to flush channel, NULL'able */ + NULL, /* Function to handle event, NULL'able */ + NULL, /* Wide seek function, NULL'able */ + NULL, /* Thread action function, NULL'able */ +#else + NULL, /* Set blocking/nonblocking behaviour, NULL'able */ + ZipChannelClose, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ + ZipChannelSeek, /* Move location of access point, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ +#endif +}; + +/* + *------------------------------------------------------------------------- + * + * ZipChannelOpen -- + * + * This function opens a Tcl_Channel on a file from a mounted ZIP + * archive according to given open mode. + * + * Results: + * Tcl_Channel on success, or NULL on error. + * + * Side effects: + * Memory is allocated, the file from the ZIP archive is uncompressed. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +ZipChannelOpen(Tcl_Interp *interp, char *filename, int mode, int permissions) +{ + ZipEntry *z; + ZipChannel *info; + int i, ch, trunc, wr, flags = 0; + char cname[128]; + + if ((mode & O_APPEND) || + ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported open mode", -1)); + } + return NULL; + } + WriteLock(); + z = ZipFSLookup(filename); + if (z == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); + } + goto error; + } + trunc = (mode & O_TRUNC) != 0; + wr = (mode & (O_WRONLY | O_RDWR)) != 0; + if ((z->cmeth != ZIP_COMPMETH_STORED) && + (z->cmeth != ZIP_COMPMETH_DEFLATED)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unsupported compression method", -1)); + } + goto error; + } + if (wr && z->isdir) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unsupported file type", -1)); + } + goto error; + } + if (!trunc) { + flags |= TCL_READABLE; + if (z->isenc && (z->zipfile->pwbuf[0] == 0)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decryption failed", -1)); + } + goto error; + } else if (wr && (z->data == NULL) && (z->nbyte > ZipFS.wrmax)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file too large", -1)); + } + goto error; + } + } else { + flags = TCL_WRITABLE; + } + info = (ZipChannel *) Tcl_AttemptAlloc(sizeof (*info)); + if (info == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + info->zipfile = z->zipfile; + info->zipentry = z; + info->nread = 0; + if (wr) { + flags |= TCL_WRITABLE; + info->iswr = 1; + info->isdir = 0; + info->nmax = ZipFS.wrmax; + info->iscompr = 0; + info->isenc = 0; + info->ubuf = (unsigned char *) Tcl_AttemptAlloc(info->nmax); + if (info->ubuf == NULL) { +merror0: + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + memset(info->ubuf, 0, info->nmax); + if (trunc) { + info->nbyte = 0; + } else { + if (z->data != NULL) { + unsigned int j = z->nbyte; + + if (j > info->nmax) { + j = info->nmax; + } + memcpy(info->ubuf, z->data, j); + info->nbyte = j; + } else { + unsigned char *zbuf = z->zipfile->data + z->offset; + + if (z->isenc) { + int len = z->zipfile->pwbuf[0]; + char pwbuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipfile->pwbuf[len - i]; + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + pwbuf[i] = '\0'; + init_keys(pwbuf, info->keys, crc32tab); + memset(pwbuf, 0, sizeof (pwbuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + zbuf += i; + } + if (z->cmeth == ZIP_COMPMETH_DEFLATED) { + z_stream stream; + int err; + unsigned char *cbuf = NULL; + + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->nbytecompr; + if (z->isenc) { + unsigned int j; + + stream.avail_in -= 12; + cbuf = (unsigned char *) + Tcl_AttemptAlloc(stream.avail_in); + if (cbuf == NULL) { + goto merror0; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + cbuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = cbuf; + } else { + stream.next_in = zbuf; + } + stream.next_out = info->ubuf; + stream.avail_out = info->nmax; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror0; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) || + ((err == Z_OK) && (stream.avail_in == 0))) { + if (cbuf != NULL) { + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) cbuf); + } + goto wrapchan; + } +cerror0: + if (cbuf != NULL) { + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) cbuf); + } + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decompression error", -1)); + } + goto error; + } else if (z->isenc) { + for (i = 0; i < z->nbyte - 12; i++) { + ch = zbuf[i]; + info->ubuf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(info->ubuf, zbuf, z->nbyte); + } + memset(info->keys, 0, sizeof (info->keys)); + goto wrapchan; + } + } + } else if (z->data != NULL) { + flags |= TCL_READABLE; + info->iswr = 0; + info->iscompr = 0; + info->isdir = 0; + info->isenc = 0; + info->nbyte = z->nbyte; + info->nmax = 0; + info->ubuf = z->data; + } else { + flags |= TCL_READABLE; + info->iswr = 0; + info->iscompr = z->cmeth == ZIP_COMPMETH_DEFLATED; + info->ubuf = z->zipfile->data + z->offset; + info->isdir = z->isdir; + info->isenc = z->isenc; + info->nbyte = z->nbyte; + info->nmax = 0; + if (info->isenc) { + int len = z->zipfile->pwbuf[0]; + char pwbuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipfile->pwbuf[len - i]; + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + pwbuf[i] = '\0'; + init_keys(pwbuf, info->keys, crc32tab); + memset(pwbuf, 0, sizeof (pwbuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + info->ubuf += i; + } + if (info->iscompr) { + z_stream stream; + int err; + unsigned char *ubuf = NULL; + unsigned int j; + + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->nbytecompr; + if (info->isenc) { + stream.avail_in -= 12; + ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in); + if (ubuf == NULL) { + info->ubuf = NULL; + goto merror; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + ubuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = ubuf; + } else { + stream.next_in = info->ubuf; + } + stream.next_out = info->ubuf = + (unsigned char *) Tcl_AttemptAlloc(info->nbyte); + if (info->ubuf == NULL) { +merror: + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + stream.avail_out = info->nbyte; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) || + ((err == Z_OK) && (stream.avail_in == 0))) { + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + goto wrapchan; + } +cerror: + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decompression error", -1)); + } + goto error; + } + } +wrapchan: + sprintf(cname, "zipfs_%lx_%d", (unsigned long) z->offset, ZipFS.idCount++); + z->zipfile->nopen++; + Unlock(); + return Tcl_CreateChannel(&ZipChannelType, cname, (ClientData) info, flags); + +error: + Unlock(); + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryStat -- + * + * This function implements the ZIP filesystem specific version + * of the library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryStat(char *path, Tcl_StatBuf *buf) +{ + ZipEntry *z; + int ret = -1; + + ReadLock(); + z = ZipFSLookup(path); + if (z == NULL) { + goto done; + } + memset(buf, 0, sizeof (Tcl_StatBuf)); + if (z->isdir) { + buf->st_mode = S_IFDIR | 0555; + } else { + buf->st_mode = S_IFREG | 0555; + } + buf->st_size = z->nbyte; + buf->st_mtime = z->timestamp; + buf->st_ctime = z->timestamp; + buf->st_atime = z->timestamp; + ret = 0; +done: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryAccess -- + * + * This function implements the ZIP filesystem specific version + * of the library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryAccess(char *path, int mode) +{ + ZipEntry *z; + + if (mode & 3) { + return -1; + } + ReadLock(); + z = ZipFSLookup(path); + Unlock(); + return (z != NULL) ? 0 : -1; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSOpenFileChannelProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +Zip_FSOpenFileChannelProc(Tcl_Interp *interp, Tcl_Obj *pathPtr, + int mode, int permissions) +{ + int len; + + return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), + mode, permissions); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSStatProc -- + * + * This function implements the ZIP filesystem specific version + * of the library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) +{ + int len; + + return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSAccessProc -- + * + * This function implements the ZIP filesystem specific version + * of the library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode) +{ + int len; + + return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFilesystemSeparatorProc -- + * + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero + * + * Results: + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("/", -1); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSMatchInDirectoryProc -- + * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. + * + * Results: + * The return value is a standard Tcl result indicating whether an + * error occurred in globbing. Errors are left in interp, good + * results are lappend'ed to resultPtr (which must be a valid object). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +static int +Zip_FSMatchInDirectoryProc(Tcl_Interp* interp, Tcl_Obj *result, + Tcl_Obj *pathPtr, const char *pattern, + Tcl_GlobTypeData *types) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int scnt, len, l, dirOnly = -1, prefixLen, strip = 0; + char *pat, *prefix, *path; + Tcl_DString ds, dsPref; + if (types != NULL) { + dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; + } + Tcl_DStringInit(&ds); + Tcl_DStringInit(&dsPref); + prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); + Tcl_DStringAppend(&dsPref, prefix, prefixLen); + prefix = Tcl_DStringValue(&dsPref); + path = AbsolutePath(prefix, &ds, 1); + len = Tcl_DStringLength(&ds); + if (strcmp(prefix, path) == 0) { + prefix = NULL; + } else { + strip = len + 1; + } + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, "/", 1); + prefixLen++; + prefix = Tcl_DStringValue(&dsPref); + } + ReadLock(); + if ((types != NULL) && (types->type == TCL_GLOB_TYPE_MOUNT)) { + l = CountSlashes(path); + if (path[len - 1] == '/') { + len--; + } else { + l++; + } + if ((pattern == NULL) || (pattern[0] == '\0')) { + pattern = "*"; + } + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); + + if (zf->mntptlen == 0) { + ZipEntry *z = zf->topents; + while (z != NULL) { + int lenz = strlen(z->name); + if ((lenz > len + 1) && + (strncmp(z->name, path, len) == 0) && + (z->name[len] == '/') && + (CountSlashes(z->name) == l) && + Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name, lenz); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, lenz)); + } + } + z = z->tnext; + } + } else if ((zf->mntptlen > len + 1) && + (strncmp(zf->mntpt, path, len) == 0) && + (zf->mntpt[len] == '/') && + (CountSlashes(zf->mntpt) == l) && + Tcl_StringCaseMatch(zf->mntpt + len + 1, pattern, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, zf->mntpt, zf->mntptlen); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); + } + } + hPtr = Tcl_NextHashEntry(&search); + } + goto end; + } + if ((pattern == NULL) || (pattern[0] == '\0')) { + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr != NULL) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if ((dirOnly < 0) || + (!dirOnly && !z->isdir) || + (dirOnly && z->isdir)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } + goto end; + } + l = strlen(pattern); + pat = Tcl_Alloc(len + l + 2); + memcpy(pat, path, len); + while ((len > 1) && (pat[len - 1] == '/')) { + --len; + } + if ((len > 1) || (pat[0] != '/')) { + pat[len] = '/'; + ++len; + } + memcpy(pat + len, pattern, l + 1); + scnt = CountSlashes(pat); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + if ((dirOnly >= 0) && + ((dirOnly && !z->isdir) || (!dirOnly && z->isdir))) { + continue; + } + if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name + strip, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name + strip, -1)); + } + } + } + Tcl_Free(pat); +end: + Unlock(); + Tcl_DStringFree(&dsPref); + Tcl_DStringFree(&ds); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSNormalizePathProc -- + * + * Function to normalize given path object. + * + * Results: + * Length of final absolute path name. + * + * Side effects: + * Path object gets converted to an absolute path. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSNormalizePathProc(Tcl_Interp *interp, Tcl_Obj *pathPtr, + int nextCheckpoint) +{ + char *path; + Tcl_DString ds; + int len; + + path = Tcl_GetStringFromObj(pathPtr, &len); + Tcl_DStringInit(&ds); + path = CanonicalPath("",path, &ds, 0); + nextCheckpoint = Tcl_DStringLength(&ds); + Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + return nextCheckpoint; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSPathInFilesystemProc -- + * + * This function determines if the given path object is in the + * ZIP filesystem. + * + * Results: + * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + int ret = -1, len; + char *path; + Tcl_DString ds; + + path = Tcl_GetStringFromObj(pathPtr, &len); + if(strncmp(path,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)!=0) { + return -1; + } + + Tcl_DStringInit(&ds); + path = CanonicalPath("",path, &ds, 1); + len = Tcl_DStringLength(&ds); + ReadLock(); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr != NULL) { + ret = TCL_OK; + goto endloop; + } + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (zf->mntptlen == 0) { + ZipEntry *z = zf->topents; + while (z != NULL) { + int lenz = strlen(z->name); + + if ((len >= lenz) && + (strncmp(path, z->name, lenz) == 0)) { + ret = TCL_OK; + goto endloop; + } + z = z->tnext; + } + } else if ((len >= zf->mntptlen) && + (strncmp(path, zf->mntpt, zf->mntptlen) == 0)) { + ret = TCL_OK; + goto endloop; + } + hPtr = Tcl_NextHashEntry(&search); + } +endloop: + Unlock(); + Tcl_DStringFree(&ds); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSListVolumesProc -- + * + * Lists the currently mounted ZIP filesystem volumes. + * + * Results: + * The list of volumes. + * + * Side effects: + * None + * + *------------------------------------------------------------------------- + */ +static Tcl_Obj * +Zip_FSListVolumesProc(void) { + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable fileHash; + Tcl_Obj *pResult=Tcl_NewObj(); + // Tcl_ListObjAppendElement(NULL, pResult, Tcl_NewStringObj(ZIPFS_VOLUME, -1)); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); + Tcl_ListObjAppendElement(NULL, pResult, Tcl_NewStringObj(zf->mntpt, -1)); + } + return pResult; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSChdirProc -- + * + * If the path object refers to a directory within the ZIP + * filesystem the current directory is set to this directory. + * + * Results: + * TCL_OK on success, -1 on error with error number set. + * + * Side effects: + * The global cwdPathPtr may change value. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSChdirProc(Tcl_Obj *pathPtr) +{ + int len; + char *path; + Tcl_DString ds; + ZipEntry *z; + int ret = TCL_OK; + path = Tcl_GetStringFromObj(pathPtr, &len); + if(strncmp(path,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)!=0) { + return -1; + } + Tcl_DStringInit(&ds); + path = CanonicalPath("",path, &ds, 1); + ReadLock(); + z = ZipFSLookup(path); + if ((z == NULL) || !z->isdir) { + Tcl_SetErrno(ENOENT); + ret = -1; + } + Unlock(); + Tcl_DStringFree(&ds); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrStringsProc -- + * + * This function implements the ZIP filesystem dependent 'file attributes' + * subcommand, for listing the set of possible attribute strings. + * + * Results: + * An array of strings + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static const char *const * +Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef) +{ + static const char *const attrs[] = { + "-uncompsize", + "-compsize", + "-offset", + "-mount", + "-archive", + "-permissions", + NULL, + }; + + return attrs; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrsGetProc -- + * + * This function implements the ZIP filesystem specific + * 'file attributes' subcommand, for 'get' operations. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSFileAttrsGetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) +{ + int len, ret = TCL_OK; + char *path; + ZipEntry *z; + + path = Tcl_GetStringFromObj(pathPtr, &len); + ReadLock(); + z = ZipFSLookup(path); + if (z == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); + } + ret = TCL_ERROR; + goto done; + } + switch (index) { + case 0: + *objPtrRef = Tcl_NewIntObj(z->nbyte); + goto done; + case 1: + *objPtrRef= Tcl_NewIntObj(z->nbytecompr); + goto done; + case 2: + *objPtrRef= Tcl_NewLongObj(z->offset); + goto done; + case 3: + *objPtrRef= Tcl_NewStringObj(z->zipfile->mntpt, -1); + goto done; + case 4: + *objPtrRef= Tcl_NewStringObj(z->zipfile->name, -1); + goto done; + case 5: + *objPtrRef= Tcl_NewStringObj("0555", -1); + goto done; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown attribute", -1)); + } + ret = TCL_ERROR; +done: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrsSetProc -- + * + * This function implements the ZIP filesystem specific + * 'file attributes' subcommand, for 'set' operations. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, + Tcl_Obj *objPtr) +{ + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFilesystemPathTypeProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("zip", -1); +} + + +/* + *------------------------------------------------------------------------- + * + * Zip_FSLoadFile -- + * + * This functions deals with loading native object code. If + * the given path object refers to a file within the ZIP + * filesystem, an approriate error code is returned to delegate + * loading to the caller (by copying the file to temp store + * and loading from there). As fallback when the file refers + * to the ZIP file system but is not present, it is looked up + * relative to the executable and loaded from there when available. + * + * Results: + * TCL_OK on success, -1 otherwise with error number set. + * + * Side effects: + * Loads native code into the process address space. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, int flags) +{ + Tcl_FSLoadFileProc2 *loadFileProc; +#ifdef ANDROID + /* + * Force loadFileProc to native implementation since the + * package manger already extracted the shared libraries + * from the APK at install time. + */ + + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc != NULL) { + return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } + Tcl_SetErrno(ENOENT); + return -1; +#else + Tcl_Obj *altPath = NULL; + int ret = -1; + + if (Tcl_FSAccess(path, R_OK) == 0) { + /* + * EXDEV should trigger loading by copying to temp store. + */ + Tcl_SetErrno(EXDEV); + return ret; + } else { + Tcl_Obj *objs[2] = { NULL, NULL }; + + objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); + if ((objs[1] != NULL) && (Zip_FSAccessProc(objs[1], R_OK) == 0)) { + const char *execName = Tcl_GetNameOfExecutable(); + + /* + * Shared object is not in ZIP but its path prefix is, + * thus try to load from directory where the executable + * came from. + */ + TclDecrRefCount(objs[1]); + objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); + /* + * Get directory name of executable manually to deal + * with cases where [file dirname [info nameofexecutable]] + * is equal to [info nameofexecutable] due to VFS effects. + */ + if (execName != NULL) { + const char *p = strrchr(execName, '/'); + + if (p > execName + 1) { + --p; + objs[0] = Tcl_NewStringObj(execName, p - execName); + } + } + if (objs[0] == NULL) { + objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), + TCL_PATH_DIRNAME); + } + if (objs[0] != NULL) { + altPath = TclJoinPath(2, objs); + if (altPath != NULL) { + Tcl_IncrRefCount(altPath); + if (Tcl_FSAccess(altPath, R_OK) == 0) { + path = altPath; + } + } + } + } + if (objs[0] != NULL) { + Tcl_DecrRefCount(objs[0]); + } + if (objs[1] != NULL) { + Tcl_DecrRefCount(objs[1]); + } + } + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc != NULL) { + ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } else { + Tcl_SetErrno(ENOENT); + } + if (altPath != NULL) { + Tcl_DecrRefCount(altPath); + } + return ret; +#endif +} + + +/* + * Define the ZIP filesystem dispatch table. + */ + +MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem; + +const Tcl_Filesystem zipfsFilesystem = { + "zipfs", + sizeof (Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_2, + Zip_FSPathInFilesystemProc, + NULL, /* dupInternalRepProc */ + NULL, /* freeInternalRepProc */ + NULL, /* internalToNormalizedProc */ + NULL, /* createInternalRepProc */ + NULL, /* Zip_FSNormalizePathProc - don't need ZIP files have one and only one name */ + Zip_FSFilesystemPathTypeProc, + Zip_FSFilesystemSeparatorProc, + Zip_FSStatProc, + Zip_FSAccessProc, + Zip_FSOpenFileChannelProc, + Zip_FSMatchInDirectoryProc, + NULL, /* utimeProc */ + NULL, /* linkProc */ + Zip_FSListVolumesProc, + Zip_FSFileAttrStringsProc, + Zip_FSFileAttrsGetProc, + Zip_FSFileAttrsSetProc, + NULL, /* createDirectoryProc */ + NULL, /* removeDirectoryProc */ + NULL, /* deleteFileProc */ + NULL, /* copyFileProc */ + NULL, /* renameFileProc */ + NULL, /* copyDirectoryProc */ + NULL, /* lstatProc */ + (Tcl_FSLoadFileProc *) Zip_FSLoadFile, + NULL, /* getCwdProc */ + NULL, /* Zip_FSChdirProc*/ +}; + +#endif /* HAVE_ZLIB */ + + +/* + *------------------------------------------------------------------------- + * + * Zipfs_doInit -- + * + * Perform per interpreter initialization of this module. + * + * Results: + * The return value is a standard Tcl result. + * + * Side effects: + * Initializes this module if not already initialized, and adds + * module related commands to the given interpreter. + * + *------------------------------------------------------------------------- + */ + +static int +Zipfs_doInit(Tcl_Interp *interp, int safe) +{ +#ifdef HAVE_ZLIB + static const EnsembleImplMap initMap[] = { + {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 0}, + {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 0}, + {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 0}, + {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 0}, + {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 0}, + {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 0}, + {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 0}, + {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, + {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, + {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, + {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + + static const EnsembleImplMap initSafeMap[] = { + {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, + {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, + {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, + {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + + static const char findproc[] = + "namespace eval zipfs {}\n" + "proc ::zipfs::find dir {\n" + " set result {}\n" + " if {[catch {glob -directory $dir -tails -nocomplain * .*} list]} {\n" + " return $result\n" + " }\n" + " foreach file $list {\n" + " if {$file eq \".\" || $file eq \"..\"} {\n" + " continue\n" + " }\n" + " set file [file join $dir $file]\n" + " lappend result $file\n" + " foreach file [::zipfs::find $file] {\n" + " lappend result $file\n" + " }\n" + " }\n" + " return [lsort $result]\n" + "}\n"; + + /* one-time initialization */ + WriteLock(); + if (!ZipFS.initialized) { +#ifdef TCL_THREADS + static const Tcl_Time t = { 0, 0 }; + + /* + * Inflate condition variable. + */ + Tcl_MutexLock(&ZipFSMutex); + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); + Tcl_MutexUnlock(&ZipFSMutex); +#endif + Tcl_FSRegister(NULL, &zipfsFilesystem); + Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); + Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); + ZIPFS_VOLUME_LEN=strlen(ZIPFS_VOLUME); + ZipFS.initialized = ZipFS.idCount = 1; + if (interp != NULL) { + Tcl_StaticPackage(interp, "zipfs", Tclzipfs_Init, Tclzipfs_SafeInit); + } + } + Unlock(); + if(interp != NULL) { + if (!safe) { + Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); + Tcl_LinkVar(interp, "::zipfs::wrmax", (char *) &ZipFS.wrmax, + TCL_LINK_INT); + } + TclMakeEnsemble(interp, "zipfs", safe ? initSafeMap : initMap); + + Tcl_PkgProvide(interp, "zipfs", "1.1"); + } + return TCL_OK; +#else + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("no zlib available", -1)); + } + return TCL_ERROR; +#endif +} + +/* + *------------------------------------------------------------------------- + * + * Tclzipfs_Init, Tclzipfs_SafeInit -- + * + * These functions are invoked to perform per interpreter initialization + * of this module. + * + * Results: + * The return value is a standard Tcl result. + * + * Side effects: + * Initializes this module if not already initialized, and adds + * module related commands to the given interpreter. + * + *------------------------------------------------------------------------- + */ + +int +Tclzipfs_Init(Tcl_Interp *interp) +{ + return Zipfs_doInit(interp, 0); +} + +int +Tclzipfs_SafeInit(Tcl_Interp *interp) +{ + return Zipfs_doInit(interp, 1); +} + +#ifndef HAVE_ZLIB + +/* + *------------------------------------------------------------------------- + * + * Tclzipfs_Mount, Tclzipfs_Unmount -- + * + * Dummy version when no ZLIB support available. + * + *------------------------------------------------------------------------- + */ + +int +Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, + const char *passwd) +{ + return Zipfs_doInit(interp, 1); +} + +int +Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname) +{ + return Zipfs_doInit(interp, 1); +} + +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: compat/zipfs/tclZipfs.h ================================================================== --- compat/zipfs/tclZipfs.h +++ compat/zipfs/tclZipfs.h @@ -1,48 +1,49 @@ -/* - * tclZipfs.h -- - * - * This header file describes the interface of the ZIPFS filesystem - * - * Copyright (c) 2013-2015 Christian Werner - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef _ZIPFS_H -#define _ZIPFS_H - -#include "tcl.h" - -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef ZIPFSAPI -# define ZIPFSAPI extern -#endif - -#ifdef BUILD_tcl -# undef ZIPFSAPI -# define ZIPFSAPI DLLEXPORT -#endif - -ZIPFSAPI int Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, - const char *mntpt, const char *passwd); -ZIPFSAPI int Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname); -ZIPFSAPI int Tclzipfs_Init(Tcl_Interp *interp); -ZIPFSAPI int Tclzipfs_SafeInit(Tcl_Interp *interp); - -#ifdef __cplusplus -} -#endif - -#endif /* _ZIPFS_H */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ +/* + * tclZipfs.h -- + * + * This header file describes the interface of the ZIPFS filesystem + * + * Copyright (c) 2013-2015 Christian Werner + * Copyright (c) 2016 Sean Woods + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef _ZIPFS_H +#define _ZIPFS_H + +#include "tcl.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef ZIPFSAPI +# define ZIPFSAPI extern +#endif + +#ifdef BUILD_tcl +# undef ZIPFSAPI +# define ZIPFSAPI DLLEXPORT +#endif + +ZIPFSAPI int Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, + const char *mntpt, const char *passwd); +ZIPFSAPI int Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname); +ZIPFSAPI int Tclzipfs_Init(Tcl_Interp *interp); +ZIPFSAPI int Tclzipfs_SafeInit(Tcl_Interp *interp); + +#ifdef __cplusplus +} +#endif + +#endif /* _ZIPFS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED compat/zipfs/zcrypt.h Index: compat/zipfs/zcrypt.h ================================================================== --- /dev/null +++ compat/zipfs/zcrypt.h @@ -0,0 +1,131 @@ +/* crypt.h -- base code for crypt/uncrypt ZIPfile + + + Version 1.01e, February 12th, 2005 + + Copyright (C) 1998-2005 Gilles Vollant + + This code is a modified version of crypting code in Infozip distribution + + The encryption/decryption parts of this source code (as opposed to the + non-echoing password parts) were originally written in Europe. The + whole source package can be freely distributed, including from the USA. + (Prior to January 2000, re-export from the US was a violation of US law.) + + This encryption code is a direct transcription of the algorithm from + Roger Schlafly, described by Phil Katz in the file appnote.txt. This + file (appnote.txt) is distributed with the PKZIP program (even in the + version without encryption capabilities). + + If you don't need crypting in your application, just define symbols + NOCRYPT and NOUNCRYPT. + + This code support the "Traditional PKWARE Encryption". + + The new AES encryption added on Zip format by Winzip (see the page + http://www.winzip.com/aes_info.htm ) and PKWare PKZip 5.x Strong + Encryption is not supported. +*/ + +#define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8)) + +/*********************************************************************** + * Return the next byte in the pseudo-random sequence + */ +static int decrypt_byte(unsigned long* pkeys, const unsigned int* pcrc_32_tab) +{ + unsigned temp; /* POTENTIAL BUG: temp*(temp^1) may overflow in an + * unpredictable manner on 16-bit systems; not a problem + * with any known compiler so far, though */ + + temp = ((unsigned)(*(pkeys+2)) & 0xffff) | 2; + return (int)(((temp * (temp ^ 1)) >> 8) & 0xff); +} + +/*********************************************************************** + * Update the encryption keys with the next byte of plain text + */ +static int update_keys(unsigned long* pkeys,const unsigned int* pcrc_32_tab,int c) +{ + (*(pkeys+0)) = CRC32((*(pkeys+0)), c); + (*(pkeys+1)) += (*(pkeys+0)) & 0xff; + (*(pkeys+1)) = (*(pkeys+1)) * 134775813L + 1; + { + register int keyshift = (int)((*(pkeys+1)) >> 24); + (*(pkeys+2)) = CRC32((*(pkeys+2)), keyshift); + } + return c; +} + + +/*********************************************************************** + * Initialize the encryption keys and the random header according to + * the given password. + */ +static void init_keys(const char* passwd,unsigned long* pkeys,const unsigned int* pcrc_32_tab) +{ + *(pkeys+0) = 305419896L; + *(pkeys+1) = 591751049L; + *(pkeys+2) = 878082192L; + while (*passwd != '\0') { + update_keys(pkeys,pcrc_32_tab,(int)*passwd); + passwd++; + } +} + +#define zdecode(pkeys,pcrc_32_tab,c) \ + (update_keys(pkeys,pcrc_32_tab,c ^= decrypt_byte(pkeys,pcrc_32_tab))) + +#define zencode(pkeys,pcrc_32_tab,c,t) \ + (t=decrypt_byte(pkeys,pcrc_32_tab), update_keys(pkeys,pcrc_32_tab,c), t^(c)) + +#ifdef INCLUDECRYPTINGCODE_IFCRYPTALLOWED + +#define RAND_HEAD_LEN 12 + /* "last resort" source for second part of crypt seed pattern */ +# ifndef ZCR_SEED2 +# define ZCR_SEED2 3141592654UL /* use PI as default pattern */ +# endif + +static int crypthead(const char* passwd, /* password string */ + unsigned char* buf, /* where to write header */ + int bufSize, + unsigned long* pkeys, + const unsigned int* pcrc_32_tab, + unsigned long crcForCrypting) +{ + int n; /* index in random header */ + int t; /* temporary */ + int c; /* random byte */ + unsigned char header[RAND_HEAD_LEN-2]; /* random header */ + static unsigned calls = 0; /* ensure different random header each time */ + + if (bufSize> 7) & 0xff; + header[n] = (unsigned char)zencode(pkeys, pcrc_32_tab, c, t); + } + /* Encrypt random header (last two bytes is high word of crc) */ + init_keys(passwd, pkeys, pcrc_32_tab); + for (n = 0; n < RAND_HEAD_LEN-2; n++) + { + buf[n] = (unsigned char)zencode(pkeys, pcrc_32_tab, header[n], t); + } + buf[n++] = (unsigned char)zencode(pkeys, pcrc_32_tab, (int)(crcForCrypting >> 16) & 0xff, t); + buf[n++] = (unsigned char)zencode(pkeys, pcrc_32_tab, (int)(crcForCrypting >> 24) & 0xff, t); + return n; +} + +#endif DELETED compat/zipfs/zvfs.c Index: compat/zipfs/zvfs.c ================================================================== --- compat/zipfs/zvfs.c +++ /dev/null @@ -1,3988 +0,0 @@ -/* - * zipfs.c -- - * - * Implementation of the ZIP filesystem used in AndroWish. - * - * Copyright (c) 2013-2015 Christian Werner - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#include "tclFileSystem.h" -#include "tclZipfs.h" - -#if !defined(_WIN32) && !defined(_WIN64) -#include -#endif -#include -#include -#include -#include -#include -#include - -#ifdef HAVE_ZLIB -#include "zlib.h" -#include "zcrypt.h" - -#define ZIPFS_VOLUME "zipfs://" -#define ZIPFS_VOLUME_LEN 8 -/* - * Various constants and offsets found in ZIP archive files - */ - -#define ZIP_SIG_LEN 4 - -/* Local header of ZIP archive member (at very beginning of each member). */ -#define ZIP_LOCAL_HEADER_SIG 0x04034b50 -#define ZIP_LOCAL_HEADER_LEN 30 -#define ZIP_LOCAL_SIG_OFFS 0 -#define ZIP_LOCAL_VERSION_OFFS 4 -#define ZIP_LOCAL_FLAGS_OFFS 6 -#define ZIP_LOCAL_COMPMETH_OFFS 8 -#define ZIP_LOCAL_MTIME_OFFS 10 -#define ZIP_LOCAL_MDATE_OFFS 12 -#define ZIP_LOCAL_CRC32_OFFS 14 -#define ZIP_LOCAL_COMPLEN_OFFS 18 -#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 -#define ZIP_LOCAL_PATHLEN_OFFS 26 -#define ZIP_LOCAL_EXTRALEN_OFFS 28 - -/* Central header of ZIP archive member at end of ZIP file. */ -#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 -#define ZIP_CENTRAL_HEADER_LEN 46 -#define ZIP_CENTRAL_SIG_OFFS 0 -#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 -#define ZIP_CENTRAL_VERSION_OFFS 6 -#define ZIP_CENTRAL_FLAGS_OFFS 8 -#define ZIP_CENTRAL_COMPMETH_OFFS 10 -#define ZIP_CENTRAL_MTIME_OFFS 12 -#define ZIP_CENTRAL_MDATE_OFFS 14 -#define ZIP_CENTRAL_CRC32_OFFS 16 -#define ZIP_CENTRAL_COMPLEN_OFFS 20 -#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 -#define ZIP_CENTRAL_PATHLEN_OFFS 28 -#define ZIP_CENTRAL_EXTRALEN_OFFS 30 -#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 -#define ZIP_CENTRAL_DISKFILE_OFFS 34 -#define ZIP_CENTRAL_IATTR_OFFS 36 -#define ZIP_CENTRAL_EATTR_OFFS 38 -#define ZIP_CENTRAL_LOCALHDR_OFFS 42 - -/* Central end signature at very end of ZIP file. */ -#define ZIP_CENTRAL_END_SIG 0x06054b50 -#define ZIP_CENTRAL_END_LEN 22 -#define ZIP_CENTRAL_END_SIG_OFFS 0 -#define ZIP_CENTRAL_DISKNO_OFFS 4 -#define ZIP_CENTRAL_DISKDIR_OFFS 6 -#define ZIP_CENTRAL_ENTS_OFFS 8 -#define ZIP_CENTRAL_TOTALENTS_OFFS 10 -#define ZIP_CENTRAL_DIRSIZE_OFFS 12 -#define ZIP_CENTRAL_DIRSTART_OFFS 16 -#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 - -#define ZIP_MIN_VERSION 20 -#define ZIP_COMPMETH_STORED 0 -#define ZIP_COMPMETH_DEFLATED 8 - -#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 - -/* - * Macros to read and write 16 and 32 bit integers from/to ZIP archives. - */ - -#define zip_read_int(p) \ - ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) -#define zip_read_short(p) \ - ((p)[0] | ((p)[1] << 8)) - -#define zip_write_int(p, v) \ - (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; \ - (p)[2] = ((v) >> 16) & 0xff; (p)[3] = ((v) >> 24) & 0xff; -#define zip_write_short(p, v) \ - (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; - -/* - * Windows drive letters. - */ - -#if defined(_WIN32) || defined(_WIN64) -#define HAS_DRIVES 1 -static const char drvletters[] = - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; -#else -#define HAS_DRIVES 0 -#endif - -/* - * Mutex to protect localtime(3) when no reentrant version available. - */ - -#if !defined(_WIN32) && !defined(_WIN64) -#ifndef HAVE_LOCALTIME_R -#ifdef TCL_THREADS -TCL_DECLARE_MUTEX(localtimeMutex) -#endif -#endif -#endif - -/* - * In-core description of mounted ZIP archive file. - */ - -typedef struct ZipFile { - char *name; /* Archive name */ - Tcl_Channel chan; /* Channel handle or NULL */ - unsigned char *data; /* Memory mapped or malloc'ed file */ - long length; /* Length of memory mapped file */ - unsigned char *tofree; /* Non-NULL if malloc'ed file */ - int nfiles; /* Number of files in archive */ - int baseoffs; /* Archive start */ - int baseoffsp; /* Password start */ - int centoffs; /* Archive directory start */ - char pwbuf[264]; /* Password buffer */ -#if defined(_WIN32) || defined(_WIN64) - HANDLE mh; -#endif - int nopen; /* Number of open files on archive */ - struct ZipEntry *entries; /* List of files in archive */ - struct ZipEntry *topents; /* List of top-level dirs in archive */ -#if HAS_DRIVES - int mntdrv; /* Drive letter of mount point */ -#endif - int mntptlen; /* Length of mount point */ - char mntpt[1]; /* Mount point */ -} ZipFile; - -/* - * In-core description of file contained in mounted ZIP archive. - */ - -typedef struct ZipEntry { - char *name; /* The full pathname of the virtual file */ - ZipFile *zipfile; /* The ZIP file holding this virtual file */ - long offset; /* Data offset into memory mapped ZIP file */ - int nbyte; /* Uncompressed size of the virtual file */ - int nbytecompr; /* Compressed size of the virtual file */ - int cmeth; /* Compress method */ - int isdir; /* Set to 1 if directory */ - int depth; /* Number of slashes in path. */ - int crc32; /* CRC-32 */ - int timestamp; /* Modification time */ - int isenc; /* True if data is encrypted */ - unsigned char *data; /* File data if written */ - struct ZipEntry *next; /* Next file in the same archive */ - struct ZipEntry *tnext; /* Next top-level dir in archive */ -} ZipEntry; - -/* - * File channel for file contained in mounted ZIP archive. - */ - -typedef struct ZipChannel { - ZipFile *zipfile; /* The ZIP file holding this channel */ - ZipEntry *zipentry; /* Pointer back to virtual file */ - unsigned long nmax; /* Max. size for write */ - unsigned long nbyte; /* Number of bytes of uncompressed data */ - unsigned long nread; /* Pos of next byte to be read from the channel */ - unsigned char *ubuf; /* Pointer to the uncompressed data */ - int iscompr; /* True if data is compressed */ - int isdir; /* Set to 1 if directory */ - int isenc; /* True if data is encrypted */ - int iswr; /* True if open for writing */ - unsigned long keys[3]; /* Key for decryption */ -} ZipChannel; - -/* - * Global variables. - * - * Most are kept in single ZipFS struct. When build with threading - * support this struct is protected by the ZipFSMutex (see below). - * - * The "fileHash" component is the process wide global table of all known - * ZIP archive members in all mounted ZIP archives. - * - * The "zipHash" components is the process wide global table of all mounted - * ZIP archive files. - */ - -static struct { - int initialized; /* True when initialized */ - int lock; /* RW lock, see below */ - int waiters; /* RW lock, see below */ - int wrmax; /* Maximum write size of a file */ - int idCount; /* Counter for channel names */ - Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ - Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ -} ZipFS = { - 0, 0, 0, 0, 0, -}; - -/* - * For password rotation. - */ - -static const char pwrot[16] = { - 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0, - 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0 -}; - -/* - * Table to compute CRC32. - */ - -static const unsigned int crc32tab[256] = { - 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, - 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, - 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, - 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, - 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, - 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, - 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, - 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, - 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, - 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, - 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, - 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, - 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, - 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, - 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, - 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, - 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, - 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, - 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, - 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, - 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, - 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, - 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, - 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, - 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, - 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, - 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, - 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, - 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, - 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, - 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, - 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, - 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, - 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, - 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, - 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, - 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, - 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, - 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, - 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, - 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, - 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, - 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, - 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, - 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, - 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, - 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, - 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, - 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, - 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, - 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, - 0x2d02ef8d, -}; - -/* - *------------------------------------------------------------------------- - * - * ReadLock, WriteLock, Unlock -- - * - * POSIX like rwlock functions to support multiple readers - * and single writer on internal structs. - * - * Limitations: - * - a read lock cannot be promoted to a write lock - * - a write lock may not be nested - * - *------------------------------------------------------------------------- - */ - -TCL_DECLARE_MUTEX(ZipFSMutex) - -#ifdef TCL_THREADS - -static Tcl_Condition ZipFSCond; - -static void -ReadLock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - while (ZipFS.lock < 0) { - ZipFS.waiters++; - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); - ZipFS.waiters--; - } - ZipFS.lock++; - Tcl_MutexUnlock(&ZipFSMutex); -} - -static void -WriteLock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - while (ZipFS.lock != 0) { - ZipFS.waiters++; - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); - ZipFS.waiters--; - } - ZipFS.lock = -1; - Tcl_MutexUnlock(&ZipFSMutex); -} - -static void -Unlock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - if (ZipFS.lock > 0) { - --ZipFS.lock; - } else if (ZipFS.lock < 0) { - ZipFS.lock = 0; - } - if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { - Tcl_ConditionNotify(&ZipFSCond); - } - Tcl_MutexUnlock(&ZipFSMutex); -} - -#else - -#define ReadLock() do {} while (0) -#define WriteLock() do {} while (0) -#define Unlock() do {} while (0) - -#endif - -/* - *------------------------------------------------------------------------- - * - * DosTimeDate, ToDosTime, ToDosDate -- - * - * Functions to perform conversions between DOS time stamps - * and POSIX time_t. - * - *------------------------------------------------------------------------- - */ - -static time_t -DosTimeDate(int dosDate, int dosTime) -{ - struct tm tm; - time_t ret; - - memset(&tm, 0, sizeof (tm)); - tm.tm_year = (((dosDate & 0xfe00) >> 9) + 80); - tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1; - tm.tm_mday = dosDate & 0x1f; - tm.tm_hour = (dosTime & 0xf800) >> 11; - tm.tm_min = (dosTime & 0x7e) >> 5; - tm.tm_sec = (dosTime & 0x1f) << 1; - ret = mktime(&tm); - if (ret == (time_t) -1) { - /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ - ret = (time_t) 315532800; - } - return ret; -} - -static int -ToDosTime(time_t when) -{ - struct tm *tmp, tm; - -#ifdef TCL_THREADS -#if defined(_WIN32) || defined(_WIN64) - /* Win32 uses thread local storage */ - tmp = localtime(&when); - tm = *tmp; -#else -#ifdef HAVE_LOCALTIME_R - tmp = &tm; - localtime_r(&when, tmp); -#else - Tcl_MutexLock(&localtimeMutex); - tmp = localtime(&when); - tm = *tmp; - Tcl_MutexUnlock(&localtimeMutex); -#endif -#endif -#else - tmp = localtime(&when); - tm = *tmp; -#endif - return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); -} - -static int -ToDosDate(time_t when) -{ - struct tm *tmp, tm; - -#ifdef TCL_THREADS -#if defined(_WIN32) || defined(_WIN64) - /* Win32 uses thread local storage */ - tmp = localtime(&when); - tm = *tmp; -#else -#ifdef HAVE_LOCALTIME_R - tmp = &tm; - localtime_r(&when, tmp); -#else - Tcl_MutexLock(&localtimeMutex); - tmp = localtime(&when); - tm = *tmp; - Tcl_MutexUnlock(&localtimeMutex); -#endif -#endif -#else - tmp = localtime(&when); - tm = *tmp; -#endif - return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; -} - -/* - *------------------------------------------------------------------------- - * - * CountSlashes -- - * - * This function counts the number of slashes in a pathname string. - * - * Results: - * Number of slashes found in string. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -CountSlashes(const char *string) -{ - int count = 0; - const char *p = string; - - while (*p != '\0') { - if (*p == '/') { - count++; - } - p++; - } - return count; -} - -/* - *------------------------------------------------------------------------- - * - * CanonicalPath -- - * - * This function computes the canonical path from a directory - * and file name components into the specified Tcl_DString. - * - * Results: - * Returns the pointer to the canonical path contained in the - * specified Tcl_DString. - * - * Side effects: - * Modifies the specified Tcl_DString. - * - *------------------------------------------------------------------------- - */ - -static char * -CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr,int ZIPFSPATH) -{ - char *path; - char *result; - int zipfspath=1; - int i, j, c, isunc = 0, isvfs=0, n=0; -#if HAS_DRIVES - if ((tail[0] != '\0') && (strchr(drvletters, tail[0]) != NULL) && - (tail[1] == ':')) { - tail += 2; - zipfspath=0; - } - /* UNC style path */ - if (tail[0] == '\\') { - root = ""; - ++tail; - zipfspath=0; - } - if (tail[0] == '\\') { - root = "/"; - ++tail; - zipfspath=0; - } - if(zipfspath) { -#endif - /* UNC style path */ - if(root && strncmp(root,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)==0) { - isvfs=1; - } else if (tail && strncmp(tail,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN) == 0) { - isvfs=2; - } - if(isvfs!=1) { - if ((root[0] == '/') && (root[1] == '/')) { - isunc = 1; - } - } -#if HAS_DRIVES - } -#endif - if(isvfs!=2) { - if (tail[0] == '/') { - if(isvfs!=1) { - root = ""; - } - ++tail; - isunc = 0; - } - if (tail[0] == '/') { - if(isvfs!=1) { - root = "/"; - } - ++tail; - isunc = 1; - } - } - i = strlen(root); - j = strlen(tail); - if(isvfs==1) { - if(i>ZIPFS_VOLUME_LEN) { - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); - } else { - Tcl_DStringSetLength(dsPtr, i + j); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - memcpy(path + i, tail, j); - } - } else if(isvfs==2) { - Tcl_DStringSetLength(dsPtr, j); - path = Tcl_DStringValue(dsPtr); - memcpy(path, tail, j); - } else { - if (ZIPFSPATH) { - Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN); - path = Tcl_DStringValue(dsPtr); - memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); - memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j); - } else { - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); - } - } -#if HAS_DRIVES - for (i = 0; path[i] != '\0'; i++) { - if (path[i] == '\\') { - path[i] = '/'; - } - } -#endif - if(ZIPFSPATH) { - n=ZIPFS_VOLUME_LEN; - } else { - n=0; - } - for (i = j = n; (c = path[i]) != '\0'; i++) { - if (c == '/') { - int c2 = path[i + 1]; - if (c2 == '/') { - continue; - } - if (c2 == '.') { - int c3 = path[i + 2]; - if ((c3 == '/') || (c3 == '\0')) { - i++; - continue; - } - if ((c3 == '.') && - ((path[i + 3] == '/') || (path [i + 3] == '\0'))) { - i += 2; - while ((j > 0) && (path[j - 1] != '/')) { - j--; - } - if (j > isunc) { - --j; - while ((j > 1 + isunc) && (path[j - 2] == '/')) { - j--; - } - } - continue; - } - } - } - path[j++] = c; - } - if (j == 0) { - path[j++] = '/'; - } - path[j] = 0; - Tcl_DStringSetLength(dsPtr, j); - result=Tcl_DStringValue(dsPtr); - return result; -} - - - -/* - *------------------------------------------------------------------------- - * - * AbsolutePath -- - * - * This function computes the absolute path from a given - * (relative) path name into the specified Tcl_DString. - * - * Results: - * Returns the pointer to the absolute path contained in the - * specified Tcl_DString. - * - * Side effects: - * Modifies the specified Tcl_DString. - * - *------------------------------------------------------------------------- - */ - -static char * -AbsolutePath(const char *path, - Tcl_DString *dsPtr, - int ZIPFSPATH) -{ - char *result; - if (*path == '~') { - Tcl_DStringAppend(dsPtr, path, -1); - return Tcl_DStringValue(dsPtr); - } - if (*path != '/') { - Tcl_DString pwd; - - /* relative path */ - Tcl_DStringInit(&pwd); - Tcl_GetCwd(NULL, &pwd); - result = Tcl_DStringValue(&pwd); - result = CanonicalPath(result, path, dsPtr,ZIPFSPATH); - Tcl_DStringFree(&pwd); - } else { - /* absolute path */ - result = CanonicalPath("", path, dsPtr,ZIPFSPATH); - } - return result; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSLookup -- - * - * This function returns the ZIP entry struct corresponding to - * the ZIP archive member of the given file name. - * - * Results: - * Returns the pointer to ZIP entry struct or NULL if the - * the given file name could not be found in the global list - * of ZIP archive members. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static ZipEntry * -ZipFSLookup(char *filename) -{ - char *realname; - - Tcl_HashEntry *hPtr; - ZipEntry *z; - Tcl_DString ds; - Tcl_DStringInit(&ds); - realname = AbsolutePath(filename, &ds, 1); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, realname); - z = hPtr ? (ZipEntry *) Tcl_GetHashValue(hPtr) : NULL; - Tcl_DStringFree(&ds); - return z; -} - -#ifdef NEVER_USED - -/* - *------------------------------------------------------------------------- - * - * ZipFSLookupMount -- - * - * This function returns an indication if the given file name - * corresponds to a mounted ZIP archive file. - * - * Results: - * Returns true, if the given file name is a mounted ZIP archive file. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSLookupMount(char *filename) -{ - char *realname; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - ZipFile *zf; - Tcl_DString ds; - int match = 0; - Tcl_DStringInit(&ds); - realname = AbsolutePath(filename, &ds, 1); - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { - if (strcmp(zf->mntpt, realname) == 0) { - match = 1; - break; - } - } - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_DStringFree(&ds); - return match; -} -#endif - -/* - *------------------------------------------------------------------------- - * - * ZipFSCloseArchive -- - * - * This function closes a mounted ZIP archive file. - * - * Results: - * None. - * - * Side effects: - * A memory mapped ZIP archive is unmapped, allocated memory is - * released. - * - *------------------------------------------------------------------------- - */ - -static void -ZipFSCloseArchive(Tcl_Interp *interp, ZipFile *zf) -{ -#if defined(_WIN32) || defined(_WIN64) - if ((zf->data != NULL) && (zf->tofree == NULL)) { - UnmapViewOfFile(zf->data); - zf->data = NULL; - } - if (zf->mh != INVALID_HANDLE_VALUE) { - CloseHandle(zf->mh); - } -#else - if ((zf->data != MAP_FAILED) && (zf->tofree == NULL)) { - munmap(zf->data, zf->length); - zf->data = MAP_FAILED; - } -#endif - if (zf->tofree != NULL) { - Tcl_Free((char *) zf->tofree); - zf->tofree = NULL; - } - Tcl_Close(interp, zf->chan); - zf->chan = NULL; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSOpenArchive -- - * - * This function opens a ZIP archive file for reading. An attempt - * is made to memory map that file. Otherwise it is read into - * an allocated memory buffer. The ZIP archive header is verified - * and must be valid for the function to succeed. When "needZip" - * is zero an embedded ZIP archive in an executable file is accepted. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with an error message - * placed into the given "interp" if it is not NULL. - * - * Side effects: - * ZIP archive is memory mapped or read into allocated memory, - * the given ZipFile struct is filled with information about - * the ZIP archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, - ZipFile *zf) -{ - int i; - ClientData handle; - unsigned char *p, *q; - -#if defined(_WIN32) || defined(_WIN64) - zf->data = NULL; - zf->mh = INVALID_HANDLE_VALUE; -#else - zf->data = MAP_FAILED; -#endif - zf->length = 0; - zf->nfiles = 0; - zf->baseoffs = zf->baseoffsp = 0; - zf->tofree = NULL; - zf->pwbuf[0] = 0; - zf->chan = Tcl_OpenFileChannel(interp, zipname, "r", 0); - if (zf->chan == NULL) { - return TCL_ERROR; - } - if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { - if (Tcl_SetChannelOption(interp, zf->chan, "-translation", "binary") - != TCL_OK) { - goto error; - } - if (Tcl_SetChannelOption(interp, zf->chan, "-encoding", "binary") - != TCL_OK) { - goto error; - } - zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); - if ((zf->length <= 0) || (zf->length > 64 * 1024 * 1024)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal file size", -1)); - } - goto error; - } - Tcl_Seek(zf->chan, 0, SEEK_SET); - zf->tofree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length); - if (zf->tofree == NULL) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); - if (i != zf->length) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file read error", -1)); - } - goto error; - } - Tcl_Close(interp, zf->chan); - zf->chan = NULL; - } else { -#if defined(_WIN32) || defined(_WIN64) - zf->length = GetFileSize((HANDLE) handle, 0); - if ((zf->length == INVALID_FILE_SIZE) || - (zf->length < ZIP_CENTRAL_END_LEN)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid file size", -1)); - } - goto error; - } - zf->mh = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, 0, - zf->length, 0); - if (zf->mh == INVALID_HANDLE_VALUE) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file mapping failed", -1)); - } - goto error; - } - zf->data = MapViewOfFile(zf->mh, FILE_MAP_READ, 0, 0, zf->length); - if (zf->data == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file mapping failed", -1)); - } - goto error; - } -#else - zf->length = lseek((int) (long) handle, 0, SEEK_END); - if ((zf->length == -1) || (zf->length < ZIP_CENTRAL_END_LEN)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid file size", -1)); - } - goto error; - } - lseek((int) (long) handle, 0, SEEK_SET); - zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, - MAP_FILE | MAP_PRIVATE, - (int) (long) handle, 0); - if (zf->data == MAP_FAILED) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file mapping failed", -1)); - } - goto error; - } -#endif - } - p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; - while (p >= zf->data) { - if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { - if (zip_read_int(p) == ZIP_CENTRAL_END_SIG) { - break; - } - p -= ZIP_SIG_LEN; - } else { - --p; - } - } - if (p < zf->data) { - if (!needZip) { - zf->baseoffs = zf->baseoffsp = zf->length; - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong end signature", -1)); - } - goto error; - } - zf->nfiles = zip_read_short(p + ZIP_CENTRAL_ENTS_OFFS); - if (zf->nfiles == 0) { - if (!needZip) { - zf->baseoffs = zf->baseoffsp = zf->length; - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("empty archive", -1)); - } - goto error; - } - q = zf->data + zip_read_int(p + ZIP_CENTRAL_DIRSTART_OFFS); - p -= zip_read_int(p + ZIP_CENTRAL_DIRSIZE_OFFS); - if ((p < zf->data) || (p > (zf->data + zf->length)) || - (q < zf->data) || (q > (zf->data + zf->length))) { - if (!needZip) { - zf->baseoffs = zf->baseoffsp = zf->length; - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("archive directory not found", -1)); - } - goto error; - } - zf->baseoffs = zf->baseoffsp = p - q; - zf->centoffs = p - zf->data; - q = p; - for (i = 0; i < zf->nfiles; i++) { - int pathlen, comlen, extra; - - if ((q + ZIP_CENTRAL_HEADER_LEN) > (zf->data + zf->length)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong header length", -1)); - } - goto error; - } - if (zip_read_int(q) != ZIP_CENTRAL_HEADER_SIG) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong header signature", -1)); - } - goto error; - } - pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; - } - q = zf->data + zf->baseoffs; - if ((zf->baseoffs >= 6) && - (zip_read_int(q - 4) == ZIP_PASSWORD_END_SIG)) { - i = q[-5]; - if (q - 5 - i > zf->data) { - zf->pwbuf[0] = i; - memcpy(zf->pwbuf + 1, q - 5 - i, i); - zf->baseoffsp -= i ? (5 + i) : 0; - } - } - return TCL_OK; - -error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * Tclzipfs_Mount -- - * - * This procedure is invoked to mount a given ZIP archive file on - * a given mountpoint with optional ZIP password. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is read, analyzed and mounted, resources are - * allocated. - * - *------------------------------------------------------------------------- - */ - -int -Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, - const char *passwd) -{ - char *realname, *p; - int i, pwlen, isNew; - ZipFile *zf, zf0; - ZipEntry *z; - Tcl_HashEntry *hPtr; - Tcl_DString ds, dsm, fpBuf; - unsigned char *q; - - ReadLock(); - if (!ZipFS.initialized) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("not initialized", -1)); - } - Unlock(); - return TCL_ERROR; - } - if (zipname == NULL) { - Tcl_HashSearch search; - int ret = TCL_OK; - - i = 0; - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { - if (interp != NULL) { - Tcl_AppendElement(interp, zf->mntpt); - Tcl_AppendElement(interp, zf->name); - } - ++i; - } - hPtr = Tcl_NextHashEntry(&search); - } - if (interp == NULL) { - ret = (i > 0) ? TCL_OK : TCL_BREAK; - } - Unlock(); - return ret; - } - if (mntpt == NULL) { - if (interp == NULL) { - Unlock(); - return TCL_OK; - } - Tcl_DStringInit(&ds); - p = AbsolutePath(zipname, &ds, 0); - hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, p); - if (hPtr != NULL) { - if ((zf = Tcl_GetHashValue(hPtr)) != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); - } - } - Unlock(); - Tcl_DStringFree(&ds); - return TCL_OK; - } - Unlock(); - pwlen = 0; - if (passwd != NULL) { - pwlen = strlen(passwd); - if ((pwlen > 255) || (strchr(passwd, 0xff) != NULL)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - } - return TCL_ERROR; - } - } - if (ZipFSOpenArchive(interp, zipname, 1, &zf0) != TCL_OK) { - return TCL_ERROR; - } - Tcl_DStringInit(&ds); - realname = AbsolutePath(zipname, &ds, 0); - /* - * Mount point can come from Tcl_GetNameOfExecutable() - * which sometimes is a relative or otherwise denormalized path. - * But an absolute name is needed as mount point here. - */ - Tcl_DStringInit(&dsm); - mntpt = CanonicalPath(ZIPFS_VOLUME, mntpt, &dsm, 1); - WriteLock(); - hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, realname, &isNew); - Tcl_DStringSetLength(&ds, 0); - if (!isNew) { - zf = (ZipFile *) Tcl_GetHashValue(hPtr); - if (interp != NULL) { - Tcl_AppendResult(interp, "already mounted on \"", zf->mntptlen ? - zf->mntpt : "/", "\"", (char *) NULL); - } - Unlock(); - Tcl_DStringFree(&ds); - Tcl_DStringFree(&dsm); - ZipFSCloseArchive(interp, &zf0); - return TCL_ERROR; - } - if (strcmp(mntpt, "/") == 0) { - mntpt = ""; - } - zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1); - if (zf == NULL) { - if (interp != NULL) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - } - Unlock(); - Tcl_DStringFree(&ds); - Tcl_DStringFree(&dsm); - ZipFSCloseArchive(interp, &zf0); - return TCL_ERROR; - } - *zf = zf0; - zf->name = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); - strcpy(zf->mntpt, mntpt); - zf->mntptlen = strlen(zf->mntpt); - zf->entries = NULL; - zf->topents = NULL; - zf->nopen = 0; - Tcl_SetHashValue(hPtr, (ClientData) zf); - if ((zf->pwbuf[0] == 0) && pwlen) { - int k = 0; - i = pwlen; - zf->pwbuf[k++] = i; - while (i > 0) { - zf->pwbuf[k] = (passwd[i - 1] & 0x0f) | - pwrot[(passwd[i - 1] >> 4) & 0x0f]; - k++; - i--; - } - zf->pwbuf[k] = '\0'; - } - if (mntpt[0] != '\0') { - z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); - z->name = NULL; - z->tnext = NULL; - z->depth = CountSlashes(mntpt); - z->zipfile = zf; - z->isdir = 1; - z->isenc = 0; - z->offset = zf->baseoffs; - z->crc32 = 0; - z->timestamp = 0; - z->nbyte = z->nbytecompr = 0; - z->cmeth = ZIP_COMPMETH_STORED; - z->data = NULL; - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mntpt, &isNew); - if (!isNew) { - /* skip it */ - Tcl_Free((char *) z); - } else { - Tcl_SetHashValue(hPtr, (ClientData) z); - z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - z->next = zf->entries; - zf->entries = z; - } - } - q = zf->data + zf->centoffs; - Tcl_DStringInit(&fpBuf); - for (i = 0; i < zf->nfiles; i++) { - int pathlen, comlen, extra, isdir = 0, dosTime, dosDate, nbcompr, offs; - unsigned char *lq, *gq = NULL; - char *fullpath, *path; - - pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); - path = Tcl_DStringValue(&ds); - if ((pathlen > 0) && (path[pathlen - 1] == '/')) { - Tcl_DStringSetLength(&ds, pathlen - 1); - path = Tcl_DStringValue(&ds); - isdir = 1; - } - if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { - goto nextent; - } - lq = zf->data + zf->baseoffs + - zip_read_int(q + ZIP_CENTRAL_LOCALHDR_OFFS); - if ((lq < zf->data) || (lq > (zf->data + zf->length))) { - goto nextent; - } - nbcompr = zip_read_int(lq + ZIP_LOCAL_COMPLEN_OFFS); - if (!isdir && (nbcompr == 0) && - (zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) && - (zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { - gq = q; - nbcompr = zip_read_int(gq + ZIP_CENTRAL_COMPLEN_OFFS); - } - offs = (lq - zf->data) - + ZIP_LOCAL_HEADER_LEN - + zip_read_short(lq + ZIP_LOCAL_PATHLEN_OFFS) - + zip_read_short(lq + ZIP_LOCAL_EXTRALEN_OFFS); - if ((offs + nbcompr) > zf->length) { - goto nextent; - } - if (!isdir && (mntpt[0] == '\0') && !CountSlashes(path)) { -#ifdef ANDROID - /* - * When mounting the ZIP archive on the root directory try - * to remap top level regular files of the archive to - * /assets/.root/... since this directory should not be - * in a valid APK due to the leading dot in the file name - * component. This trick should make the files - * AndroidManifest.xml, resources.arsc, and classes.dex - * visible to Tcl. - */ - Tcl_DString ds2; - - Tcl_DStringInit(&ds2); - Tcl_DStringAppend(&ds2, "assets/.root/", -1); - Tcl_DStringAppend(&ds2, path, -1); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); - if (hPtr != NULL) { - /* should not happen but skip it anyway */ - Tcl_DStringFree(&ds2); - goto nextent; - } - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), - Tcl_DStringLength(&ds2)); - path = Tcl_DStringValue(&ds); - Tcl_DStringFree(&ds2); -#else - /* - * Regular files skipped when mounting on root. - */ - goto nextent; -#endif - } - Tcl_DStringSetLength(&fpBuf, 0); - fullpath = CanonicalPath(mntpt, path, &fpBuf, 1); - z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); - z->name = NULL; - z->tnext = NULL; - z->depth = CountSlashes(fullpath); - z->zipfile = zf; - z->isdir = isdir; - z->isenc = (zip_read_short(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) - && (nbcompr > 12); - z->offset = offs; - if (gq != NULL) { - z->crc32 = zip_read_int(gq + ZIP_CENTRAL_CRC32_OFFS); - dosDate = zip_read_short(gq + ZIP_CENTRAL_MDATE_OFFS); - dosTime = zip_read_short(gq + ZIP_CENTRAL_MTIME_OFFS); - z->timestamp = DosTimeDate(dosDate, dosTime); - z->nbyte = zip_read_int(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); - z->cmeth = zip_read_short(gq + ZIP_CENTRAL_COMPMETH_OFFS); - } else { - z->crc32 = zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS); - dosDate = zip_read_short(lq + ZIP_LOCAL_MDATE_OFFS); - dosTime = zip_read_short(lq + ZIP_LOCAL_MTIME_OFFS); - z->timestamp = DosTimeDate(dosDate, dosTime); - z->nbyte = zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); - z->cmeth = zip_read_short(lq + ZIP_LOCAL_COMPMETH_OFFS); - } - z->nbytecompr = nbcompr; - z->data = NULL; - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); - if (!isNew) { - /* should not happen but skip it anyway */ - Tcl_Free((char *) z); - } else { - Tcl_SetHashValue(hPtr, (ClientData) z); - z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - z->next = zf->entries; - zf->entries = z; - if (isdir && (mntpt[0] == '\0') && (z->depth == 1)) { - z->tnext = zf->topents; - zf->topents = z; - } - if (!z->isdir && (z->depth > 1)) { - char *dir, *end; - ZipEntry *zd; - - Tcl_DStringSetLength(&ds, strlen(z->name) + 8); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, z->name, -1); - dir = Tcl_DStringValue(&ds); - end = strrchr(dir, '/'); - while ((end != NULL) && (end != dir)) { - Tcl_DStringSetLength(&ds, end - dir); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, dir); - if (hPtr != NULL) { - break; - } - zd = (ZipEntry *) Tcl_Alloc(sizeof (*zd)); - zd->name = NULL; - zd->tnext = NULL; - zd->depth = CountSlashes(dir); - zd->zipfile = zf; - zd->isdir = 1; - zd->isenc = 0; - zd->offset = z->offset; - zd->crc32 = 0; - zd->timestamp = z->timestamp; - zd->nbyte = zd->nbytecompr = 0; - zd->cmeth = ZIP_COMPMETH_STORED; - zd->data = NULL; - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); - if (!isNew) { - /* should not happen but skip it anyway */ - Tcl_Free((char *) zd); - } else { - Tcl_SetHashValue(hPtr, (ClientData) zd); - zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - zd->next = zf->entries; - zf->entries = zd; - if ((mntpt[0] == '\0') && (zd->depth == 1)) { - zd->tnext = zf->topents; - zf->topents = zd; - } - } - end = strrchr(dir, '/'); - } - } - } -nextent: - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; - } - Unlock(); - Tcl_DStringFree(&fpBuf); - Tcl_DStringFree(&ds); - Tcl_DStringFree(&dsm); - Tcl_FSMountsChanged(NULL); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * Tclzipfs_Unmount -- - * - * This procedure is invoked to unmount a given ZIP archive. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A mounted ZIP archive file is unmounted, resources are free'd. - * - *------------------------------------------------------------------------- - */ - -int -Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname) -{ - char *realname; - ZipFile *zf; - ZipEntry *z, *znext; - Tcl_HashEntry *hPtr; - Tcl_DString ds; - int ret = TCL_OK, unmounted = 0; - - Tcl_DStringInit(&ds); - realname = AbsolutePath(zipname, &ds, 0); - WriteLock(); - if (!ZipFS.initialized) { - goto done; - } - hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, realname); - if (hPtr == NULL) { - /* don't report error */ - goto done; - } - zf = (ZipFile *) Tcl_GetHashValue(hPtr); - if (zf->nopen > 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("filesystem is busy", -1)); - } - ret = TCL_ERROR; - goto done; - } - Tcl_DeleteHashEntry(hPtr); - for (z = zf->entries; z; z = znext) { - znext = z->next; - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } - if (z->data != NULL) { - Tcl_Free((char *) z->data); - } - Tcl_Free((char *) z); - } - ZipFSCloseArchive(interp, zf); - Tcl_Free((char *) zf); - unmounted = 1; -done: - Unlock(); - Tcl_DStringFree(&ds); - if (unmounted) { - Tcl_FSMountsChanged(NULL); - } - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMountObjCmd -- - * - * This procedure is invoked to process the "zipfs::mount" command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is mounted, resources are allocated. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMountObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - if (objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "?zipfile? ?mountpoint? ?password?"); - return TCL_ERROR; - } - return Tclzipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, - (objc > 2) ? Tcl_GetString(objv[2]) : NULL, - (objc > 3) ? Tcl_GetString(objv[3]) : NULL); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSUnmountObjCmd -- - * - * This procedure is invoked to process the "zipfs::unmount" command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A mounted ZIP archive file is unmounted, resources are free'd. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSUnmountObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); - return TCL_ERROR; - } - return Tclzipfs_Unmount(interp, Tcl_GetString(objv[1])); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkKeyObjCmd -- - * - * This procedure is invoked to process the "zipfs::mkkey" command. - * It produces a rotated password to be embedded into an image file. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkKeyObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - int len, i = 0; - char *pw, pwbuf[264]; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "password"); - return TCL_ERROR; - } - pw = Tcl_GetString(objv[1]); - len = strlen(pw); - if (len == 0) { - return TCL_OK; - } - if ((len > 255) || (strchr(pw, 0xff) != NULL)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - return TCL_ERROR; - } - while (len > 0) { - int ch = pw[len - 1]; - - pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; - len--; - } - pwbuf[i] = i; - ++i; - pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - pwbuf[i] = '\0'; - Tcl_AppendResult(interp, pwbuf, (char *) NULL); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipAddFile -- - * - * This procedure is used by ZipFSMkZipOrImgCmd() to add a single - * file to the output ZIP archive file being written. A ZipEntry - * struct about the input file is added to the given fileHash table - * for later creation of the central ZIP directory. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Input file is read and (compressed and) written to the output - * ZIP archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipAddFile(Tcl_Interp *interp, const char *path, const char *name, - Tcl_Channel out, const char *passwd, - char *buf, int bufsize, Tcl_HashTable *fileHash) -{ - Tcl_Channel in; - Tcl_HashEntry *hPtr; - ZipEntry *z; - z_stream stream; - const char *zpath; - int nbyte, nbytecompr, len, crc, flush, pos[3], zpathlen, olen; - int mtime = 0, isNew, align = 0, cmeth; - unsigned long keys[3], keys0[3]; - char obuf[4096]; - - zpath = name; - while (zpath != NULL && zpath[0] == '/') { - zpath++; - } - if ((zpath == NULL) || (zpath[0] == '\0')) { - return TCL_OK; - } - zpathlen = strlen(zpath); - if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { - Tcl_AppendResult(interp, "path too long for \"", path, "\"", - (char *) NULL); - return TCL_ERROR; - } - in = Tcl_OpenFileChannel(interp, path, "r", 0); - if ((in == NULL) || - (Tcl_SetChannelOption(interp, in, "-translation", "binary") - != TCL_OK) || - (Tcl_SetChannelOption(interp, in, "-encoding", "binary") - != TCL_OK)) { -#if defined(_WIN32) || defined(_WIN64) - /* hopefully a directory */ - if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { - Tcl_Close(interp, in); - return TCL_OK; - } -#endif - Tcl_Close(interp, in); - return TCL_ERROR; - } else { - Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); - Tcl_StatBuf statBuf; - - Tcl_IncrRefCount(pathObj); - if (Tcl_FSStat(pathObj, &statBuf) != -1) { - mtime = statBuf.st_mtime; - } - Tcl_DecrRefCount(pathObj); - } - Tcl_ResetResult(interp); - crc = 0; - nbyte = nbytecompr = 0; - while ((len = Tcl_Read(in, buf, bufsize)) > 0) { - crc = crc32(crc, (unsigned char *) buf, len); - nbyte += len; - } - if (len == -1) { - if (nbyte == 0) { - if (strcmp("illegal operation on a directory", - Tcl_PosixError(interp)) == 0) { - Tcl_Close(interp, in); - return TCL_OK; - } - } - Tcl_AppendResult(interp, "read error on \"", path, "\"", - (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - if (Tcl_Seek(in, 0, SEEK_SET) == -1) { - Tcl_AppendResult(interp, "seek error on \"", path, "\"", - (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - pos[0] = Tcl_Tell(out); - memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); - memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); - len = zpathlen + ZIP_LOCAL_HEADER_LEN; - if (Tcl_Write(out, buf, len) != len) { -wrerr: - Tcl_AppendResult(interp, "write error", (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - if ((len + pos[0]) & 3) { - char abuf[8]; - - /* - * Align payload to next 4-byte boundary using a dummy extra - * entry similar to the zipalign tool from Android's SDK. - */ - align = 4 + ((len + pos[0]) & 3); - zip_write_short(abuf, 0xffff); - zip_write_short(abuf + 2, align - 4); - zip_write_int(abuf + 4, 0x03020100); - if (Tcl_Write(out, abuf, align) != align) { - goto wrerr; - } - } - if (passwd != NULL) { - int i, ch, tmp; - unsigned char kvbuf[24]; - Tcl_Obj *ret; - - init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { - if (Tcl_EvalEx(interp, "expr int(rand() * 256) % 256", -1, 0) != TCL_OK) { - Tcl_AppendResult(interp, "PRNG error", (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - ret = Tcl_GetObjResult(interp); - if (Tcl_GetIntFromObj(interp, ret, &ch) != TCL_OK) { - Tcl_Close(interp, in); - return TCL_ERROR; - } - kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp); - } - Tcl_ResetResult(interp); - init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { - kvbuf[i] = (unsigned char) zencode(keys, crc32tab, - kvbuf[i + 12], tmp); - } - kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp); - kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp); - len = Tcl_Write(out, (char *) kvbuf, 12); - memset(kvbuf, 0, 24); - if (len != 12) { - Tcl_AppendResult(interp, "write error", (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - memcpy(keys0, keys, sizeof (keys0)); - nbytecompr += 12; - } - Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - cmeth = ZIP_COMPMETH_DEFLATED; - memset(&stream, 0, sizeof (stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) - != Z_OK) { - Tcl_AppendResult(interp, "compression init error on \"", path, "\"", - (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - do { - len = Tcl_Read(in, buf, bufsize); - if (len == -1) { - Tcl_AppendResult(interp, "read error on \"", path, "\"", - (char *) NULL); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - stream.avail_in = len; - stream.next_in = (unsigned char *) buf; - flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; - do { - stream.avail_out = sizeof (obuf); - stream.next_out = (unsigned char *) obuf; - len = deflate(&stream, flush); - if (len == Z_STREAM_ERROR) { - Tcl_AppendResult(interp, "deflate error on \"", path, "\"", - (char *) NULL); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - olen = sizeof (obuf) - stream.avail_out; - if (passwd != NULL) { - int i, tmp; - - for (i = 0; i < olen; i++) { - obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); - } - } - if (olen && (Tcl_Write(out, obuf, olen) != olen)) { - Tcl_AppendResult(interp, "write error", (char *) NULL); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - nbytecompr += olen; - } while (stream.avail_out == 0); - } while (flush != Z_FINISH); - deflateEnd(&stream); - Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - if (nbyte - nbytecompr <= 0) { - /* - * Compressed file larger than input, - * write it again uncompressed. - */ - if ((int) Tcl_Seek(in, 0, SEEK_SET) != 0) { - goto seekErr; - } - if ((int) Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { -seekErr: - Tcl_Close(interp, in); - Tcl_AppendResult(interp, "seek error", (char *) NULL); - return TCL_ERROR; - } - nbytecompr = (passwd != NULL) ? 12 : 0; - while (1) { - len = Tcl_Read(in, buf, bufsize); - if (len == -1) { - Tcl_AppendResult(interp, "read error on \"", path, "\"", - (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } else if (len == 0) { - break; - } - if (passwd != NULL) { - int i, tmp; - - for (i = 0; i < len; i++) { - buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); - } - } - if (Tcl_Write(out, buf, len) != len) { - Tcl_AppendResult(interp, "write error", (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - nbytecompr += len; - } - cmeth = ZIP_COMPMETH_STORED; - Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - Tcl_TruncateChannel(out, pos[1]); - } - Tcl_Close(interp, in); - - z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); - z->name = NULL; - z->tnext = NULL; - z->depth = 0; - z->zipfile = NULL; - z->isdir = 0; - z->isenc = (passwd != NULL) ? 1 : 0; - z->offset = pos[0]; - z->crc32 = crc; - z->timestamp = mtime; - z->nbyte = nbyte; - z->nbytecompr = nbytecompr; - z->cmeth = cmeth; - z->data = NULL; - hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); - if (!isNew) { - Tcl_AppendResult(interp, "non-unique path name \"", path, "\"", - (char *) NULL); - Tcl_Free((char *) z); - return TCL_ERROR; - } else { - Tcl_SetHashValue(hPtr, (ClientData) z); - z->name = Tcl_GetHashKey(fileHash, hPtr); - z->next = NULL; - } - - /* - * Write final local header information. - */ - zip_write_int(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); - zip_write_short(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); - zip_write_short(buf + ZIP_LOCAL_FLAGS_OFFS, z->isenc); - zip_write_short(buf + ZIP_LOCAL_COMPMETH_OFFS, z->cmeth); - zip_write_short(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); - zip_write_short(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); - zip_write_int(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); - zip_write_int(buf + ZIP_LOCAL_COMPLEN_OFFS, z->nbytecompr); - zip_write_int(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->nbyte); - zip_write_short(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); - zip_write_short(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); - if ((int) Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free((char *) z); - Tcl_AppendResult(interp, "seek error", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free((char *) z); - Tcl_AppendResult(interp, "write error", (char *) NULL); - return TCL_ERROR; - } - Tcl_Flush(out); - if ((int) Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free((char *) z); - Tcl_AppendResult(interp, "seek error", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkZipOrImgObjCmd -- - * - * This procedure is creates a new ZIP archive file or image file - * given output filename, input directory of files to be archived, - * optional password, and optional image to be prepended to the - * output ZIP archive file. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A new ZIP archive file or image file is written. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkZipOrImgObjCmd(ClientData clientData, Tcl_Interp *interp, - int isImg, int isList, int objc, Tcl_Obj *const objv[]) -{ - Tcl_Channel out; - int len = 0, pwlen = 0, slen = 0, i, count, ret = TCL_ERROR, lobjc, pos[3]; - Tcl_Obj **lobjv, *list = NULL; - ZipEntry *z; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_HashTable fileHash; - char *strip = NULL, *pw = NULL, pwbuf[264], buf[4096]; - - if (isList) { - if ((objc < 3) || (objc > (isImg ? 5 : 4))) { - Tcl_WrongNumArgs(interp, 1, objv, isImg ? - "outfile inlist ?password infile?" : - "outfile inlist ?password?"); - return TCL_ERROR; - } - } else { - if ((objc < 3) || (objc > (isImg ? 6 : 5))) { - Tcl_WrongNumArgs(interp, 1, objv, isImg ? - "outfile indir ?strip? ?password? ?infile?" : - "outfile indir ?strip? ?password?"); - return TCL_ERROR; - } - } - pwbuf[0] = 0; - if (objc > (isList ? 3 : 4)) { - pw = Tcl_GetString(objv[isList ? 3 : 4]); - pwlen = strlen(pw); - if ((pwlen > 255) || (strchr(pw, 0xff) != NULL)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - return TCL_ERROR; - } - } - if (isList) { - list = objv[2]; - Tcl_IncrRefCount(list); - } else { - Tcl_Obj *cmd[3]; - - cmd[1] = Tcl_NewStringObj("::zipfs::find", -1); - cmd[2] = objv[2]; - cmd[0] = Tcl_NewListObj(2, cmd + 1); - Tcl_IncrRefCount(cmd[0]); - if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { - Tcl_DecrRefCount(cmd[0]); - return TCL_ERROR; - } - Tcl_DecrRefCount(cmd[0]); - list = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(list); - } - if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { - Tcl_DecrRefCount(list); - return TCL_ERROR; - } - if (isList && (lobjc % 2)) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("need even number of elements", -1)); - return TCL_ERROR; - } - if (lobjc == 0) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); - return TCL_ERROR; - } - out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "w", 0755); - if ((out == NULL) || - (Tcl_SetChannelOption(interp, out, "-translation", "binary") - != TCL_OK) || - (Tcl_SetChannelOption(interp, out, "-encoding", "binary") - != TCL_OK)) { - Tcl_DecrRefCount(list); - Tcl_Close(interp, out); - return TCL_ERROR; - } - if (isImg) { - ZipFile zf0; - const char *imgName; - - if (isList) { - imgName = (objc > 4) ? Tcl_GetString(objv[4]) : - Tcl_GetNameOfExecutable(); - } else { - imgName = (objc > 5) ? Tcl_GetString(objv[5]) : - Tcl_GetNameOfExecutable(); - } - if (ZipFSOpenArchive(interp, imgName, 0, &zf0) != TCL_OK) { - Tcl_DecrRefCount(list); - Tcl_Close(interp, out); - return TCL_ERROR; - } - if ((pw != NULL) && pwlen) { - i = 0; - len = pwlen; - while (len > 0) { - int ch = pw[len - 1]; - - pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; - len--; - } - pwbuf[i] = i; - ++i; - pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - pwbuf[i] = '\0'; - } - i = Tcl_Write(out, (char *) zf0.data, zf0.baseoffsp); - if (i != zf0.baseoffsp) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); - Tcl_Close(interp, out); - ZipFSCloseArchive(interp, &zf0); - return TCL_ERROR; - } - ZipFSCloseArchive(interp, &zf0); - len = strlen(pwbuf); - if (len > 0) { - i = Tcl_Write(out, pwbuf, len); - if (i != len) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); - Tcl_Close(interp, out); - return TCL_ERROR; - } - } - memset(pwbuf, 0, sizeof (pwbuf)); - Tcl_Flush(out); - } - Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); - pos[0] = Tcl_Tell(out); - if (!isList && (objc > 3)) { - strip = Tcl_GetString(objv[3]); - slen = strlen(strip); - } - for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; - - path = Tcl_GetString(lobjv[i]); - if (isList) { - name = Tcl_GetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } - if (name[0] == '\0') { - continue; - } - if (ZipAddFile(interp, path, name, out, pw, buf, sizeof (buf), - &fileHash) != TCL_OK) { - goto done; - } - } - pos[1] = Tcl_Tell(out); - count = 0; - for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; - - path = Tcl_GetString(lobjv[i]); - if (isList) { - name = Tcl_GetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } - if (name[0] == '\0') { - continue; - } - hPtr = Tcl_FindHashEntry(&fileHash, name); - if (hPtr == NULL) { - continue; - } - z = (ZipEntry *) Tcl_GetHashValue(hPtr); - len = strlen(z->name); - zip_write_int(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); - zip_write_short(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); - zip_write_short(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); - zip_write_short(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isenc ? 1 : 0); - zip_write_short(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->cmeth); - zip_write_short(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); - zip_write_short(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); - zip_write_int(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); - zip_write_int(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->nbytecompr); - zip_write_int(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->nbyte); - zip_write_short(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); - zip_write_short(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_IATTR_OFFS, 0); - zip_write_int(buf + ZIP_CENTRAL_EATTR_OFFS, 0); - zip_write_int(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); - if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != - ZIP_CENTRAL_HEADER_LEN) || - (Tcl_Write(out, z->name, len) != len)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); - goto done; - } - count++; - } - Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - zip_write_int(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); - zip_write_short(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_ENTS_OFFS, count); - zip_write_short(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); - zip_write_int(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); - zip_write_int(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); - zip_write_short(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); - if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); - goto done; - } - Tcl_Flush(out); - ret = TCL_OK; -done: - if (ret == TCL_OK) { - ret = Tcl_Close(interp, out); - } else { - Tcl_Close(interp, out); - } - Tcl_DecrRefCount(list); - hPtr = Tcl_FirstHashEntry(&fileHash, &search); - while (hPtr != NULL) { - z = (ZipEntry *) Tcl_GetHashValue(hPtr); - Tcl_Free((char *) z); - Tcl_DeleteHashEntry(hPtr); - hPtr = Tcl_FirstHashEntry(&fileHash, &search); - } - Tcl_DeleteHashTable(&fileHash); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkZipObjCmd -- - * - * This procedure is invoked to process the "zipfs::mkzip" command. - * See description of ZipFSMkZipOrImgCmd(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See description of ZipFSMkZipOrImgCmd(). - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 0, objc, objv); -} - -static int -ZipFSLMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 1, objc, objv); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkImgObjCmd -- - * - * This procedure is invoked to process the "zipfs::mkimg" command. - * See description of ZipFSMkZipOrImgCmd(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See description of ZipFSMkZipOrImgCmd(). - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 0, objc, objv); -} - -static int -ZipFSLMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 1, objc, objv); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSExistsObjCmd -- - * - * This procedure is invoked to process the "zipfs::exists" command. - * It tests for the existence of a file in the ZIP filesystem and - * places a boolean into the interp's result. - * - * Results: - * Always TCL_OK. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSExistsObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - char *filename; - int exists; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "filename"); - return TCL_ERROR; - } - filename = Tcl_GetStringFromObj(objv[1], 0); - ReadLock(); - exists = ZipFSLookup(filename) != NULL; - Unlock(); - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), exists); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSInfoObjCmd -- - * - * This procedure is invoked to process the "zipfs::info" command. - * On success, it returns a Tcl list made up of name of ZIP archive - * file, size uncompressed, size compressed, and archive offset of - * a file in the ZIP filesystem. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSInfoObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - char *filename; - ZipEntry *z; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "filename"); - return TCL_ERROR; - } - filename = Tcl_GetStringFromObj(objv[1], 0); - ReadLock(); - z = ZipFSLookup(filename); - if (z != NULL) { - Tcl_Obj *result = Tcl_GetObjResult(interp); - - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->zipfile->name, -1)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbyte)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbytecompr)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->offset)); - } - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSListObjCmd -- - * - * This procedure is invoked to process the "zipfs::list" command. - * On success, it returns a Tcl list of files of the ZIP filesystem - * which match a search pattern (glob or regexp). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSListObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - char *pattern = NULL; - Tcl_RegExp regexp = NULL; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_Obj *result = Tcl_GetObjResult(interp); - - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); - return TCL_ERROR; - } - if (objc == 3) { - int n; - char *what = Tcl_GetStringFromObj(objv[1], &n); - - if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { - pattern = Tcl_GetString(objv[2]); - } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { - regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); - if (regexp == NULL) { - return TCL_ERROR; - } - } else { - Tcl_AppendResult(interp, "unknown option \"", what, - "\"", (char *) NULL); - return TCL_ERROR; - } - } else if (objc == 2) { - pattern = Tcl_GetStringFromObj(objv[1], 0); - } - ReadLock(); - if (pattern != NULL) { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - if (Tcl_StringMatch(z->name, pattern)) { - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } else if (regexp != NULL) { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } else { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelClose -- - * - * This function is called to close a channel. - * - * Results: - * Always TCL_OK. - * - * Side effects: - * Resources are free'd. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelClose(ClientData instanceData, Tcl_Interp *interp) -{ - ZipChannel *info = (ZipChannel *) instanceData; - - if (info->iscompr && (info->ubuf != NULL)) { - Tcl_Free((char *) info->ubuf); - info->ubuf = NULL; - } - if (info->isenc) { - info->isenc = 0; - memset(info->keys, 0, sizeof (info->keys)); - } - if (info->iswr) { - ZipEntry *z = info->zipentry; - unsigned char *newdata; - - newdata = (unsigned char *) - Tcl_AttemptRealloc((char *) info->ubuf, info->nread); - if (newdata != NULL) { - if (z->data != NULL) { - Tcl_Free((char *) z->data); - } - z->data = newdata; - z->nbyte = z->nbytecompr = info->nbyte; - z->cmeth = ZIP_COMPMETH_STORED; - z->timestamp = time(NULL); - z->isdir = 0; - z->isenc = 0; - z->offset = 0; - z->crc32 = 0; - } else { - Tcl_Free((char *) info->ubuf); - } - } - WriteLock(); - info->zipfile->nopen--; - Unlock(); - Tcl_Free((char *) info); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelRead -- - * - * This function is called to read data from channel. - * - * Results: - * Number of bytes read or -1 on error with error number set. - * - * Side effects: - * Data is read and file pointer is advanced. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelRead(ClientData instanceData, char *buf, int toRead, int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; - - if (info->isdir) { - *errloc = EISDIR; - return -1; - } - nextpos = info->nread + toRead; - if (nextpos > info->nbyte) { - toRead = info->nbyte - info->nread; - nextpos = info->nbyte; - } - if (toRead == 0) { - return 0; - } - if (info->isenc) { - int i, ch; - - for (i = 0; i < toRead; i++) { - ch = info->ubuf[i + info->nread]; - buf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(buf, info->ubuf + info->nread, toRead); - } - info->nread = nextpos; - *errloc = 0; - return toRead; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelWrite -- - * - * This function is called to write data into channel. - * - * Results: - * Number of bytes written or -1 on error with error number set. - * - * Side effects: - * Data is written and file pointer is advanced. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelWrite(ClientData instanceData, const char *buf, - int toWrite, int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; - - if (!info->iswr) { - *errloc = EINVAL; - return -1; - } - nextpos = info->nread + toWrite; - if (nextpos > info->nmax) { - toWrite = info->nmax - info->nread; - nextpos = info->nmax; - } - if (toWrite == 0) { - return 0; - } - memcpy(info->ubuf + info->nread, buf, toWrite); - info->nread = nextpos; - if (info->nread > info->nbyte) { - info->nbyte = info->nread; - } - *errloc = 0; - return toWrite; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelSeek -- - * - * This function is called to position file pointer of channel. - * - * Results: - * New file position or -1 on error with error number set. - * - * Side effects: - * File pointer is repositioned according to offset and mode. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelSeek(ClientData instanceData, long offset, int mode, int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - - if (info->isdir) { - *errloc = EINVAL; - return -1; - } - switch (mode) { - case SEEK_CUR: - offset += info->nread; - break; - case SEEK_END: - offset += info->nbyte; - break; - case SEEK_SET: - break; - default: - *errloc = EINVAL; - return -1; - } - if (offset < 0) { - *errloc = EINVAL; - return -1; - } - if (info->iswr) { - if ((unsigned long) offset > info->nmax) { - *errloc = EINVAL; - return -1; - } - if ((unsigned long) offset > info->nbyte) { - info->nbyte = offset; - } - } else if ((unsigned long) offset > info->nbyte) { - *errloc = EINVAL; - return -1; - } - info->nread = (unsigned long) offset; - return info->nread; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelWatchChannel -- - * - * This function is called for event notifications on channel. - * - * Results: - * None. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static void -ZipChannelWatchChannel(ClientData instanceData, int mask) -{ - return; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelGetFile -- - * - * This function is called to retrieve OS handle for channel. - * - * Results: - * Always TCL_ERROR since there's never an OS handle for a - * file within a ZIP archive. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelGetFile(ClientData instanceData, int direction, - ClientData *handlePtr) -{ - return TCL_ERROR; -} - -/* - * The channel type/driver definition used for ZIP archive members. - */ - -static Tcl_ChannelType ZipChannelType = { - "zip", /* Type name. */ -#ifdef TCL_CHANNEL_VERSION_4 - TCL_CHANNEL_VERSION_4, - ZipChannelClose, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ - ZipChannelSeek, /* Move location of access point, NULL'able */ - NULL, /* Set options, NULL'able */ - NULL, /* Get options, NULL'able */ - ZipChannelWatchChannel, /* Initialize notifier */ - ZipChannelGetFile, /* Get OS handle from the channel */ - NULL, /* 2nd version of close channel, NULL'able */ - NULL, /* Set blocking mode for raw channel, NULL'able */ - NULL, /* Function to flush channel, NULL'able */ - NULL, /* Function to handle event, NULL'able */ - NULL, /* Wide seek function, NULL'able */ - NULL, /* Thread action function, NULL'able */ -#else - NULL, /* Set blocking/nonblocking behaviour, NULL'able */ - ZipChannelClose, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ - ZipChannelSeek, /* Move location of access point, NULL'able */ - NULL, /* Set options, NULL'able */ - NULL, /* Get options, NULL'able */ - ZipChannelWatchChannel, /* Initialize notifier */ - ZipChannelGetFile, /* Get OS handle from the channel */ -#endif -}; - -/* - *------------------------------------------------------------------------- - * - * ZipChannelOpen -- - * - * This function opens a Tcl_Channel on a file from a mounted ZIP - * archive according to given open mode. - * - * Results: - * Tcl_Channel on success, or NULL on error. - * - * Side effects: - * Memory is allocated, the file from the ZIP archive is uncompressed. - * - *------------------------------------------------------------------------- - */ - -static Tcl_Channel -ZipChannelOpen(Tcl_Interp *interp, char *filename, int mode, int permissions) -{ - ZipEntry *z; - ZipChannel *info; - int i, ch, trunc, wr, flags = 0; - char cname[128]; - - if ((mode & O_APPEND) || - ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported open mode", -1)); - } - return NULL; - } - WriteLock(); - z = ZipFSLookup(filename); - if (z == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); - } - goto error; - } - trunc = (mode & O_TRUNC) != 0; - wr = (mode & (O_WRONLY | O_RDWR)) != 0; - if ((z->cmeth != ZIP_COMPMETH_STORED) && - (z->cmeth != ZIP_COMPMETH_DEFLATED)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unsupported compression method", -1)); - } - goto error; - } - if (wr && z->isdir) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unsupported file type", -1)); - } - goto error; - } - if (!trunc) { - flags |= TCL_READABLE; - if (z->isenc && (z->zipfile->pwbuf[0] == 0)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("decryption failed", -1)); - } - goto error; - } else if (wr && (z->data == NULL) && (z->nbyte > ZipFS.wrmax)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file too large", -1)); - } - goto error; - } - } else { - flags = TCL_WRITABLE; - } - info = (ZipChannel *) Tcl_AttemptAlloc(sizeof (*info)); - if (info == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - info->zipfile = z->zipfile; - info->zipentry = z; - info->nread = 0; - if (wr) { - flags |= TCL_WRITABLE; - info->iswr = 1; - info->isdir = 0; - info->nmax = ZipFS.wrmax; - info->iscompr = 0; - info->isenc = 0; - info->ubuf = (unsigned char *) Tcl_AttemptAlloc(info->nmax); - if (info->ubuf == NULL) { -merror0: - if (info->ubuf != NULL) { - Tcl_Free((char *) info->ubuf); - } - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - memset(info->ubuf, 0, info->nmax); - if (trunc) { - info->nbyte = 0; - } else { - if (z->data != NULL) { - unsigned int j = z->nbyte; - - if (j > info->nmax) { - j = info->nmax; - } - memcpy(info->ubuf, z->data, j); - info->nbyte = j; - } else { - unsigned char *zbuf = z->zipfile->data + z->offset; - - if (z->isenc) { - int len = z->zipfile->pwbuf[0]; - char pwbuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipfile->pwbuf[len - i]; - pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - pwbuf[i] = '\0'; - init_keys(pwbuf, info->keys, crc32tab); - memset(pwbuf, 0, sizeof (pwbuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - zbuf += i; - } - if (z->cmeth == ZIP_COMPMETH_DEFLATED) { - z_stream stream; - int err; - unsigned char *cbuf = NULL; - - memset(&stream, 0, sizeof (stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = z->nbytecompr; - if (z->isenc) { - unsigned int j; - - stream.avail_in -= 12; - cbuf = (unsigned char *) - Tcl_AttemptAlloc(stream.avail_in); - if (cbuf == NULL) { - goto merror0; - } - for (j = 0; j < stream.avail_in; j++) { - ch = info->ubuf[j]; - cbuf[j] = zdecode(info->keys, crc32tab, ch); - } - stream.next_in = cbuf; - } else { - stream.next_in = zbuf; - } - stream.next_out = info->ubuf; - stream.avail_out = info->nmax; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror0; - } - err = inflate(&stream, Z_SYNC_FLUSH); - inflateEnd(&stream); - if ((err == Z_STREAM_END) || - ((err == Z_OK) && (stream.avail_in == 0))) { - if (cbuf != NULL) { - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) cbuf); - } - goto wrapchan; - } -cerror0: - if (cbuf != NULL) { - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) cbuf); - } - if (info->ubuf != NULL) { - Tcl_Free((char *) info->ubuf); - } - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("decompression error", -1)); - } - goto error; - } else if (z->isenc) { - for (i = 0; i < z->nbyte - 12; i++) { - ch = zbuf[i]; - info->ubuf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(info->ubuf, zbuf, z->nbyte); - } - memset(info->keys, 0, sizeof (info->keys)); - goto wrapchan; - } - } - } else if (z->data != NULL) { - flags |= TCL_READABLE; - info->iswr = 0; - info->iscompr = 0; - info->isdir = 0; - info->isenc = 0; - info->nbyte = z->nbyte; - info->nmax = 0; - info->ubuf = z->data; - } else { - flags |= TCL_READABLE; - info->iswr = 0; - info->iscompr = z->cmeth == ZIP_COMPMETH_DEFLATED; - info->ubuf = z->zipfile->data + z->offset; - info->isdir = z->isdir; - info->isenc = z->isenc; - info->nbyte = z->nbyte; - info->nmax = 0; - if (info->isenc) { - int len = z->zipfile->pwbuf[0]; - char pwbuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipfile->pwbuf[len - i]; - pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - pwbuf[i] = '\0'; - init_keys(pwbuf, info->keys, crc32tab); - memset(pwbuf, 0, sizeof (pwbuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - info->ubuf += i; - } - if (info->iscompr) { - z_stream stream; - int err; - unsigned char *ubuf = NULL; - unsigned int j; - - memset(&stream, 0, sizeof (stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = z->nbytecompr; - if (info->isenc) { - stream.avail_in -= 12; - ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in); - if (ubuf == NULL) { - info->ubuf = NULL; - goto merror; - } - for (j = 0; j < stream.avail_in; j++) { - ch = info->ubuf[j]; - ubuf[j] = zdecode(info->keys, crc32tab, ch); - } - stream.next_in = ubuf; - } else { - stream.next_in = info->ubuf; - } - stream.next_out = info->ubuf = - (unsigned char *) Tcl_AttemptAlloc(info->nbyte); - if (info->ubuf == NULL) { -merror: - if (ubuf != NULL) { - info->isenc = 0; - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) ubuf); - } - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - stream.avail_out = info->nbyte; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror; - } - err = inflate(&stream, Z_SYNC_FLUSH); - inflateEnd(&stream); - if ((err == Z_STREAM_END) || - ((err == Z_OK) && (stream.avail_in == 0))) { - if (ubuf != NULL) { - info->isenc = 0; - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) ubuf); - } - goto wrapchan; - } -cerror: - if (ubuf != NULL) { - info->isenc = 0; - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) ubuf); - } - if (info->ubuf != NULL) { - Tcl_Free((char *) info->ubuf); - } - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("decompression error", -1)); - } - goto error; - } - } -wrapchan: - sprintf(cname, "zipfs_%lx_%d", (unsigned long) z->offset, ZipFS.idCount++); - z->zipfile->nopen++; - Unlock(); - return Tcl_CreateChannel(&ZipChannelType, cname, (ClientData) info, flags); - -error: - Unlock(); - return NULL; -} - -/* - *------------------------------------------------------------------------- - * - * ZipEntryStat -- - * - * This function implements the ZIP filesystem specific version - * of the library version of stat. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipEntryStat(char *path, Tcl_StatBuf *buf) -{ - ZipEntry *z; - int ret = -1; - - ReadLock(); - z = ZipFSLookup(path); - if (z == NULL) { - goto done; - } - memset(buf, 0, sizeof (Tcl_StatBuf)); - if (z->isdir) { - buf->st_mode = S_IFDIR | 0555; - } else { - buf->st_mode = S_IFREG | 0555; - } - buf->st_size = z->nbyte; - buf->st_mtime = z->timestamp; - buf->st_ctime = z->timestamp; - buf->st_atime = z->timestamp; - ret = 0; -done: - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipEntryAccess -- - * - * This function implements the ZIP filesystem specific version - * of the library version of access. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipEntryAccess(char *path, int mode) -{ - ZipEntry *z; - - if (mode & 3) { - return -1; - } - ReadLock(); - z = ZipFSLookup(path); - Unlock(); - return (z != NULL) ? 0 : -1; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSOpenFileChannelProc -- - * - * Results: - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -static Tcl_Channel -Zip_FSOpenFileChannelProc(Tcl_Interp *interp, Tcl_Obj *pathPtr, - int mode, int permissions) -{ - int len; - - return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), - mode, permissions); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSStatProc -- - * - * This function implements the ZIP filesystem specific version - * of the library version of stat. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) -{ - int len; - - return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSAccessProc -- - * - * This function implements the ZIP filesystem specific version - * of the library version of access. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode) -{ - int len; - - return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFilesystemSeparatorProc -- - * - * This function returns the separator to be used for a given path. The - * object returned should have a refCount of zero - * - * Results: - * A Tcl object, with a refCount of zero. If the caller needs to retain a - * reference to the object, it should call Tcl_IncrRefCount, and should - * otherwise free the object. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr) -{ - return Tcl_NewStringObj("/", -1); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSMatchInDirectoryProc -- - * - * This routine is used by the globbing code to search a directory for - * all files which match a given pattern. - * - * Results: - * The return value is a standard Tcl result indicating whether an - * error occurred in globbing. Errors are left in interp, good - * results are lappend'ed to resultPtr (which must be a valid object). - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ -static int -Zip_FSMatchInDirectoryProc(Tcl_Interp* interp, Tcl_Obj *result, - Tcl_Obj *pathPtr, const char *pattern, - Tcl_GlobTypeData *types) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - int scnt, len, l, dirOnly = -1, prefixLen, strip = 0; - char *pat, *prefix, *path; - Tcl_DString ds, dsPref; - - if (types != NULL) { - dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; - } - Tcl_DStringInit(&ds); - Tcl_DStringInit(&dsPref); - prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); - Tcl_DStringAppend(&dsPref, prefix, prefixLen); - prefix = Tcl_DStringValue(&dsPref); - path = AbsolutePath(prefix, &ds, 1); - len = Tcl_DStringLength(&ds); - if (strcmp(prefix, path) == 0) { - prefix = NULL; - } else { - strip = len + 1; - } - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, "/", 1); - prefixLen++; - prefix = Tcl_DStringValue(&dsPref); - } - ReadLock(); - if ((types != NULL) && (types->type == TCL_GLOB_TYPE_MOUNT)) { - l = CountSlashes(path); - if (path[len - 1] == '/') { - len--; - } else { - l++; - } - if ((pattern == NULL) || (pattern[0] == '\0')) { - pattern = "*"; - } - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); - - if (zf->mntptlen == 0) { - ZipEntry *z = zf->topents; - while (z != NULL) { - int lenz = strlen(z->name); - if ((lenz > len + 1) && - (strncmp(z->name, path, len) == 0) && - (z->name[len] == '/') && - (CountSlashes(z->name) == l) && - Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, z->name, lenz); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, lenz)); - } - } - z = z->tnext; - } - } else if ((zf->mntptlen > len + 1) && - (strncmp(zf->mntpt, path, len) == 0) && - (zf->mntpt[len] == '/') && - (CountSlashes(zf->mntpt) == l) && - Tcl_StringCaseMatch(zf->mntpt + len + 1, pattern, 0)) { - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, zf->mntpt, zf->mntptlen); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); - } - } - hPtr = Tcl_NextHashEntry(&search); - } - goto end; - } - if ((pattern == NULL) || (pattern[0] == '\0')) { - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr != NULL) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - if ((dirOnly < 0) || - (!dirOnly && !z->isdir) || - (dirOnly && z->isdir)) { - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, z->name, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } - goto end; - } - l = strlen(pattern); - pat = Tcl_Alloc(len + l + 2); - memcpy(pat, path, len); - while ((len > 1) && (pat[len - 1] == '/')) { - --len; - } - if ((len > 1) || (pat[0] != '/')) { - pat[len] = '/'; - ++len; - } - memcpy(pat + len, pattern, l + 1); - scnt = CountSlashes(pat); - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - if ((dirOnly >= 0) && - ((dirOnly && !z->isdir) || (!dirOnly && z->isdir))) { - continue; - } - if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, z->name + strip, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name + strip, -1)); - } - } - } - Tcl_Free(pat); -end: - Unlock(); - Tcl_DStringFree(&dsPref); - Tcl_DStringFree(&ds); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSNormalizePathProc -- - * - * Function to normalize given path object. - * - * Results: - * Length of final absolute path name. - * - * Side effects: - * Path object gets converted to an absolute path. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSNormalizePathProc(Tcl_Interp *interp, Tcl_Obj *pathPtr, - int nextCheckpoint) -{ - char *path; - Tcl_DString ds; - int len; - - path = Tcl_GetStringFromObj(pathPtr, &len); - Tcl_DStringInit(&ds); - path = AbsolutePath(path, &ds, 1); - nextCheckpoint = Tcl_DStringLength(&ds); - Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - return nextCheckpoint; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSPathInFilesystemProc -- - * - * This function determines if the given path object is in the - * ZIP filesystem. - * - * Results: - * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - ZipFile *zf; - int ret = -1, len; - char *path; - Tcl_DString ds; - - path = Tcl_GetStringFromObj(pathPtr, &len); - if(strncmp(path,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)!=0) { - return -1; - } - - Tcl_DStringInit(&ds); - path = AbsolutePath(path, &ds, 1); - len = Tcl_DStringLength(&ds); - ReadLock(); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr != NULL) { - ret = TCL_OK; - goto endloop; - } - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - zf = (ZipFile *) Tcl_GetHashValue(hPtr); - if (zf->mntptlen == 0) { - ZipEntry *z = zf->topents; - while (z != NULL) { - int lenz = strlen(z->name); - - if ((len >= lenz) && - (strncmp(path, z->name, lenz) == 0)) { - ret = TCL_OK; - goto endloop; - } - z = z->tnext; - } - } else if ((len >= zf->mntptlen) && - (strncmp(path, zf->mntpt, zf->mntptlen) == 0)) { - ret = TCL_OK; - goto endloop; - } - hPtr = Tcl_NextHashEntry(&search); - } -endloop: - Unlock(); - Tcl_DStringFree(&ds); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSListVolumesProc -- - * - * Lists the currently mounted ZIP filesystem volumes. - * - * Results: - * The list of volumes. - * - * Side effects: - * None - * - *------------------------------------------------------------------------- - */ -static Tcl_Obj * -Zip_FSListVolumesProc(void) { - return Tcl_NewStringObj(ZIPFS_VOLUME, -1); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSChdirProc -- - * - * If the path object refers to a directory within the ZIP - * filesystem the current directory is set to this directory. - * - * Results: - * TCL_OK on success, -1 on error with error number set. - * - * Side effects: - * The global cwdPathPtr may change value. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSChdirProc(Tcl_Obj *pathPtr) -{ - int len; - char *path; - Tcl_DString ds; - ZipEntry *z; - int ret = TCL_OK; -#if HAS_DRIVES - int drive = 0; -#endif - - path = Tcl_GetStringFromObj(pathPtr, &len); - Tcl_DStringInit(&ds); - path = AbsolutePath(path, &ds, 1); - ReadLock(); - z = ZipFSLookup(path); - if ((z == NULL) || !z->isdir) { - Tcl_SetErrno(ENOENT); - ret = -1; - } -#if HAS_DRIVES - if ((z != NULL) && (drive != z->zipfile->mntdrv)) { - Tcl_SetErrno(ENOENT); - ret = -1; - } -#endif - Unlock(); - Tcl_DStringFree(&ds); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFileAttrStringsProc -- - * - * This function implements the ZIP filesystem dependent 'file attributes' - * subcommand, for listing the set of possible attribute strings. - * - * Results: - * An array of strings - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static const char *const * -Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef) -{ - static const char *const attrs[] = { - "-uncompsize", - "-compsize", - "-offset", - "-mount", - "-archive", - "-permissions", - NULL, - }; - - return attrs; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFileAttrsGetProc -- - * - * This function implements the ZIP filesystem specific - * 'file attributes' subcommand, for 'get' operations. - * - * Results: - * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK - * was returned) is likely to have a refCount of zero. Either way we must - * either store it somewhere (e.g. the Tcl result), or Incr/Decr its - * refCount to ensure it is properly freed. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSFileAttrsGetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, - Tcl_Obj **objPtrRef) -{ - int len, ret = TCL_OK; - char *path; - ZipEntry *z; - - path = Tcl_GetStringFromObj(pathPtr, &len); - ReadLock(); - z = ZipFSLookup(path); - if (z == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); - } - ret = TCL_ERROR; - goto done; - } - switch (index) { - case 0: - *objPtrRef = Tcl_NewIntObj(z->nbyte); - goto done; - case 1: - *objPtrRef= Tcl_NewIntObj(z->nbytecompr); - goto done; - case 2: - *objPtrRef= Tcl_NewLongObj(z->offset); - goto done; - case 3: - *objPtrRef= Tcl_NewStringObj(z->zipfile->mntpt, -1); - goto done; - case 4: - *objPtrRef= Tcl_NewStringObj(z->zipfile->name, -1); - goto done; - case 5: - *objPtrRef= Tcl_NewStringObj("0555", -1); - goto done; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown attribute", -1)); - } - ret = TCL_ERROR; -done: - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFileAttrsSetProc -- - * - * This function implements the ZIP filesystem specific - * 'file attributes' subcommand, for 'set' operations. - * - * Results: - * Standard Tcl return code. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, - Tcl_Obj *objPtr) -{ - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); - } - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFilesystemPathTypeProc -- - * - * Results: - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr) -{ - return Tcl_NewStringObj("zip", -1); -} - - -/* - *------------------------------------------------------------------------- - * - * Zip_FSLoadFile -- - * - * This functions deals with loading native object code. If - * the given path object refers to a file within the ZIP - * filesystem, an approriate error code is returned to delegate - * loading to the caller (by copying the file to temp store - * and loading from there). As fallback when the file refers - * to the ZIP file system but is not present, it is looked up - * relative to the executable and loaded from there when available. - * - * Results: - * TCL_OK on success, -1 otherwise with error number set. - * - * Side effects: - * Loads native code into the process address space. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr, int flags) -{ - Tcl_FSLoadFileProc2 *loadFileProc; -#ifdef ANDROID - /* - * Force loadFileProc to native implementation since the - * package manger already extracted the shared libraries - * from the APK at install time. - */ - - loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; - if (loadFileProc != NULL) { - return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); - } - Tcl_SetErrno(ENOENT); - return -1; -#else - Tcl_Obj *altPath = NULL; - int ret = -1; - - if (Tcl_FSAccess(path, R_OK) == 0) { - /* - * EXDEV should trigger loading by copying to temp store. - */ - Tcl_SetErrno(EXDEV); - return ret; - } else { - Tcl_Obj *objs[2] = { NULL, NULL }; - - objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); - if ((objs[1] != NULL) && (Zip_FSAccessProc(objs[1], R_OK) == 0)) { - const char *execName = Tcl_GetNameOfExecutable(); - - /* - * Shared object is not in ZIP but its path prefix is, - * thus try to load from directory where the executable - * came from. - */ - TclDecrRefCount(objs[1]); - objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); - /* - * Get directory name of executable manually to deal - * with cases where [file dirname [info nameofexecutable]] - * is equal to [info nameofexecutable] due to VFS effects. - */ - if (execName != NULL) { - const char *p = strrchr(execName, '/'); - - if (p > execName + 1) { - --p; - objs[0] = Tcl_NewStringObj(execName, p - execName); - } - } - if (objs[0] == NULL) { - objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), - TCL_PATH_DIRNAME); - } - if (objs[0] != NULL) { - altPath = TclJoinPath(2, objs); - if (altPath != NULL) { - Tcl_IncrRefCount(altPath); - if (Tcl_FSAccess(altPath, R_OK) == 0) { - path = altPath; - } - } - } - } - if (objs[0] != NULL) { - Tcl_DecrRefCount(objs[0]); - } - if (objs[1] != NULL) { - Tcl_DecrRefCount(objs[1]); - } - } - loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; - if (loadFileProc != NULL) { - ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); - } else { - Tcl_SetErrno(ENOENT); - } - if (altPath != NULL) { - Tcl_DecrRefCount(altPath); - } - return ret; -#endif -} - - -/* - * Define the ZIP filesystem dispatch table. - */ - -MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem; - -const Tcl_Filesystem zipfsFilesystem = { - "zipfs", - sizeof (Tcl_Filesystem), - TCL_FILESYSTEM_VERSION_2, - Zip_FSPathInFilesystemProc, - NULL, /* dupInternalRepProc */ - NULL, /* freeInternalRepProc */ - NULL, /* internalToNormalizedProc */ - NULL, /* createInternalRepProc */ - Zip_FSNormalizePathProc, - Zip_FSFilesystemPathTypeProc, - Zip_FSFilesystemSeparatorProc, - Zip_FSStatProc, - Zip_FSAccessProc, - Zip_FSOpenFileChannelProc, - Zip_FSMatchInDirectoryProc, - NULL, /* utimeProc */ - NULL, /* linkProc */ - Zip_FSListVolumesProc, - Zip_FSFileAttrStringsProc, - Zip_FSFileAttrsGetProc, - Zip_FSFileAttrsSetProc, - NULL, /* createDirectoryProc */ - NULL, /* removeDirectoryProc */ - NULL, /* deleteFileProc */ - NULL, /* copyFileProc */ - NULL, /* renameFileProc */ - NULL, /* copyDirectoryProc */ - NULL, /* lstatProc */ - (Tcl_FSLoadFileProc *) Zip_FSLoadFile, - NULL, /* getCwdProc */ - Zip_FSChdirProc, -}; - -#endif /* HAVE_ZLIB */ - - -/* - *------------------------------------------------------------------------- - * - * Zipfs_doInit -- - * - * Perform per interpreter initialization of this module. - * - * Results: - * The return value is a standard Tcl result. - * - * Side effects: - * Initializes this module if not already initialized, and adds - * module related commands to the given interpreter. - * - *------------------------------------------------------------------------- - */ - -static int -Zipfs_doInit(Tcl_Interp *interp, int safe) -{ -#ifdef HAVE_ZLIB - static const EnsembleImplMap initMap[] = { - {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 0}, - {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 0}, - {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 0}, - {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 0}, - {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 0}, - {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 0}, - {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 0}, - {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, - {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, - {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - - static const EnsembleImplMap initSafeMap[] = { - {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, - {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, - {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - - static const char findproc[] = - "namespace eval zipfs {}\n" - "proc ::zipfs::find dir {\n" - " set result {}\n" - " if {[catch {glob -directory $dir -tails -nocomplain * .*} list]} {\n" - " return $result\n" - " }\n" - " foreach file $list {\n" - " if {$file eq \".\" || $file eq \"..\"} {\n" - " continue\n" - " }\n" - " set file [file join $dir $file]\n" - " lappend result $file\n" - " foreach file [::zipfs::find $file] {\n" - " lappend result $file\n" - " }\n" - " }\n" - " return [lsort $result]\n" - "}\n"; - - /* one-time initialization */ - WriteLock(); - if (!ZipFS.initialized) { -#ifdef TCL_THREADS - static const Tcl_Time t = { 0, 0 }; - - /* - * Inflate condition variable. - */ - Tcl_MutexLock(&ZipFSMutex); - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); - Tcl_MutexUnlock(&ZipFSMutex); -#endif - Tcl_FSRegister(NULL, &zipfsFilesystem); - Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); - Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); - ZipFS.initialized = ZipFS.idCount = 1; - if (interp != NULL) { - Tcl_StaticPackage(interp, "zipfs", Tclzipfs_Init, Tclzipfs_SafeInit); - } - } - Unlock(); - if(interp != NULL) { - if (!safe) { - Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); - Tcl_LinkVar(interp, "::zipfs::wrmax", (char *) &ZipFS.wrmax, - TCL_LINK_INT); - } - TclMakeEnsemble(interp, "zipfs", safe ? initSafeMap : initMap); - - Tcl_PkgProvide(interp, "zipfs", "1.0"); - } - return TCL_OK; -#else - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("no zlib available", -1)); - } - return TCL_ERROR; -#endif -} - -/* - *------------------------------------------------------------------------- - * - * Tclzipfs_Init, Tclzipfs_SafeInit -- - * - * These functions are invoked to perform per interpreter initialization - * of this module. - * - * Results: - * The return value is a standard Tcl result. - * - * Side effects: - * Initializes this module if not already initialized, and adds - * module related commands to the given interpreter. - * - *------------------------------------------------------------------------- - */ - -int -Tclzipfs_Init(Tcl_Interp *interp) -{ - return Zipfs_doInit(interp, 0); -} - -int -Tclzipfs_SafeInit(Tcl_Interp *interp) -{ - return Zipfs_doInit(interp, 1); -} - -#ifndef HAVE_ZLIB - -/* - *------------------------------------------------------------------------- - * - * Tclzipfs_Mount, Tclzipfs_Unmount -- - * - * Dummy version when no ZLIB support available. - * - *------------------------------------------------------------------------- - */ - -int -Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, - const char *passwd) -{ - return Zipfs_doInit(interp, 1); -} - -int -Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname) -{ - return Zipfs_doInit(interp, 1); -} - -#endif - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED configure.ac Index: configure.ac ================================================================== --- configure.ac +++ /dev/null @@ -1,187 +0,0 @@ -#!/bin/bash -norc -dnl This file is an input file used by the GNU "autoconf" program to -dnl generate the file "configure", which is run during Tcl installation -dnl to configure the system for the local environment. - -#----------------------------------------------------------------------- -# Sample configure.ac for Tcl Extensions. The only places you should -# need to modify this file are marked by the string __CHANGE__ -#----------------------------------------------------------------------- - -#----------------------------------------------------------------------- -# __CHANGE__ -# Set your package name and version numbers here. -# -# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION -# set as provided. These will also be added as -D defs in your Makefile -# so you can encode the package version directly into the source files. -# This will also define a special symbol for Windows (BUILD_ -# so that we create the export library with the dll. -#----------------------------------------------------------------------- - -AC_INIT([toadkit], [3.0]) - -#-------------------------------------------------------------------- -# Call TEA_INIT as the first TEA_ macro to set up initial vars. -# This will define a ${TEA_PLATFORM} variable == "unix" or "windows" -# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE. -#-------------------------------------------------------------------- - -TEA_INIT([3.10]) -AC_PROG_LN_S -CONFIG_CLEAN_FILES= -if test ! -d $srcdir/tclconfig ; then - if test -d $srcdir/../tclconfig ; then - $LN_S $srcdir/../tclconfig tclconfig - CONFIG_CLEAN_FILES=tclconfig - fi -fi -AC_SUBST(CONFIG_CLEAN_FILES) -AC_CONFIG_AUX_DIR(tclconfig) - -#-------------------------------------------------------------------- -# Load the tclConfig.sh file -#-------------------------------------------------------------------- - -TEA_PATH_TCLCONFIG -TEA_LOAD_TCLCONFIG - -#-------------------------------------------------------------------- -# Load the tkConfig.sh file if necessary (Tk extension) -#-------------------------------------------------------------------- - -TEA_PATH_TKCONFIG -TEA_LOAD_TKCONFIG - -#----------------------------------------------------------------------- -# Handle the --prefix=... option by defaulting to what Tcl gave. -# Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER. -#----------------------------------------------------------------------- - -TEA_PREFIX - -#----------------------------------------------------------------------- -# Standard compiler checks. -# This sets up CC by using the CC env var, or looks for gcc otherwise. -# This also calls AC_PROG_CC and a few others to create the basic setup -# necessary to compile executables. -#----------------------------------------------------------------------- - -TEA_SETUP_COMPILER - -#----------------------------------------------------------------------- -# __CHANGE__ -# Specify the C source files to compile in TEA_ADD_SOURCES, -# public headers that need to be installed in TEA_ADD_HEADERS, -# stub library C source files to compile in TEA_ADD_STUB_SOURCES, -# and runtime Tcl library files in TEA_ADD_TCL_SOURCES. -# This defines PKG(_STUB)_SOURCES, PKG(_STUB)_OBJECTS, PKG_HEADERS -# and PKG_TCL_SOURCES. -#----------------------------------------------------------------------- - -TEA_ADD_SOURCES([]) -TEA_ADD_HEADERS([]) -TEA_ADD_INCLUDES([]) -TEA_ADD_LIBS([]) -TEA_ADD_CFLAGS([]) -TEA_ADD_STUB_SOURCES([]) -TEA_ADD_TCL_SOURCES([]) - -#-------------------------------------------------------------------- -# __CHANGE__ -# -# You can add more files to clean if your extension creates any extra -# files by extending CLEANFILES. -# Add pkgIndex.tcl if it is generated in the Makefile instead of ./configure -# and change Makefile.in to move it from CONFIG_CLEAN_FILES to BINARIES var. -# -# A few miscellaneous platform-specific items: -# TEA_ADD_* any platform specific compiler/build info here. -#-------------------------------------------------------------------- - -#CLEANFILES="$CLEANFILES pkgIndex.tcl" -if test "${TEA_PLATFORM}" = "windows" ; then - # Ensure no empty if clauses - : - #TEA_ADD_SOURCES([win/winFile.c]) - #TEA_ADD_INCLUDES([-I\"$(${CYGPATH} ${srcdir}/win)\"]) -else - # Ensure no empty else clauses - : - #TEA_ADD_SOURCES([unix/unixFile.c]) - #TEA_ADD_LIBS([-lsuperfly]) -fi - -#-------------------------------------------------------------------- -# __CHANGE__ -# Choose which headers you need. Extension authors should try very -# hard to only rely on the Tcl public header files. Internal headers -# contain private data structures and are subject to change without -# notice. -# This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG -#-------------------------------------------------------------------- - -TEA_PUBLIC_TCL_HEADERS -#TEA_PRIVATE_TCL_HEADERS - -TEA_PUBLIC_TK_HEADERS -#TEA_PRIVATE_TK_HEADERS -TEA_PATH_X - -#-------------------------------------------------------------------- -# Check whether --enable-threads or --disable-threads was given. -# This auto-enables if Tcl was compiled threaded. -#-------------------------------------------------------------------- - -TEA_ENABLE_THREADS - -#-------------------------------------------------------------------- -# The statement below defines a collection of symbols related to -# building as a shared library instead of a static library. -#-------------------------------------------------------------------- - -TEA_ENABLE_SHARED - -#-------------------------------------------------------------------- -# This macro figures out what flags to use with the compiler/linker -# when building shared/static debug/optimized objects. This information -# can be taken from the tclConfig.sh file, but this figures it all out. -#-------------------------------------------------------------------- - -TEA_CONFIG_CFLAGS - -#-------------------------------------------------------------------- -# Set the default compiler switches based on the --enable-symbols option. -#-------------------------------------------------------------------- - -TEA_ENABLE_SYMBOLS - -#-------------------------------------------------------------------- -# This macro generates a line to use when building a library. It -# depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS, -# and TEA_LOAD_TCLCONFIG macros above. -#-------------------------------------------------------------------- - -TEA_MAKE_LIB - -#-------------------------------------------------------------------- -# Determine the name of the tclsh and/or wish executables in the -# Tcl and Tk build directories or the location they were installed -# into. These paths are used to support running test cases only, -# the Makefile should not be making use of these paths to generate -# a pkgIndex.tcl file or anything else at extension build time. -#-------------------------------------------------------------------- - -TEA_PROG_TCLSH -TEA_PROG_WISH - -TEA_CONFIG_TEAPOT - -#-------------------------------------------------------------------- -# Finally, substitute all of the various values into the Makefile. -# You may alternatively have a special pkgIndex.tcl.in or other files -# which require substituting th AC variables in. Include these here. -#-------------------------------------------------------------------- - -AC_OUTPUT([config.tcl:../tclconfig/config.tcl.in]) -${TCLSH_PROG} ${srcdir}/make.tcl autoconf DELETED cthulhu.ini Index: cthulhu.ini ================================================================== --- cthulhu.ini +++ /dev/null @@ -1,9 +0,0 @@ -### -# This file is read by scripts/cthulhu.tcl to configure -# the project. This is a Tcl script, so feel free to execute -# arbirary Tcl commands/source subscripts/etc -### -set ::project(name) odie -set ::project(pkgname) odie -set ::project(pkgvers) 10.1.2 - DELETED example/odielib/cube.tcl Index: example/odielib/cube.tcl ================================================================== --- example/odielib/cube.tcl +++ /dev/null @@ -1,66 +0,0 @@ -package require Tk -package require odielibc - -# this demonstration shows how to use odielib -# to perform an orthogonal 3D transform on a set of points -# and display it on a canvas. - -# create random lines -set data {} -for {set i 0} {$i<1000} {incr i} { - set r1 [expr {rand()-0.5}] - set r2 [expr {rand()-0.5}] - set r3 [expr {rand()-0.5}] - lappend data [vectorxyz::create $r1 $r2 $r3] -} - -# create a canvas -::slicer ::sx -::sx create 1 main 0 -1000 1000 - -canvas .c -width 500 -height 500 -# four sliders -ttk::label .s#l -text "Scale:" -ttk::scale .s -variable s -from 1.0 -to 250.0 -command updatePlot -ttk::label .phi#l -text "Phi:" -ttk::scale .phi -variable phi -from 0.0 -to 6.28 -command updatePlot -ttk::label .chi#l -text "Chi:" -ttk::scale .chi -variable chi -from 0.0 -to 6.28 -command updatePlot -ttk::label .psi#l -text "Psi:" -ttk::scale .psi -variable psi -from 0.0 -to 6.28 -command updatePlot - -set s 100.0 -set phi 0.5 -set chi 0.12 -set psi 0.0 - -grid .s#l .s -sticky nsew -grid .phi#l .phi -sticky nsew -grid .chi#l .chi -sticky nsew -grid .psi#l .psi -sticky nsew -grid .c -sticky nsew -columnspan 2 - -grid rowconfigure . .c -weight 1 -grid columnconfigure . .c -weight 1 - -::plotter ::px - -proc updatePlot {args} { - set cpoints [updateTransform] - .c delete all - foreach {x0 y0 x1 y1} $cpoints { - .c create line $x0 $y0 $x1 $y1 - } -} -proc updateTransform {} { - ::px centerset [expr {1/$::s}] [winfo width .c] [winfo height .c] - set xform [::affine3d::from_euler [vectorxyz::create $::phi $::chi $::psi]] - set rawcoords [::vectorxyz::transform $xform {*}$::data] - return [::px canvascoords $rawcoords] -} - -update; # let the geometry propagate -updatePlot - -package require taotk -console:start DELETED example/tao-core/signal.tcl Index: example/tao-core/signal.tcl ================================================================== --- example/tao-core/signal.tcl +++ /dev/null @@ -1,8 +0,0 @@ -package require odielibc - -for {set x 1} {$x < 64} {incr x} { - proc sig$x {} [list puts "Got signal $x"] - catch {signal add $x sig$x} - puts "SIGNAL ADD $x" -} -vwait forever DELETED example/tao-layout/table.tcl Index: example/tao-layout/table.tcl ================================================================== --- example/tao-layout/table.tcl +++ /dev/null @@ -1,87 +0,0 @@ -### -# Example of a table layout in action -### -source [file dirname [file normalize [info script]]]/../../modules/packages.tcl -package require taotk-layout - -taotk::layout create main .canvas -pack .canvas -side top -fill both -expand 1 - - -::irmgui::define taotk::layout::colorwidget { - superclass taotk::layout::string - -} - -proc addcell {row column text args} { - if {($row % 2)==0} { - set bg [taotk::stylesheet cget color-row-even] - } else { - set bg [taotk::stylesheet cget color-row-odd] - } - set id [main dynamic_widget font $::font anchor nw justify left background $bg {*}$args] - $id put $text - set uuid [$id uuid] - main table_place $uuid $column $row - return $id -} - -set font {Helvetica 12} -foreach color { - red orange green blue -} { - incr row - if {($row % 2)==0} { - set bg [taotk::stylesheet cget color-row-even] - } else { - set bg [taotk::stylesheet cget color-row-odd] - } - set id [main dynamic_widget widget entry.text font $font anchor nw justify right background $bg] - $id put "$color:" - set uuid [$id uuid] - main table_place $uuid 0 $row - - set id [main dynamic_widget widget colorwidget font $font label "$color:" anchor nw justify left fill $color background $bg] - $id put $color - set uuid [$id uuid] - main table_place $uuid 1 $row -} - -incr row -if {($row % 2)==0} { - set bg [taotk::stylesheet cget color-row-even] -} else { - set bg [taotk::stylesheet cget color-row-odd] -} -set id [main dynamic_widget widget entry.text font $font anchor nw justify right background $bg] -$id put "Date:" -set uuid [$id uuid] -main table_place $uuid 0 $row - -set id [main dynamic_widget widget unixtime font $font anchor nw justify left background $bg] -$id put [clock seconds] -set uuid [$id uuid] -main table_place $uuid 1 $row - -incr row -if {($row % 2)==0} { - set bg [taotk::stylesheet cget color-row-even] -} else { - set bg [taotk::stylesheet cget color-row-odd] -} -set id [main dynamic_widget widget entry.text font $font anchor nw justify right background $bg] -$id put "Date:" -set uuid [$id uuid] -main table_place $uuid 0 $row - -set id [main dynamic_widget widget select values { - One Two Three Four Five Six Seven Eight Nine Ten Eleven -} font $font anchor nw justify left background $bg] -$id put One -set uuid [$id uuid] -main table_place $uuid 1 $row - -main redraw -main arrange -console:start -taotk::sqlconsole .sql db [main organ db] DELETED example/tao-physics/rocket-notk.tcl Index: example/tao-physics/rocket-notk.tcl ================================================================== --- example/tao-physics/rocket-notk.tcl +++ /dev/null @@ -1,105 +0,0 @@ -source [file normalize [file dirname [info script]]]/../../modules/tao-physics/index.tcl -package require csv - -tao::class rocket { - superclass physics::base - - property physics mass { - default 200 - units kg - } - - property physics fuel { - default 10 - units kg - } - - property physics fuel_burn_rate { - default 1 - units kg/s - } - - property physics fuel_energy_release { - default 10000 - units N/kg - } - - option world { - default {} - } - - constructor {objects args} { - foreach {item obj} $objects { - my graft $item $obj - } - my config set [::tao::args_to_options {*}$args] - my initialize - } - -} - -::physics::world create world - -set n [rocket new {world ::world}] -$n physics heading [::vector::scale {0 0 45} [::odiemath::m_pi_180]] -# -#exit -set pscript { - set g [my physics property gravity] - set thrust {0 0 0} - if {$fuel > 0} { - set dfuel [expr {$::dT * $fuel_burn_rate}] - if {$dfuel > $fuel} { - set dfuel $fuel - set fuel 0 - } else { - set fuel [expr {$fuel-$dfuel}] - } - if { $dfuel <= 0} { - set thrust_mag 0.0 - set fuel 0.0 - } else { - set mass [expr {$mass-$dfuel}] - set thrust [::vector::scale $direction [expr {$dfuel * $fuel_energy_release/$mass}] 0] - } - } - #puts [list f: $fuel $fuel_burn_rate $thrust] - set acceleration [vector::add [vector::scale $g $::dT] $thrust] - set velocity [vector::add $velocity $acceleration] - set position [vector::add $position [::vector::scale $velocity $::dT]] -} - -set ::dT 0.1 -for {set step 0} {$step < 2000} {incr step} { - set state [$n physics with $pscript] - dict with state {} - set t [expr {$step*$::dT}] - #puts [list [expr {$t/10.0}] x $position v $velocity a $acceleration m $mass m/f $fuel t $thrust $direction] - set plot_position($t) $position - if {[lindex $position 1] < 0} break -} - -set minx 1e10 -set maxx -1e10 -set miny 1e10 -set maxy -1e10 - -foreach {t pos} [array get plot_position] { - foreach {x y z} $pos {} - if { $x > $maxx } { set maxx $x } - if { $x < $minx } { set minx $x } - if { $y > $maxy } { set maxy $y } - if { $y < $miny } { set miny $x } -} -set fout [open rocket.csv w] -puts $fout [::csv::join {t x y}] -foreach t [lsort -real [array names plot_position]] { - # If you want to crash tcl use: - #lappend plotlist {*}[lrange $plot_position($t) 0 1] - - #lappend plotlist $t {*}[set lrange lrange; $lrange $plot_position($t) 0 1] - #lappend plotlist {*}[lrange [::vector::to_list $plot_position($t)] 0 1] - #$p plot main {*}[lrange [::vector::to_list $plot_position($t)] 0 1] - puts $fout [csv::join [list $t {*}[::vector::index $plot_position($t) 0 1]]] -} -close $fout DELETED example/tao-physics/rocket.tcl Index: example/tao-physics/rocket.tcl ================================================================== --- example/tao-physics/rocket.tcl +++ /dev/null @@ -1,136 +0,0 @@ -source [file normalize [file dirname [info script]]]/../../modules/tao-physics/index.tcl -package require Tk -package require Plotchart -tao::class rocket { - superclass physics::base - - property physics mass { - default 200 - units kg - } - - property physics fuel { - default 10 - units kg - } - - property physics fuel_burn_rate { - default 1 - units kg/s - } - - property physics fuel_energy_release { - default 10000 - units N/kg - } - - option world { - default {} - } - - constructor {objects args} { - foreach {item obj} $objects { - my graft $item $obj - } - my config set [::tao::args_to_options {*}$args] - my initialize - } - -} - -::physics::world create world - -set n [rocket new {world ::world}] -$n physics heading [::vector::scale {0 0 45} [::odiemath::m_pi_180]] -# -#exit -set pscript { - set g [my physics property gravity] - set thrust {0 0 0} - if {$fuel > 0} { - set dfuel [expr {$::dT * $fuel_burn_rate}] - if {$dfuel > $fuel} { - set dfuel $fuel - set fuel 0 - } else { - set fuel [expr {$fuel-$dfuel}] - } - if { $dfuel <= 0} { - set thrust_mag 0.0 - set fuel 0.0 - } else { - set mass [expr {$mass-$dfuel}] - set thrust [::vector::scale $direction [expr {$dfuel * $fuel_energy_release/$mass}] 0] - } - } - #puts [list f: $fuel $fuel_burn_rate $thrust] - set acceleration [vector::add [vector::scale $g $::dT] $thrust] - set velocity [vector::add $velocity $acceleration] - set position [vector::add $position [::vector::scale $velocity $::dT]] -} - -set ::dT 0.1 -for {set step 0} {$step < 2000} {incr step} { - set state [$n physics with $pscript] - dict with state {} - set t [expr {$step*$::dT}] - #puts [list [expr {$t/10.0}] x $position v $velocity a $acceleration m $mass m/f $fuel t $thrust $direction] - set plot_position($t) $position - if {[lindex $position 1] < 0} break -} - -set minx 1e10 -set maxx -1e10 -set miny 1e10 -set maxy -1e10 - -foreach {t pos} [array get plot_position] { - foreach {x y z} $pos {} - if { $x > $maxx } { set maxx $x } - if { $x < $minx } { set minx $x } - if { $y > $maxy } { set maxy $y } - if { $y < $miny } { set miny $x } -} - -canvas .plot -width 500 -height 500 -pack .plot - - -set p [::Plotchart::createXYPlot .plot [list $minx $maxx 10] [list $miny $maxy 10]] -foreach t [lsort -real [array names plot_position]] { - # If you want to crash tcl use: - #lappend plotlist {*}[lrange $plot_position($t) 0 1] - - #lappend plotlist $t {*}[set lrange lrange; $lrange $plot_position($t) 0 1] - #lappend plotlist {*}[lrange [::vector::to_list $plot_position($t)] 0 1] - #$p plot main {*}[lrange [::vector::to_list $plot_position($t)] 0 1] - - $p plot main {*}[::vector::index $plot_position($t) 0 1] -} - -puts done - -if 0 { - -foreach {lx ly lx} $plot_position(0.0) {} - -set scalex [expr {500/($maxx-$minx)}] -set scaley [expr {500/($maxy-$miny)}] -if { $scalex > $scaley } { - set scale $scaley -} else { - set scale $scalex -} - - - -foreach t [lsort -real [array names plot_position]] { - puts $t - puts [list $t $plot_position($t)] - foreach {x y z} $plot_position($t) {} - - .plot create oval [expr {($x-$minx)*$scale-1}] [expr {($maxy-$y)*$scale-1}] [expr {($x-$minx)*$scale+1}] [expr {($maxy-$y)*$scale+1}] -} -} -puts UPDATE -update Index: generic/rc4.tcl ================================================================== --- generic/rc4.tcl +++ generic/rc4.tcl @@ -1,493 +1,497 @@ -## -# Implementation of an RC4 codec for TCL. -# Includes a source code encryption/decryption system -### - -set here [file dirname [info script]] -my define set pkg_name rc4 -my define set pkg_vers 2.0 -my define set initfunc Rc4_Init -my define set output_c rc4.c -my define set autoload 1 - -my include {} -my include {} -my include {} -my include {} - -# 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 define 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())]] - } - set fout [open $pwdfile w] - puts $fout $curpwd - close $fout -} else { - set fin [open $pwdfile r] - set curpwd [string trim [read $fin]] - set keylen [string length $curpwd] - close $fin -} -# Write that password into a C function -set buffer {} -for {set idx 0} {$idx < $keylen} {incr idx} { - set cval [string index $curpwd $idx] - scan $cval %c ival - ::practcl::cputs buffer " keybuf\[$idx\] = $ival;" -} -::practcl::cputs buffer " keybuf\[$keylen\] = 0;" -::practcl::cputs buffer " return keybuf\;" - -my c_function {static char *rc4GetPwdKey(char *keybuf)} $buffer - -my code header { -/* -** An RC4 codec is an instance of the following structure. -*/ -typedef struct Rc4Codec Rc4Codec; -struct Rc4Codec { - unsigned char i, j; - unsigned char s[256]; -}; -static Tcl_WideInt next_random_number = 1; - -/* -** The characters used for HTTP base64 encoding. -*/ -static const unsigned char zBase[] = - "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~"; - -} - -my c_function {static void rc4_init(Rc4Codec *p, int nByte, unsigned char *pKey)} { - /* - ** Initialize an RC4 codec with the given key sequence. - */ - int k, l; - unsigned char i, j, t, *s; - i = j = p->i = p->j = 0; - s = p->s; - for(k=0; k<256; k++){ - s[k] = k; - } - l = 0; - for(k=0; k<256; k++){ - t = s[k]; - j += t + pKey[l++]; - if( l>=nByte ) l = 0; - s[k] = s[j]; - s[j] = t; - } - - /* Discard the first 1024 bytes of key stream to thwart the - ** Fluhrer-Mantin-Shamir attack. - */ - for(k=0; k<1024; k++){ - t = s[++i]; - j += t; - s[i] = s[j]; - s[j] = t; - } - p->j = j; -} - -my c_function {static void rc4_coder(Rc4Codec *p, int nByte, unsigned char *pData)} { - /* - ** Encode/Decode nBytes bytes of traffic using the given codec. - */ - register unsigned char ti, tj, i, j, *s; - s = p->s; - i = p->i; - j = p->j; - while( nByte-->0 ){ - ti = s[++i]; - j += ti; - tj = s[i] = s[j]; - s[j] = ti; - tj += ti; - *(pData++) ^= s[tj]; - } - p->i = i; - p->j = j; -} - -my c_function {static int CodecObjCmd( - void *pCodec, - Tcl_Interp *interp, - int objc, - Tcl_Obj *CONST objv[] -)} { - /* - ** Usage: NAME TEXT - ** - ** There is a separate TCL command created for each rc4 codec instance. - ** This is the implementation of that command. Apply the codec to the - ** input and return the results. - */ - unsigned char *data; - int nData; - Tcl_Obj *pResult; - if( objc!=2 ){ - Tcl_WrongNumArgs(interp, 2, objv, "TEXT"); - return TCL_ERROR; - } - data = Tcl_GetByteArrayFromObj(objv[1], &nData); - pResult = Tcl_NewByteArrayObj(data, nData); - data = Tcl_GetByteArrayFromObj(pResult, 0); - rc4_coder((Rc4Codec*)pCodec, nData, data); - Tcl_SetObjResult(interp, pResult); - return TCL_OK; -} - -my c_function {static void CodecDestructor(void *pCodec)} { - /* - ** Destructor for codec. - */ - Tcl_Free((char *)pCodec); -} - -my c_tclproc_raw ::rc4 { - /* - ** Usage: rc4 NAME PASSWORD - ** - ** Create a new rc4 codec called NAME and initialized using PASSWORD. - */ - Rc4Codec *pCodec; - const char *zName; - unsigned char *pKey; - int nKey; - - if( objc!=3 ){ - Tcl_WrongNumArgs(interp, 2, objv, "NAME PASSWORD"); - return TCL_ERROR; - } - zName = Tcl_GetStringFromObj(objv[1], 0); - pKey = Tcl_GetByteArrayFromObj(objv[2], &nKey); - pCodec = (Rc4Codec*)Tcl_Alloc( sizeof(*pCodec) ); - rc4_init(pCodec, nKey, pKey); - Tcl_CreateObjCommand(interp, zName, CodecObjCmd, pCodec, CodecDestructor); - return TCL_OK; -} - -my c_function {static char *encode64(const char *zData, int nData, int *pnOut)} { - /* - ** Encode a string using a base-64 encoding. - ** The encoding can be reversed using the decode64 function. - ** - ** Space to hold the result comes from Tcl_Alloc(). - */ - char *z64; - int i, n; - - if( nData<=0 ){ - nData = strlen(zData); - } - z64 = Tcl_Alloc( (nData*4)/3 + 6 ); - for(i=n=0; i+2>2) & 0x3f ]; - z64[n++] = zBase[ ((zData[i]<<4) & 0x30) | ((zData[i+1]>>4) & 0x0f) ]; - z64[n++] = zBase[ ((zData[i+1]<<2) & 0x3c) | ((zData[i+2]>>6) & 0x03) ]; - z64[n++] = zBase[ zData[i+2] & 0x3f ]; - } - if( i+1>2) & 0x3f ]; - z64[n++] = zBase[ ((zData[i]<<4) & 0x30) | ((zData[i+1]>>4) & 0x0f) ]; - z64[n++] = zBase[ ((zData[i+1]<<2) & 0x3c) ]; - }else if( i>2) & 0x3f ]; - z64[n++] = zBase[ ((zData[i]<<4) & 0x30) ]; - } - z64[n] = 0; - if( pnOut ) *pnOut = n; - return z64; -} - -my c_function {char *decode64(const char *z64, int n64, int *pnOut)} { - /* - ** This function treats its input as a base-64 string and returns the - ** decoded value of that string. Characters of input that are not - ** valid base-64 characters (such as spaces and newlines) are ignored. - ** - ** Space to hold the decoded string is obtained from Tcl_Alloc(). - */ - char *zData; - int i, j; - int a, b, c, d; - static int isInit = 0; - static int trans[128]; - - if( !isInit ){ - for(i=0; i<128; i++){ trans[i] = 0; } - for(i=0; zBase[i]; i++){ trans[zBase[i] & 0x7f] = i; } - isInit = 1; - } - if( n64<0 ){ - n64 = strlen(z64); - } - while( n64>0 && z64[n64-1]=='=' ) n64--; - zData = Tcl_Alloc( (n64*3)/4 + 4 ); - for(i=j=0; i+3>4) & 0x03); - zData[j++] = ((b<<4) & 0xf0) | ((c>>2) & 0x0f); - zData[j++] = ((c<<6) & 0xc0) | (d & 0x3f); - } - if( i+2>4) & 0x03); - zData[j++] = ((b<<4) & 0xf0) | ((c>>2) & 0x0f); - }else if( i+1>4) & 0x03); - } - zData[j] = 0; - if( pnOut ) *pnOut = j; - return zData; -} - -my c_function {static unsigned char randomByte(void)} { - char i; - /* RAND_MAX assumed to be 256 */ - char repeat=(next_random_number % 10)+2; - for(i=0;i252 ) nPasswd = 252; - memcpy(&zKey[4], zPasswd, nPasswd); - rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); - zIn = Tcl_GetStringFromObj(objv[2], &nIn); - zBuf = Tcl_Alloc( nIn + 5 ); - memcpy(zBuf, zKey, 4); - memcpy(&zBuf[4], zIn, nIn); - rc4_coder(&codec, nIn, (unsigned char*)&zBuf[4]); - zOut = encode64(zBuf, nIn+4, &nOut); - Tcl_SetObjResult(interp, Tcl_NewStringObj(zOut, nOut)); - Tcl_Free((char *)zOut); - Tcl_Free((char *)zBuf); - return TCL_OK; -} - -my c_tclproc_raw ::rc4decrypt { - /* - ** Usage: rc4decrypt PASSWORD CYPHERTEXT - ** - ** Decrypt CYPHERTEXT using PASSWORD and a nonce found at the beginning of - ** the cyphertext. The cyphertext is base64 encoded. - */ - const char *zPasswd; - int nPasswd; - char *zIn; - int nIn; - char *zOut; - int nOut; - char zKey[256]; - Rc4Codec codec; - - if( objc!=3 ){ - Tcl_WrongNumArgs(interp, 2, objv, "PASSWORD TEXT"); - return TCL_ERROR; - } - zPasswd = Tcl_GetStringFromObj(objv[1], &nPasswd); - zIn = Tcl_GetStringFromObj(objv[2], &nIn); - zOut = decode64(zIn, nIn, &nOut); - if( nOut<4 ){ - return TCL_OK; - } - memcpy(zKey, zOut, 4); - if( nPasswd>252 ) nPasswd = 252; - memcpy(&zKey[4], zPasswd, nPasswd); - rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); - rc4_coder(&codec, nOut-4, (unsigned char*)&zOut[4]); - Tcl_SetObjResult(interp, Tcl_NewStringObj(&zOut[4], nOut-4)); - Tcl_Free((char *)zOut); - return TCL_OK; -} - -my c_tclproc_raw ::source_encrypt { - /* - ** Usage: source_encrypt TEXT - ** - ** Encrypt TEXT using compiled in PASSWORD and a random nonce. Encode the result - ** as a single token using base64. - */ - char zPasswd[32]; - int nPasswd; - char *zIn; - int nIn; - char *zBuf; - char *zOut; - int nOut; - char zKey[256]; - Rc4Codec codec; - extern void sqliteRandomness(int,void*); - - if( objc!=2 ){ - Tcl_WrongNumArgs(interp, 2, objv, "TEXT"); - return TCL_ERROR; - } - rc4GetPwdKey(zPasswd); - nPasswd=strlen(zPasswd); - - rc4_randomness(4, zKey); - if( nPasswd>252 ) nPasswd = 252; - memcpy(&zKey[4], zPasswd, nPasswd); - rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); - zIn = Tcl_GetStringFromObj(objv[1], &nIn); - zBuf = Tcl_Alloc( nIn + 5 ); - memcpy(zBuf, zKey, 4); - memcpy(&zBuf[4], zIn, nIn); - rc4_coder(&codec, nIn, (unsigned char*)&zBuf[4]); - zOut = encode64(zBuf, nIn+4, &nOut); - Tcl_SetObjResult(interp, Tcl_NewStringObj(zOut, nOut)); - Tcl_Free((char *)zOut); - Tcl_Free((char *)zBuf); - return TCL_OK; -} - -if 0 { -# Here is a decrypt function, but we don't normally express it -# as it would allow a crafty fellow to reduce to cleartext all -# any of the code we spent so much time ecrypting -my c_tclproc_raw ::source_decrypt { - /* - ** Usage: source_decrypt CYPHERTEXT - ** - ** Decrypt CYPHERTEXT using compiled in PASSWORD and a nonce - ** found at the beginning of - ** the cyphertext. The cyphertext is base64 encoded. - */ - char zPasswd[32]; - int nPasswd; - char *zIn; - int nIn; - char *zOut; - int nOut; - char zKey[256]; - Rc4Codec codec; - - if( objc!=2 ){ - Tcl_WrongNumArgs(interp, 2, objv, "TEXT"); - return TCL_ERROR; - } - rc4GetPwdKey(zPasswd); - nPasswd=strlen(zPasswd); - - zIn = Tcl_GetStringFromObj(objv[1], &nIn); - zOut = decode64(zIn, nIn, &nOut); - if( nOut<4 ){ - return TCL_OK; - } - memcpy(zKey, zOut, 4); - if( nPasswd>252 ) nPasswd = 252; - memcpy(&zKey[4], zPasswd, nPasswd); - rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); - rc4_coder(&codec, nOut-4, (unsigned char*)&zOut[4]); - Tcl_SetObjResult(interp, Tcl_NewStringObj(&zOut[4], nOut-4)); - Tcl_Free((char *)zOut); - return TCL_OK; -} -} - -my c_tclproc_raw ::eval_decrypt { - /* - ** Usage: eval_decrypt CYPHERTEXT - ** - ** Decrypt CYPHERTEXT using compiled in PASSWORD and a nonce - ** found at the beginning of - ** the cyphertext. The cyphertext is base64 encoded. - */ - char zPasswd[32]; - int nPasswd; - char *zIn; - int nIn; - char *zOut; - int nOut; - char zKey[256]; - Rc4Codec codec; - Tcl_Obj *cleartext; - int code=TCL_OK; - - if( objc!=2 ){ - Tcl_WrongNumArgs(interp, 2, objv, "TEXT"); - return TCL_ERROR; - } - rc4GetPwdKey(zPasswd); - nPasswd=strlen(zPasswd); - - zIn = Tcl_GetStringFromObj(objv[1], &nIn); - zOut = decode64(zIn, nIn, &nOut); - if( nOut<4 ){ - return TCL_OK; - } - memcpy(zKey, zOut, 4); - if( nPasswd>252 ) nPasswd = 252; - memcpy(&zKey[4], zPasswd, nPasswd); - rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); - rc4_coder(&codec, nOut-4, (unsigned char*)&zOut[4]); - cleartext=Tcl_NewStringObj(&zOut[4], nOut-4); - Tcl_IncrRefCount(cleartext); - code=Tcl_EvalObj(interp,cleartext); - Tcl_DecrRefCount(cleartext); - Tcl_Free((char *)zOut); - return code; +## +# Implementation of an RC4 codec for TCL. +# Includes a source code encryption/decryption system +### + +set here [file dirname [info script]] +my define set pkg_name rc4 +my define set pkg_vers 2.0 +my define set initfunc Rc4_Init +my define set output_c rc4.c +my define set autoload 1 + +my include {} +my include {} +my include {} +my include {} + +# 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 define 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())]] + } + set fout [open $pwdfile w] + puts $fout $curpwd + close $fout +} else { + set fin [open $pwdfile r] + set curpwd [string trim [read $fin]] + set keylen [string length $curpwd] + close $fin +} +# Write that password into a C function +set buffer {} +for {set idx 0} {$idx < $keylen} {incr idx} { + set cval [string index $curpwd $idx] + scan $cval %c ival + ::practcl::cputs buffer " keybuf\[$idx\] = $ival;" +} +::practcl::cputs buffer " keybuf\[$keylen\] = 0;" +::practcl::cputs buffer " return keybuf\;" + +my c_function {static char *rc4GetPwdKey(char *keybuf)} $buffer + +my code header { +/* +** An RC4 codec is an instance of the following structure. +*/ +typedef struct Rc4Codec Rc4Codec; +struct Rc4Codec { + unsigned char i, j; + unsigned char s[256]; +}; +static Tcl_WideInt next_random_number = 1; + +/* +** The characters used for HTTP base64 encoding. +*/ +static const unsigned char zBase[] = + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~"; + +} + +my c_function {static void rc4_init(Rc4Codec *p, int nByte, unsigned char *pKey)} { + /* + ** Initialize an RC4 codec with the given key sequence. + */ + int k, l; + unsigned char i, j, t, *s; + i = j = p->i = p->j = 0; + s = p->s; + for(k=0; k<256; k++){ + s[k] = k; + } + l = 0; + for(k=0; k<256; k++){ + t = s[k]; + j += t + pKey[l++]; + if( l>=nByte ) l = 0; + s[k] = s[j]; + s[j] = t; + } + + /* Discard the first 1024 bytes of key stream to thwart the + ** Fluhrer-Mantin-Shamir attack. + */ + for(k=0; k<1024; k++){ + t = s[++i]; + j += t; + s[i] = s[j]; + s[j] = t; + } + p->j = j; +} + +my c_function {static void rc4_coder(Rc4Codec *p, int nByte, unsigned char *pData)} { + /* + ** Encode/Decode nBytes bytes of traffic using the given codec. + */ + register unsigned char ti, tj, i, j, *s; + s = p->s; + i = p->i; + j = p->j; + while( nByte-->0 ){ + ti = s[++i]; + j += ti; + tj = s[i] = s[j]; + s[j] = ti; + tj += ti; + *(pData++) ^= s[tj]; + } + p->i = i; + p->j = j; +} + +my c_function {static int CodecObjCmd( + void *pCodec, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[] +)} { + /* + ** Usage: NAME TEXT + ** + ** There is a separate TCL command created for each rc4 codec instance. + ** This is the implementation of that command. Apply the codec to the + ** input and return the results. + */ + unsigned char *data; + int nData; + Tcl_Obj *pResult; + if( objc!=2 ){ + Tcl_WrongNumArgs(interp, 2, objv, "TEXT"); + return TCL_ERROR; + } + data = Tcl_GetByteArrayFromObj(objv[1], &nData); + pResult = Tcl_NewByteArrayObj(data, nData); + data = Tcl_GetByteArrayFromObj(pResult, 0); + rc4_coder((Rc4Codec*)pCodec, nData, data); + Tcl_SetObjResult(interp, pResult); + return TCL_OK; +} + +my c_function {static void CodecDestructor(void *pCodec)} { + /* + ** Destructor for codec. + */ + Tcl_Free((char *)pCodec); +} + +my c_tclproc_raw ::rc4 { + /* + ** Usage: rc4 NAME PASSWORD + ** + ** Create a new rc4 codec called NAME and initialized using PASSWORD. + */ + Rc4Codec *pCodec; + const char *zName; + unsigned char *pKey; + int nKey; + + if( objc!=3 ){ + Tcl_WrongNumArgs(interp, 1, objv, "NAME PASSWORD"); + return TCL_ERROR; + } + zName = Tcl_GetStringFromObj(objv[1], 0); + pKey = Tcl_GetByteArrayFromObj(objv[2], &nKey); + pCodec = (Rc4Codec*)Tcl_Alloc( sizeof(*pCodec) ); + rc4_init(pCodec, nKey, pKey); + Tcl_CreateObjCommand(interp, zName, CodecObjCmd, pCodec, CodecDestructor); + return TCL_OK; +} + +my c_function {static char *encode64(const char *zData, int nData, int *pnOut)} { + /* + ** Encode a string using a base-64 encoding. + ** The encoding can be reversed using the decode64 function. + ** + ** Space to hold the result comes from Tcl_Alloc(). + */ + char *z64; + int i, n; + + if( nData<=0 ){ + nData = strlen(zData); + } + z64 = Tcl_Alloc( (nData*4)/3 + 6 ); + for(i=n=0; i+2>2) & 0x3f ]; + z64[n++] = zBase[ ((zData[i]<<4) & 0x30) | ((zData[i+1]>>4) & 0x0f) ]; + z64[n++] = zBase[ ((zData[i+1]<<2) & 0x3c) | ((zData[i+2]>>6) & 0x03) ]; + z64[n++] = zBase[ zData[i+2] & 0x3f ]; + } + if( i+1>2) & 0x3f ]; + z64[n++] = zBase[ ((zData[i]<<4) & 0x30) | ((zData[i+1]>>4) & 0x0f) ]; + z64[n++] = zBase[ ((zData[i+1]<<2) & 0x3c) ]; + }else if( i>2) & 0x3f ]; + z64[n++] = zBase[ ((zData[i]<<4) & 0x30) ]; + } + z64[n] = 0; + if( pnOut ) *pnOut = n; + return z64; +} + +my c_function {char *decode64(const char *z64, int n64, int *pnOut)} { + /* + ** This function treats its input as a base-64 string and returns the + ** decoded value of that string. Characters of input that are not + ** valid base-64 characters (such as spaces and newlines) are ignored. + ** + ** Space to hold the decoded string is obtained from Tcl_Alloc(). + */ + char *zData; + int i, j; + int a, b, c, d; + static int isInit = 0; + static int trans[128]; + + if( !isInit ){ + for(i=0; i<128; i++){ trans[i] = 0; } + for(i=0; zBase[i]; i++){ trans[zBase[i] & 0x7f] = i; } + isInit = 1; + } + if( n64<0 ){ + n64 = strlen(z64); + } + while( n64>0 && z64[n64-1]=='=' ) n64--; + zData = Tcl_Alloc( (n64*3)/4 + 4 ); + for(i=j=0; i+3>4) & 0x03); + zData[j++] = ((b<<4) & 0xf0) | ((c>>2) & 0x0f); + zData[j++] = ((c<<6) & 0xc0) | (d & 0x3f); + } + if( i+2>4) & 0x03); + zData[j++] = ((b<<4) & 0xf0) | ((c>>2) & 0x0f); + }else if( i+1>4) & 0x03); + } + zData[j] = 0; + if( pnOut ) *pnOut = j; + return zData; +} + +my c_function {static unsigned char randomByte(void)} { + char i; + /* RAND_MAX assumed to be 256 */ + char repeat=(next_random_number % 10)+2; + for(i=0;i252 ) nPasswd = 252; + memcpy(&zKey[4], zPasswd, nPasswd); + rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); + zIn = Tcl_GetStringFromObj(objv[2], &nIn); + zBuf = Tcl_Alloc( nIn + 5 ); + memcpy(zBuf, zKey, 4); + memcpy(&zBuf[4], zIn, nIn); + rc4_coder(&codec, nIn, (unsigned char*)&zBuf[4]); + zOut = encode64(zBuf, nIn+4, &nOut); + Tcl_SetObjResult(interp, Tcl_NewStringObj(zOut, nOut)); + Tcl_Free((char *)zOut); + Tcl_Free((char *)zBuf); + return TCL_OK; +} + +my c_tclproc_raw ::rc4decrypt { + /* + ** Usage: rc4decrypt PASSWORD CYPHERTEXT + ** + ** Decrypt CYPHERTEXT using PASSWORD and a nonce found at the beginning of + ** the cyphertext. The cyphertext is base64 encoded. + */ + const char *zPasswd; + int nPasswd; + char *zIn; + int nIn; + char *zOut; + int nOut; + char zKey[256]; + Rc4Codec codec; + + if( objc!=3 ){ + Tcl_WrongNumArgs(interp, 2, objv, "PASSWORD TEXT"); + return TCL_ERROR; + } + zPasswd = Tcl_GetStringFromObj(objv[1], &nPasswd); + zIn = Tcl_GetStringFromObj(objv[2], &nIn); + zOut = decode64(zIn, nIn, &nOut); + if( nOut<4 ){ + return TCL_OK; + } + memcpy(zKey, zOut, 4); + if( nPasswd>252 ) nPasswd = 252; + memcpy(&zKey[4], zPasswd, nPasswd); + rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); + rc4_coder(&codec, nOut-4, (unsigned char*)&zOut[4]); + Tcl_SetObjResult(interp, Tcl_NewStringObj(&zOut[4], nOut-4)); + Tcl_Free((char *)zOut); + return TCL_OK; +} + +my c_tclproc_raw ::source_encrypt { + /* + ** Usage: source_encrypt TEXT + ** + ** Encrypt TEXT using compiled in PASSWORD and a random nonce. Encode the result + ** as a single token using base64. + */ + char zPasswd[32]; + int nPasswd; + char *zIn; + int nIn; + char *zBuf; + char *zOut; + int nOut; + char zKey[256]; + Rc4Codec codec; + extern void sqliteRandomness(int,void*); + + if( objc!=2 ){ + Tcl_WrongNumArgs(interp, 2, objv, "TEXT"); + return TCL_ERROR; + } + rc4GetPwdKey(zPasswd); + nPasswd=strlen(zPasswd); + + rc4_randomness(4, zKey); + if( nPasswd>252 ) nPasswd = 252; + memcpy(&zKey[4], zPasswd, nPasswd); + rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); + zIn = Tcl_GetStringFromObj(objv[1], &nIn); + zBuf = Tcl_Alloc( nIn + 5 ); + memcpy(zBuf, zKey, 4); + memcpy(&zBuf[4], zIn, nIn); + rc4_coder(&codec, nIn, (unsigned char*)&zBuf[4]); + zOut = encode64(zBuf, nIn+4, &nOut); + Tcl_SetObjResult(interp, Tcl_NewStringObj(zOut, nOut)); + Tcl_Free((char *)zOut); + Tcl_Free((char *)zBuf); + return TCL_OK; +} + +if 0 { +# Here is a decrypt function, but we don't normally express it +# as it would allow a crafty fellow to reduce to cleartext all +# any of the code we spent so much time ecrypting +my c_tclproc_raw ::source_decrypt { + /* + ** Usage: source_decrypt CYPHERTEXT + ** + ** Decrypt CYPHERTEXT using compiled in PASSWORD and a nonce + ** found at the beginning of + ** the cyphertext. The cyphertext is base64 encoded. + */ + char zPasswd[32]; + int nPasswd; + char *zIn; + int nIn; + char *zOut; + int nOut; + char zKey[256]; + Rc4Codec codec; + + if( objc!=2 ){ + Tcl_WrongNumArgs(interp, 2, objv, "TEXT"); + return TCL_ERROR; + } + rc4GetPwdKey(zPasswd); + nPasswd=strlen(zPasswd); + + zIn = Tcl_GetStringFromObj(objv[1], &nIn); + zOut = decode64(zIn, nIn, &nOut); + if( nOut<4 ){ + return TCL_OK; + } + memcpy(zKey, zOut, 4); + if( nPasswd>252 ) nPasswd = 252; + memcpy(&zKey[4], zPasswd, nPasswd); + rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); + rc4_coder(&codec, nOut-4, (unsigned char*)&zOut[4]); + Tcl_SetObjResult(interp, Tcl_NewStringObj(&zOut[4], nOut-4)); + Tcl_Free((char *)zOut); + return TCL_OK; +} +} + +my c_tclproc_raw ::eval_decrypt { + /* + ** Usage: eval_decrypt CYPHERTEXT + ** + ** Decrypt CYPHERTEXT using compiled in PASSWORD and a nonce + ** found at the beginning of + ** the cyphertext. The cyphertext is base64 encoded. + */ + char zPasswd[32]; + int nPasswd; + char *zIn; + int nIn; + char *zOut; + int nOut; + char zKey[256]; + Rc4Codec codec; + Tcl_Obj *cleartext; + int code=TCL_OK; + + if( objc!=2 ){ + Tcl_WrongNumArgs(interp, 2, objv, "TEXT"); + return TCL_ERROR; + } + rc4GetPwdKey(zPasswd); + nPasswd=strlen(zPasswd); + + zIn = Tcl_GetStringFromObj(objv[1], &nIn); + zOut = decode64(zIn, nIn, &nOut); + if( nOut<4 ){ + return TCL_OK; + } + memcpy(zKey, zOut, 4); + if( nPasswd>252 ) nPasswd = 252; + memcpy(&zKey[4], zPasswd, nPasswd); + rc4_init(&codec, nPasswd+4, (unsigned char*)zKey); + rc4_coder(&codec, nOut-4, (unsigned char*)&zOut[4]); + cleartext=Tcl_NewStringObj(&zOut[4], nOut-4); + Tcl_IncrRefCount(cleartext); + code=Tcl_EvalObj(interp,cleartext); + Tcl_DecrRefCount(cleartext); + Tcl_Free((char *)zOut); + return code; +} + +my c_tclproc_raw ::noop { + return TCL_OK; } Index: generic/toadkit.h ================================================================== --- generic/toadkit.h +++ generic/toadkit.h @@ -27,11 +27,11 @@ */ #define STATIC_BUILD 1 #undef USE_TCL_STUBS #define TOADKIT_INIT "main.tcl" -#define TOADKIT_VFSMOUNT "/zvfs" +#define TOADKIT_VFSMOUNT "zipfs:/app" /* Make sure the stubbed variants of those are never used. */ #undef Tcl_ObjSetVar2 #undef Tcl_NewStringObj #undef Tk_Init Index: generic/zvfsboot.c ================================================================== --- generic/zvfsboot.c +++ generic/zvfsboot.c @@ -8,11 +8,11 @@ ** Boot a shell, mount the executable's VFS, detect main.tcl */ int Tcl_Zvfs_Boot(const char *archive,const char *vfsmountpoint,const char *initscript) { Tclzipfs_Init(NULL); if(!vfsmountpoint) { - vfsmountpoint="/zvfs"; + vfsmountpoint=TOADKIT_VFSMOUNT; } if(!initscript) { initscript="main.tcl"; } /* We have to initialize the virtual filesystem before calling DELETED install-sh Index: install-sh ================================================================== --- install-sh +++ /dev/null @@ -1,528 +0,0 @@ -#!/bin/sh -# install - install a program, script, or datafile - -scriptversion=2011-04-20.01; # UTC - -# This originates from X11R5 (mit/util/scripts/install.sh), which was -# later released in X11R6 (xc/config/util/install.sh) with the -# following copyright and license. -# -# Copyright (C) 1994 X Consortium -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN -# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- -# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -# -# Except as contained in this notice, the name of the X Consortium shall not -# be used in advertising or otherwise to promote the sale, use or other deal- -# ings in this Software without prior written authorization from the X Consor- -# tium. -# -# -# FSF changes to this file are in the public domain. -# -# Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it -# when there is no Makefile. -# -# This script is compatible with the BSD install script, but was written -# from scratch. - -nl=' -' -IFS=" "" $nl" - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit=${DOITPROG-} -if test -z "$doit"; then - doit_exec=exec -else - doit_exec=$doit -fi - -# Put in absolute file names if you don't have them in your path; -# or use environment vars. - -chgrpprog=${CHGRPPROG-chgrp} -chmodprog=${CHMODPROG-chmod} -chownprog=${CHOWNPROG-chown} -cmpprog=${CMPPROG-cmp} -cpprog=${CPPROG-cp} -mkdirprog=${MKDIRPROG-mkdir} -mvprog=${MVPROG-mv} -rmprog=${RMPROG-rm} -stripprog=${STRIPPROG-strip} - -posix_glob='?' -initialize_posix_glob=' - test "$posix_glob" != "?" || { - if (set -f) 2>/dev/null; then - posix_glob= - else - posix_glob=: - fi - } -' - -posix_mkdir= - -# Desired mode of installed file. -mode=0755 - -chgrpcmd= -chmodcmd=$chmodprog -chowncmd= -mvcmd=$mvprog -rmcmd="$rmprog -f" -stripcmd= - -src= -dst= -dir_arg= -dst_arg= - -copy_on_change=false -no_target_directory= - -usage="\ -Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE - or: $0 [OPTION]... SRCFILES... DIRECTORY - or: $0 [OPTION]... -t DIRECTORY SRCFILES... - or: $0 [OPTION]... -d DIRECTORIES... - -In the 1st form, copy SRCFILE to DSTFILE. -In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. -In the 4th, create DIRECTORIES. - -Options: - --help display this help and exit. - --version display version info and exit. - - -c (ignored) - -C install only if different (preserve the last data modification time) - -d create directories instead of installing files. - -g GROUP $chgrpprog installed files to GROUP. - -m MODE $chmodprog installed files to MODE. - -o USER $chownprog installed files to USER. - -s $stripprog installed files. - -S $stripprog installed files. - -t DIRECTORY install into DIRECTORY. - -T report an error if DSTFILE is a directory. - -Environment variables override the default commands: - CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG - RMPROG STRIPPROG -" - -while test $# -ne 0; do - case $1 in - -c) ;; - - -C) copy_on_change=true;; - - -d) dir_arg=true;; - - -g) chgrpcmd="$chgrpprog $2" - shift;; - - --help) echo "$usage"; exit $?;; - - -m) mode=$2 - case $mode in - *' '* | *' '* | *' -'* | *'*'* | *'?'* | *'['*) - echo "$0: invalid mode: $mode" >&2 - exit 1;; - esac - shift;; - - -o) chowncmd="$chownprog $2" - shift;; - - -s) stripcmd=$stripprog;; - - -S) stripcmd="$stripprog $2" - shift;; - - -t) dst_arg=$2 - shift;; - - -T) no_target_directory=true;; - - --version) echo "$0 $scriptversion"; exit $?;; - - --) shift - break;; - - -*) echo "$0: invalid option: $1" >&2 - exit 1;; - - *) break;; - esac - shift -done - -if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then - # When -d is used, all remaining arguments are directories to create. - # When -t is used, the destination is already specified. - # Otherwise, the last argument is the destination. Remove it from $@. - for arg - do - if test -n "$dst_arg"; then - # $@ is not empty: it contains at least $arg. - set fnord "$@" "$dst_arg" - shift # fnord - fi - shift # arg - dst_arg=$arg - done -fi - -if test $# -eq 0; then - if test -z "$dir_arg"; then - echo "$0: no input file specified." >&2 - exit 1 - fi - # It's OK to call `install-sh -d' without argument. - # This can happen when creating conditional directories. - exit 0 -fi - -if test -z "$dir_arg"; then - do_exit='(exit $ret); exit $ret' - trap "ret=129; $do_exit" 1 - trap "ret=130; $do_exit" 2 - trap "ret=141; $do_exit" 13 - trap "ret=143; $do_exit" 15 - - # Set umask so as not to create temps with too-generous modes. - # However, 'strip' requires both read and write access to temps. - case $mode in - # Optimize common cases. - *644) cp_umask=133;; - *755) cp_umask=22;; - - *[0-7]) - if test -z "$stripcmd"; then - u_plus_rw= - else - u_plus_rw='% 200' - fi - cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; - *) - if test -z "$stripcmd"; then - u_plus_rw= - else - u_plus_rw=,u+rw - fi - cp_umask=$mode$u_plus_rw;; - esac -fi - -for src -do - # Protect names starting with `-'. - case $src in - -*) src=./$src;; - esac - - if test -n "$dir_arg"; then - dst=$src - dstdir=$dst - test -d "$dstdir" - dstdir_status=$? - else - - # Waiting for this to be detected by the "$cpprog $src $dsttmp" command - # might cause directories to be created, which would be especially bad - # if $src (and thus $dsttmp) contains '*'. - if test ! -f "$src" && test ! -d "$src"; then - echo "$0: $src does not exist." >&2 - exit 1 - fi - - if test -z "$dst_arg"; then - echo "$0: no destination specified." >&2 - exit 1 - fi - - dst=$dst_arg - # Protect names starting with `-'. - case $dst in - -*) dst=./$dst;; - esac - - # If destination is a directory, append the input filename; won't work - # if double slashes aren't ignored. - if test -d "$dst"; then - if test -n "$no_target_directory"; then - echo "$0: $dst_arg: Is a directory" >&2 - exit 1 - fi - dstdir=$dst - dst=$dstdir/`basename "$src"` - dstdir_status=0 - else - # Prefer dirname, but fall back on a substitute if dirname fails. - dstdir=` - (dirname "$dst") 2>/dev/null || - expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$dst" : 'X\(//\)[^/]' \| \ - X"$dst" : 'X\(//\)$' \| \ - X"$dst" : 'X\(/\)' \| . 2>/dev/null || - echo X"$dst" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q' - ` - - test -d "$dstdir" - dstdir_status=$? - fi - fi - - obsolete_mkdir_used=false - - if test $dstdir_status != 0; then - case $posix_mkdir in - '') - # Create intermediate dirs using mode 755 as modified by the umask. - # This is like FreeBSD 'install' as of 1997-10-28. - umask=`umask` - case $stripcmd.$umask in - # Optimize common cases. - *[2367][2367]) mkdir_umask=$umask;; - .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; - - *[0-7]) - mkdir_umask=`expr $umask + 22 \ - - $umask % 100 % 40 + $umask % 20 \ - - $umask % 10 % 4 + $umask % 2 - `;; - *) mkdir_umask=$umask,go-w;; - esac - - # With -d, create the new directory with the user-specified mode. - # Otherwise, rely on $mkdir_umask. - if test -n "$dir_arg"; then - mkdir_mode=-m$mode - else - mkdir_mode= - fi - - posix_mkdir=false - case $umask in - *[123567][0-7][0-7]) - # POSIX mkdir -p sets u+wx bits regardless of umask, which - # is incompatible with FreeBSD 'install' when (umask & 300) != 0. - ;; - *) - tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ - trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 - - if (umask $mkdir_umask && - exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 - then - if test -z "$dir_arg" || { - # Check for POSIX incompatibilities with -m. - # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or - # other-writeable bit of parent directory when it shouldn't. - # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. - ls_ld_tmpdir=`ls -ld "$tmpdir"` - case $ls_ld_tmpdir in - d????-?r-*) different_mode=700;; - d????-?--*) different_mode=755;; - *) false;; - esac && - $mkdirprog -m$different_mode -p -- "$tmpdir" && { - ls_ld_tmpdir_1=`ls -ld "$tmpdir"` - test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" - } - } - then posix_mkdir=: - fi - rmdir "$tmpdir/d" "$tmpdir" - else - # Remove any dirs left behind by ancient mkdir implementations. - rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null - fi - trap '' 0;; - esac;; - esac - - if - $posix_mkdir && ( - umask $mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" - ) - then : - else - - # The umask is ridiculous, or mkdir does not conform to POSIX, - # or it failed possibly due to a race condition. Create the - # directory the slow way, step by step, checking for races as we go. - - case $dstdir in - /*) prefix='/';; - -*) prefix='./';; - *) prefix='';; - esac - - eval "$initialize_posix_glob" - - oIFS=$IFS - IFS=/ - $posix_glob set -f - set fnord $dstdir - shift - $posix_glob set +f - IFS=$oIFS - - prefixes= - - for d - do - test -z "$d" && continue - - prefix=$prefix$d - if test -d "$prefix"; then - prefixes= - else - if $posix_mkdir; then - (umask=$mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break - # Don't fail if two instances are running concurrently. - test -d "$prefix" || exit 1 - else - case $prefix in - *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; - *) qprefix=$prefix;; - esac - prefixes="$prefixes '$qprefix'" - fi - fi - prefix=$prefix/ - done - - if test -n "$prefixes"; then - # Don't fail if two instances are running concurrently. - (umask $mkdir_umask && - eval "\$doit_exec \$mkdirprog $prefixes") || - test -d "$dstdir" || exit 1 - obsolete_mkdir_used=true - fi - fi - fi - - if test -n "$dir_arg"; then - { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && - { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && - { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || - test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 - else - - # Make a couple of temp file names in the proper directory. - dsttmp=$dstdir/_inst.$$_ - rmtmp=$dstdir/_rm.$$_ - - # Trap to clean up those temp files at exit. - trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 - - # Copy the file name to the temp name. - (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && - - # and set any options; do chmod last to preserve setuid bits. - # - # If any of these fail, we abort the whole thing. If we want to - # ignore errors from any of these, just make sure not to ignore - # errors from the above "$doit $cpprog $src $dsttmp" command. - # - { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && - { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && - { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && - { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && - - # If -C, don't bother to copy if it wouldn't change the file. - if $copy_on_change && - old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && - new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && - - eval "$initialize_posix_glob" && - $posix_glob set -f && - set X $old && old=:$2:$4:$5:$6 && - set X $new && new=:$2:$4:$5:$6 && - $posix_glob set +f && - - test "$old" = "$new" && - $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 - then - rm -f "$dsttmp" - else - # Rename the file to the real destination. - $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || - - # The rename failed, perhaps because mv can't rename something else - # to itself, or perhaps because mv is so ancient that it does not - # support -f. - { - # Now remove or move aside any old file at destination location. - # We try this two ways since rm can't unlink itself on some - # systems and the destination file might be busy for other - # reasons. In this case, the final cleanup might fail but the new - # file should still install successfully. - { - test ! -f "$dst" || - $doit $rmcmd -f "$dst" 2>/dev/null || - { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && - { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } - } || - { echo "$0: cannot unlink or rename $dst" >&2 - (exit 1); exit 1 - } - } && - - # Now rename the file to the real destination. - $doit $mvcmd "$dsttmp" "$dst" - } - fi || exit 1 - - trap '' 0 - fi -done - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "scriptversion=" -# time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" -# time-stamp-end: "; # UTC" -# End: Index: make.tcl ================================================================== --- make.tcl +++ make.tcl @@ -8,83 +8,102 @@ # * (several .c and .h files) - C sources that are generated on the fly by automation ### # Ad a "just in case" version or practcl we ship locally set ::CWD [pwd] -set ::project(builddir) $::CWD -set ::project(srcdir) [file dirname [file normalize [info script]]] -set ::project(sandbox) [file dirname $::project(srcdir)] -set ::project(download) [file join $::project(sandbox) download] -set ::project(teapot) [file join $::project(sandbox) teapot] -if {[file exists [file join $::project(sandbox) tclconfig practcl.tcl]]} { - source [file join $::project(sandbox) tclconfig practcl.tcl] +set ::SRCDIR [file dirname [file normalize [info script]]] +set ::SANDBOX [file dirname $::SRCDIR] + +if {[file exists [file join $::SRCDIR .. tclconfig practcl.tcl]]} { + source [file join $::SRCDIR .. tclconfig practcl.tcl] } else { - source [file join $::project(srcdir) tclconfig practcl.tcl] + source [file join $::SRCDIR tclconfig practcl.tcl] } -array set ::project [::practcl::config.tcl $CWD] -set SRCPATH $::project(srcdir) -set SANDBOX $::project(sandbox) +set ::practcl::CONFIG(sandbox) $::SANDBOX + file mkdir $CWD/build -::practcl::target autoconf { - triggers {} -} +set ::CWD [pwd] +::practcl::tclkit create BASEKIT [::practcl::config.tcl $CWD] +BASEKIT define set sandbox $::SANDBOX +BASEKIT define set name toadkit +BASEKIT define set name toadkit +BASEKIT define set version 8.6.5 +BASEKIT define set localpath toadkit +BASEKIT define set profile devel +BASEKIT define set prefix /zvfs +BASEKIT define set installdir [file join $::CWD PKGROOT] +BASEKIT define set USEMSVC [info exists env(VisualStudioVersion)] +BASEKIT define set prefix_broken_destdir [file join $::SANDBOX tmp] +BASEKIT define set tclkit_bare [file join $CWD tclkit_bare[BASEKIT define get EXEEXT]] +BASEKIT define set output_c toadkit.c +BASEKIT define set libs {} +BASEKIT source [file join $::SRCDIR basekit.ini] + ::practcl::target tcltk { - depends deps + depends {deps configure} triggers {script-packages script-pkgindex} + filename [file join $CWD config.tcl] } ::practcl::target basekit { depends {deps tcltk} triggers {} - filename [file join $CWD tclkit_bare$::project(EXEEXT)] + filename [file join $CWD [BASEKIT define get tclkit_bare]] } ::practcl::target packages { depends {deps tcltk} } +::practcl::target toadkit { + aliases example + depends {deps tcltk basekit packages} +} ::practcl::target distclean {} switch [lindex $argv 0] { - autoconf - - pre - - deps { - ::practcl::trigger autoconf - } os { puts "OS: [practcl::os]" - parray ::project + foreach {var val} [::practcl::local_os] { + puts "${var}: $val" + } + #parray ::project + exit 0 + } + info { + puts "OS: [practcl::os]" + foreach {var val} [::practcl::local_os] { + puts "${var}: $val" + } + puts *** + foreach item [BASEKIT link list core.library] { + puts " [list PACKAGE [$item define get name]]" + foreach {f v} [$item define dump] { + puts " $f: $v" + } + } + foreach item [BASEKIT link list package] { + puts " [list PACKAGE [$item define get name]]" + foreach {f v} [$item define dump] { + puts " $f: $v" + } + } exit 0 } wrap { ::practcl::depends basekit } all { # Auto detect missing bits - foreach {item obj} $::make_objects { - if {[$obj check]} { - $obj trigger - } - } + ::practcl::trigger toadkit } package { ::practcl::trigger packages } default { ::practcl::trigger {*}$argv } } -parray make - -set ::CWD [pwd] -::practcl::tclkit create BASEKIT {} -BASEKIT define set name toadkit -BASEKIT define set pkg_name toadkit -BASEKIT define set pkg_version 8.6.5 -BASEKIT define set localpath toadkit -BASEKIT define set profile devel -BASEKIT source [file join $::project(srcdir) basekit.ini] - if {$make(distclean)} { # Clean all source code back to it's pristine state from fossil foreach item [BASEKIT link list package] { $item go set projdir [$item define get localsrcdir] @@ -92,87 +111,70 @@ fossil $projdir clean -force } } } -if {$make(autoconf)} { - BASEKIT implement $CWD -} - -file mkdir [file join $CWD build] - -if {0} { - file mkdir $::project(download) - foreach item [BASEKIT link core.library] { - $item unpack - } - foreach item [BASEKIT link package] { - $item unpack - } - cd $::project(srcdir) - catch {doexec autoconf -f} - cd $CWD - set fout [open $target(deps) w] - puts $fout [clock format [clock seconds]] - close $fout -} - -if {$make(tcltk)} { - ### - # Download our required packages - ### - set tcl_config_opts {} - set tk_config_opts {} - switch [::practcl::os] { - windows { - #lappend tcl_config_opts --disable-stubs - } - linux { - lappend tk_config_opts --enable-xft=no --enable-xss=no - } - macosx { - lappend tcl_config_opts --enable-corefoundation=yes --enable-framework=no - lappend tk_config_opts --enable-aqua=yes - } - } - lappend tcl_config_opts --with-tzdata --prefix [BASEKIT define get prefix] - BASEKIT.TCLCORE define set config_opts $tcl_config_opts - BASEKIT.TCLCORE go - set _TclSrcDir [BASEKIT.TCLCORE define get localsrcdir] - BASEKIT define set tclsrcdir $_TclSrcDir - lappend tk_config_opts --with-tcl=$_TclSrcDir - BASEKIT.TKCORE define set config_opts $tk_config_opts - BASEKIT.TCLCORE compile - BASEKIT.TKCORE compile +file mkdir [file join $CWD build] + +if {$make(tcltk)} { + set os [BASEKIT define get TEACUP_OS] + set tcl_config_opts [::practcl::platform::tcl_core_options $os] + set tk_config_opts [::practcl::platform::tk_core_options $os] + + lappend tcl_config_opts --prefix [BASEKIT define get prefix] + BASEKIT project TCLCORE define set config_opts $tcl_config_opts + BASEKIT project TCLCORE go + BASEKIT project TCLCORE compile + + set _TclSrcDir [BASEKIT project TCLCORE define get localsrcdir] + BASEKIT define set tclsrcdir $_TclSrcDir + lappend tk_config_opts --with-tcl=$_TclSrcDir + BASEKIT project tk define set config_opts $tk_config_opts + BASEKIT project tk compile +} + +if {[lindex $argv 0] eq "package"} { + #set result {} + set INSTALLDIR [BASEKIT define get installdir] + foreach item [lrange $argv 1 end] { + set obj [BASEKIT project $item] + puts [list build $item [$obj define get static] [info object class $obj]] + if {[string is true [$obj define get static]]} { + $obj compile + } + if {[string is true [$obj define get vfsinstall]]} { + $obj install $INSTALLDIR + } + } + #puts "RESULT: $result" +} elseif {$make(packages)} { + set INSTALLDIR [BASEKIT define get installdir] + foreach item [BASEKIT link list package] { + puts [list GENERATING $item [$item define get srcdir]] + if {[string is true [$item define get static 0]]} { + $item compile + } + if {[string is true [$item define get vfsinstall 1]]} { + $item install $INSTALLDIR + } + } } if {$make(basekit)} { - set pkg_objs {} - foreach item [BASEKIT link list package] { - if {[string is true [$item define get static]]} { - lappend pkg_objs $item - } - } - ::practcl::build::static-tclsh $target(basekit) BASEKIT BASEKIT.TCLCORE BASEKIT.TKCORE $pkg_objs -} - -if {[lindex $argv 0] eq "package"} { - set result {} - foreach item [lrange $argv 1 end] { - if {[string is true [PKG.$item define get static]]} { - lappend result {*}[PKG.$item linker-products] - } else { - PKG.$item install-vfs - } - } - puts "RESULT: $result" -} elseif {$make(packages)} { - foreach item [BASEKIT link list package] { - if {[string is true [$item define get vfsinstall]]} { - $item install-vfs - } - } + BASEKIT implement $CWD + if {![file exists [file join $CWD make.tcl]]} { + set fout [open [file join $CWD make.tcl] w] + puts $fout [list source [file join $::SRCDIR make.tcl]] + close $fout + } + BASEKIT build-tclsh $target(basekit) BASEKIT } if {[lindex $argv 0] eq "wrap"} { BASEKIT wrap $CWD {*}[lrange $argv 1 end] } +if {$make(toadkit)} { + file mkdir [file join $CWD toadkit.vfs] + BASEKIT wrap $CWD toadkit [file join $CWD toadkit.vfs] [file join $CWD PKGROOT] + +} + DELETED odie.m4 Index: odie.m4 ================================================================== --- odie.m4 +++ /dev/null @@ -1,1237 +0,0 @@ -#--- -# Set up odie environment -#-- -AC_DEFUN([SC_ODIE], [ - ### - # Gather and store information about the local OS - ### - VFS_CP="cp -a" - ODIE_SRC_DIR=`pwd` - ODIE_BINARY_PLATFORM="unknown" - ODIE_TEA_CONFIG_FLAGS="" - case "`uname -s`" in - *win32*|*WIN32*|*MINGW32_*) - AC_CHECK_PROG(CYGPATH, cygpath, cygpath -w, echo) - EXEEXT=".exe" - ODIE_PLATFORM="windows" - ODIE_SRC_DIR=`pwd -W` - VFS_CP="cp -a --no-preserve=links" - ;; - *CYGWIN_*) - CYGPATH=echo - EXEEXT=".exe" - AC_MSG_CHECKING([platform]) - AC_TRY_COMPILE(,[ - #ifdef _WIN32 - #error win32 - #endif - ], ODIE_PLATFORM="unix", - ODIE_PLATFORM="windows" - ) - ODIE_SRC_DIR=`pwd -W` - ;; - *) - CYGPATH=echo - # Maybe we are cross-compiling.... - case ${host_alias} in - *mingw32*) - EXEEXT=".exe" - ODIE_PLATFORM="windows" - SC_PROG_TCLSH - ;; - *) - EXEEXT="" - ODIE_PLATFORM="unix" - ;; - esac - ;; - esac - - AC_MSG_RESULT($ODIE_PLATFORM) - AC_SUBST(ODIE_SRC_DIR) - AC_SUBST(TCLSH_PROG) - AC_SUBST(WISH_PROG) - AC_SUBST(TCLKIT_PROG) - AC_SUBST(TKKIT_PROG) - AC_SUBST(TOADKIT_PROG) - ODIE_CPU=`uname -m` - ODIE_BUILD_SYSTEM=`uname -s`-${ODIE_CPU} - # TEA specific: - if test "${ODIE_PLATFORM}" = "windows" ; then - ODIE_SYSTEM=windows - TCLSH_PROG='${exec_prefix}/bin/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}.exe' - WISH_PROG='${exec_prefix}/bin/wish${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}.exe' - TCLKIT_PROG='${exec_prefix}/bin/tclkit${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}.exe' - TKKIT_PROG='${exec_prefix}/bin/tkkit${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}.exe' - TOADKIT_PROG='${exec_prefix}/bin/toadkit${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}.exe' - else - ODIE_SYSTEM=`uname -s`-`uname -r` - TCLSH_PROG='${exec_prefix}/bin/tclsh${TCL_VERSION}' - WISH_PROG='${exec_prefix}/bin/wish${TCL_VERSION}' - TCLKIT_PROG='${exec_prefix}/bin/tclkit${TCL_VERSION}' - TKKIT_PROG='${exec_prefix}/bin/tkkit${TCL_VERSION}' - TOADKIT_PROG='${exec_prefix}/bin/toadkit${TCL_VERSION}' - if test "$?" -ne 0 ; then - AC_MSG_WARN([can't find uname command]) - ODIE_SYSTEM=unknown - else - if test "`uname -s`" = "AIX" ; then - ODIE_SYSTEM=AIX-`uname -v`.`uname -r` - fi - fi - fi - ODIE_OS="generic" - ODIE_TCLSRC_DIR="unix" - ODIE_PLATFORM_DIR="unix" - - AC_MSG_CHECKING([if 64bit support is requested]) - AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)], [do64bit=$enableval], [do64bit=detect]) - AC_MSG_RESULT($do64bit) - AC_MSG_CHECKING([if cocoa support is requested]) - AC_ARG_ENABLE(cocoa,[ --enable-cocoa enable cocoa support (where applicable)], [doCocoa=$enableval], [doCocoa=yes]) - AC_MSG_RESULT($doCocoa) - AC_MSG_CHECKING([if corefoundation support is requested]) - AC_ARG_ENABLE(corefoundation,[ --enable-corefoundation enable core foundation support (where applicable)], [doCorefoundation=$enableval], [doCorefoundation=yes]) - AC_MSG_RESULT($doCorefoundation) - - - ODIE_BUILD_64BIT=$do64bit - case "$do64bit" in - amd64|x64|yes) - ODIE_TCL_CONFIG_FLAGS='--enable-64bit' - ODIE_TK_CONFIG_FLAGS='--enable-64bit' - ;; - 0|no) - if test "${ODIE_CPU}" = "x86_64" ; then - ${ODIE_CPU}="ix86" - fi - ODIE_TCL_CONFIG_FLAGS='--enable-64bit=no' - ODIE_TK_CONFIG_FLAGS='--enable-64bit=no' - ;; - detect) - case "${ODIE_CPU}" in - amd64|x64|x86_64) - ODIE_BUILD_64BIT="yes" - ;; - *) - ODIE_BUILD_64BIT="no" - ;; - esac - ;; - *) - case "${ODIE_CPU}" in - amd64|x64|x86_64) - ODIE_BUILD_64BIT="yes" - ;; - esac - ODIE_TCL_CONFIG_FLAGS= - ODIE_TK_CONFIG_FLAGS= - ;; - esac - - case $ODIE_SYSTEM in - windows*) - ODIE_WINDOW_SYSTEM="windows" - ODIE_OS="windows" - ODIE_TCLSRC_DIR="win" - ODIE_PLATFORM_DIR="win" - ODIE_BUILD_TCLSH= - ODIE_BINARY_PLATFORM="windows-${ODIE_CPU}" - ;; - Linux*) - ODIE_WINDOW_SYSTEM="x11" - ODIE_OS="linux" - ODIE_TCL_CONFIG_FLAGS='' - ODIE_TK_CONFIG_FLAGS=' --enable-xft=no --enable-xss=no' - ODIE_BINARY_PLATFORM="linux-${ODIE_CPU}" - ;; - Darwin-*) - ODIE_OS="macosx" - ODIE_PLATFORM_DIR="macosx" - ODIE_PLATFORM="macosx" - - case "$doCocoa" in - true|1|yes) - ODIE_WINDOW_SYSTEM="cocoa" - ODIE_TK_CONFIG_FLAGS="${ODIE_TK_CONFIG_FLAGS} --enable-aqua=yes" - ;; - *) - ODIE_WINDOW_SYSTEM="x11" - ODIE_TK_CONFIG_FLAGS="${ODIE_TK_CONFIG_FLAGS} --enable-aqua=no" - ;; - esac - case "$doCorefoundation" in - true|1|yes) - ODIE_TCL_CONFIG_FLAGS="${ODIE_TCL_CONFIG_FLAGS} --enable-corefoundation=yes" - ODIE_TK_CONFIG_FLAGS="${ODIE_TK_CONFIG_FLAGS} --enable-corefoundation=yes" - ;; - *) - ODIE_TCL_CONFIG_FLAGS="${ODIE_TCL_CONFIG_FLAGS} --enable-corefoundation=no" - ODIE_TK_CONFIG_FLAGS="${ODIE_TK_CONFIG_FLAGS} --enable-corefoundation=no" - ;; - esac - ODIE_BINARY_PLATFORM="macosx-${ODIE_WINDOW_SYSTEM}-${ODIE_CPU}" - ODIE_TCL_CONFIG_FLAGS="${ODIE_TCL_CONFIG_FLAGS} --enable-framework=no" - ;; - esac - - case $ODIE_BUILD_SYSTEM in - windows*|*win32*|*WIN32*) - FOSSIL_CHECKOUT="_FOSSIL_" - ODIE_BUILD_OS="windows" - ;; - *MINGW32_*|*CYGWIN_*) - FOSSIL_CHECKOUT="_FOSSIL_" - ODIE_BUILD_OS="cygwin" - ;; - Linux*) - ODIE_BUILD_OS="linux" - FOSSIL_CHECKOUT=".fslckout" - ;; - Darwin-*) - ODIE_BUILD_OS="macosx" - FOSSIL_CHECKOUT=".fslckout" - ;; - esac - - # Check if exec_prefix is set. If not use fall back to prefix. - # Note when adjusted, so that TEA_PREFIX can correct for this. - # This is needed for recursive configures, since autoconf propagates - # $prefix, but not $exec_prefix (doh!). - if test x$exec_prefix = xNONE ; then - exec_prefix_default=yes - exec_prefix=$prefix - fi - TEA_VERSION="3.9" - TEA_PLATFORM=${ODIE_PLATFORM} - ### - # DETECT CROSS COMPILE - ### - ODIE_HOST=$host - ODIE_TARGET=$target - MKHDR_PROG='${exec_prefix}/bin/mkhdr${EXEEXT}' - - AC_SUBST(MKHDR_PROG) - AC_SUBST(ODIE_HOST) - AC_SUBST(ODIE_TARGET) - AC_SUBST(ODIE_BUILD_OS) - AC_SUBST(ODIE_BUILD_SYSTEM) - AC_SUBST(ODIE_BUILD_64BIT) - AC_SUBST(ODIE_PLATFORM) - AC_SUBST(ODIE_TCLSRC_DIR) - AC_SUBST(ODIE_PLATFORM_DIR) - AC_SUBST(ODIE_SYSTEM) - AC_SUBST(ODIE_OS) - AC_SUBST(ODIE_TCL_CONFIG_FLAGS) - AC_SUBST(ODIE_TK_CONFIG_FLAGS) - AC_SUBST(ODIE_CPU) - AC_SUBST(ODIE_BINARY_PLATFORM) - AC_SUBST(ODIE_WINDOW_SYSTEM) - AC_SUBST(VFS_CP) -]) - - -#------------------------------------------------------------------------ -# SC_PROG_ZIP -# Locate a zip executable installed on the system path. This macro -# will only find a zip executable that already exists on the system. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# ZIP_PROG -#------------------------------------------------------------------------ - -AC_DEFUN([SC_PROG_ZIP], [ - if test "${ODIE_BUILD_OS}" = "cygwin"; then - AC_MSG_CHECKING([Using ${ODIE_BUILD_OS} zip/unzip]) - here=`pwd` - cd /bin ; zipbindir=`pwd -W` ; cd $here - ZIP_PROG=${zipbindir}/zip.exe - UNZIP_PROG=${zipbindir}/unzip.exe - if test ! -f "/bin/zip.exe" ; then - mingw-get.exe install msys-zip - fi - if test ! -f "/bin/unzip.exe" ; then - mingw-get.exe install msys-unzip - fi - AC_SUBST(ZIP_PROG) - AC_SUBST(UNZIP_PROG) - AC_MSG_RESULT([$ZIP_PROG]) - AC_MSG_RESULT([$UNZIP_PROG]) - - else - AC_CACHE_VAL(ac_cv_path_zip, [ - search_path=`echo ${exec_prefix}/bin /opt/local/bin ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/zip 2> /dev/null` ; do - if test x"$ac_cv_path_zip" = x ; then - if test -f "$j" ; then - ac_cv_path_zip=$j - break - fi - fi - done - done - ]) - AC_CACHE_VAL(ac_cv_path_unzip, [ - search_path=`echo ${exec_prefix}/bin /opt/local/bin ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/unzip.exe 2> /dev/null` `ls -r $dir/unzip 2> /dev/null` ; do - if test x"$ac_cv_path_unzip" = x ; then - if test -f "$j" ; then - ac_cv_path_unzip=$j - break - fi - fi - done - done - ]) - if test -f "$ac_cv_path_zip" ; then - ZIP_PROG="$ac_cv_path_zip" - AC_MSG_RESULT([$ZIP_PROG]) - else - # It is not an error if an installed version of Tcl can't be located. - ZIP_PROG="" - AC_MSG_RESULT([No zip found on PATH]) - fi - if test -f "$ac_cv_path_unzip" ; then - UNZIP_PROG="$ac_cv_path_unzip" - AC_MSG_RESULT([$UNZIP_PROG]) - else - # It is not an error if an installed version of Tcl can't be located. - UNZIP_PROG="" - AC_MSG_RESULT([No unzip found on PATH]) - fi - AC_SUBST(ZIP_PROG) - AC_SUBST(UNZIP_PROG) - fi -]) - -#------------------------------------------------------------------------ -# SC_PROG_STRIP -# Locate a strip executable installed on the system path. This macro -# will only find a strip executable that already exists on the system. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# STRIP_PROG -#------------------------------------------------------------------------ - -AC_DEFUN([SC_PROG_STRIP], [ - AC_MSG_CHECKING([for strip]) - AC_CACHE_VAL(ac_cv_path_strip, [ - search_path=`echo ${exec_prefix}/bin /opt/local/bin ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/strip 2> /dev/null` \ - `ls -r $dir/strip.exe 2> /dev/null` ; do - if test x"$ac_cv_path_strip" = x ; then - if test -f "$j" ; then - ac_cv_path_strip=$j - break - fi - fi - done - done - ]) - - if test -f "$ac_cv_path_strip" ; then - STRIP_PROG="$ac_cv_path_strip" - AC_MSG_RESULT([$STRIP_PROG]) - else - # It is not an error if an installed version of Tcl can't be located. - STRIP_PROG="" - AC_MSG_RESULT([No strip found on PATH]) - fi - AC_SUBST(STRIP_PROG) -]) - - -#------------------------------------------------------------------------ -# SC_PROG_FOSSIL -# Locate a fossil executable installed on the system path. This macro -# will only find a fossil executable that already exists on the system. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# FOSSIL_PROG -#------------------------------------------------------------------------ - -AC_DEFUN([SC_PROG_FOSSIL], [ - FOSSIL_CHECKOUT=".fslckout" - - AC_MSG_CHECKING([for fossil]) - case `uname -s`-`uname -m` in - windows*|*win32*|*WIN32*|*MINGW32_*|*CYGWIN_*) - FOSSIL_CHECKOUT="_FOSSIL_" - AC_CACHE_VAL(ac_cv_path_fossil, [ - search_path=`echo ${exec_prefix}/bin /opt/local/bin c:/odie/bin c:/tcl/bin ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - rdir="`(cd $dir ; pwd -W)`" - for j in `ls -r --append-exe $rdir/fossil 2> /dev/null` ; do - if test x"$ac_cv_path_fossil" = x ; then - if test -f "$j" ; then - ac_cv_path_fossil=$j - break - fi - fi - done - done - ]) - ;; - *) - FOSSIL_CHECKOUT=".fslckout" - AC_CACHE_VAL(ac_cv_path_fossil, [ - search_path=`echo ${exec_prefix}/bin /opt/local/bin ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/fossil 2> /dev/null` \ - `ls -r $dir/fossil.exe 2> /dev/null` ; do - if test x"$ac_cv_path_fossil" = x ; then - if test -f "$j" ; then - ac_cv_path_fossil=$j - break - fi - fi - done - done - ]) - ;; - esac - - - - - if test -f "$ac_cv_path_fossil" ; then - FOSSIL_PROG="$ac_cv_path_fossil" - AC_MSG_RESULT([$FOSSIL_PROG]) - else - # It is not an error if an installed version of Tcl can't be located. - FOSSIL_PROG="" - AC_MSG_RESULT([No fossil found on PATH]) - fi - - AC_SUBST(FOSSIL_CHECKOUT) - AC_SUBST(FOSSIL_PROG) -]) - - -AC_DEFUN([SC_PROG_GIT], [ - AC_MSG_CHECKING([for git]) - case `uname -s`-`uname -m` in - windows*|*win32*|*WIN32*|*MINGW32_*|*CYGWIN_*) - AC_CACHE_VAL(ac_cv_path_git, [ - search_path=`echo ${exec_prefix}/bin /opt/local/bin c:/odie/bin c:/tcl/bin ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - rdir="`(cd $dir ; pwd -W)`" - for j in `ls -r --append-exe $rdir/git 2> /dev/null` ; do - if test x"$ac_cv_path_git" = x ; then - if test -f "$j" ; then - ac_cv_path_git=$j - break - fi - fi - done - done - ]) - ;; - *) - AC_CACHE_VAL(ac_cv_path_git, [ - search_path=`echo ${exec_prefix}/bin /opt/local/bin ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/git 2> /dev/null` \ - `ls -r $dir/git.exe 2> /dev/null` ; do - if test x"$ac_cv_path_git" = x ; then - if test -f "$j" ; then - ac_cv_path_git=$j - break - fi - fi - done - done - ]) - ;; - esac - - - - - if test -f "$ac_cv_path_git" ; then - GIT_PROG="$ac_cv_path_git" - AC_MSG_RESULT([$GIT_PROG]) - else - # It is not an error if an installed version of Tcl can't be located. - GIT_PROG="" - AC_MSG_RESULT([No git found on PATH]) - fi - - AC_SUBST(GIT_PROG) -]) - -#-------------------------------------------------------------------- -# SC_CONFIG_CFLAGS_WIN -# -# Try to determine the proper flags to pass to the compiler -# for building shared libraries and other such nonsense. -# -# NOTE: The backslashes in quotes below are substituted twice -# due to the fact that they are in a macro and then inlined -# in the final configure script. -# -# Arguments: -# none -# -# Results: -# -# Can the following vars: -# EXTRA_CFLAGS -# CFLAGS_DEBUG -# CFLAGS_OPTIMIZE -# CFLAGS_WARNING -# LDFLAGS_DEBUG -# LDFLAGS_OPTIMIZE -# LDFLAGS_CONSOLE -# LDFLAGS_WINDOW -# CC_OBJNAME -# CC_EXENAME -# CYGPATH -# STLIB_LD -# SHLIB_LD -# SHLIB_LD_LIBS -# LIBS -# AR -# RC -# RES -# -# MAKE_LIB -# MAKE_STUB_LIB -# MAKE_EXE -# MAKE_DLL -# -# LIBSUFFIX -# LIBFLAGSUFFIX -# LIBPREFIX -# LIBRARIES -# EXESUFFIX -# DLLSUFFIX -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_CONFIG_CFLAGS_WIN], [ - - # Step 0: Enable 64 bit support? - - AC_MSG_CHECKING([if 64bit support is requested]) - AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)], [do64bit=$enableval], [do64bit=no]) - AC_MSG_RESULT($do64bit) - - # Cross-compiling options for Windows/CE builds - - AC_MSG_CHECKING([if Windows/CE build is requested]) - AC_ARG_ENABLE(wince,[ --enable-wince enable Win/CE support (where applicable)], [doWince=$enableval], [doWince=no]) - AC_MSG_RESULT($doWince) - - AC_MSG_CHECKING([for Windows/CE celib directory]) - AC_ARG_WITH(celib,[ --with-celib=DIR use Windows/CE support library from DIR], - CELIB_DIR=$withval, CELIB_DIR=NO_CELIB) - AC_MSG_RESULT([$CELIB_DIR]) - - # Set some defaults (may get changed below) - EXTRA_CFLAGS="" - AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden]) - - AC_CHECK_PROG(CYGPATH, cygpath, cygpath -w, echo) - - SHLIB_SUFFIX=".dll" - - # MACHINE is IX86 for LINK, but this is used by the manifest, - # which requires x86|amd64|ia64. - MACHINE="X86" - - if test "$GCC" = "yes"; then - - AC_CACHE_CHECK(for cross-compile version of gcc, - ac_cv_cross, - AC_TRY_COMPILE([ - #ifndef _WIN32 - #error cross-compiler - #endif - ], [], - ac_cv_cross=no, - ac_cv_cross=yes) - ) - - if test "$ac_cv_cross" = "yes"; then - case "$do64bit" in - amd64|x64|yes) - CC="x86_64-w64-mingw32-gcc" - LD="x86_64-w64-mingw32-ld" - AR="x86_64-w64-mingw32-ar" - RANLIB="x86_64-w64-mingw32-ranlib" - RC="x86_64-w64-mingw32-windres" - ;; - *) - CC="i686-w64-mingw32-gcc" - LD="i686-w64-mingw32-ld" - AR="i686-w64-mingw32-ar" - RANLIB="i686-w64-mingw32-ranlib" - RC="i686-w64-mingw32-windres" - ;; - esac - fi - fi - - # Check for a bug in gcc's windres that causes the - # compile to fail when a Windows native path is - # passed into windres. The mingw toolchain requires - # Windows native paths while Cygwin should work - # with both. Avoid the bug by passing a POSIX - # path when using the Cygwin toolchain. - - if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then - conftest=/tmp/conftest.rc - echo "STRINGTABLE BEGIN" > $conftest - echo "101 \"name\"" >> $conftest - echo "END" >> $conftest - - AC_MSG_CHECKING([for Windows native path bug in windres]) - cyg_conftest=`$CYGPATH $conftest` - if AC_TRY_COMMAND($RC -o conftest.res.o $cyg_conftest) ; then - AC_MSG_RESULT([no]) - else - AC_MSG_RESULT([yes]) - CYGPATH=echo - fi - conftest= - cyg_conftest= - fi - - if test "$CYGPATH" = "echo"; then - DEPARG='"$<"' - else - DEPARG='"$(shell $(CYGPATH) $<)"' - fi - - # set various compiler flags depending on whether we are using gcc or cl - - if test "${GCC}" = "yes" ; then - extra_cflags="-pipe" - extra_ldflags="-pipe -static-libgcc" - AC_CACHE_CHECK(for mingw32 version of gcc, - ac_cv_win32, - AC_TRY_COMPILE([ - #ifdef _WIN32 - #error win32 - #endif - ], [], - ac_cv_win32=no, - ac_cv_win32=yes) - ) - if test "$ac_cv_win32" != "yes"; then - AC_MSG_ERROR([${CC} cannot produce win32 executables.]) - fi - - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" - AC_CACHE_CHECK(for working -municode linker flag, - ac_cv_municode, - AC_TRY_LINK([ - #include - int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} - ], - [], - ac_cv_municode=yes, - ac_cv_municode=no) - ) - CFLAGS=$hold_cflags - if test "$ac_cv_municode" = "yes" ; then - extra_ldflags="$extra_ldflags -municode" - else - extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" - fi - fi - - AC_MSG_CHECKING([compiler flags]) - if test "${GCC}" = "yes" ; then - SHLIB_LD="" - SHLIB_LD_LIBS='${LIBS}' - LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -lws2_32" - # mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't - LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32" - STLIB_LD='${AR} cr' - RC_OUT=-o - RC_TYPE= - RC_INCLUDE=--include - RC_DEFINE=--define - RES=res.o - MAKE_LIB="\${STLIB_LD} \[$]@" - MAKE_STUB_LIB="\${STLIB_LD} \[$]@" - POST_MAKE_LIB="\${RANLIB} \[$]@" - MAKE_EXE="\${CC} -o \[$]@" - LIBPREFIX="lib" - - if test "${SHARED_BUILD}" = "0" ; then - # static - AC_MSG_RESULT([using static flags]) - runtime= - LIBRARIES="\${STATIC_LIBRARIES}" - EXESUFFIX="s\${DBGX}.exe" - else - # dynamic - AC_MSG_RESULT([using shared flags]) - - # ad-hoc check to see if CC supports -shared. - if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then - AC_MSG_ERROR([${CC} does not support the -shared option. - You will need to upgrade to a newer version of the toolchain.]) - fi - - runtime= - # Add SHLIB_LD_LIBS to the Make rule, not here. - - EXESUFFIX="\${DBGX}.exe" - LIBRARIES="\${SHARED_LIBRARIES}" - fi - # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. - SHLIB_LD='${CC} -shared' - SHLIB_LD_LIBS='${LIBS}' - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \ - -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)" - # DLLSUFFIX is separate because it is the building block for - # users of tclConfig.sh that may build shared or static. - DLLSUFFIX="\${DBGX}.dll" - LIBSUFFIX="\${DBGX}.a" - LIBFLAGSUFFIX="\${DBGX}" - SHLIB_SUFFIX=.dll - - EXTRA_CFLAGS="${extra_cflags}" - - CFLAGS_DEBUG=-g - CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wdeclaration-after-statement" - LDFLAGS_DEBUG= - LDFLAGS_OPTIMIZE= - - # Specify the CC output file names based on the target name - CC_OBJNAME="-o \[$]@" - CC_EXENAME="-o \[$]@" - - # Specify linker flags depending on the type of app being - # built -- Console vs. Window. - # - # ORIGINAL COMMENT: - # We need to pass -e _WinMain@16 so that ld will use - # WinMain() instead of main() as the entry point. We can't - # use autoconf to check for this case since it would need - # to run an executable and that does not work when - # cross compiling. Remove this -e workaround once we - # require a gcc that does not have this bug. - # - # MK NOTE: Tk should use a different mechanism. This causes - # interesting problems, such as wish dying at startup. - #LDFLAGS_WINDOW="-mwindows -e _WinMain@16 ${extra_ldflags}" - LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}" - LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" - - case "$do64bit" in - amd64|x64|yes) - MACHINE="AMD64" ; # assume AMD64 as default 64-bit build - AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) - ;; - ia64) - MACHINE="IA64" - AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) - ;; - *) - AC_TRY_COMPILE([ - #ifndef _WIN64 - #error 32-bit - #endif - ], [], - tcl_win_64bit=yes, - tcl_win_64bit=no - ) - if test "$tcl_win_64bit" = "yes" ; then - do64bit=amd64 - MACHINE="AMD64" - AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) - fi - ;; - esac - else - if test "${SHARED_BUILD}" = "0" ; then - # static - AC_MSG_RESULT([using static flags]) - runtime=-MT - LIBRARIES="\${STATIC_LIBRARIES}" - EXESUFFIX="s\${DBGX}.exe" - else - # dynamic - AC_MSG_RESULT([using shared flags]) - runtime=-MD - # Add SHLIB_LD_LIBS to the Make rule, not here. - LIBRARIES="\${SHARED_LIBRARIES}" - EXESUFFIX="\${DBGX}.exe" - fi - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@" - # DLLSUFFIX is separate because it is the building block for - # users of tclConfig.sh that may build shared or static. - DLLSUFFIX="\${DBGX}.dll" - LIBSUFFIX="\${DBGX}.lib" - LIBFLAGSUFFIX="\${DBGX}" - - # This is a 2-stage check to make sure we have the 64-bit SDK - # We have to know where the SDK is installed. - # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs - if test "$do64bit" != "no" ; then - if test "x${MSSDK}x" = "xx" ; then - MSSDK="C:/Progra~1/Microsoft Platform SDK" - fi - MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` - PATH64="" - case "$do64bit" in - amd64|x64|yes) - MACHINE="AMD64" ; # assume AMD64 as default 64-bit build - PATH64="${MSSDK}/Bin/Win64/x86/AMD64" - ;; - ia64) - MACHINE="IA64" - PATH64="${MSSDK}/Bin/Win64" - ;; - esac - if test ! -d "${PATH64}" ; then - AC_MSG_WARN([Could not find 64-bit $MACHINE SDK to enable 64bit mode]) - AC_MSG_WARN([Ensure latest Platform SDK is installed]) - do64bit="no" - else - AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) - fi - fi - - LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib ws2_32.lib" - if test "$do64bit" != "no" ; then - # The space-based-path will work for the Makefile, but will - # not work if AC_TRY_COMPILE is called. TEA has the - # TEA_PATH_NOSPACE to avoid this issue. - # Check if _WIN64 is already recognized, and if so we don't - # need to modify CC. - AC_CHECK_DECL([_WIN64], [], - [CC="\"${PATH64}/cl.exe\" -I\"${MSSDK}/Include\" \ - -I\"${MSSDK}/Include/crt\" \ - -I\"${MSSDK}/Include/crt/sys\""]) - RC="\"${MSSDK}/bin/rc.exe\"" - CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" - # Do not use -O2 for Win64 - this has proved buggy in code gen. - CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" - lflags="-nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\"" - LINKBIN="\"${PATH64}/link.exe\"" - # Avoid 'unresolved external symbol __security_cookie' errors. - # c.f. http://support.microsoft.com/?id=894573 - LIBS="$LIBS bufferoverflowU.lib" - else - RC="rc" - # -Od - no optimization - # -WX - warnings as errors - CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" - # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) - CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" - lflags="-nologo" - LINKBIN="link" - fi - - if test "$doWince" != "no" ; then - # Set defaults for common evc4/PPC2003 setup - # Currently Tcl requires 300+, possibly 420+ for sockets - CEVERSION=420; # could be 211 300 301 400 420 ... - TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... - ARCH=ARM; # could be ARM MIPS X86EM ... - PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" - if test "$doWince" != "yes"; then - # If !yes then the user specified something - # Reset ARCH to allow user to skip specifying it - ARCH= - eval `echo $doWince | awk -F "," '{ \ - if (length([$]1)) { printf "CEVERSION=\"%s\"\n", [$]1; \ - if ([$]1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ - if (length([$]2)) { printf "TARGETCPU=\"%s\"\n", toupper([$]2) }; \ - if (length([$]3)) { printf "ARCH=\"%s\"\n", toupper([$]3) }; \ - if (length([$]4)) { printf "PLATFORM=\"%s\"\n", [$]4 }; \ - }'` - if test "x${ARCH}" = "x" ; then - ARCH=$TARGETCPU; - fi - fi - OSVERSION=WCE$CEVERSION; - if test "x${WCEROOT}" = "x" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" - if test ! -d "${WCEROOT}" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded Tools" - fi - fi - if test "x${SDKROOT}" = "x" ; then - SDKROOT="C:/Program Files/Windows CE Tools" - if test ! -d "${SDKROOT}" ; then - SDKROOT="C:/Windows CE Tools" - fi - fi - # The space-based-path will work for the Makefile, but will - # not work if AC_TRY_COMPILE is called. - WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` - SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` - CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` - if test ! -d "${CELIB_DIR}/inc"; then - AC_MSG_ERROR([Invalid celib directory "${CELIB_DIR}"]) - fi - if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\ - -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then - AC_MSG_ERROR([could not find PocketPC SDK or target compiler to enable WinCE mode [$CEVERSION,$TARGETCPU,$ARCH,$PLATFORM]]) - else - CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" - if test -d "${CEINCLUDE}/${TARGETCPU}" ; then - CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" - fi - CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" - fi - fi - - if test "$doWince" != "no" ; then - CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" - if test "${TARGETCPU}" = "X86"; then - CC="${CEBINROOT}/cl.exe" - else - CC="${CEBINROOT}/cl${ARCH}.exe" - fi - CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" - RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" - arch=`echo ${ARCH} | awk '{print tolower([$]0)}'` - defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS" - for i in $defs ; do - AC_DEFINE_UNQUOTED($i) - done -# if test "${ARCH}" = "X86EM"; then -# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION) -# fi - AC_DEFINE_UNQUOTED(_WIN32_WCE, $CEVERSION) - AC_DEFINE_UNQUOTED(UNDER_CE, $CEVERSION) - CFLAGS_DEBUG="-nologo -Zi -Od" - CFLAGS_OPTIMIZE="-nologo -O2" - lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` - lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" - LINKBIN="\"${CEBINROOT}/link.exe\"" - AC_SUBST(CELIB_DIR) - if test "${CEVERSION}" -lt 400 ; then - LIBS="coredll.lib corelibc.lib winsock.lib" - else - LIBS="coredll.lib corelibc.lib ws2.lib" - fi - # celib currently stuck at wce300 status - #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib" - LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\"" - LIBS_GUI="commctrl.lib commdlg.lib" - else - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" - fi - - SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" - SHLIB_LD_LIBS='${LIBS}' - # link -lib only works when -lib is the first arg - STLIB_LD="${LINKBIN} -lib ${lflags}" - RC_OUT=-fo - RC_TYPE=-r - RC_INCLUDE=-i - RC_DEFINE=-d - RES=res - MAKE_LIB="\${STLIB_LD} -out:\[$]@" - MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\[$]@" - POST_MAKE_LIB= - MAKE_EXE="\${CC} -Fe\[$]@" - LIBPREFIX="" - - CFLAGS_DEBUG="${CFLAGS_DEBUG} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE" - CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE" - - EXTRA_CFLAGS="" - CFLAGS_WARNING="-W3" - LDFLAGS_DEBUG="-debug" - LDFLAGS_OPTIMIZE="-release" - - # Specify the CC output file names based on the target name - CC_OBJNAME="-Fo\[$]@" - CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\"" - - # Specify linker flags depending on the type of app being - # built -- Console vs. Window. - if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then - LDFLAGS_CONSOLE="-link ${lflags}" - LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} - else - LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" - LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" - fi - fi - - if test "$do64bit" != "no" ; then - AC_DEFINE(TCL_CFG_DO64BIT) - fi - - if test "${GCC}" = "yes" ; then - AC_CACHE_CHECK(for SEH support in compiler, - tcl_cv_seh, - AC_TRY_RUN([ - #define WIN32_LEAN_AND_MEAN - #include - #undef WIN32_LEAN_AND_MEAN - - int main(int argc, char** argv) { - int a, b = 0; - __try { - a = 666 / b; - } - __except (EXCEPTION_EXECUTE_HANDLER) { - return 0; - } - return 1; - } - ], - tcl_cv_seh=yes, - tcl_cv_seh=no, - tcl_cv_seh=no) - ) - if test "$tcl_cv_seh" = "no" ; then - AC_DEFINE(HAVE_NO_SEH, 1, - [Defined when mingw does not support SEH]) - fi - - # - # Check to see if the excpt.h include file provided contains the - # definition for EXCEPTION_DISPOSITION; if not, which is the case - # with Cygwin's version as of 2002-04-10, define it to be int, - # sufficient for getting the current code to work. - # - AC_CACHE_CHECK(for EXCEPTION_DISPOSITION support in include files, - tcl_cv_eh_disposition, - AC_TRY_COMPILE([ -# define WIN32_LEAN_AND_MEAN -# include -# undef WIN32_LEAN_AND_MEAN - ],[ - EXCEPTION_DISPOSITION x; - ], - tcl_cv_eh_disposition=yes, - tcl_cv_eh_disposition=no) - ) - if test "$tcl_cv_eh_disposition" = "no" ; then - AC_DEFINE(EXCEPTION_DISPOSITION, int, - [Defined when cygwin/mingw does not support EXCEPTION DISPOSITION]) - fi - - # Check to see if winnt.h defines CHAR, SHORT, and LONG - # even if VOID has already been #defined. The win32api - # used by mingw and cygwin is known to do this. - - AC_CACHE_CHECK(for winnt.h that ignores VOID define, - tcl_cv_winnt_ignore_void, - AC_TRY_COMPILE([ - #define VOID void - #define WIN32_LEAN_AND_MEAN - #include - #undef WIN32_LEAN_AND_MEAN - ], [ - CHAR c; - SHORT s; - LONG l; - ], - tcl_cv_winnt_ignore_void=yes, - tcl_cv_winnt_ignore_void=no) - ) - if test "$tcl_cv_winnt_ignore_void" = "yes" ; then - AC_DEFINE(HAVE_WINNT_IGNORE_VOID, 1, - [Defined when cygwin/mingw ignores VOID define in winnt.h]) - fi - - # See if the compiler supports casting to a union type. - # This is used to stop gcc from printing a compiler - # warning when initializing a union member. - - AC_CACHE_CHECK(for cast to union support, - tcl_cv_cast_to_union, - AC_TRY_COMPILE([], - [ - union foo { int i; double d; }; - union foo f = (union foo) (int) 0; - ], - tcl_cv_cast_to_union=yes, - tcl_cv_cast_to_union=no) - ) - if test "$tcl_cv_cast_to_union" = "yes"; then - AC_DEFINE(HAVE_CAST_TO_UNION, 1, - [Defined when compiler supports casting to union type.]) - fi - fi - - # DL_LIBS is empty, but then we match the Unix version - AC_SUBST(DL_LIBS) - AC_SUBST(CFLAGS_DEBUG) - AC_SUBST(CFLAGS_OPTIMIZE) - AC_SUBST(CFLAGS_WARNING) -]) - -#-------------------------------------------------------------------- -# Using our autodetected Tcl binary, call the cthulhu script to -# produce the dynamically generated parts of our program -#-------------------------------------------------------------------- -AC_DEFUN([CTHULHU_DYNAMIC], [ - AC_MSG_CHECKING([building dynamic portions of the code]) - - ${CC} -o mkhdr.o -c scripts/mkhdr.c - ${CC} mkhdr.o -o mkhdr -]) - -### -# Replacements for the standard TEA Functions -### -# Possible values for key variables defined: -# -# TEA_WINDOWINGSYSTEM - win32 aqua x11 (mirrors 'tk windowingsystem') -# TEA_PLATFORM - windows unix -# - -#------------------------------------------------------------------------ -# TEA_PATH_TCLCONFIG -- -# -# Locate the tclConfig.sh file and perform a sanity check on -# the Tcl compile flags -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tcl=... -# -# Defines the following vars: -# TCL_BIN_DIR Full path to the directory containing -# the tclConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN([ODIE_PATH_TCLCONFIG], [ - for i in \ - ../tcl \ - `ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../tcl \ - `ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../../tcl \ - `ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test "${TEA_PLATFORM}" = "windows" \ - -a -f "$i/win/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd $i/win; pwd)`" - break - fi - if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" - break - fi - done - if test x"${ac_cv_c_tclconfig}" = x ; then - ac_cv_c_tclconfig={prefix}/lib - fi - no_tcl= - TCL_BIN_DIR="${ac_cv_c_tclconfig}" - AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh]) -]) - - -AC_DEFUN([ODIE_PATH_TKCONFIG], [ - for i in \ - ../tk \ - `ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../tk \ - `ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../../tk \ - `ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test "${TEA_PLATFORM}" = "windows" \ - -a -f "$i/win/tkConfig.sh" ; then - ac_cv_c_tkconfig="`(cd $i/win; pwd)`" - break - fi - if test -f "$i/unix/tkConfig.sh" ; then - ac_cv_c_tkconfig="`(cd $i/unix; pwd)`" - break - fi - done - if test x"${ac_cv_c_tkconfig}" = x ; then - ac_cv_c_tkconfig={prefix}/lib - fi - no_tk= - TK_BIN_DIR="${ac_cv_c_tkconfig}" - AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh]) -]) - -AC_DEFUN([ODIE_PROG_TCLSH], [ - AC_MSG_CHECKING([for tclsh]) - if test -f "${TCL_BIN_DIR}/Makefile" ; then - AC_MSG_NOTICE([Using Tcl in TCL_BIN_DIR $TEA_PLATFORM $ODIE_PLATFORM]) - # tclConfig.sh is in Tcl build directory - if test "${ODIE_PLATFORM}" = "windows"; then - TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" - else - TCLSH_PROG="${TCL_BIN_DIR}/tclsh" - fi - else - AC_MSG_NOTICE([Using Tcl in $prefix/lib $TEA_PLATFORM $ODIE_PLATFORM]) - # tclConfig.sh is in install location - if test "${ODIE_PLATFORM}" = "windows"; then - TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" - else - TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_DBGX}" - fi - TCLSH_PROG="${exec_prefix}/bin/${TCLSH_PROG}" - fi - AC_MSG_RESULT([${TCLSH_PROG}]) - AC_SUBST(TCLSH_PROG) -]) - - -AC_DEFUN([ODIE_PROG_WISH], [ - AC_MSG_CHECKING([for wish]) - if test -f "${TK_BIN_DIR}/Makefile" ; then - AC_MSG_NOTICE([Using Tk in TK_BIN_DIR $TEA_PLATFORM $ODIE_PLATFORM]) - # tkConfig.sh is in Tk build directory - if test "${ODIE_PLATFORM}" = "windows"; then - WISH_PROG="${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${TK_DBGX}${EXEEXT}" - else - WISH_PROG="${TK_BIN_DIR}/wish" - fi - else - AC_MSG_NOTICE([Using Tk in $prefix/lib $TEA_PLATFORM $ODIE_PLATFORM]) - # tkConfig.sh is in install location - if test "${ODIE_PLATFORM}" = "windows"; then - WISH_PROG="wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${TK_DBGX}${EXEEXT}" - else - WISH_PROG="wish${TK_MAJOR_VERSION}.${TK_MINOR_VERSION}${TK_DBGX}" - fi - WISH_PROG="${exec_prefix}/bin/${WISH_PROG}" - fi - AC_MSG_RESULT([${WISH_PROG}]) - AC_SUBST(WISH_PROG) -]) DELETED odieConfig.sh.in Index: odieConfig.sh.in ================================================================== --- odieConfig.sh.in +++ /dev/null @@ -1,89 +0,0 @@ -# -# This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is -# a template for a Makefile; to generate the actual Makefile, run -# "./configure", which is a configuration script generated by the "autoconf" -# program (constructs like "@foo@" will get replaced in the actual Makefile. - -#-------------------------------------------------------------------------- -# Things you can change to personalize the Makefile for your own site (you can -# make these changes in either Makefile.in or Makefile, but changes to -# Makefile will get lost if you re-run the configuration script). -#-------------------------------------------------------------------------- - -# Default top-level directories in which to install architecture-specific -# files (exec_prefix) and machine-independent files such as scripts (prefix). -# The values specified here may be overridden at configure-time with the -# --exec-prefix and --prefix options to the "configure" script. The *dir vars -# are standard configure substitutions that are based off prefix and -# exec_prefix. -SHELL=@SHELL@ -ODIE_BUILD_TCLSH=@ODIE_BUILD_TCLSH@ - -prefix=@prefix@ -exec_prefix=@exec_prefix@ -bindir=@bindir@ -libdir=@libdir@ -includedir=@includedir@ -datarootdir=@datarootdir@ -mandir=@mandir@ - -# The following definition can be set to non-null for special systems like AFS -# with replication. It allows the pathnames used for installation to be -# different than those used for actually reference files at run-time. -# INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. -INSTALL_ROOT=${DESTDIR} - -ODIE_ROOT=@prefix@ -LOCAL_REPO=@prefix@ -FOSSIL_CHECKOUT=@ODIE_FOSSIL_CHECKOUT@ -PLATFORM=${ODIE_PLATFORM} - -RC=@RC@ -RES=@RES@ -TK_RES=@TK_RES@ -### -# Backward compadible names needed by build systems -### -SANDBOX=@ODIE_SANDBOX_PATH@ -DOWNLOAD=@ODIE_DOWNLOAD_PATH@ -ODIEMIRRORURL=@ODIE_MIRROR_URL@ - -# ODIE_TCLSH is the name of a tclsh executable produced -# my make tcltk -EXE_SUFFIX=@EXEEXT@ -EXE=${EXE_SUFFIX} -TCL_EXE=tclsh${EXE_SUFFIX} -TCLTEST_EXE=tcltest${EXE_SUFFIX} -ODIE_TCLSH=@ODIE_TCL_SHELL@ -ODIE_WISH=@ODIE_WISH_SHELL@ -TCLSH=${ODIE_TCLSH} -TCL_SHELL=${ODIE_BUILD_TCLSH} - -CC=@CC@ -#CC=purify -best-effort @CC@ -DPURIFY - -ODIE_STATIC_TCLLIB=${exec_prefix}/lib/tclstaticlib.a -ODIE_STATIC_TKLIB=${exec_prefix}/lib/tkstaticlib.a - -TOADKIT=@ODIE_TOADKIT@ -ODIE_MKHDR=${exec_prefix}/bin/mkhdr${EXE_SUFFIX} -ZIPSETUP=${exec_prefix}/bin/zzipsetupstub${EXE_SUFFIX} - -GIT_PROG=@GIT_PROG@ -FOSSIL=@FOSSIL_PROG@ -MKHDR=@MKHDR_PROG@ -ZIP=@ZIP_PROG@ -UNZIP=@UNZIP_PROG@ - -ODIE_RM=${ODIE_BUILD_TCLSH} -ODIE_RM+=${ODIE_SRC_DIR}/scripts/rmdir.tcl -SHERPA=${ODIE_BUILD_TCLSH} -SHERPA+=@ODIE_SANDBOX_PATH@/gort/gort.tcl -GORT=${ODIE_BUILD_TCLSH} -GORT+=@ODIE_SANDBOX_PATH@/gort/gort.tcl -KETTLE=${ODIE_BUILD_TCLSH} -KETTLE+=${exec_prefix}/bin/kettle - -### -# Bits generated by autosetup -### DELETED odieConfig.tcl.in Index: odieConfig.tcl.in ================================================================== --- odieConfig.tcl.in +++ /dev/null @@ -1,104 +0,0 @@ -### -# The properties in this file are propagates out to all modules -# (This file is loaded before the code in scripts/*) -### -array set ::odie {} - -### -# Directory where packages and binaries are installed -# (Must be an absolute path name) -### -set prefix "@prefix@" -set exec_prefix "@exec_prefix@" -set TCL_VERSION @TCL_VERSION@ -set TCL_MAJOR_VERSION @TCL_MAJOR_VERSION@ -set TCL_MINOR_VERSION @TCL_MINOR_VERSION@ -set TK_VERSION @TK_VERSION@ -set TK_MAJOR_VERSION @TK_MAJOR_VERSION@ -set TK_MINOR_VERSION @TK_MINOR_VERSION@ -set ODIE_BINARY_PLATFORM @ODIE_BINARY_PLATFORM@ -set ODIEMIRRORURL @ODIE_MIRROR_URL@ - -set EXEEXT "@EXEEXT@" -package require platform -set ::odie(local_repo) $prefix -set ::odie(platform_build) [::platform::generic] -### -# Data populated by configure -## -array set ::odie [subst { - tcl_version "@TCL_VERSION@" - tcl_patch_level "@TCL_VERSION@@TCL_PATCH_LEVEL@" - tk_version "@TK_VERSION@" - tk_patch_level "@TK_VERSION@@TK_PATCH_LEVEL@" - host "@ODIE_HOST@" - target "@ODIE_TARGET@" - build_system "@ODIE_BUILD_SYSTEM@" - build_os "@ODIE_BUILD_OS@" - build_tclsh "@ODIE_BUILD_TCLSH@" - build_64bit "@ODIE_BUILD_64BIT@" - - src_dir "@ODIE_SRC_DIR@" - odie_src_dir "@ODIE_SRC_DIR@" - zipdir "@ODIE_ZIPDIR_PATH@" - sandbox "@ODIE_SANDBOX_PATH@" - download "@ODIE_DOWNLOAD_PATH@" - platform "@ODIE_PLATFORM@" - tcl_src_dir "@ODIE_TCLSRC_DIR@" - platform_dir "@ODIE_PLATFORM_DIR@" - system "@ODIE_SYSTEM@" - os "@ODIE_OS@" - odie_binary_platform "@ODIE_BINARY_PLATFORM@" - odie_cpu "@ODIE_CPU@" - odie_window_system "@ODIE_WINDOW_SYSTEM@" - tcl_fossil_branch "@TCL_FOSSIL_BRANCH@" - tk_fossil_branch "@TK_FOSSIL_BRANCH@" - cc "@CC@" - shell "@MAKEFILE_SHELL@" - exe_suffix "@EXEEXT@" - shlib_suffix "@SHLIB_SUFFIX@" - zip "@ZIP_PROG@" - unzip "@UNZIP_PROG@" - strip "@STRIP_PROG@" - mkhdr "@MKHDR_PROG@" - git "@GIT_PROG@" - fossil "@FOSSIL_PROG@" - tcl_shell "@TCLSH_PROG@" - wish_shell "@WISH_PROG@" - zzetup "${exec_prefix}/bin/zzipsetupstub@EXEEXT@" - wish_kit "@TKKIT_PROG@" - tcl_kit "@TCLKIT_PROG@" - toad_kit "@TOADKIT_PROG@" - gort "@ODIE_BUILD_TCLSH@ @ODIE_SANDBOX_PATH@/gort/gort.tcl" - sherpa "@ODIE_BUILD_TCLSH@ @ODIE_SANDBOX_PATH@/gort/gort.tcl" - kettle "${exec_prefix}/bin/kettle" - zip_kit "${exec_prefix}/bin/zipkit.zip" - lib "$prefix/lib" - rc "@RC@" - res "@RES@" - tk_res "@TK_RES@" - vfs_cp "@VFS_CP@" - mirror "$ODIEMIRRORURL" -}] -# tcl_libs "@TCL_LIBS@" - -### -# List paths where fossil repositories are stored -# (To save us having to download things...) -### -set ::odie(fossil_paths) {} -# Add our download directory -lappend ::odie(fossil_paths) $::odie(download) - -### -# Which extensions to link statically -### -switch $::tcl_platform(platform) { - windows { - set ::odie(static_linked_extensions) {tcl tk registry dde} - } - default { - set ::odie(static_linked_extensions) {tcl tk} - } -} - DELETED project.rc.in Index: project.rc.in ================================================================== --- project.rc.in +++ /dev/null @@ -1,62 +0,0 @@ -array set ::project { - name {@PACKAGE_NAME@} - version {@PACKAGE_VERSION@} - libfile {@PKG_LIB_FILE@} - srcdir {@srcdir@} - prefix {@prefix@} - exec_prefix {@exec_prefix@} - exeext {@EXEEXT@} - CC {@CC@} - AR {@AR@} - CFLAGS_DEBUG {@CFLAGS_DEBUG@} - CFLAGS_OPTIMIZE {@CFLAGS_OPTIMIZE@} - CFLAGS_DEFAULT {@CFLAGS_DEFAULT@} - CFLAGS_WARNING {@CFLAGS_WARNING@} - DEFS {@DEFS@} - EXEEXT {@EXEEXT@} - LDFLAGS_DEFAULT {@LDFLAGS_DEFAULT@} - MAKE_LIB {@MAKE_LIB@} - MAKE_SHARED_LIB {@MAKE_SHARED_LIB@} - MAKE_STATIC_LIB {@MAKE_STATIC_LIB@} - MAKE_STUB_LIB {@MAKE_STUB_LIB@} - OBJEXT {@OBJEXT@} - RANLIB {@RANLIB@} - RANLIB_STUB {@RANLIB_STUB@} - SHLIB_CFLAGS {@SHLIB_CFLAGS@} - SHLIB_LD {@SHLIB_LD@} - SHLIB_LD_LIBS {@SHLIB_LD_LIBS@} - SHLIB_SUFFIX {@SHLIB_SUFFIX@} - STLIB_LD {@STLIB_LD@} - TCL_DEFS {@TCL_DEFS@} - TCL_VERSION {@TCL_VERSION@} - TCL_PATCH_LEVEL {@TCL_PATCH_LEVEL@} - TCL_BIN_DIR {@TCL_BIN_DIR@} - TCL_SRC_DIR {@TCL_SRC_DIR@} - TK_VERSION {@TK_VERSION@} - TK_PATCH_LEVEL {@TK_PATCH_LEVEL@} - TK_BIN_DIR {@TK_BIN_DIR@} - TK_SRC_DIR {@TK_SRC_DIR@} - - TEA_PLATFORM {@TEA_PLATFORM@} - TEA_WINDOWINGSYSTEM {@TEA_WINDOWINGSYSTEM@} - TEA_SYSTEM {@TEA_SYSTEM@} - TEACUP_OS {@TEACUP_OS@} - TEACUP_ARCH {@TEACUP_ARCH@} - TEACUP_TOOLSET {@TEACUP_TOOLSET@} - TEACUP_PROFILE {@TEACUP_PROFILE@} - - PRACTCL_DEFS {@PRACTCL_DEFS@} - PRACTCL_TOOLSET {@PRACTCL_TOOLSET@} - PRACTCL_SHARED_LIB {@PRACTCL_SHARED_LIB@} - PRACTCL_STATIC_LIB {@PRACTCL_STATIC_LIB@} - PRACTCL_STUB_LIB {@PRACTCL_STUB_LIB@} - PRACTCL_VC_MANIFEST_EMBED_DLL {@PRACTCL_VC_MANIFEST_EMBED_DLL@} - PRACTCL_VC_MANIFEST_EMBED_EXE {@PRACTCL_VC_MANIFEST_EMBED_EXE@} - PRACTCL_NAME_LIBRARY {@PRACTCL_NAME_LIBRARY@} -} -set ::project(srcdir) [file normalize [file join [file dirname [info script]] $::project(srcdir)]] -package ifneeded practcl 0.3 [list source [file join $::project(srcdir) tclconfig practcl.tcl]] - -set ::project(sandbox) [file dirname $::project(srcdir)] -set ::project(download) [file join $::project(sandbox) download] -set ::project(teapot) [file join $::project(sandbox) teapot] DELETED scripts/common.tcl Index: scripts/common.tcl ================================================================== --- scripts/common.tcl +++ /dev/null @@ -1,260 +0,0 @@ -### -# Common suite of routines for the odie boostrap process -### -set path [file normalize [file join [file dirname [file normalize [info script]]] ..]] -if {[file exists [file join $path odieConfig.tcl]]} { - source [file join $path odieConfig.tcl] -} -lappend ::auto_path [file join $::odie(prefix) lib] -set ::autosetup(exe) $::argv0 -set ::autosetup(istcl) 1 -set ::autosetup(start) [clock millis] -set ::autosetup(installed) 0 -set ::autosetup(msg-checking) 0 -set ::autosetup(msg-quiet) 0 -set ::autosetup(msg-timing) 0 -set ::autosetup(dir) [file join $path autosetup] -set ::autosetup(builddir) [file join $path] -set ::autosetup(srcdir) [file join $path] -set ::autosetup(libdir) [file join $path autosetup lib] -set ::autosetup(debug) 1 -set ::autosetup(cmdline) {} -set ::autosetup(options) {} -set ::autosetup(optionhelp) {} -set ::autosetup(showhelp) 0 - -foreach file { - core.tcl formatting.tcl getopt.tcl misc.tcl -} { - source [file join $::autosetup(libdir) $file] -} - -proc ::noop args {} - -namespace eval ::gort_bootstrap {} - -proc ::gort_bootstrap::download_fossil {pkg} { - variable distribution - set PKG_SRCPATH [sandbox_path $pkg] - set fosdb [fossil_db $pkg] - if {![file exists $fosdb]} { - puts "Fossil clone $pkg" - set fossil_url {} - if {[dict exists $distribution $pkg fossil_url]} { - set fossil_url [dict get $distribution $pkg fossil_url] - } - if {$fossil_url eq {}} { - set fossil_url $::odie(mirror_url)/$pkg - } - doexec $::odie(fossil) clone $fossil_url $fosdb - } - - if {![file exists ${PKG_SRCPATH}/$::odie(fossil_checkout)]} { - puts "Fossil open $pkg" - file mkdir ${PKG_SRCPATH} - cd ${PKG_SRCPATH} - doexec $::odie(fossil) open $fosdb - } - cd ${PKG_SRCPATH} - if {[dict exists $distribution $pkg fossil_branch]} { - doexec $::odie(fossil) update [dict get $distribution $pkg fossil_branch] - } else { - doexec $::odie(fossil) update - } - return ${PKG_SRCPATH} -} - -proc ::gort_bootstrap::fossil_db pkg { - if {[file exists [file join $::odie(download) $pkg.fossil]]} { - return [file join $::odie(download) $pkg.fossil] - } - return [file join $::odie(download) $pkg.fos] -} - - -proc ::gort_bootstrap::sandbox_path pkg { - return [file join $::odie(sandbox) $pkg] -} - -proc ::gort_bootstrap::build_gnumake {pkg action} { - puts "BUILD GNUMAKE $pkg $action" - if {$action eq "install"} { - set PKG_SRCPATH [sandbox_path $pkg] - cd ${PKG_SRCPATH} - doexec $::odie(fossil) update - set args [list --prefix=$::odie(local_repo)] - if {$::odie(host) != $::odie(target)} { - lappend args --host=$::odie(host) - } - if {[file exists ${PKG_SRCPATH}/auto.def]} { - doexec [info nameofexecutable] $::odie(odie_src_dir)/autosetup/autosetup {*}$args - } elseif {![file exists ${PKG_SRCPATH}/Makefile]} { - lappend args --libdir=$::odie(local_repo)/lib - doexec sh ./configure {*}$args - } - if [catch { - domake install - } err] { - puts "Died on $err" - exit 1 - } - } else { - set PKG_SRCPATH [sandbox_path $pkg] - cd ${PKG_SRCPATH} - if [catch { - domake $action - } err] { - puts "Died on $err" - exit 1 - } - } -} - -proc ::gort_bootstrap::build_sak {pkg action} { - if {$action eq "install"} { - set PKG_SRCPATH [sandbox_path $pkg] - doexec $::odie(build_tclsh) [file join $PKG_SRCPATH installer.tcl] \ - -app-path $::odie(prefix)/bin -pkg-path $::odie(prefix)/lib/$pkg \ - -no-examples -no-nroff -no-html \ - -no-wait -no-gui - } -} - -proc ::gort_bootstrap::build_kettle {pkg action} { - set PKG_SRCPATH [sandbox_path $pkg] - if {$pkg eq "kettle"} { - doexec $::odie(build_tclsh) [file join $PKG_SRCPATH kettle] -f [file join $PKG_SRCPATH build.tcl] $action - } else { - doexec $::odie(build_tclsh) $::odie(kettle) -f [file join $PKG_SRCPATH build.tcl] $action - } -} - -proc ::gort_bootstrap::build_sqlite {pkg action} { - ### - # Sqlite - ### - puts "INSTALLING SQLITE" - set SQLITE_VERSION 3.8.7.2 - set SQLITE_TFNAME sqlite-autoconf-3080704 - set SQLITE_SRCPATH $::odie(sandbox)/sqlite - set SQLITE_URL http://sqlite.org/2014/${SQLITE_TFNAME}.tar.gz - # In MSYS, tar may not understand the prefix - set download_msys [::cygpath [pwd]] - set SQLITE_TARBALL [file join [::realpath $::odie(download)] sqlite${SQLITE_VERSION}.tar.gz] - cd [::realpath $::odie(src_dir)] - if {![file exists $SQLITE_TARBALL]} { - doexec $::odie(build_tclsh) scripts/url-get.tcl ${SQLITE_URL} ${SQLITE_TARBALL} - } - if {![file exists ${SQLITE_SRCPATH}/README]} { - file delete -force ${SQLITE_SRCPATH} - cd $::odie(sandbox) - doexec tar xfz [::cygpath ${SQLITE_TARBALL}] - file rename -force ${SQLITE_TFNAME} ${SQLITE_SRCPATH} - } - cd ${SQLITE_SRCPATH}/tea - if {![file exists ${SQLITE_SRCPATH}/tea/Makefile]} { - doexec sh ./configure --prefix=[::cygpath $::odie(local_repo)] --libdir=[::cygpath $::odie(local_repo)/lib] --host=$::odie(host) - } - doexec make install -} - -proc ::gort_bootstrap::install_package package { - variable distribution - set pkginfo [dict get $distribution $package] - puts [list $package $pkginfo] - set download [dict get $pkginfo get_proc] - $download $package - set build [dict get $pkginfo build_proc] - $build $package install -} - -proc ::gort_bootstrap::distribution {name properties} { - variable distribution - foreach {field value} $properties { - - dict set distribution $name $field $value - } - if {![dict exists $distribution $name get_proc]} { - dict set distribution $name get_proc ::noop - } - if {![dict exists $distribution $name build_proc]} { - dict set distribution $name build_proc ::noop - } -} - -::gort_bootstrap::distribution sqlite { - get_proc ::noop - build_proc build_sqlite - #build_proc ::noop -} - -if {!$::odie(windows)} { - ::gort_bootstrap::distribution tclx { - get_proc download_fossil - build_proc build_gnumake - } -if 0 { - ::gort_bootstrap::distribution kettle { - get_proc download_fossil - requires {tclx tcllib tklib} - build_proc build_kettle - } -} -} -::gort_bootstrap::distribution tclvfs { - get_proc download_fossil - requires tcllib - build_proc build_gnumake -} -::gort_bootstrap::distribution taolib { - get_proc download_fossil - requires {sqlite tcllib tklib} - build_proc build_sak -} -::gort_bootstrap::distribution tcllib { - get_proc download_fossil - fossil_branch odie - build_proc build_sak -} -::gort_bootstrap::distribution tklib { - get_proc download_fossil - requires tcllib - build_proc build_sak -} - -::gort_bootstrap::distribution odielib { - get_proc download_fossil - fossil_branch autosetup - requires {tcllib sqlite} - build_proc build_gnumake -} - -::gort_bootstrap::distribution gort { - get_proc download_fossil - fossil_branch trunk - requires {tcllib odielib taolib sqlite} - build_proc build_gnumake -} - -proc ::doexec args { - exec {*}$args >&@ stdout -} - -### -# Make sure the odielib toolkit is downloaded -### -if {![file exists [file join $::odie(sandbox) odielib modules odie index.tcl]]} { - ::gort_bootstrap::download_fossil odielib -} -source [file join $path .. odielib modules odie index.tcl] -source [file join $path .. odielib modules cmdline cmdline.tcl] -source [file join $path .. odielib modules fileutil index.tcl] -source [file join $path .. odielib modules codebale index.tcl] - - - -#::gort_bootstrap::distribution gort { -# get_proc download_fossil -# requires {taolib tcllib odielib kettle} -# build_proc build_kettle -#} DELETED scripts/cthulhu.h Index: scripts/cthulhu.h ================================================================== --- scripts/cthulhu.h +++ /dev/null @@ -1,24 +0,0 @@ -#include -/* -** Needed to sort out differences in the way GCC marks -** INLINE functions between version 4.X and 5.X -*/ -#ifdef __GNUC_STDC_INLINE__ - #define CTHULHU_INLINE extern inline -#else - #define CTHULHU_INLINE __inline__ -#endif - -#define TCL_COMMAND -#define TCL_MODULE -#define STUB_EXPORT - -/* -** Provide a dummy Tcl_InitStubs if we are using this as a static -** library. -*/ -#ifndef USE_TCL_STUBS -# undef Tcl_InitStubs -# define Tcl_InitStubs(a,b,c) TCL_VERSION -#endif - DELETED scripts/diagram.tcl Index: scripts/diagram.tcl ================================================================== --- scripts/diagram.tcl +++ /dev/null @@ -1,24 +0,0 @@ -source [file join [file dirname [file normalize [info script]]] common.tcl] -source [file join $::odielib(srcroot) modules codebale index.tcl] -source [file join $::odielib(srcroot) modules tao index.tcl] -source [file join $::odielib(srcroot) modules tao-sqlite index.tcl] - -file mkdir $::odielib(srcroot)/autodoc -if {![file exists $::odielib(srcroot)/autodoc/taodb.sqlite]} { - foreach module $::odielib(modules) { - set mpath [file join $::odielib(srcroot) modules $module] - if {[file exists $mpath/index.tcl]} { - source $mpath/index.tcl - } - } - ::tao::db backup $::odielib(srcroot)/autodoc/taodb.sqlite -} else { - namespace eval ::tao {} - package require sqlite3 - sqlite3 ::tao::db $::odielib(srcroot)/autodoc/taodb.sqlite -} - -::tao::diagram all $::odielib(srcroot)/autodoc/classes.gv -foreach module [::tao::db eval {select distinct package from class}] { - ::tao::diagram $module $::odielib(srcroot)/autodoc/module_$module.gv -} DELETED scripts/feedback.inc Index: scripts/feedback.inc ================================================================== --- scripts/feedback.inc +++ /dev/null @@ -1,12 +0,0 @@ -[section {Bugs, Ideas, Feedback}] -[vset TRACKER http://fossil.etoyoc.com/fossil/odielib/reportlist] -[vset LABEL {Odielib Trackers}] - -This document, and the package it describes, will undoubtedly contain -bugs and other problems. - -Please report such in the category [emph [vset CATEGORY]] of the -[uri [vset TRACKER] [vset LABEL]]. - -Please also report any ideas for enhancements you may have for either -package and/or documentation. DELETED scripts/gort.tcl Index: scripts/gort.tcl ================================================================== --- scripts/gort.tcl +++ /dev/null @@ -1,81 +0,0 @@ -#!/bin/sh -# Copyright (c) 2006-2011 WorkWare Systems http://www.workware.net.au/ -# All rights reserved -# vim:se syntax=tcl: -# \ -dir=`dirname "$0"`; exec "`$dir/../autosetup/find-tclsh`" "$0" "$@" - -### -# Micronized version of gort for bootstrapping Odie -### - -set path [file normalize [file join [file dirname [file normalize [info script]]] ..]] -source [file join $path scripts common.tcl] - -namespace eval ::command {} - -proc ::command::help {} { - foreach command [lsort -dictionary [info command ::command::*]] { - puts " * [namespace tail $command]" - } -} - -proc ::command::package-list {} { - foreach distro [lsort -dictionary [dict keys $::gort_bootstrap::distribution]] { - puts " * $distro" - } -} - -proc ::command::install {package} { - if {$package eq "all"} { - install-all - return - } - ::gort_bootstrap::install_package $package -} - -proc ::command::install-all {} { - set info $::gort_bootstrap::distribution - set allpkgs [lsort -dictionary [dict keys $info]] - set installed {} - foreach item $allpkgs { - if {[dict exists $info $item requires]} { - set requires($item) [dict get $info $item requires] - } else { - set requires($item) {} - } - } - - for {set i 0} {$i < [llength $allpkgs]} {incr i} { - foreach item $allpkgs { - if { $item in $installed } continue - set needs {} - foreach req $requires($item) { - if { $req ni $installed } { - lappend needs $req - } - } - if {[llength $needs]} { - puts [list $item needs $needs] - continue - } - lappend installed $item - } - } - foreach item $installed { - puts "INSTALLING $item" - } - foreach item $installed { - ::gort_bootstrap::install_package $item - } -} - -set method [lindex $argv 0] -if { [info command ::command::$method] eq {} } { - puts stderr "Invalid command: $method." - ::command::help - exit 1 -} -::command::$method {*}[lrange $argv 1 end] -update -exit 0 DELETED scripts/make_distclean.sh Index: scripts/make_distclean.sh ================================================================== --- scripts/make_distclean.sh +++ /dev/null @@ -1,32 +0,0 @@ -#! /bin/bash - -source odieConfig.sh -rm -rf autodoc embedded -rm -rf autom4te.cache -rm -rf build -rm -rf config.* helpdoc.* librarypkgindex.tcl -rm -rf cthulhu.mk mkhdr* - -cd ${ODIE_SANDBOX_PATH}/tcl/${ODIE_TCL_PLATFORM_DIR} ; make distclean -cd ${ODIE_SANDBOX_PATH}/tk/${ODIE_TCL_PLATFORM_DIR} ; make distclean -cd ${ODIE_SANDBOX_PATH}/tcl-static/${ODIE_TCL_PLATFORM_DIR} ; make distclean -cd ${ODIE_SANDBOX_PATH}/tk-static/${ODIE_TCL_PLATFORM_DIR} ; make distclean -cd ${ODIE_SANDBOX_PATH}/sqlite/tea ; make distclean -cd ${ODIE_SANDBOX_PATH}/tclvfs ; make distclean -cd ${ODIE_SANDBOX_PATH}/tcllib ; make distclean -cd ${ODIE_SRC_DIR} ; ${ODIE_BUILD_TCLSH} build.tcl clean - -find ${ODIE_SRC_DIR} -type d -iname "*.vfs" -exec rm {} \; - -if [ ! -f "odieConfig.sh" ]; then - rm odieConfig.sh -fi -if [ ! -f "odieConfig.tcl" ]; then - rm odieConfig.tcl -fi -if [ ! -f "Makefile" ]; then - rm Makefile -fi -if [ ! -f "scripts/common.tcl" ]; then - rm scripts/common.tcl -fi DELETED scripts/make_gort.tcl Index: scripts/make_gort.tcl ================================================================== --- scripts/make_gort.tcl +++ /dev/null @@ -1,56 +0,0 @@ -#!/bin/sh -# Copyright (c) 2006-2011 WorkWare Systems http://www.workware.net.au/ -# All rights reserved -# vim:se syntax=tcl: -# \ -dir=`dirname "$0"`; exec "`$dir/../autosetup/find-tclsh`" "$0" "$@" - -set path [file dirname [file normalize [info script]]] -proc ::doexec args { - exec {*}$args >&@ stdout -} - -source $path/../odieConfig.tcl - -proc get_distro {pkg {tag trunk} {local_path {}}} { - if {$local_path eq {}} { - set local_path $pkg - } - set PKG_SRCPATH $::odie(sandbox)/$local_path - if {![file exists $::odie(download)/$pkg.fos]} { - puts "Fossil clone $pkg" - doexec $::odie(fossil) clone $::odie(mirror_url)/$pkg $::odie(download)/$pkg.fos - } - - if {![file exists ${PKG_SRCPATH}/$::odie(fossil_checkout)]} { - puts "Fossil open $local_path" - file mkdir ${PKG_SRCPATH} - cd ${PKG_SRCPATH} - doexec $::odie(fossil) open $::odie(download)/$pkg.fos - } - cd ${PKG_SRCPATH} - doexec $::odie(fossil) update $tag - return ${PKG_SRCPATH} -} - -get_distro tcllib odie -get_distro gort trunk -get_distro gort sherpa sherpa - -### -# Build supporting libraries needed by Gort -## -file mkdir $::odie(prefix)/bin -# Rebuild gort -set GORT_SRCPATH $::odie(src_dir)/../gort -set SHERPA_SRCPATH $::odie(src_dir)/../sherpa - -if {$::tcl_platform(platform) eq "windows"} { - file copy -force ${GORT_SRCPATH}/gort.tcl $::odie(prefix)/bin/gort.tcl - file copy -force ${SHERPA_SRCPATH}/sherpa.tcl $::odie(prefix)/bin/sherpa.tcl -} else { - file delete $::odie(prefix)/bin/gort - file link -symbolic $::odie(prefix)/bin/gort ${GORT_SRCPATH}/gort.tcl - file delete $::odie(prefix)/bin/sherpa - file link -symbolic $::odie(prefix)/bin/sherpa ${SHERPA_SRCPATH}/sherpa.tcl -} DELETED scripts/make_skel.sh Index: scripts/make_skel.sh ================================================================== --- scripts/make_skel.sh +++ /dev/null @@ -1,41 +0,0 @@ -#! /bin/bash - -source odieConfig.sh - -echo "Building Skeleton" -mkdir -p ${LOCAL_REPO} -mkdir -p ${LOCAL_REPO}/bin -mkdir -p ${LOCAL_REPO}/etc -mkdir -p ${LOCAL_REPO}/include -mkdir -p ${LOCAL_REPO}/lib -mkdir -p ${LOCAL_REPO}/lib64 -mkdir -p ${LOCAL_REPO}/doc -mkdir -p ${LOCAL_REPO}/share -mkdir -p ${LOCAL_REPO}/var -mkdir -p ${LOCAL_REPO}/zipdir -mkdir -p ${bindir} -mkdir -p ${libdir} -mkdir -p ${includedir} -mkdir -p ${datarootdir} -mkdir -p ${mandir} -mkdir -p ${DOWNLOAD} -mkdir -p ${SANDBOX} - -echo "Unpacking tclconfig" -mkdir -p ${SANDBOX}/tclconfig -# Make sure we have a copy of tclconfig -if [ ! -e "${DOWNLOAD}/tclconfig.fos" ] ; then \ - ${FOSSIL} clone ${ODIEMIRRORURL}/tclconfig ${DOWNLOAD}/tclconfig.fos ; \ -fi -if [ ! -e "${SANDBOX}/tclconfig/${FOSSIL_CHECKOUT}" ] ; then \ - cd ${SANDBOX}/tclconfig ; - ${FOSSIL} open ${DOWNLOAD}/tclconfig.fos ; \ -fi - -### -# Build and install the mkhdr binary -### -cd ${ODIE_SRC_DIR} -${CC} -o mkhdr.o -c scripts/mkhdr.c -${CC} mkhdr.o -o mkhdr${EXEEXT} -cp -af mkhdr${EXEEXT} ${LOCAL_REPO}/bin/mkhdr${EXEEXT} DELETED scripts/make_sqlite.tcl Index: scripts/make_sqlite.tcl ================================================================== --- scripts/make_sqlite.tcl +++ /dev/null @@ -1,35 +0,0 @@ -#!/bin/sh -# Copyright (c) 2006-2011 WorkWare Systems http://www.workware.net.au/ -# All rights reserved -# vim:se syntax=tcl: -# \ -dir=`dirname "$0"`; exec "`$dir/../autosetup/find-tclsh`" "$0" "$@" - -set path [file normalize [file join [file dirname [file normalize [info script]]] ..]] -source [file join $path scripts common.tcl] - -### -# Sqlite -### -set SQLITE_VERSION 3.8.7.4 -set SQLITE_TFNAME sqlite-autoconf-3080704 -set SQLITE_SRCPATH $::odie(sandbox)/sqlite -set SQLITE_URL http://sqlite.org/2014/${SQLITE_TFNAME}.tar.gz -# In MSYS, tar may not understand the prefix -set download_msys [exec pwd] -set SQLITE_TARBALL [file join [::realpath $::odie(download)] sqlite${SQLITE_VERSION}.tar.gz] -cd [::realpath $::odie(src_dir)] -if {![file exists $SQLITE_TARBALL]} { - doexec $::odie(build_tclsh) scripts/url-get.tcl ${SQLITE_URL} ${SQLITE_TARBALL} -} -if {![file exists ${SQLITE_SRCPATH}/README]} { - file delete -force ${SQLITE_SRCPATH} - cd $::odie(sandbox) - doexec tar xfz [::cygpath ${SQLITE_TARBALL}] - file rename -force ${SQLITE_TFNAME} ${SQLITE_SRCPATH} -} -cd ${SQLITE_SRCPATH}/tea -if {![file exists ${SQLITE_SRCPATH}/tea/Makefile]} { - doexec sh ./configure --prefix=[::cygpath $::odie(local_repo)] --libdir=[::cygpath $::odie(local_repo)/lib] --host=$::odie(host) -} -doexec make install DELETED scripts/make_tcl.sh Index: scripts/make_tcl.sh ================================================================== --- scripts/make_tcl.sh +++ /dev/null @@ -1,134 +0,0 @@ -#! /bin/bash - -source odieConfig.sh - -TCL_SRCPATH=${SANDBOX}/tcl/${ODIE_TCL_PLATFORM_DIR} -TK_SRCPATH=${SANDBOX}/tk/${ODIE_TCL_PLATFORM_DIR} -ODIE_SRCPATH=${SANDBOX}/odie - -echo DOWNLOAD $DOWNLOAD -echo "Cloning Tcl/Tk Sources" -if [ ! -f "${DOWNLOAD}/tcl.fos" ]; then - ${FOSSIL} clone ${ODIEMIRRORURL}/tcl ${DOWNLOAD}/tcl.fos -fi -if [ ! -f "${SANDBOX}/tcl/${FOSSIL_CHECKOUT}" ]; then - mkdir -p ${SANDBOX}/tcl - cd ${SANDBOX}/tcl - ${FOSSIL} open ${DOWNLOAD}/tcl.fos -fi - -echo "Building Local Tcl" - -echo $ODIE_HOST -echo $ODIE_TARGET - -cd ${SANDBOX}/tcl -${FOSSIL} update ${TCL_FOSSIL_BRANCH} -cd ${TCL_SRCPATH} -echo Build Dynamic Tcl -if [ "${ODIE_HOST}" != "${ODIE_TARGET}" ] ; then - sh ./configure --prefix=${LOCAL_REPO} --libdir=${LOCAL_REPO}/lib --with-tzdata --host=${ODIE_TARGET} ${TCL_CONFIG_FLAGS} -else - sh ./configure --prefix=${LOCAL_REPO} --libdir=${LOCAL_REPO}/lib --with-tzdata ${TCL_CONFIG_FLAGS} -fi -make clean -make binaries -make install - -echo "Cloning TclConfig" -if [ ! -f "${DOWNLOAD}/tclconfig.fos" ]; then - ${FOSSIL} clone ${ODIEMIRRORURL}/tclconfig ${DOWNLOAD}/tclconfig.fos -fi -if [ ! -f "${SANDBOX}/tclconfig/${FOSSIL_CHECKOUT}" ]; then - mkdir -p ${SANDBOX}/tclconfig - cd ${SANDBOX}/tclconfig - ${FOSSIL} open ${DOWNLOAD}/tclconfig.fos -fi -cd ${SANDBOX}/tclconfig -${FOSSIL} update trunk - -echo "Cloning Sqlite Sources" -if [ ! -f "${DOWNLOAD}/sqlite.fos" ]; then - ${FOSSIL} clone ${ODIEMIRRORURL}/sqlite ${DOWNLOAD}/sqlite.fos -fi -if [ ! -f "${SANDBOX}/sqlite/${FOSSIL_CHECKOUT}" ]; then - mkdir -p ${SANDBOX}/sqlite - cd ${SANDBOX}/sqlite - ${FOSSIL} open ${DOWNLOAD}/sqlite.fos -fi -if [ ! -f "${SANDBOX}/sqlite/tclconfig/tcl.m4" ]; then - cp -a ${SANDBOX}/tclconfig ${SANDBOX}/sqlite/tclconfig -fi -echo "Building Sqlite" -cd ${SANDBOX}/sqlite -${FOSSIL} update release -if [ "${ODIE_HOST}" != "${ODIE_TARGET}" ] ; then - sh ./configure --prefix=${LOCAL_REPO} --libdir=${LOCAL_REPO}/lib --with-tzdata --host=${ODIE_TARGET} ${TCL_CONFIG_FLAGS} -else - sh ./configure --prefix=${LOCAL_REPO} --libdir=${LOCAL_REPO}/lib --with-tzdata ${TCL_CONFIG_FLAGS} -fi -make clean -make binaries -make install - -echo "Cloning Thread Sources" -if [ ! -f "${DOWNLOAD}/thread.fos" ]; then - ${FOSSIL} clone ${ODIEMIRRORURL}/thread ${DOWNLOAD}/thread.fos -fi -if [ ! -f "${SANDBOX}/thread/${FOSSIL_CHECKOUT}" ]; then - mkdir -p ${SANDBOX}/thread - cd ${SANDBOX}/thread - ${FOSSIL} open ${DOWNLOAD}/thread.fos -fi -if [ ! -f "${SANDBOX}/thread/tclconfig/tcl.m4" ]; then - cp -a ${SANDBOX}/tclconfig ${SANDBOX}/thread/tclconfig -fi -echo "Building Thread" -cd ${SANDBOX}/thread] -${FOSSIL} update release -if [ "${ODIE_HOST}" != "${ODIE_TARGET}" ] ; then - sh ./configure --prefix=${LOCAL_REPO} --libdir=${LOCAL_REPO}/lib --with-tzdata --host=${ODIE_TARGET} ${TCL_CONFIG_FLAGS} -else - sh ./configure --prefix=${LOCAL_REPO} --libdir=${LOCAL_REPO}/lib --with-tzdata ${TCL_CONFIG_FLAGS} -fi -make clean -make binaries -make install - -if [ "${TK_FOSSIL_BRANCH}" != "none" ] ; then - TK_SRCPATH=${SANDBOX}/tk/${ODIE_TCL_PLATFORM_DIR} - if [ ! -f "${DOWNLOAD}/tk.fos" ] ; then - ${FOSSIL} clone ${ODIEMIRRORURL}/tk ${DOWNLOAD}/tk.fos - fi - if [ ! -f "${SANDBOX}/tk/${FOSSIL_CHECKOUT}" ] ; then - mkdir -p ${SANDBOX}/tk - cd ${SANDBOX}/tk - ${FOSSIL} open ${DOWNLOAD}/tk.fos ${TK_FOSSIL_BRANCH} - fi - echo "Building Local Tk" - cd ${SANDBOX}/tk - ${FOSSIL} update ${TK_FOSSIL_BRANCH} - cd ${TK_SRCPATH} - echo Build Dynamic Tk - if [ "${ODIE_OS}" == "macosx" ] ; then - if [ "${ODIE_CONFIG_WINDOWSYSTEM}" == "x11" ] ; then - export CPPFLAGS=-I/opt/X11/include - fi - fi - if [ "${ODIE_HOST}" != "${ODIE_TARGET}" ] ; then - sh ./configure --prefix=${LOCAL_REPO} --libdir=${LOCAL_REPO}/lib --host=${ODIE_TARGET} ${TK_CONFIG_FLAGS} - else - sh ./configure --prefix=${LOCAL_REPO} --libdir=${LOCAL_REPO}/lib ${TK_CONFIG_FLAGS} - fi - make clean - make binaries - make install -fi - - - -### -# Re-run our configure to learn new things from Tcl -### -cd ${ODIE_SRCPATH} -make reconfig DELETED scripts/mingw_cross_compile.sh Index: scripts/mingw_cross_compile.sh ================================================================== --- scripts/mingw_cross_compile.sh +++ /dev/null @@ -1,14 +0,0 @@ -# -# Install tools on the mac -# sudo port install i386-mingw32-binutils i386-mingw32-gcc i386-mingw32-libunicows i386-mingw32-runtime i386-mingw32-w32api - - -CC=/opt/local/bin/i386-mingw32-gcc -CXX=/opt/local/bin/i386-mingw32-g++ -MINGWFLAGS="-mwin32 -mconsole -march=i686 " -CFLAGS="$MINGWFLAGS" -CXXFLAGS="$MINGWFLAGS" - -# -# Later configure with: -# ./configure CC=$CC CXX=$CXX --target=ix86-pc-windows DELETED scripts/mkdoc.tcl Index: scripts/mkdoc.tcl ================================================================== --- scripts/mkdoc.tcl +++ /dev/null @@ -1,9 +0,0 @@ - -source [file join [file dirname [file normalize [info script]]] common.tcl] - -package require codebale -::codebale::mkdoc_embedded_html $::odielib(srcroot) $::odielib(modules) [file join $::odielib(srcroot) autodoc] \ - -nav {Odie Home} /fossil/odie/home \ - -o /var/www/odie/docs - -exit 0 DELETED scripts/mkhdr.c Index: scripts/mkhdr.c ================================================================== --- scripts/mkhdr.c +++ /dev/null @@ -1,3381 +0,0 @@ -static const char ident[] = "@(#) $Header: /cvstrac/cvstrac/makeheaders.c,v 1.4 2005/03/16 22:17:51 drh Exp $"; -/* -** This program is free software; you can redistribute it and/or -** modify it under the terms of the Simplified BSD License (also -** known as the "2-Clause License" or "FreeBSD License".) -** -** Copyright 1993 D. Richard Hipp. All rights reserved. -** -** Redistribution and use in source and binary forms, with or -** without modification, are permitted provided that the following -** conditions are met: -** -** 1. Redistributions of source code must retain the above copyright -** notice, this list of conditions and the following disclaimer. -** -** 2. Redistributions in binary form must reproduce the above copyright -** notice, this list of conditions and the following disclaimer in -** the documentation and/or other materials provided with the -** distribution. -** -** This software is provided "as is" and any express or implied warranties, -** including, but not limited to, the implied warranties of merchantability -** and fitness for a particular purpose are disclaimed. In no event shall -** the author or contributors be liable for any direct, indirect, incidental, -** special, exemplary, or consequential damages (including, but not limited -** to, procurement of substitute goods or services; loss of use, data or -** profits; or business interruption) however caused and on any theory of -** liability, whether in contract, strict liability, or tort (including -** negligence or otherwise) arising in any way out of the use of this -** software, even if advised of the possibility of such damage. -** -** 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. -** appropriate header files. -*/ - -#include -#include -#include -#include -#include -#include -#if defined( __MINGW32__) || defined(__DMC__) || defined(_MSC_VER) || defined(__POCC__) -# ifndef WIN32 -# define WIN32 -# endif -# include -#else -# include -#endif - -/* -** Macros for debugging. -*/ -#ifdef DEBUG -static int debugMask = 0; -# define debug0(F,M) if( (F)&debugMask ){ fprintf(stderr,M); } -# define debug1(F,M,A) if( (F)&debugMask ){ fprintf(stderr,M,A); } -# define debug2(F,M,A,B) if( (F)&debugMask ){ fprintf(stderr,M,A,B); } -# define debug3(F,M,A,B,C) if( (F)&debugMask ){ fprintf(stderr,M,A,B,C); } -# define PARSER 0x00000001 -# define DECL_DUMP 0x00000002 -# define TOKENIZER 0x00000004 -#else -# define debug0(Flags, Format) -# define debug1(Flags, Format, A) -# define debug2(Flags, Format, A, B) -# define debug3(Flags, Format, A, B, C) -#endif - -/* -** The following macros are purely for the purpose of testing this -** program on itself. They don't really contribute to the code. -*/ -#define INTERFACE 1 -#define EXPORT_INTERFACE 1 -#define EXPORT - -/* -** Each token in a source file is represented by an instance of -** the following structure. Tokens are collected onto a list. -*/ -typedef struct Token Token; -struct Token { - const char *zText; /* The text of the token */ - int nText; /* Number of characters in the token's text */ - int eType; /* The type of this token */ - int nLine; /* The line number on which the token starts */ - Token *pComment; /* Most recent block comment before this token */ - Token *pNext; /* Next token on the list */ - Token *pPrev; /* Previous token on the list */ -}; - -/* -** During tokenization, information about the state of the input -** stream is held in an instance of the following structure -*/ -typedef struct InStream InStream; -struct InStream { - const char *z; /* Complete text of the input */ - int i; /* Next character to read from the input */ - int nLine; /* The line number for character z[i] */ -}; - -/* -** Each declaration in the C or C++ source files is parsed out and stored as -** an instance of the following structure. -** -** A "forward declaration" is a declaration that an object exists that -** doesn't tell about the objects structure. A typical forward declaration -** is: -** -** struct Xyzzy; -** -** Not every object has a forward declaration. If it does, thought, the -** forward declaration will be contained in the zFwd field for C and -** the zFwdCpp for C++. The zDecl field contains the complete -** declaration text. -*/ -typedef struct Decl Decl; -struct Decl { - char *zName; /* Name of the object being declared. The appearance - ** of this name is a source file triggers the declaration - ** to be added to the header for that file. */ - char *zFile; /* File from which extracted. */ - char *zIf; /* Surround the declaration with this #if */ - char *zFwd; /* A forward declaration. NULL if there is none. */ - char *zFwdCpp; /* Use this forward declaration for C++. */ - char *zDecl; /* A full declaration of this object */ - char *zExtra; /* Extra declaration text inserted into class objects */ - int extraType; /* Last public:, protected: or private: in zExtraDecl */ - struct Include *pInclude; /* #includes that come before this declaration */ - int flags; /* See the "Properties" below */ - Token *pComment; /* A block comment associated with this declaration */ - Token tokenCode; /* Implementation of functions and procedures */ - Decl *pSameName; /* Next declaration with the same "zName" */ - Decl *pSameHash; /* Next declaration with same hash but different zName */ - Decl *pNext; /* Next declaration with a different name */ -}; - -/* -** Properties associated with declarations. -** -** DP_Forward and DP_Declared are used during the generation of a single -** header file in order to prevent duplicate declarations and definitions. -** DP_Forward is set after the object has been given a forward declaration -** and DP_Declared is set after the object gets a full declarations. -** (Example: A forward declaration is "typedef struct Abc Abc;" and the -** full declaration is "struct Abc { int a; float b; };".) -** -** The DP_Export and DP_Local flags are more permanent. They mark objects -** that have EXPORT scope and LOCAL scope respectively. If both of these -** marks are missing, then the object has library scope. The meanings of -** the scopes are as follows: -** -** LOCAL scope The object is only usable within the file in -** which it is declared. -** -** library scope The object is visible and usable within other -** files in the same project. By if the project is -** a library, then the object is not visible to users -** of the library. (i.e. the object does not appear -** in the output when using the -H option.) -** -** EXPORT scope The object is visible and usable everywhere. -** -** The DP_Flag is a temporary use flag that is used during processing to -** prevent an infinite loop. It's use is localized. -** -** The DP_Cplusplus, DP_ExternCReqd and DP_ExternReqd flags are permanent -** and are used to specify what type of declaration the object requires. -*/ -#define DP_Forward 0x001 /* Has a forward declaration in this file */ -#define DP_Declared 0x002 /* Has a full declaration in this file */ -#define DP_Export 0x004 /* Export this declaration */ -#define DP_Local 0x008 /* Declare in its home file only */ -#define DP_Flag 0x010 /* Use to mark a subset of a Decl list - ** for special processing */ -#define DP_Cplusplus 0x020 /* Has C++ linkage and cannot appear in a - ** C header file */ -#define DP_ExternCReqd 0x040 /* Prepend 'extern "C"' in a C++ header. - ** Prepend nothing in a C header */ -#define DP_ExternReqd 0x080 /* Prepend 'extern "C"' in a C++ header if - ** DP_Cplusplus is not also set. If DP_Cplusplus - ** is set or this is a C header then - ** prepend 'extern' */ - -/* -** Convenience macros for dealing with declaration properties -*/ -#define DeclHasProperty(D,P) (((D)->flags&(P))==(P)) -#define DeclHasAnyProperty(D,P) (((D)->flags&(P))!=0) -#define DeclSetProperty(D,P) (D)->flags |= (P) -#define DeclClearProperty(D,P) (D)->flags &= ~(P) - -/* -** These are state properties of the parser. Each of the values is -** distinct from the DP_ values above so that both can be used in -** the same "flags" field. -** -** Be careful not to confuse PS_Export with DP_Export or -** PS_Local with DP_Local. Their names are similar, but the meanings -** of these flags are very different. -*/ -#define PS_Extern 0x000800 /* "extern" has been seen */ -#define PS_Export 0x001000 /* If between "#if EXPORT_INTERFACE" - ** and "#endif" */ -#define PS_Export2 0x002000 /* If "EXPORT" seen */ -#define PS_Typedef 0x004000 /* If "typedef" has been seen */ -#define PS_Static 0x008000 /* If "static" has been seen */ -#define PS_Interface 0x010000 /* If within #if INTERFACE..#endif */ -#define PS_Method 0x020000 /* If "::" token has been seen */ -#define PS_Local 0x040000 /* If within #if LOCAL_INTERFACE..#endif */ -#define PS_Local2 0x080000 /* If "LOCAL" seen. */ -#define PS_Public 0x100000 /* If "PUBLIC" seen. */ -#define PS_Protected 0x200000 /* If "PROTECTED" seen. */ -#define PS_Private 0x400000 /* If "PRIVATE" seen. */ -#define PS_PPP 0x700000 /* If any of PUBLIC, PRIVATE, PROTECTED */ - -/* -** The following set of flags are ORed into the "flags" field of -** a Decl in order to identify what type of object is being -** declared. -*/ -#define TY_Class 0x00100000 -#define TY_Subroutine 0x00200000 -#define TY_Macro 0x00400000 -#define TY_Typedef 0x00800000 -#define TY_Variable 0x01000000 -#define TY_Structure 0x02000000 -#define TY_Union 0x04000000 -#define TY_Enumeration 0x08000000 -#define TY_Defunct 0x10000000 /* Used to erase a declaration */ - -/* -** Each nested #if (or #ifdef or #ifndef) is stored in a stack of -** instances of the following structure. -*/ -typedef struct Ifmacro Ifmacro; -struct Ifmacro { - int nLine; /* Line number where this macro occurs */ - char *zCondition; /* Text of the condition for this macro */ - Ifmacro *pNext; /* Next down in the stack */ - int flags; /* Can hold PS_Export, PS_Interface or PS_Local flags */ -}; - -/* -** When parsing a file, we need to keep track of what other files have -** be #include-ed. For each #include found, we create an instance of -** the following structure. -*/ -typedef struct Include Include; -struct Include { - char *zFile; /* The name of file include. Includes "" or <> */ - char *zIf; /* If not NULL, #include should be enclosed in #if */ - char *zLabel; /* A unique label used to test if this #include has - * appeared already in a file or not */ - Include *pNext; /* Previous include file, or NULL if this is the first */ -}; - -/* -** Identifiers found in a source file that might be used later to provoke -** the copying of a declaration into the corresponding header file are -** stored in a hash table as instances of the following structure. -*/ -typedef struct Ident Ident; -struct Ident { - char *zName; /* The text of this identifier */ - Ident *pCollide; /* Next identifier with the same hash */ - Ident *pNext; /* Next identifier in a list of them all */ -}; - -/* -** A complete table of identifiers is stored in an instance of -** the next structure. -*/ -#define IDENT_HASH_SIZE 2237 -typedef struct IdentTable IdentTable; -struct IdentTable { - Ident *pList; /* List of all identifiers in this table */ - Ident *apTable[IDENT_HASH_SIZE]; /* The hash table */ -}; - -/* -** The following structure holds all information for a single -** source file named on the command line of this program. -*/ -typedef struct InFile InFile; -struct InFile { - char *zSrc; /* Name of input file */ - char *zHdr; /* Name of the generated .h file for this input. - ** Will be NULL if input is to be scanned only */ - int flags; /* One or more DP_, PS_ and/or TY_ flags */ - InFile *pNext; /* Next input file in the list of them all */ - IdentTable idTable; /* All identifiers in this input file */ -}; - -/* -** An unbounded string is able to grow without limit. We use these -** to construct large in-memory strings from lots of smaller components. -*/ -typedef struct String String; -struct String { - int nAlloc; /* Number of bytes allocated */ - int nUsed; /* Number of bytes used (not counting null terminator) */ - char *zText; /* Text of the string */ -}; - -/* -** The following structure contains a lot of state information used -** while generating a .h file. We put the information in this structure -** and pass around a pointer to this structure, rather than pass around -** all of the information separately. This helps reduce the number of -** arguments to generator functions. -*/ -typedef struct GenState GenState; -struct GenState { - String *pStr; /* Write output to this string */ - IdentTable *pTable; /* A table holding the zLabel of every #include that - * has already been generated. Used to avoid - * generating duplicate #includes. */ - const char *zIf; /* If not NULL, then we are within a #if with - * this argument. */ - int nErr; /* Number of errors */ - const char *zFilename; /* Name of the source file being scanned */ - int flags; /* Various flags (DP_ and PS_ flags above) */ -}; - -/* -** The following text line appears at the top of every file generated -** by this program. By recognizing this line, the program can be sure -** never to read a file that it generated itself. -*/ -const char zTopLine[] = - "/* \aThis file was automatically generated. Do not edit! */\n"; -#define nTopLine (sizeof(zTopLine)-1) - -/* -** The name of the file currently being parsed. -*/ -static char *zFilename; - -/* -** The stack of #if macros for the file currently being parsed. -*/ -static Ifmacro *ifStack = 0; - -/* -** A list of all files that have been #included so far in a file being -** parsed. -*/ -static Include *includeList = 0; - -/* -** The last block comment seen. -*/ -static Token *blockComment = 0; - -/* -** The following flag is set if the -doc flag appears on the -** command line. -*/ -static int doc_flag = 0; - -/* -** If the following flag is set, then makeheaders will attempt to -** generate prototypes for static functions and procedures. -*/ -static int proto_static = 0; - -/* -** A list of all declarations. The list is held together using the -** pNext field of the Decl structure. -*/ -static Decl *pDeclFirst; /* First on the list */ -static Decl *pDeclLast; /* Last on the list */ - -/* -** A hash table of all declarations -*/ -#define DECL_HASH_SIZE 3371 -static Decl *apTable[DECL_HASH_SIZE]; - -/* -** The TEST macro must be defined to something. Make sure this is the -** case. -*/ -#ifndef TEST -# define TEST 0 -#endif - -#ifdef NOT_USED -/* -** We do our own assertion macro so that we can have more control -** over debugging. -*/ -#define Assert(X) if(!(X)){ CantHappen(__LINE__); } -#define CANT_HAPPEN CantHappen(__LINE__) -static void CantHappen(int iLine){ - fprintf(stderr,"Assertion failed on line %d\n",iLine); - *(char*)1 = 0; /* Force a core-dump */ -} -#endif - -/* -** Memory allocation functions that are guaranteed never to return NULL. -*/ -static void *SafeMalloc(int nByte){ - void *p = malloc( nByte ); - if( p==0 ){ - fprintf(stderr,"Out of memory. Can't allocate %d bytes.\n",nByte); - exit(1); - } - return p; -} -static void SafeFree(void *pOld){ - if( pOld ){ - free(pOld); - } -} -static void *SafeRealloc(void *pOld, int nByte){ - void *p; - if( pOld==0 ){ - p = SafeMalloc(nByte); - }else{ - p = realloc(pOld, nByte); - if( p==0 ){ - fprintf(stderr, - "Out of memory. Can't enlarge an allocation to %d bytes\n",nByte); - exit(1); - } - } - return p; -} -static char *StrDup(const char *zSrc, int nByte){ - char *zDest; - if( nByte<=0 ){ - nByte = strlen(zSrc); - } - zDest = SafeMalloc( nByte + 1 ); - strncpy(zDest,zSrc,nByte); - zDest[nByte] = 0; - return zDest; -} - -/* -** Return TRUE if the character X can be part of an identifier -*/ -#define ISALNUM(X) ((X)=='_' || isalnum(X)) - -/* -** Routines for dealing with unbounded strings. -*/ -static void StringInit(String *pStr){ - pStr->nAlloc = 0; - pStr->nUsed = 0; - pStr->zText = 0; -} -static void StringReset(String *pStr){ - SafeFree(pStr->zText); - StringInit(pStr); -} -static void StringAppend(String *pStr, const char *zText, int nByte){ - if( nByte<=0 ){ - nByte = strlen(zText); - } - if( pStr->nUsed + nByte >= pStr->nAlloc ){ - if( pStr->nAlloc==0 ){ - pStr->nAlloc = nByte + 100; - pStr->zText = SafeMalloc( pStr->nAlloc ); - }else{ - pStr->nAlloc = pStr->nAlloc*2 + nByte; - pStr->zText = SafeRealloc(pStr->zText, pStr->nAlloc); - } - } - strncpy(&pStr->zText[pStr->nUsed],zText,nByte); - pStr->nUsed += nByte; - pStr->zText[pStr->nUsed] = 0; -} -#define StringGet(S) ((S)->zText?(S)->zText:"") - -/* -** Compute a hash on a string. The number returned is a non-negative -** value between 0 and 2**31 - 1 -*/ -static int Hash(const char *z, int n){ - int h = 0; - if( n<=0 ){ - n = strlen(z); - } - while( n-- ){ - h = h ^ (h<<5) ^ *z++; - } - return h & 0x7fffffff; -} - -/* -** Given an identifier name, try to find a declaration for that -** identifier in the hash table. If found, return a pointer to -** the Decl structure. If not found, return 0. -*/ -static Decl *FindDecl(const char *zName, int len){ - int h; - Decl *p; - - if( len<=0 ){ - len = strlen(zName); - } - h = Hash(zName,len) % DECL_HASH_SIZE; - p = apTable[h]; - while( p && (strncmp(p->zName,zName,len)!=0 || p->zName[len]!=0) ){ - p = p->pSameHash; - } - return p; -} - -/* -** Install the given declaration both in the hash table and on -** the list of all declarations. -*/ -static void InstallDecl(Decl *pDecl){ - int h; - Decl *pOther; - - h = Hash(pDecl->zName,0) % DECL_HASH_SIZE; - pOther = apTable[h]; - while( pOther && strcmp(pDecl->zName,pOther->zName)!=0 ){ - pOther = pOther->pSameHash; - } - if( pOther ){ - pDecl->pSameName = pOther->pSameName; - pOther->pSameName = pDecl; - }else{ - pDecl->pSameName = 0; - pDecl->pSameHash = apTable[h]; - apTable[h] = pDecl; - } - pDecl->pNext = 0; - if( pDeclFirst==0 ){ - pDeclFirst = pDeclLast = pDecl; - }else{ - pDeclLast->pNext = pDecl; - pDeclLast = pDecl; - } -} - -/* -** Look at the current ifStack. If anything declared at the current -** position must be surrounded with -** -** #if STUFF -** #endif -** -** Then this routine computes STUFF and returns a pointer to it. Memory -** to hold the value returned is obtained from malloc(). -*/ -static char *GetIfString(void){ - Ifmacro *pIf; - char *zResult = 0; - int hasIf = 0; - String str; - - for(pIf = ifStack; pIf; pIf=pIf->pNext){ - if( pIf->zCondition==0 || *pIf->zCondition==0 ) continue; - if( !hasIf ){ - hasIf = 1; - StringInit(&str); - }else{ - StringAppend(&str," && ",4); - } - StringAppend(&str,pIf->zCondition,0); - } - if( hasIf ){ - zResult = StrDup(StringGet(&str),0); - StringReset(&str); - }else{ - zResult = 0; - } - return zResult; -} - -/* -** Create a new declaration and put it in the hash table. Also -** return a pointer to it so that we can fill in the zFwd and zDecl -** fields, and so forth. -*/ -static Decl *CreateDecl( - const char *zName, /* Name of the object being declared. */ - int nName /* Length of the name */ -){ - Decl *pDecl; - - pDecl = SafeMalloc( sizeof(Decl) + nName + 1); - memset(pDecl,0,sizeof(Decl)); - pDecl->zName = (char*)&pDecl[1]; - sprintf(pDecl->zName,"%.*s",nName,zName); - pDecl->zFile = zFilename; - pDecl->pInclude = includeList; - pDecl->zIf = GetIfString(); - InstallDecl(pDecl); - return pDecl; -} - -/* -** Insert a new identifier into an table of identifiers. Return TRUE if -** a new identifier was inserted and return FALSE if the identifier was -** already in the table. -*/ -static int IdentTableInsert( - IdentTable *pTable, /* The table into which we will insert */ - const char *zId, /* Name of the identifiers */ - int nId /* Length of the identifier name */ -){ - int h; - Ident *pId; - - if( nId<=0 ){ - nId = strlen(zId); - } - h = Hash(zId,nId) % IDENT_HASH_SIZE; - for(pId = pTable->apTable[h]; pId; pId=pId->pCollide){ - if( strncmp(zId,pId->zName,nId)==0 && pId->zName[nId]==0 ){ - /* printf("Already in table: %.*s\n",nId,zId); */ - return 0; - } - } - pId = SafeMalloc( sizeof(Ident) + nId + 1 ); - pId->zName = (char*)&pId[1]; - sprintf(pId->zName,"%.*s",nId,zId); - pId->pNext = pTable->pList; - pTable->pList = pId; - pId->pCollide = pTable->apTable[h]; - pTable->apTable[h] = pId; - /* printf("Add to table: %.*s\n",nId,zId); */ - return 1; -} - -/* -** Check to see if the given value is in the given IdentTable. Return -** true if it is and false if it is not. -*/ -static int IdentTableTest( - IdentTable *pTable, /* The table in which to search */ - const char *zId, /* Name of the identifiers */ - int nId /* Length of the identifier name */ -){ - int h; - Ident *pId; - - if( nId<=0 ){ - nId = strlen(zId); - } - h = Hash(zId,nId) % IDENT_HASH_SIZE; - for(pId = pTable->apTable[h]; pId; pId=pId->pCollide){ - if( strncmp(zId,pId->zName,nId)==0 && pId->zName[nId]==0 ){ - return 1; - } - } - return 0; -} - -/* -** Remove every identifier from the given table. Reset the table to -** its initial state. -*/ -static void IdentTableReset(IdentTable *pTable){ - Ident *pId, *pNext; - - for(pId = pTable->pList; pId; pId = pNext){ - pNext = pId->pNext; - SafeFree(pId); - } - memset(pTable,0,sizeof(IdentTable)); -} - -#ifdef DEBUG -/* -** Print the name of every identifier in the given table, one per line -*/ -static void IdentTablePrint(IdentTable *pTable, FILE *pOut){ - Ident *pId; - - for(pId = pTable->pList; pId; pId = pId->pNext){ - fprintf(pOut,"%s\n",pId->zName); - } -} -#endif - -/* -** Read an entire file into memory. Return a pointer to the memory. -** -** The memory is obtained from SafeMalloc and must be freed by the -** calling function. -** -** If the read fails for any reason, 0 is returned. -*/ -static char *ReadFile(const char *zFilename){ - struct stat sStat; - FILE *pIn; - char *zBuf; - int n; - - if( stat(zFilename,&sStat)!=0 -#ifndef WIN32 - || !S_ISREG(sStat.st_mode) -#endif - ){ - return 0; - } - pIn = fopen(zFilename,"r"); - if( pIn==0 ){ - return 0; - } - zBuf = SafeMalloc( sStat.st_size + 1 ); - n = fread(zBuf,1,sStat.st_size,pIn); - zBuf[n] = 0; - fclose(pIn); - return zBuf; -} - -/* -** Write the contents of a string into a file. Return the number of -** errors -*/ -static int WriteFile(const char *zFilename, const char *zOutput){ - FILE *pOut; - pOut = fopen(zFilename,"w"); - if( pOut==0 ){ - return 1; - } - fwrite(zOutput,1,strlen(zOutput),pOut); - fclose(pOut); - return 0; -} - -/* -** Major token types -*/ -#define TT_Space 1 /* Contiguous white space */ -#define TT_Id 2 /* An identifier */ -#define TT_Preprocessor 3 /* Any C preprocessor directive */ -#define TT_Comment 4 /* Either C or C++ style comment */ -#define TT_Number 5 /* Any numeric constant */ -#define TT_String 6 /* String or character constants. ".." or '.' */ -#define TT_Braces 7 /* All text between { and a matching } */ -#define TT_EOF 8 /* End of file */ -#define TT_Error 9 /* An error condition */ -#define TT_BlockComment 10 /* A C-Style comment at the left margin that - * spans multple lines */ -#define TT_Other 0 /* None of the above */ - -/* -** Get a single low-level token from the input file. Update the -** file pointer so that it points to the first character beyond the -** token. -** -** A "low-level token" is any token except TT_Braces. A TT_Braces token -** consists of many smaller tokens and is assembled by a routine that -** calls this one. -** -** The function returns the number of errors. An error is an -** unterminated string or character literal or an unterminated -** comment. -** -** Profiling shows that this routine consumes about half the -** CPU time on a typical run of makeheaders. -*/ -static int GetToken(InStream *pIn, Token *pToken){ - int i; - const char *z; - int cStart; - int c; - int startLine; /* Line on which a structure begins */ - int nlisc = 0; /* True if there is a new-line in a ".." or '..' */ - int nErr = 0; /* Number of errors seen */ - - z = pIn->z; - i = pIn->i; - pToken->nLine = pIn->nLine; - pToken->zText = &z[i]; - switch( z[i] ){ - case 0: - pToken->eType = TT_EOF; - pToken->nText = 0; - break; - - case '#': - if( i==0 || z[i-1]=='\n' || (i>1 && z[i-1]=='\r' && z[i-2]=='\n')){ - /* We found a preprocessor statement */ - pToken->eType = TT_Preprocessor; - i++; - while( z[i]!=0 && z[i]!='\n' ){ - if( z[i]=='\\' ){ - i++; - if( z[i]=='\n' ) pIn->nLine++; - } - i++; - } - pToken->nText = i - pIn->i; - }else{ - /* Just an operator */ - pToken->eType = TT_Other; - pToken->nText = 1; - } - break; - - case ' ': - case '\t': - case '\r': - case '\f': - case '\n': - while( isspace(z[i]) ){ - if( z[i]=='\n' ) pIn->nLine++; - i++; - } - pToken->eType = TT_Space; - pToken->nText = i - pIn->i; - break; - - case '\\': - pToken->nText = 2; - pToken->eType = TT_Other; - if( z[i+1]=='\n' ){ - pIn->nLine++; - pToken->eType = TT_Space; - }else if( z[i+1]==0 ){ - pToken->nText = 1; - } - break; - - case '\'': - case '\"': - cStart = z[i]; - startLine = pIn->nLine; - do{ - i++; - c = z[i]; - if( c=='\n' ){ - if( !nlisc ){ - fprintf(stderr, - "%s:%d: (warning) Newline in string or character literal.\n", - zFilename, pIn->nLine); - nlisc = 1; - } - pIn->nLine++; - } - if( c=='\\' ){ - i++; - c = z[i]; - if( c=='\n' ){ - pIn->nLine++; - } - }else if( c==cStart ){ - i++; - c = 0; - }else if( c==0 ){ - fprintf(stderr, "%s:%d: Unterminated string or character literal.\n", - zFilename, startLine); - nErr++; - } - }while( c ); - pToken->eType = TT_String; - pToken->nText = i - pIn->i; - break; - - case '/': - if( z[i+1]=='/' ){ - /* C++ style comment */ - while( z[i] && z[i]!='\n' ){ i++; } - pToken->eType = TT_Comment; - pToken->nText = i - pIn->i; - }else if( z[i+1]=='*' ){ - /* C style comment */ - int isBlockComment = i==0 || z[i-1]=='\n'; - i += 2; - startLine = pIn->nLine; - while( z[i] && (z[i]!='*' || z[i+1]!='/') ){ - if( z[i]=='\n' ){ - pIn->nLine++; - if( isBlockComment ){ - if( z[i+1]=='*' || z[i+2]=='*' ){ - isBlockComment = 2; - }else{ - isBlockComment = 0; - } - } - } - i++; - } - if( z[i] ){ - i += 2; - }else{ - isBlockComment = 0; - fprintf(stderr,"%s:%d: Unterminated comment\n", - zFilename, startLine); - nErr++; - } - pToken->eType = isBlockComment==2 ? TT_BlockComment : TT_Comment; - pToken->nText = i - pIn->i; - }else{ - /* A divide operator */ - pToken->eType = TT_Other; - pToken->nText = 1 + (z[i+1]=='+'); - } - break; - - case '0': - if( z[i+1]=='x' || z[i+1]=='X' ){ - /* A hex constant */ - i += 2; - while( isxdigit(z[i]) ){ i++; } - }else{ - /* An octal constant */ - while( isdigit(z[i]) ){ i++; } - } - pToken->eType = TT_Number; - pToken->nText = i - pIn->i; - break; - - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - while( isdigit(z[i]) ){ i++; } - if( (c=z[i])=='.' ){ - i++; - while( isdigit(z[i]) ){ i++; } - c = z[i]; - if( c=='e' || c=='E' ){ - i++; - if( ((c=z[i])=='+' || c=='-') && isdigit(z[i+1]) ){ i++; } - while( isdigit(z[i]) ){ i++; } - c = z[i]; - } - if( c=='f' || c=='F' || c=='l' || c=='L' ){ i++; } - }else if( c=='e' || c=='E' ){ - i++; - if( ((c=z[i])=='+' || c=='-') && isdigit(z[i+1]) ){ i++; } - while( isdigit(z[i]) ){ i++; } - }else if( c=='L' || c=='l' ){ - i++; - c = z[i]; - if( c=='u' || c=='U' ){ i++; } - }else if( c=='u' || c=='U' ){ - i++; - c = z[i]; - if( c=='l' || c=='L' ){ i++; } - } - pToken->eType = TT_Number; - pToken->nText = i - pIn->i; - break; - - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g': - case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n': - case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u': - case 'v': case 'w': case 'x': case 'y': case 'z': case 'A': case 'B': - case 'C': case 'D': case 'E': case 'F': case 'G': case 'H': case 'I': - case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': - case 'Q': case 'R': case 'S': case 'T': case 'U': case 'V': case 'W': - case 'X': case 'Y': case 'Z': case '_': - while( isalnum(z[i]) || z[i]=='_' ){ i++; }; - pToken->eType = TT_Id; - pToken->nText = i - pIn->i; - break; - - case ':': - pToken->eType = TT_Other; - pToken->nText = 1 + (z[i+1]==':'); - break; - - case '=': - case '<': - case '>': - case '+': - case '-': - case '*': - case '%': - case '^': - case '&': - case '|': - pToken->eType = TT_Other; - pToken->nText = 1 + (z[i+1]=='='); - break; - - default: - pToken->eType = TT_Other; - pToken->nText = 1; - break; - } - pIn->i += pToken->nText; - return nErr; -} - -/* -** This routine recovers the next token from the input file which is -** not a space or a comment or any text between an "#if 0" and "#endif". -** -** This routine returns the number of errors encountered. An error -** is an unterminated token or unmatched "#if 0". -** -** Profiling shows that this routine uses about a quarter of the -** CPU time in a typical run. -*/ -static int GetNonspaceToken(InStream *pIn, Token *pToken){ - int nIf = 0; - int inZero = 0; - const char *z; - int value; - int startLine; - int nErr = 0; - - startLine = pIn->nLine; - while( 1 ){ - nErr += GetToken(pIn,pToken); - /* printf("%04d: Type=%d nIf=%d [%.*s]\n", - pToken->nLine,pToken->eType,nIf,pToken->nText, - pToken->eType!=TT_Space ? pToken->zText : ""); */ - pToken->pComment = blockComment; - switch( pToken->eType ){ - case TT_Comment: - case TT_Space: - break; - - case TT_BlockComment: - if( doc_flag ){ - blockComment = SafeMalloc( sizeof(Token) ); - *blockComment = *pToken; - } - break; - - case TT_EOF: - if( nIf ){ - fprintf(stderr,"%s:%d: Unterminated \"#if\"\n", - zFilename, startLine); - nErr++; - } - return nErr; - - case TT_Preprocessor: - z = &pToken->zText[1]; - while( *z==' ' || *z=='\t' ) z++; - if( sscanf(z,"if %d",&value)==1 && value==0 ){ - nIf++; - inZero = 1; - }else if( inZero ){ - if( strncmp(z,"if",2)==0 ){ - nIf++; - }else if( strncmp(z,"endif",5)==0 ){ - nIf--; - if( nIf==0 ) inZero = 0; - } - }else{ - return nErr; - } - break; - - default: - if( !inZero ){ - return nErr; - } - break; - } - } - /* NOT REACHED */ -} - -/* -** This routine looks for identifiers (strings of contiguous alphanumeric -** characters) within a preprocessor directive and adds every such string -** found to the given identifier table -*/ -static void FindIdentifiersInMacro(Token *pToken, IdentTable *pTable){ - Token sToken; - InStream sIn; - int go = 1; - - sIn.z = pToken->zText; - sIn.i = 1; - sIn.nLine = 1; - while( go && sIn.i < pToken->nText ){ - GetToken(&sIn,&sToken); - switch( sToken.eType ){ - case TT_Id: - IdentTableInsert(pTable,sToken.zText,sToken.nText); - break; - - case TT_EOF: - go = 0; - break; - - default: - break; - } - } -} - -/* -** This routine gets the next token. Everything contained within -** {...} is collapsed into a single TT_Braces token. Whitespace is -** omitted. -** -** If pTable is not NULL, then insert every identifier seen into the -** IdentTable. This includes any identifiers seen inside of {...}. -** -** The number of errors encountered is returned. An error is an -** unterminated token. -*/ -static int GetBigToken(InStream *pIn, Token *pToken, IdentTable *pTable){ - const char *z, *zStart; - int iStart; - int nBrace; - int c; - int nLine; - int nErr; - - nErr = GetNonspaceToken(pIn,pToken); - switch( pToken->eType ){ - case TT_Id: - if( pTable!=0 ){ - IdentTableInsert(pTable,pToken->zText,pToken->nText); - } - return nErr; - - case TT_Preprocessor: - if( pTable!=0 ){ - FindIdentifiersInMacro(pToken,pTable); - } - return nErr; - - case TT_Other: - if( pToken->zText[0]=='{' ) break; - return nErr; - - default: - return nErr; - } - - z = pIn->z; - iStart = pIn->i; - zStart = pToken->zText; - nLine = pToken->nLine; - nBrace = 1; - while( nBrace ){ - nErr += GetNonspaceToken(pIn,pToken); - /* printf("%04d: nBrace=%d [%.*s]\n",pToken->nLine,nBrace, - pToken->nText,pToken->zText); */ - switch( pToken->eType ){ - case TT_EOF: - fprintf(stderr,"%s:%d: Unterminated \"{\"\n", - zFilename, nLine); - nErr++; - pToken->eType = TT_Error; - return nErr; - - case TT_Id: - if( pTable ){ - IdentTableInsert(pTable,pToken->zText,pToken->nText); - } - break; - - case TT_Preprocessor: - if( pTable!=0 ){ - FindIdentifiersInMacro(pToken,pTable); - } - break; - - case TT_Other: - if( (c = pToken->zText[0])=='{' ){ - nBrace++; - }else if( c=='}' ){ - nBrace--; - } - break; - - default: - break; - } - } - pToken->eType = TT_Braces; - pToken->nText = 1 + pIn->i - iStart; - pToken->zText = zStart; - pToken->nLine = nLine; - return nErr; -} - -/* -** This routine frees up a list of Tokens. The pComment tokens are -** not cleared by this. So we leak a little memory when using the -doc -** option. So what. -*/ -static void FreeTokenList(Token *pList){ - Token *pNext; - while( pList ){ - pNext = pList->pNext; - SafeFree(pList); - pList = pNext; - } -} - -/* -** Tokenize an entire file. Return a pointer to the list of tokens. -** -** Space for each token is obtained from a separate malloc() call. The -** calling function is responsible for freeing this space. -** -** If pTable is not NULL, then fill the table with all identifiers seen in -** the input file. -*/ -static Token *TokenizeFile(const char *zFile, IdentTable *pTable){ - InStream sIn; - Token *pFirst = 0, *pLast = 0, *pNew; - int nErr = 0; - - sIn.z = zFile; - sIn.i = 0; - sIn.nLine = 1; - blockComment = 0; - - while( sIn.z[sIn.i]!=0 ){ - pNew = SafeMalloc( sizeof(Token) ); - nErr += GetBigToken(&sIn,pNew,pTable); - debug3(TOKENIZER, "Token on line %d: [%.*s]\n", - pNew->nLine, pNew->nText<50 ? pNew->nText : 50, pNew->zText); - if( pFirst==0 ){ - pFirst = pLast = pNew; - pNew->pPrev = 0; - }else{ - pLast->pNext = pNew; - pNew->pPrev = pLast; - pLast = pNew; - } - if( pNew->eType==TT_EOF ) break; - } - if( pLast ) pLast->pNext = 0; - blockComment = 0; - if( nErr ){ - FreeTokenList(pFirst); - pFirst = 0; - } - - return pFirst; -} - -#if TEST==1 -/* -** Use the following routine to test or debug the tokenizer. -*/ -void main(int argc, char **argv){ - char *zFile; - Token *pList, *p; - IdentTable sTable; - - if( argc!=2 ){ - fprintf(stderr,"Usage: %s filename\n",*argv); - exit(1); - } - memset(&sTable,0,sizeof(sTable)); - zFile = ReadFile(argv[1]); - if( zFile==0 ){ - fprintf(stderr,"Can't read file \"%s\"\n",argv[1]); - exit(1); - } - pList = TokenizeFile(zFile,&sTable); - for(p=pList; p; p=p->pNext){ - int j; - switch( p->eType ){ - case TT_Space: - printf("%4d: Space\n",p->nLine); - break; - case TT_Id: - printf("%4d: Id %.*s\n",p->nLine,p->nText,p->zText); - break; - case TT_Preprocessor: - printf("%4d: Preprocessor %.*s\n",p->nLine,p->nText,p->zText); - break; - case TT_Comment: - printf("%4d: Comment\n",p->nLine); - break; - case TT_BlockComment: - printf("%4d: Block Comment\n",p->nLine); - break; - case TT_Number: - printf("%4d: Number %.*s\n",p->nLine,p->nText,p->zText); - break; - case TT_String: - printf("%4d: String %.*s\n",p->nLine,p->nText,p->zText); - break; - case TT_Other: - printf("%4d: Other %.*s\n",p->nLine,p->nText,p->zText); - break; - case TT_Braces: - for(j=0; jnText && j<30 && p->zText[j]!='\n'; j++){} - printf("%4d: Braces %.*s...}\n",p->nLine,j,p->zText); - break; - case TT_EOF: - printf("%4d: End of file\n",p->nLine); - break; - default: - printf("%4d: type %d\n",p->nLine,p->eType); - break; - } - } - FreeTokenList(pList); - SafeFree(zFile); - IdentTablePrint(&sTable,stdout); -} -#endif - -#ifdef DEBUG -/* -** For debugging purposes, write out a list of tokens. -*/ -static void PrintTokens(Token *pFirst, Token *pLast){ - int needSpace = 0; - int c; - - pLast = pLast->pNext; - while( pFirst!=pLast ){ - switch( pFirst->eType ){ - case TT_Preprocessor: - printf("\n%.*s\n",pFirst->nText,pFirst->zText); - needSpace = 0; - break; - - case TT_Id: - case TT_Number: - printf("%s%.*s", needSpace ? " " : "", pFirst->nText, pFirst->zText); - needSpace = 1; - break; - - default: - c = pFirst->zText[0]; - printf("%s%.*s", - (needSpace && (c=='*' || c=='{')) ? " " : "", - pFirst->nText, pFirst->zText); - needSpace = pFirst->zText[0]==','; - break; - } - pFirst = pFirst->pNext; - } -} -#endif - -/* -** Convert a sequence of tokens into a string and return a pointer -** to that string. Space to hold the string is obtained from malloc() -** and must be freed by the calling function. -** -** Certain keywords (EXPORT, PRIVATE, PUBLIC, PROTECTED) are always -** skipped. -** -** If pSkip!=0 then skip over nSkip tokens beginning with pSkip. -** -** If zTerm!=0 then append the text to the end. -*/ -static char *TokensToString( - Token *pFirst, /* First token in the string */ - Token *pLast, /* Last token in the string */ - char *zTerm, /* Terminate the string with this text if not NULL */ - Token *pSkip, /* Skip this token if not NULL */ - int nSkip /* Skip a total of this many tokens */ -){ - char *zReturn; - String str; - int needSpace = 0; - int c; - int iSkip = 0; - int skipOne = 0; - - StringInit(&str); - pLast = pLast->pNext; - while( pFirst!=pLast ){ - if( pFirst==pSkip ){ iSkip = nSkip; } - if( iSkip>0 ){ - iSkip--; - pFirst=pFirst->pNext; - continue; - } - switch( pFirst->eType ){ - case TT_Preprocessor: - StringAppend(&str,"\n",1); - StringAppend(&str,pFirst->zText,pFirst->nText); - StringAppend(&str,"\n",1); - needSpace = 0; - break; - - case TT_Id: - switch( pFirst->zText[0] ){ - case 'E': - if( pFirst->nText==6 && strncmp(pFirst->zText,"EXPORT",6)==0 ){ - skipOne = 1; - } - break; - case 'P': - switch( pFirst->nText ){ - case 6: skipOne = !strncmp(pFirst->zText,"PUBLIC", 6); break; - case 7: skipOne = !strncmp(pFirst->zText,"PRIVATE",7); break; - case 9: skipOne = !strncmp(pFirst->zText,"PROTECTED",9); break; - default: break; - } - break; - default: - break; - } - if( skipOne ){ - pFirst = pFirst->pNext; - continue; - } - /* Fall thru to the next case */ - case TT_Number: - if( needSpace ){ - StringAppend(&str," ",1); - } - StringAppend(&str,pFirst->zText,pFirst->nText); - needSpace = 1; - break; - - default: - c = pFirst->zText[0]; - if( needSpace && (c=='*' || c=='{') ){ - StringAppend(&str," ",1); - } - StringAppend(&str,pFirst->zText,pFirst->nText); - /* needSpace = pFirst->zText[0]==','; */ - needSpace = 0; - break; - } - pFirst = pFirst->pNext; - } - if( zTerm && *zTerm ){ - StringAppend(&str,zTerm,strlen(zTerm)); - } - zReturn = StrDup(StringGet(&str),0); - StringReset(&str); - return zReturn; -} - -/* -** This routine is called when we see one of the keywords "struct", -** "enum", "union" or "class". This might be the beginning of a -** type declaration. This routine will process the declaration and -** remove the declaration tokens from the input stream. -** -** If this is a type declaration that is immediately followed by a -** semicolon (in other words it isn't also a variable definition) -** then set *pReset to ';'. Otherwise leave *pReset at 0. The -** *pReset flag causes the parser to skip ahead to the next token -** that begins with the value placed in the *pReset flag, if that -** value is different from 0. -*/ -static int ProcessTypeDecl(Token *pList, int flags, int *pReset){ - Token *pName, *pEnd; - Decl *pDecl; - String str; - int need_to_collapse = 1; - int type = 0; - - *pReset = 0; - if( pList==0 || pList->pNext==0 || pList->pNext->eType!=TT_Id ){ - return 0; - } - pName = pList->pNext; - - /* Catch the case of "struct Foo;" and skip it. */ - if( pName->pNext && pName->pNext->zText[0]==';' ){ - *pReset = ';'; - return 0; - } - - for(pEnd=pName->pNext; pEnd && pEnd->eType!=TT_Braces; pEnd=pEnd->pNext){ - switch( pEnd->zText[0] ){ - case '(': - case '*': - case '[': - case '=': - case ';': - return 0; - } - } - if( pEnd==0 ){ - return 0; - } - - /* - ** At this point, we know we have a type declaration that is bounded - ** by pList and pEnd and has the name pName. - */ - - /* - ** If the braces are followed immedately by a semicolon, then we are - ** dealing a type declaration only. There is not variable definition - ** following the type declaration. So reset... - */ - if( pEnd->pNext==0 || pEnd->pNext->zText[0]==';' ){ - *pReset = ';'; - need_to_collapse = 0; - }else{ - need_to_collapse = 1; - } - - if( proto_static==0 && (flags & (PS_Local|PS_Export|PS_Interface))==0 ){ - /* Ignore these objects unless they are explicitly declared as interface, - ** or unless the "-local" command line option was specified. */ - *pReset = ';'; - return 0; - } - -#ifdef DEBUG - if( debugMask & PARSER ){ - printf("**** Found type: %.*s %.*s...\n", - pList->nText, pList->zText, pName->nText, pName->zText); - PrintTokens(pList,pEnd); - printf(";\n"); - } -#endif - - /* - ** Create a new Decl object for this definition. Actually, if this - ** is a C++ class definition, then the Decl object might already exist, - ** so check first for that case before creating a new one. - */ - switch( *pList->zText ){ - case 'c': type = TY_Class; break; - case 's': type = TY_Structure; break; - case 'e': type = TY_Enumeration; break; - case 'u': type = TY_Union; break; - default: /* Can't Happen */ break; - } - if( type!=TY_Class ){ - pDecl = 0; - }else{ - pDecl = FindDecl(pName->zText, pName->nText); - if( pDecl && (pDecl->flags & type)!=type ) pDecl = 0; - } - if( pDecl==0 ){ - pDecl = CreateDecl(pName->zText,pName->nText); - } - if( (flags & PS_Static) || !(flags & (PS_Interface|PS_Export)) ){ - DeclSetProperty(pDecl,DP_Local); - } - DeclSetProperty(pDecl,type); - - /* The object has a full declaration only if it is contained within - ** "#if INTERFACE...#endif" or "#if EXPORT_INTERFACE...#endif" or - ** "#if LOCAL_INTERFACE...#endif". Otherwise, we only give it a - ** forward declaration. - */ - if( flags & (PS_Local | PS_Export | PS_Interface) ){ - pDecl->zDecl = TokensToString(pList,pEnd,";\n",0,0); - }else{ - pDecl->zDecl = 0; - } - pDecl->pComment = pList->pComment; - StringInit(&str); - StringAppend(&str,"typedef ",0); - StringAppend(&str,pList->zText,pList->nText); - StringAppend(&str," ",0); - StringAppend(&str,pName->zText,pName->nText); - StringAppend(&str," ",0); - StringAppend(&str,pName->zText,pName->nText); - StringAppend(&str,";\n",2); - pDecl->zFwd = StrDup(StringGet(&str),0); - StringReset(&str); - StringInit(&str); - StringAppend(&str,pList->zText,pList->nText); - StringAppend(&str," ",0); - StringAppend(&str,pName->zText,pName->nText); - StringAppend(&str,";\n",2); - pDecl->zFwdCpp = StrDup(StringGet(&str),0); - StringReset(&str); - if( flags & PS_Export ){ - DeclSetProperty(pDecl,DP_Export); - }else if( flags & PS_Local ){ - DeclSetProperty(pDecl,DP_Local); - } - - /* Here's something weird. ANSI-C doesn't allow a forward declaration - ** of an enumeration. So we have to build the typedef into the - ** definition. - */ - if( pDecl->zDecl && DeclHasProperty(pDecl, TY_Enumeration) ){ - StringInit(&str); - StringAppend(&str,pDecl->zDecl,0); - StringAppend(&str,pDecl->zFwd,0); - SafeFree(pDecl->zDecl); - SafeFree(pDecl->zFwd); - pDecl->zFwd = 0; - pDecl->zDecl = StrDup(StringGet(&str),0); - StringReset(&str); - } - - if( pName->pNext->zText[0]==':' ){ - DeclSetProperty(pDecl,DP_Cplusplus); - } - if( pName->nText==5 && strncmp(pName->zText,"class",5)==0 ){ - DeclSetProperty(pDecl,DP_Cplusplus); - } - - /* - ** Remove all but pList and pName from the input stream. - */ - if( need_to_collapse ){ - while( pEnd!=pName ){ - Token *pPrev = pEnd->pPrev; - pPrev->pNext = pEnd->pNext; - pEnd->pNext->pPrev = pPrev; - SafeFree(pEnd); - pEnd = pPrev; - } - } - return 0; -} - -/* -** Given a list of tokens that declare something (a function, procedure, -** variable or typedef) find the token which contains the name of the -** thing being declared. -** -** Algorithm: -** -** The name is: -** -** 1. The first identifier that is followed by a "[", or -** -** 2. The first identifier that is followed by a "(" where the -** "(" is followed by another identifier, or -** -** 3. The first identifier followed by "::", or -** -** 4. If none of the above, then the last identifier. -** -** In all of the above, certain reserved words (like "char") are -** not considered identifiers. -*/ -static Token *FindDeclName(Token *pFirst, Token *pLast){ - Token *pName = 0; - Token *p; - int c; - - if( pFirst==0 || pLast==0 ){ - return 0; - } - pLast = pLast->pNext; - for(p=pFirst; p && p!=pLast; p=p->pNext){ - if( p->eType==TT_Id ){ - static IdentTable sReserved; - static int isInit = 0; - static char *aWords[] = { "char", "class", - "const", "double", "enum", "extern", "EXPORT", "ET_PROC", - "float", "int", "long", - "PRIVATE", "PROTECTED", "PUBLIC", - "register", "static", "struct", "sizeof", "signed", "typedef", - "union", "volatile", "virtual", "void", }; - - if( !isInit ){ - int i; - for(i=0; izText,p->nText) ){ - pName = p; - } - }else if( p==pFirst ){ - continue; - }else if( (c=p->zText[0])=='[' && pName ){ - break; - }else if( c=='(' && p->pNext && p->pNext->eType==TT_Id && pName ){ - break; - }else if( c==':' && p->zText[1]==':' && pName ){ - break; - } - } - return pName; -} - -/* -** This routine is called when we see a method for a class that begins -** with the PUBLIC, PRIVATE, or PROTECTED keywords. Such methods are -** added to their class definitions. -*/ -static int ProcessMethodDef(Token *pFirst, Token *pLast, int flags){ - Token *pCode; - Token *pClass; - char *zDecl; - Decl *pDecl; - String str; - int type; - - pCode = pLast; - pLast = pLast->pPrev; - while( pFirst->zText[0]=='P' ){ - int rc = 1; - switch( pFirst->nText ){ - case 6: rc = strncmp(pFirst->zText,"PUBLIC",6); break; - case 7: rc = strncmp(pFirst->zText,"PRIVATE",7); break; - case 9: rc = strncmp(pFirst->zText,"PROTECTED",9); break; - default: break; - } - if( rc ) break; - pFirst = pFirst->pNext; - } - pClass = FindDeclName(pFirst,pLast); - if( pClass==0 ){ - fprintf(stderr,"%s:%d: Unable to find the class name for this method\n", - zFilename, pFirst->nLine); - return 1; - } - pDecl = FindDecl(pClass->zText, pClass->nText); - if( pDecl==0 || (pDecl->flags & TY_Class)!=TY_Class ){ - pDecl = CreateDecl(pClass->zText, pClass->nText); - DeclSetProperty(pDecl, TY_Class); - } - StringInit(&str); - if( pDecl->zExtra ){ - StringAppend(&str, pDecl->zExtra, 0); - SafeFree(pDecl->zExtra); - pDecl->zExtra = 0; - } - type = flags & PS_PPP; - if( pDecl->extraType!=type ){ - if( type & PS_Public ){ - StringAppend(&str, "public:\n", 0); - pDecl->extraType = PS_Public; - }else if( type & PS_Protected ){ - StringAppend(&str, "protected:\n", 0); - pDecl->extraType = PS_Protected; - }else if( type & PS_Private ){ - StringAppend(&str, "private:\n", 0); - pDecl->extraType = PS_Private; - } - } - StringAppend(&str, " ", 0); - zDecl = TokensToString(pFirst, pLast, ";\n", pClass, 2); - StringAppend(&str, zDecl, 0); - SafeFree(zDecl); - pDecl->zExtra = StrDup(StringGet(&str), 0); - StringReset(&str); - return 0; -} - -/* -** This routine is called when we see a function or procedure definition. -** We make an entry in the declaration table that is a prototype for this -** function or procedure. -*/ -static int ProcessProcedureDef(Token *pFirst, Token *pLast, int flags){ - Token *pName; - Decl *pDecl; - Token *pCode; - - if( pFirst==0 || pLast==0 ){ - return 0; - } - if( flags & PS_Method ){ - if( flags & PS_PPP ){ - return ProcessMethodDef(pFirst, pLast, flags); - }else{ - return 0; - } - } - if( (flags & PS_Static)!=0 && !proto_static ){ - return 0; - } - pCode = pLast; - while( pLast && pLast!=pFirst && pLast->zText[0]!=')' ){ - pLast = pLast->pPrev; - } - if( pLast==0 || pLast==pFirst || pFirst->pNext==pLast ){ - fprintf(stderr,"%s:%d: Unrecognized syntax.\n", - zFilename, pFirst->nLine); - return 1; - } - if( flags & (PS_Interface|PS_Export|PS_Local) ){ - fprintf(stderr,"%s:%d: Missing \"inline\" on function or procedure.\n", - zFilename, pFirst->nLine); - return 1; - } - pName = FindDeclName(pFirst,pLast); - if( pName==0 ){ - fprintf(stderr,"%s:%d: Malformed function or procedure definition.\n", - zFilename, pFirst->nLine); - return 1; - } - - /* - ** At this point we've isolated a procedure declaration between pFirst - ** and pLast with the name pName. - */ -#ifdef DEBUG - if( debugMask & PARSER ){ - printf("**** Found routine: %.*s on line %d...\n", pName->nText, - pName->zText, pFirst->nLine); - PrintTokens(pFirst,pLast); - printf(";\n"); - } -#endif - pDecl = CreateDecl(pName->zText,pName->nText); - pDecl->pComment = pFirst->pComment; - if( pCode && pCode->eType==TT_Braces ){ - pDecl->tokenCode = *pCode; - } - DeclSetProperty(pDecl,TY_Subroutine); - pDecl->zDecl = TokensToString(pFirst,pLast,";\n",0,0); - if( (flags & (PS_Static|PS_Local2))!=0 ){ - DeclSetProperty(pDecl,DP_Local); - }else if( (flags & (PS_Export2))!=0 ){ - DeclSetProperty(pDecl,DP_Export); - } - - if( flags & DP_Cplusplus ){ - DeclSetProperty(pDecl,DP_Cplusplus); - }else{ - DeclSetProperty(pDecl,DP_ExternCReqd); - } - - return 0; -} - -/* -** This routine is called whenever we see the "inline" keyword. We -** need to seek-out the inline function or procedure and make a -** declaration out of the entire definition. -*/ -static int ProcessInlineProc(Token *pFirst, int flags, int *pReset){ - Token *pName; - Token *pEnd; - Decl *pDecl; - - for(pEnd=pFirst; pEnd; pEnd = pEnd->pNext){ - if( pEnd->zText[0]=='{' || pEnd->zText[0]==';' ){ - *pReset = pEnd->zText[0]; - break; - } - } - if( pEnd==0 ){ - *pReset = ';'; - fprintf(stderr,"%s:%d: incomplete inline procedure definition\n", - zFilename, pFirst->nLine); - return 1; - } - pName = FindDeclName(pFirst,pEnd); - if( pName==0 ){ - fprintf(stderr,"%s:%d: malformed inline procedure definition\n", - zFilename, pFirst->nLine); - return 1; - } - -#ifdef DEBUG - if( debugMask & PARSER ){ - printf("**** Found inline routine: %.*s on line %d...\n", - pName->nText, pName->zText, pFirst->nLine); - PrintTokens(pFirst,pEnd); - printf("\n"); - } -#endif - pDecl = CreateDecl(pName->zText,pName->nText); - pDecl->pComment = pFirst->pComment; - DeclSetProperty(pDecl,TY_Subroutine); - pDecl->zDecl = TokensToString(pFirst,pEnd,";\n",0,0); - if( (flags & (PS_Static|PS_Local|PS_Local2)) ){ - DeclSetProperty(pDecl,DP_Local); - }else if( flags & (PS_Export|PS_Export2) ){ - DeclSetProperty(pDecl,DP_Export); - } - - if( flags & DP_Cplusplus ){ - DeclSetProperty(pDecl,DP_Cplusplus); - }else{ - DeclSetProperty(pDecl,DP_ExternCReqd); - } - - return 0; -} - -/* -** Determine if the tokens between pFirst and pEnd form a variable -** definition or a function prototype. Return TRUE if we are dealing -** with a variable defintion and FALSE for a prototype. -** -** pEnd is the token that ends the object. It can be either a ';' or -** a '='. If it is '=', then assume we have a variable definition. -** -** If pEnd is ';', then the determination is more difficult. We have -** to search for an occurance of an ID followed immediately by '('. -** If found, we have a prototype. Otherwise we are dealing with a -** variable definition. -*/ -static int isVariableDef(Token *pFirst, Token *pEnd){ - if( pEnd && pEnd->zText[0]=='=' && - (pEnd->pPrev->nText!=8 || strncmp(pEnd->pPrev->zText,"operator",8)!=0) - ){ - return 1; - } - while( pFirst && pFirst!=pEnd && pFirst->pNext && pFirst->pNext!=pEnd ){ - if( pFirst->eType==TT_Id && pFirst->pNext->zText[0]=='(' ){ - return 0; - } - pFirst = pFirst->pNext; - } - return 1; -} - - -/* -** This routine is called whenever we encounter a ";" or "=". The stuff -** between pFirst and pLast constitutes either a typedef or a global -** variable definition. Do the right thing. -*/ -static int ProcessDecl(Token *pFirst, Token *pEnd, int flags){ - Token *pName; - Decl *pDecl; - int isLocal = 0; - int isVar; - int nErr = 0; - - if( pFirst==0 || pEnd==0 ){ - return 0; - } - if( flags & PS_Typedef ){ - if( (flags & (PS_Export2|PS_Local2))!=0 ){ - fprintf(stderr,"%s:%d: \"EXPORT\" or \"LOCAL\" ignored before typedef.\n", - zFilename, pFirst->nLine); - nErr++; - } - if( (flags & (PS_Interface|PS_Export|PS_Local|DP_Cplusplus))==0 ){ - /* It is illegal to duplicate a typedef in C (but OK in C++). - ** So don't record typedefs that aren't within a C++ file or - ** within #if INTERFACE..#endif */ - return nErr; - } - if( (flags & (PS_Interface|PS_Export|PS_Local))==0 && proto_static==0 ){ - /* Ignore typedefs that are not with "#if INTERFACE..#endif" unless - ** the "-local" command line option is used. */ - return nErr; - } - if( (flags & (PS_Interface|PS_Export))==0 ){ - /* typedefs are always local, unless within #if INTERFACE..#endif */ - isLocal = 1; - } - }else if( flags & (PS_Static|PS_Local2) ){ - if( proto_static==0 && (flags & PS_Local2)==0 ){ - /* Don't record static variables unless the "-local" command line - ** option was specified or the "LOCAL" keyword is used. */ - return nErr; - } - while( pFirst!=0 && pFirst->pNext!=pEnd && - ((pFirst->nText==6 && strncmp(pFirst->zText,"static",6)==0) - || (pFirst->nText==5 && strncmp(pFirst->zText,"LOCAL",6)==0)) - ){ - /* Lose the initial "static" or local from local variables. - ** We'll prepend "extern" later. */ - pFirst = pFirst->pNext; - isLocal = 1; - } - if( pFirst==0 || !isLocal ){ - return nErr; - } - }else if( flags & PS_Method ){ - /* Methods are declared by their class. Don't declare separately. */ - return nErr; - } - isVar = (flags & (PS_Typedef|PS_Method))==0 && isVariableDef(pFirst,pEnd); - if( isVar && (flags & (PS_Interface|PS_Export|PS_Local))!=0 - && (flags & PS_Extern)==0 ){ - fprintf(stderr,"%s:%d: Can't define a variable in this context\n", - zFilename, pFirst->nLine); - nErr++; - } - pName = FindDeclName(pFirst,pEnd->pPrev); - if( pName==0 ){ - fprintf(stderr,"%s:%d: Can't find a name for the object declared here.\n", - zFilename, pFirst->nLine); - return nErr+1; - } - -#ifdef DEBUG - if( debugMask & PARSER ){ - if( flags & PS_Typedef ){ - printf("**** Found typedef %.*s at line %d...\n", - pName->nText, pName->zText, pName->nLine); - }else if( isVar ){ - printf("**** Found variable %.*s at line %d...\n", - pName->nText, pName->zText, pName->nLine); - }else{ - printf("**** Found prototype %.*s at line %d...\n", - pName->nText, pName->zText, pName->nLine); - } - PrintTokens(pFirst,pEnd->pPrev); - printf(";\n"); - } -#endif - - pDecl = CreateDecl(pName->zText,pName->nText); - if( (flags & PS_Typedef) ){ - DeclSetProperty(pDecl, TY_Typedef); - }else if( isVar ){ - DeclSetProperty(pDecl,DP_ExternReqd | TY_Variable); - if( !(flags & DP_Cplusplus) ){ - DeclSetProperty(pDecl,DP_ExternCReqd); - } - }else{ - DeclSetProperty(pDecl, TY_Subroutine); - if( !(flags & DP_Cplusplus) ){ - DeclSetProperty(pDecl,DP_ExternCReqd); - } - } - pDecl->pComment = pFirst->pComment; - pDecl->zDecl = TokensToString(pFirst,pEnd->pPrev,";\n",0,0); - if( isLocal || (flags & (PS_Local|PS_Local2))!=0 ){ - DeclSetProperty(pDecl,DP_Local); - }else if( flags & (PS_Export|PS_Export2) ){ - DeclSetProperty(pDecl,DP_Export); - } - if( flags & DP_Cplusplus ){ - DeclSetProperty(pDecl,DP_Cplusplus); - } - return nErr; -} - -/* -** Push an if condition onto the if stack -*/ -static void PushIfMacro( - const char *zPrefix, /* A prefix, like "define" or "!" */ - const char *zText, /* The condition */ - int nText, /* Number of characters in zText */ - int nLine, /* Line number where this macro occurs */ - int flags /* Either 0, PS_Interface, PS_Export or PS_Local */ -){ - Ifmacro *pIf; - int nByte; - - nByte = sizeof(Ifmacro); - if( zText ){ - if( zPrefix ){ - nByte += strlen(zPrefix) + 2; - } - nByte += nText + 1; - } - pIf = SafeMalloc( nByte ); - if( zText ){ - pIf->zCondition = (char*)&pIf[1]; - if( zPrefix ){ - sprintf(pIf->zCondition,"%s(%.*s)",zPrefix,nText,zText); - }else{ - sprintf(pIf->zCondition,"%.*s",nText,zText); - } - }else{ - pIf->zCondition = 0; - } - pIf->nLine = nLine; - pIf->flags = flags; - pIf->pNext = ifStack; - ifStack = pIf; -} - -/* -** This routine is called to handle all preprocessor directives. -** -** This routine will recompute the value of *pPresetFlags to be the -** logical or of all flags on all nested #ifs. The #ifs that set flags -** are as follows: -** -** conditional flag set -** ------------------------ -------------------- -** #if INTERFACE PS_Interface -** #if EXPORT_INTERFACE PS_Export -** #if LOCAL_INTERFACE PS_Local -** -** For example, if after processing the preprocessor token given -** by pToken there is an "#if INTERFACE" on the preprocessor -** stack, then *pPresetFlags will be set to PS_Interface. -*/ -static int ParsePreprocessor(Token *pToken, int flags, int *pPresetFlags){ - const char *zCmd; - int nCmd; - const char *zArg; - int nArg; - int nErr = 0; - Ifmacro *pIf; - - zCmd = &pToken->zText[1]; - while( isspace(*zCmd) && *zCmd!='\n' ){ - zCmd++; - } - if( !isalpha(*zCmd) ){ - return 0; - } - nCmd = 1; - while( isalpha(zCmd[nCmd]) ){ - nCmd++; - } - - if( nCmd==5 && strncmp(zCmd,"endif",5)==0 ){ - /* - ** Pop the if stack - */ - pIf = ifStack; - if( pIf==0 ){ - fprintf(stderr,"%s:%d: extra '#endif'.\n",zFilename,pToken->nLine); - return 1; - } - ifStack = pIf->pNext; - SafeFree(pIf); - }else if( nCmd==6 && strncmp(zCmd,"define",6)==0 ){ - /* - ** Record a #define if we are in PS_Interface or PS_Export - */ - Decl *pDecl; - if( !(flags & (PS_Local|PS_Interface|PS_Export)) ){ return 0; } - zArg = &zCmd[6]; - while( *zArg && isspace(*zArg) && *zArg!='\n' ){ - zArg++; - } - if( *zArg==0 || *zArg=='\n' ){ return 0; } - for(nArg=0; ISALNUM(zArg[nArg]); nArg++){} - if( nArg==0 ){ return 0; } - pDecl = CreateDecl(zArg,nArg); - pDecl->pComment = pToken->pComment; - DeclSetProperty(pDecl,TY_Macro); - pDecl->zDecl = SafeMalloc( pToken->nText + 2 ); - sprintf(pDecl->zDecl,"%.*s\n",pToken->nText,pToken->zText); - if( flags & PS_Export ){ - DeclSetProperty(pDecl,DP_Export); - }else if( flags & PS_Local ){ - DeclSetProperty(pDecl,DP_Local); - } - }else if( nCmd==7 && strncmp(zCmd,"include",7)==0 ){ - /* - ** Record an #include if we are in PS_Interface or PS_Export - */ - Include *pInclude; - char *zIf; - - if( !(flags & (PS_Interface|PS_Export)) ){ return 0; } - zArg = &zCmd[7]; - while( *zArg && isspace(*zArg) ){ zArg++; } - for(nArg=0; !isspace(zArg[nArg]); nArg++){} - if( (zArg[0]=='"' && zArg[nArg-1]!='"') - ||(zArg[0]=='<' && zArg[nArg-1]!='>') - ){ - fprintf(stderr,"%s:%d: malformed #include statement.\n", - zFilename,pToken->nLine); - return 1; - } - zIf = GetIfString(); - if( zIf ){ - pInclude = SafeMalloc( sizeof(Include) + nArg*2 + strlen(zIf) + 10 ); - pInclude->zFile = (char*)&pInclude[1]; - pInclude->zLabel = &pInclude->zFile[nArg+1]; - sprintf(pInclude->zFile,"%.*s",nArg,zArg); - sprintf(pInclude->zLabel,"%.*s:%s",nArg,zArg,zIf); - pInclude->zIf = &pInclude->zLabel[nArg+1]; - SafeFree(zIf); - }else{ - pInclude = SafeMalloc( sizeof(Include) + nArg + 1 ); - pInclude->zFile = (char*)&pInclude[1]; - sprintf(pInclude->zFile,"%.*s",nArg,zArg); - pInclude->zIf = 0; - pInclude->zLabel = pInclude->zFile; - } - pInclude->pNext = includeList; - includeList = pInclude; - }else if( nCmd==2 && strncmp(zCmd,"if",2)==0 ){ - /* - ** Push an #if. Watch for the special cases of INTERFACE - ** and EXPORT_INTERFACE and LOCAL_INTERFACE - */ - zArg = &zCmd[2]; - while( *zArg && isspace(*zArg) && *zArg!='\n' ){ - zArg++; - } - if( *zArg==0 || *zArg=='\n' ){ return 0; } - nArg = pToken->nText + (int)(pToken->zText - zArg); - if( nArg==9 && strncmp(zArg,"INTERFACE",9)==0 ){ - PushIfMacro(0,0,0,pToken->nLine,PS_Interface); - }else if( nArg==16 && strncmp(zArg,"EXPORT_INTERFACE",16)==0 ){ - PushIfMacro(0,0,0,pToken->nLine,PS_Export); - }else if( nArg==15 && strncmp(zArg,"LOCAL_INTERFACE",15)==0 ){ - PushIfMacro(0,0,0,pToken->nLine,PS_Local); - }else{ - PushIfMacro(0,zArg,nArg,pToken->nLine,0); - } - }else if( nCmd==5 && strncmp(zCmd,"ifdef",5)==0 ){ - /* - ** Push an #ifdef. - */ - zArg = &zCmd[5]; - while( *zArg && isspace(*zArg) && *zArg!='\n' ){ - zArg++; - } - if( *zArg==0 || *zArg=='\n' ){ return 0; } - nArg = pToken->nText + (int)(pToken->zText - zArg); - PushIfMacro("defined",zArg,nArg,pToken->nLine,0); - }else if( nCmd==6 && strncmp(zCmd,"ifndef",6)==0 ){ - /* - ** Push an #ifndef. - */ - zArg = &zCmd[6]; - while( *zArg && isspace(*zArg) && *zArg!='\n' ){ - zArg++; - } - if( *zArg==0 || *zArg=='\n' ){ return 0; } - nArg = pToken->nText + (int)(pToken->zText - zArg); - PushIfMacro("!defined",zArg,nArg,pToken->nLine,0); - }else if( nCmd==4 && strncmp(zCmd,"else",4)==0 ){ - /* - ** Invert the #if on the top of the stack - */ - if( ifStack==0 ){ - fprintf(stderr,"%s:%d: '#else' without an '#if'\n",zFilename, - pToken->nLine); - return 1; - } - pIf = ifStack; - if( pIf->zCondition ){ - ifStack = ifStack->pNext; - PushIfMacro("!",pIf->zCondition,strlen(pIf->zCondition),pIf->nLine,0); - SafeFree(pIf); - }else{ - pIf->flags = 0; - } - }else{ - /* - ** This directive can be safely ignored - */ - return 0; - } - - /* - ** Recompute the preset flags - */ - *pPresetFlags = 0; - for(pIf = ifStack; pIf; pIf=pIf->pNext){ - *pPresetFlags |= pIf->flags; - } - - return nErr; -} - -/* -** Parse an entire file. Return the number of errors. -** -** pList is a list of tokens in the file. Whitespace tokens have been -** eliminated, and text with {...} has been collapsed into a -** single TT_Brace token. -** -** initFlags are a set of parse flags that should always be set for this -** file. For .c files this is normally 0. For .h files it is PS_Interface. -*/ -static int ParseFile(Token *pList, int initFlags){ - int nErr = 0; - Token *pStart = 0; - int flags = initFlags; - int presetFlags = initFlags; - int resetFlag = 0; - - includeList = 0; - while( pList ){ - switch( pList->eType ){ - case TT_EOF: - goto end_of_loop; - - case TT_Preprocessor: - nErr += ParsePreprocessor(pList,flags,&presetFlags); - pStart = 0; - presetFlags |= initFlags; - flags = presetFlags; - break; - - case TT_Other: - switch( pList->zText[0] ){ - case ';': - nErr += ProcessDecl(pStart,pList,flags); - pStart = 0; - flags = presetFlags; - break; - - case '=': - if( pList->pPrev->nText==8 - && strncmp(pList->pPrev->zText,"operator",8)==0 ){ - break; - } - nErr += ProcessDecl(pStart,pList,flags); - pStart = 0; - while( pList && pList->zText[0]!=';' ){ - pList = pList->pNext; - } - if( pList==0 ) goto end_of_loop; - flags = presetFlags; - break; - - case ':': - if( pList->zText[1]==':' ){ - flags |= PS_Method; - } - break; - - default: - break; - } - break; - - case TT_Braces: - nErr += ProcessProcedureDef(pStart,pList,flags); - pStart = 0; - flags = presetFlags; - break; - - case TT_Id: - if( pStart==0 ){ - pStart = pList; - flags = presetFlags; - } - resetFlag = 0; - switch( pList->zText[0] ){ - case 'c': - if( pList->nText==5 && strncmp(pList->zText,"class",5)==0 ){ - nErr += ProcessTypeDecl(pList,flags,&resetFlag); - } - break; - - case 'E': - if( pList->nText==6 && strncmp(pList->zText,"EXPORT",6)==0 ){ - flags |= PS_Export2; - /* pStart = 0; */ - } - break; - - case 'e': - if( pList->nText==4 && strncmp(pList->zText,"enum",4)==0 ){ - if( pList->pNext && pList->pNext->eType==TT_Braces ){ - pList = pList->pNext; - }else{ - nErr += ProcessTypeDecl(pList,flags,&resetFlag); - } - }else if( pList->nText==6 && strncmp(pList->zText,"extern",6)==0 ){ - pList = pList->pNext; - if( pList && pList->nText==3 && strncmp(pList->zText,"\"C\"",3)==0 ){ - pList = pList->pNext; - flags &= ~DP_Cplusplus; - }else{ - flags |= PS_Extern; - } - pStart = pList; - } - break; - - case 'i': - if( pList->nText==6 && strncmp(pList->zText,"inline",6)==0 ){ - nErr += ProcessInlineProc(pList,flags,&resetFlag); - } - break; - - case 'L': - if( pList->nText==5 && strncmp(pList->zText,"LOCAL",5)==0 ){ - flags |= PS_Local2; - pStart = pList; - } - break; - - case 'P': - if( pList->nText==6 && strncmp(pList->zText, "PUBLIC",6)==0 ){ - flags |= PS_Public; - pStart = pList; - }else if( pList->nText==7 && strncmp(pList->zText, "PRIVATE",7)==0 ){ - flags |= PS_Private; - pStart = pList; - }else if( pList->nText==9 && strncmp(pList->zText,"PROTECTED",9)==0 ){ - flags |= PS_Protected; - pStart = pList; - } - break; - - case 's': - if( pList->nText==6 && strncmp(pList->zText,"struct",6)==0 ){ - if( pList->pNext && pList->pNext->eType==TT_Braces ){ - pList = pList->pNext; - }else{ - nErr += ProcessTypeDecl(pList,flags,&resetFlag); - } - }else if( pList->nText==6 && strncmp(pList->zText,"static",6)==0 ){ - flags |= PS_Static; - } - break; - - case 't': - if( pList->nText==7 && strncmp(pList->zText,"typedef",7)==0 ){ - flags |= PS_Typedef; - } - break; - - case 'u': - if( pList->nText==5 && strncmp(pList->zText,"union",5)==0 ){ - if( pList->pNext && pList->pNext->eType==TT_Braces ){ - pList = pList->pNext; - }else{ - nErr += ProcessTypeDecl(pList,flags,&resetFlag); - } - } - break; - - default: - break; - } - if( resetFlag!=0 ){ - while( pList && pList->zText[0]!=resetFlag ){ - pList = pList->pNext; - } - if( pList==0 ) goto end_of_loop; - pStart = 0; - flags = presetFlags; - } - break; - - case TT_String: - case TT_Number: - break; - - default: - pStart = pList; - flags = presetFlags; - break; - } - pList = pList->pNext; - } - end_of_loop: - - /* Verify that all #ifs have a matching "#endif" */ - while( ifStack ){ - Ifmacro *pIf = ifStack; - ifStack = pIf->pNext; - fprintf(stderr,"%s:%d: This '#if' has no '#endif'\n",zFilename, - pIf->nLine); - SafeFree(pIf); - } - - return nErr; -} - -/* -** If the given Decl object has a non-null zExtra field, then the text -** of that zExtra field needs to be inserted in the middle of the -** zDecl field before the last "}" in the zDecl. This routine does that. -** If the zExtra is NULL, this routine is a no-op. -** -** zExtra holds extra method declarations for classes. The declarations -** have to be inserted into the class definition. -*/ -static void InsertExtraDecl(Decl *pDecl){ - int i; - String str; - - if( pDecl==0 || pDecl->zExtra==0 || pDecl->zDecl==0 ) return; - i = strlen(pDecl->zDecl) - 1; - while( i>0 && pDecl->zDecl[i]!='}' ){ i--; } - StringInit(&str); - StringAppend(&str, pDecl->zDecl, i); - StringAppend(&str, pDecl->zExtra, 0); - StringAppend(&str, &pDecl->zDecl[i], 0); - SafeFree(pDecl->zDecl); - SafeFree(pDecl->zExtra); - pDecl->zDecl = StrDup(StringGet(&str), 0); - StringReset(&str); - pDecl->zExtra = 0; -} - -/* -** Reset the DP_Forward and DP_Declared flags on all Decl structures. -** Set both flags for anything that is tagged as local and isn't -** in the file zFilename so that it won't be printing in other files. -*/ -static void ResetDeclFlags(char *zFilename){ - Decl *pDecl; - - for(pDecl = pDeclFirst; pDecl; pDecl = pDecl->pNext){ - DeclClearProperty(pDecl,DP_Forward|DP_Declared); - if( DeclHasProperty(pDecl,DP_Local) && pDecl->zFile!=zFilename ){ - DeclSetProperty(pDecl,DP_Forward|DP_Declared); - } - } -} - -/* -** Forward declaration of the ScanText() function. -*/ -static void ScanText(const char*, GenState *pState); - -/* -** The output in pStr is currently within an #if CONTEXT where context -** is equal to *pzIf. (*pzIf might be NULL to indicate that we are -** not within any #if at the moment.) We are getting ready to output -** some text that needs to be within the context of "#if NEW" where -** NEW is zIf. Make an appropriate change to the context. -*/ -static void ChangeIfContext( - const char *zIf, /* The desired #if context */ - GenState *pState /* Current state of the code generator */ -){ - if( zIf==0 ){ - if( pState->zIf==0 ) return; - StringAppend(pState->pStr,"#endif\n",0); - pState->zIf = 0; - }else{ - if( pState->zIf ){ - if( strcmp(zIf,pState->zIf)==0 ) return; - StringAppend(pState->pStr,"#endif\n",0); - pState->zIf = 0; - } - ScanText(zIf, pState); - if( pState->zIf!=0 ){ - StringAppend(pState->pStr,"#endif\n",0); - } - StringAppend(pState->pStr,"#if ",0); - StringAppend(pState->pStr,zIf,0); - StringAppend(pState->pStr,"\n",0); - pState->zIf = zIf; - } -} - -/* -** Add to the string pStr a #include of every file on the list of -** include files pInclude. The table pTable contains all files that -** have already been #included at least once. Don't add any -** duplicates. Update pTable with every new #include that is added. -*/ -static void AddIncludes( - Include *pInclude, /* Write every #include on this list */ - GenState *pState /* Current state of the code generator */ -){ - if( pInclude ){ - if( pInclude->pNext ){ - AddIncludes(pInclude->pNext,pState); - } - if( IdentTableInsert(pState->pTable,pInclude->zLabel,0) ){ - ChangeIfContext(pInclude->zIf,pState); - StringAppend(pState->pStr,"#include ",0); - StringAppend(pState->pStr,pInclude->zFile,0); - StringAppend(pState->pStr,"\n",1); - } - } -} - -/* -** Add to the string pStr a declaration for the object described -** in pDecl. -** -** If pDecl has already been declared in this file, detect that -** fact and abort early. Do not duplicate a declaration. -** -** If the needFullDecl flag is false and this object has a forward -** declaration, then supply the forward declaration only. A later -** call to CompleteForwardDeclarations() will finish the declaration -** for us. But if needFullDecl is true, we must supply the full -** declaration now. Some objects do not have a forward declaration. -** For those objects, we must print the full declaration now. -** -** Because it is illegal to duplicate a typedef in C, care is taken -** to insure that typedefs for the same identifier are only issued once. -*/ -static void DeclareObject( - Decl *pDecl, /* The thing to be declared */ - GenState *pState, /* Current state of the code generator */ - int needFullDecl /* Must have the full declaration. A forward - * declaration isn't enough */ -){ - Decl *p; /* The object to be declared */ - int flag; - int isCpp; /* True if generating C++ */ - int doneTypedef = 0; /* True if a typedef has been done for this object */ - - /* printf("BEGIN %s of %s\n",needFullDecl?"FULL":"PROTOTYPE",pDecl->zName);*/ - /* - ** For any object that has a forward declaration, go ahead and do the - ** forward declaration first. - */ - isCpp = (pState->flags & DP_Cplusplus) != 0; - for(p=pDecl; p; p=p->pSameName){ - if( p->zFwd ){ - if( !DeclHasProperty(p,DP_Forward) ){ - DeclSetProperty(p,DP_Forward); - if( strncmp(p->zFwd,"typedef",7)==0 ){ - if( doneTypedef ) continue; - doneTypedef = 1; - } - ChangeIfContext(p->zIf,pState); - StringAppend(pState->pStr,isCpp ? p->zFwdCpp : p->zFwd,0); - } - } - } - - /* - ** Early out if everything is already suitably declared. - ** - ** This is a very important step because it prevents us from - ** executing the code the follows in a recursive call to this - ** function with the same value for pDecl. - */ - flag = needFullDecl ? DP_Declared|DP_Forward : DP_Forward; - for(p=pDecl; p; p=p->pSameName){ - if( !DeclHasProperty(p,flag) ) break; - } - if( p==0 ){ - return; - } - - /* - ** Make sure we have all necessary #includes - */ - for(p=pDecl; p; p=p->pSameName){ - AddIncludes(p->pInclude,pState); - } - - /* - ** Go ahead an mark everything as being declared, to prevent an - ** infinite loop thru the ScanText() function. At the same time, - ** we decide which objects need a full declaration and mark them - ** with the DP_Flag bit. We are only able to use DP_Flag in this - ** way because we know we'll never execute this far into this - ** function on a recursive call with the same pDecl. Hence, recursive - ** calls to this function (through ScanText()) can never change the - ** value of DP_Flag out from under us. - */ - for(p=pDecl; p; p=p->pSameName){ - if( !DeclHasProperty(p,DP_Declared) - && (p->zFwd==0 || needFullDecl) - && p->zDecl!=0 - ){ - DeclSetProperty(p,DP_Forward|DP_Declared|DP_Flag); - }else{ - DeclClearProperty(p,DP_Flag); - } - } - - /* - ** Call ScanText() recusively (this routine is called from ScanText()) - ** to include declarations required to come before these declarations. - */ - for(p=pDecl; p; p=p->pSameName){ - if( DeclHasProperty(p,DP_Flag) ){ - if( p->zDecl[0]=='#' ){ - ScanText(&p->zDecl[1],pState); - }else{ - InsertExtraDecl(p); - ScanText(p->zDecl,pState); - } - } - } - - /* - ** Output the declarations. Do this in two passes. First - ** output everything that isn't a typedef. Then go back and - ** get the typedefs by the same name. - */ - for(p=pDecl; p; p=p->pSameName){ - if( DeclHasProperty(p,DP_Flag) && !DeclHasProperty(p,TY_Typedef) ){ - if( DeclHasAnyProperty(p,TY_Enumeration) ){ - if( doneTypedef ) continue; - doneTypedef = 1; - } - ChangeIfContext(p->zIf,pState); - if( !isCpp && DeclHasAnyProperty(p,DP_ExternReqd) ){ - StringAppend(pState->pStr,"extern ",0); - }else if( isCpp && DeclHasProperty(p,DP_Cplusplus|DP_ExternReqd) ){ - StringAppend(pState->pStr,"extern ",0); - }else if( isCpp && DeclHasAnyProperty(p,DP_ExternCReqd|DP_ExternReqd) ){ - StringAppend(pState->pStr,"extern \"C\" ",0); - } - InsertExtraDecl(p); - StringAppend(pState->pStr,p->zDecl,0); - /* - if( !isCpp && DeclHasProperty(p,DP_Cplusplus) ){ - fprintf(stderr, - "%s: C code ought not reference the C++ object \"%s\"\n", - pState->zFilename, p->zName); - pState->nErr++; - } - */ - DeclClearProperty(p,DP_Flag); - } - } - for(p=pDecl; p && !doneTypedef; p=p->pSameName){ - if( DeclHasProperty(p,DP_Flag) ){ - /* This has to be a typedef */ - doneTypedef = 1; - ChangeIfContext(p->zIf,pState); - InsertExtraDecl(p); - StringAppend(pState->pStr,p->zDecl,0); - } - } -} - -/* -** This routine scans the input text given, and appends to the -** string in pState->pStr the text of any declarations that must -** occur before the text in zText. -** -** If an identifier in zText is immediately followed by '*', then -** only forward declarations are needed for that identifier. If the -** identifier name is not followed immediately by '*', we must supply -** a full declaration. -*/ -static void ScanText( - const char *zText, /* The input text to be scanned */ - GenState *pState /* Current state of the code generator */ -){ - int nextValid = 0; /* True is sNext contains valid data */ - InStream sIn; /* The input text */ - Token sToken; /* The current token being examined */ - Token sNext; /* The next non-space token */ - - /* printf("BEGIN SCAN TEXT on %s\n", zText); */ - - sIn.z = zText; - sIn.i = 0; - sIn.nLine = 1; - while( sIn.z[sIn.i]!=0 ){ - if( nextValid ){ - sToken = sNext; - nextValid = 0; - }else{ - GetNonspaceToken(&sIn,&sToken); - } - if( sToken.eType==TT_Id ){ - int needFullDecl; /* True if we need to provide the full declaration, - ** not just the forward declaration */ - Decl *pDecl; /* The declaration having the name in sToken */ - - /* - ** See if there is a declaration in the database with the name given - ** by sToken. - */ - pDecl = FindDecl(sToken.zText,sToken.nText); - if( pDecl==0 ) continue; - - /* - ** If we get this far, we've found an identifier that has a - ** declaration in the database. Now see if we the full declaration - ** or just a forward declaration. - */ - GetNonspaceToken(&sIn,&sNext); - if( sNext.zText[0]=='*' ){ - needFullDecl = 0; - }else{ - needFullDecl = 1; - nextValid = sNext.eType==TT_Id; - } - - /* - ** Generate the needed declaration. - */ - DeclareObject(pDecl,pState,needFullDecl); - }else if( sToken.eType==TT_Preprocessor ){ - sIn.i -= sToken.nText - 1; - } - } - /* printf("END SCANTEXT\n"); */ -} - -/* -** Provide a full declaration to any object which so far has had only -** a foward declaration. -*/ -static void CompleteForwardDeclarations(GenState *pState){ - Decl *pDecl; - int progress; - - do{ - progress = 0; - for(pDecl=pDeclFirst; pDecl; pDecl=pDecl->pNext){ - if( DeclHasProperty(pDecl,DP_Forward) - && !DeclHasProperty(pDecl,DP_Declared) - ){ - DeclareObject(pDecl,pState,1); - progress = 1; - assert( DeclHasProperty(pDecl,DP_Declared) ); - } - } - }while( progress ); -} - -/* -** Generate an include file for the given source file. Return the number -** of errors encountered. -** -** if nolocal_flag is true, then we do not generate declarations for -** objected marked DP_Local. -*/ -static int MakeHeader(InFile *pFile, FILE *report, int nolocal_flag){ - int nErr = 0; - GenState sState; - String outStr; - IdentTable includeTable; - Ident *pId; - char *zNewVersion; - char *zOldVersion; - - if( pFile->zHdr==0 || *pFile->zHdr==0 ) return 0; - sState.pStr = &outStr; - StringInit(&outStr); - StringAppend(&outStr,zTopLine,nTopLine); - sState.pTable = &includeTable; - memset(&includeTable,0,sizeof(includeTable)); - sState.zIf = 0; - sState.nErr = 0; - sState.zFilename = pFile->zSrc; - sState.flags = pFile->flags & DP_Cplusplus; - ResetDeclFlags(nolocal_flag ? "no" : pFile->zSrc); - for(pId = pFile->idTable.pList; pId; pId=pId->pNext){ - Decl *pDecl = FindDecl(pId->zName,0); - if( pDecl ){ - DeclareObject(pDecl,&sState,1); - } - } - CompleteForwardDeclarations(&sState); - ChangeIfContext(0,&sState); - nErr += sState.nErr; - zOldVersion = ReadFile(pFile->zHdr); - zNewVersion = StringGet(&outStr); - if( report ) fprintf(report,"%s: ",pFile->zHdr); - if( zOldVersion==0 ){ - if( report ) fprintf(report,"updated\n"); - if( WriteFile(pFile->zHdr,zNewVersion) ){ - fprintf(stderr,"%s: Can't write to file\n",pFile->zHdr); - nErr++; - } - }else if( strncmp(zOldVersion,zTopLine,nTopLine)!=0 ){ - if( report ) fprintf(report,"error!\n"); - fprintf(stderr, - "%s: Can't overwrite this file because it wasn't previously\n" - "%*s generated by 'makeheaders'.\n", - pFile->zHdr, (int)strlen(pFile->zHdr), ""); - nErr++; - }else if( strcmp(zOldVersion,zNewVersion)!=0 ){ - if( report ) fprintf(report,"updated\n"); - if( WriteFile(pFile->zHdr,zNewVersion) ){ - fprintf(stderr,"%s: Can't write to file\n",pFile->zHdr); - nErr++; - } - }else if( report ){ - fprintf(report,"unchanged\n"); - } - SafeFree(zOldVersion); - IdentTableReset(&includeTable); - StringReset(&outStr); - return nErr; -} - -/* -** Generate a global header file -- a header file that contains all -** declarations. If the forExport flag is true, then only those -** objects that are exported are included in the header file. -*/ -static int MakeGlobalHeader(int forExport){ - GenState sState; - String outStr; - IdentTable includeTable; - Decl *pDecl; - - sState.pStr = &outStr; - StringInit(&outStr); - /* StringAppend(&outStr,zTopLine,nTopLine); */ - sState.pTable = &includeTable; - memset(&includeTable,0,sizeof(includeTable)); - sState.zIf = 0; - sState.nErr = 0; - sState.zFilename = "(all)"; - sState.flags = 0; - ResetDeclFlags(0); - for(pDecl=pDeclFirst; pDecl; pDecl=pDecl->pNext){ - if( forExport==0 || DeclHasProperty(pDecl,DP_Export) ){ - DeclareObject(pDecl,&sState,1); - } - } - ChangeIfContext(0,&sState); - printf("%s",StringGet(&outStr)); - IdentTableReset(&includeTable); - StringReset(&outStr); - return 0; -} - -#ifdef DEBUG -/* -** Return the number of characters in the given string prior to the -** first newline. -*/ -static int ClipTrailingNewline(char *z){ - int n = strlen(z); - while( n>0 && (z[n-1]=='\n' || z[n-1]=='\r') ){ n--; } - return n; -} - -/* -** Dump the entire declaration list for debugging purposes -*/ -static void DumpDeclList(void){ - Decl *pDecl; - - for(pDecl = pDeclFirst; pDecl; pDecl=pDecl->pNext){ - printf("**** %s from file %s ****\n",pDecl->zName,pDecl->zFile); - if( pDecl->zIf ){ - printf("If: [%.*s]\n",ClipTrailingNewline(pDecl->zIf),pDecl->zIf); - } - if( pDecl->zFwd ){ - printf("Decl: [%.*s]\n",ClipTrailingNewline(pDecl->zFwd),pDecl->zFwd); - } - if( pDecl->zDecl ){ - InsertExtraDecl(pDecl); - printf("Def: [%.*s]\n",ClipTrailingNewline(pDecl->zDecl),pDecl->zDecl); - } - if( pDecl->flags ){ - static struct { - int mask; - char *desc; - } flagSet[] = { - { TY_Class, "class" }, - { TY_Enumeration, "enum" }, - { TY_Structure, "struct" }, - { TY_Union, "union" }, - { TY_Variable, "variable" }, - { TY_Subroutine, "function" }, - { TY_Typedef, "typedef" }, - { TY_Macro, "macro" }, - { DP_Export, "export" }, - { DP_Local, "local" }, - { DP_Cplusplus, "C++" }, - }; - int i; - printf("flags:"); - for(i=0; iflags ){ - printf(" %s", flagSet[i].desc); - } - } - printf("\n"); - } - if( pDecl->pInclude ){ - Include *p; - printf("includes:"); - for(p=pDecl->pInclude; p; p=p->pNext){ - printf(" %s",p->zFile); - } - printf("\n"); - } - } -} -#endif - -/* -** When the "-doc" command-line option is used, this routine is called -** to print all of the database information to standard output. -*/ -static void DocumentationDump(void){ - Decl *pDecl; - static struct { - int mask; - char flag; - } flagSet[] = { - { TY_Class, 'c' }, - { TY_Enumeration, 'e' }, - { TY_Structure, 's' }, - { TY_Union, 'u' }, - { TY_Variable, 'v' }, - { TY_Subroutine, 'f' }, - { TY_Typedef, 't' }, - { TY_Macro, 'm' }, - { DP_Export, 'x' }, - { DP_Local, 'l' }, - { DP_Cplusplus, '+' }, - }; - - for(pDecl = pDeclFirst; pDecl; pDecl=pDecl->pNext){ - int i; - int nLabel = 0; - char *zDecl; - char zLabel[50]; - for(i=0; izDecl; - if( zDecl==0 ) zDecl = pDecl->zFwd; - printf("%s %s %s %p %d %d %d %d %d {\n", - pDecl->zName, - zLabel, - pDecl->zFile, - pDecl->pComment, - pDecl->pComment ? pDecl->pComment->nText+1 : 0, - pDecl->zIf ? (int)strlen(pDecl->zIf)+1 : 0, - zDecl ? (int)strlen(zDecl) : 0, - pDecl->pComment ? pDecl->pComment->nLine : 0, - pDecl->tokenCode.nText ? pDecl->tokenCode.nText+1 : 0 - ); - if( pDecl->pComment ){ - printf(" comment {%.*s}\n",pDecl->pComment->nText, pDecl->pComment->zText); - } - if( pDecl->zIf ){ - printf(" zif {%s}\n",pDecl->zIf); - } - if( zDecl ){ - printf(" definition {%s}\n",zDecl); - } - if( pDecl->tokenCode.nText ){ - printf(" body {%.*s}\n",pDecl->tokenCode.nText, pDecl->tokenCode.zText); - } - printf("}\n"); - } -} - -/* -** Given the complete text of an input file, this routine prints a -** documentation record for the header comment at the beginning of the -** file (if the file has a header comment.) -*/ -void PrintModuleRecord(const char *zFile, const char *zFilename){ - int i; - static int addr = 5; - while( isspace(*zFile) ){ zFile++; } - if( *zFile!='/' || zFile[1]!='*' ) return; - for(i=2; zFile[i] && (zFile[i-1]!='/' || zFile[i-2]!='*'); i++){} - if( zFile[i]==0 ) return; - printf("%s M %s %d %d 0 0 0 0 {\n comment {%.*s} \n} \n", - zFilename, zFilename, addr, i+1, i, zFile); - addr += 4; -} - - -/* -** Given an input argument to the program, construct a new InFile -** object. -*/ -static InFile *CreateInFile(char *zArg, int *pnErr){ - int nSrc; - char *zSrc; - InFile *pFile; - int i; - - /* - ** Get the name of the input file to be scanned. The input file is - ** everything before the first ':' or the whole file if no ':' is seen. - ** - ** Except, on windows, ignore any ':' that occurs as the second character - ** since it might be part of the drive specifier. So really, the ":' has - ** to be the 3rd or later character in the name. This precludes 1-character - ** file names, which really should not be a problem. - */ - zSrc = zArg; - for(nSrc=2; zSrc[nSrc] && zArg[nSrc]!=':'; nSrc++){} - pFile = SafeMalloc( sizeof(InFile) ); - memset(pFile,0,sizeof(InFile)); - pFile->zSrc = StrDup(zSrc,nSrc); - - /* Figure out if we are dealing with C or C++ code. Assume any - ** file with ".c" or ".h" is C code and all else is C++. - */ - if( nSrc>2 && zSrc[nSrc-2]=='.' && (zSrc[nSrc-1]=='c' || zSrc[nSrc-1]=='h')){ - pFile->flags &= ~DP_Cplusplus; - }else{ - pFile->flags |= DP_Cplusplus; - } - - /* - ** If a separate header file is specified, use it - */ - if( zSrc[nSrc]==':' ){ - int nHdr; - char *zHdr; - zHdr = &zSrc[nSrc+1]; - for(nHdr=0; zHdr[nHdr] && zHdr[nHdr]!=':'; nHdr++){} - pFile->zHdr = StrDup(zHdr,nHdr); - } - - /* Look for any 'c' or 'C' in the suffix of the file name and change - ** that character to 'h' or 'H' respectively. If no 'c' or 'C' is found, - ** then assume we are dealing with a header. - */ - else{ - int foundC = 0; - pFile->zHdr = StrDup(zSrc,nSrc); - for(i = nSrc-1; i>0 && pFile->zHdr[i]!='.'; i--){ - if( pFile->zHdr[i]=='c' ){ - foundC = 1; - pFile->zHdr[i] = 'h'; - }else if( pFile->zHdr[i]=='C' ){ - foundC = 1; - pFile->zHdr[i] = 'H'; - } - } - if( !foundC ){ - SafeFree(pFile->zHdr); - pFile->zHdr = 0; - } - } - - /* - ** If pFile->zSrc contains no 'c' or 'C' in its extension, it - ** must be a header file. In that case, we need to set the - ** PS_Interface flag. - */ - pFile->flags |= PS_Interface; - for(i=nSrc-1; i>0 && zSrc[i]!='.'; i--){ - if( zSrc[i]=='c' || zSrc[i]=='C' ){ - pFile->flags &= ~PS_Interface; - break; - } - } - - /* Done! - */ - return pFile; -} - -/* MS-Windows and MS-DOS both have the following serious OS bug: the -** length of a command line is severely restricted. But this program -** occasionally requires long command lines. Hence the following -** work around. -** -** If the parameters "-f FILENAME" appear anywhere on the command line, -** then the named file is scanned for additional command line arguments. -** These arguments are substituted in place of the "FILENAME" argument -** in the original argument list. -** -** This first parameter to this routine is the index of the "-f" -** parameter in the argv[] array. The argc and argv are passed by -** pointer so that they can be changed. -** -** Parsing of the parameters in the file is very simple. Parameters -** can be separated by any amount of white-space (including newlines -** and carriage returns.) There are now quoting characters of any -** kind. The length of a token is limited to about 1000 characters. -*/ -static void AddParameters(int index, int *pArgc, char ***pArgv){ - int argc = *pArgc; /* The original argc value */ - char **argv = *pArgv; /* The original argv value */ - int newArgc; /* Value for argc after inserting new arguments */ - char **zNew = 0; /* The new argv after this routine is done */ - char *zFile; /* Name of the input file */ - int nNew = 0; /* Number of new entries in the argv[] file */ - int nAlloc = 0; /* Space allocated for zNew[] */ - int i; /* Loop counter */ - int n; /* Number of characters in a new argument */ - int c; /* Next character of input */ - int startOfLine = 1; /* True if we are where '#' can start a comment */ - FILE *in; /* The input file */ - char zBuf[1000]; /* A single argument is accumulated here */ - - if( index+1==argc ) return; - zFile = argv[index+1]; - in = fopen(zFile,"r"); - if( in==0 ){ - fprintf(stderr,"Can't open input file \"%s\"\n",zFile); - exit(1); - } - c = ' '; - while( c!=EOF ){ - while( c!=EOF && isspace(c) ){ - if( c=='\n' ){ - startOfLine = 1; - } - c = getc(in); - if( startOfLine && c=='#' ){ - while( c!=EOF && c!='\n' ){ - c = getc(in); - } - } - } - n = 0; - while( c!=EOF && !isspace(c) ){ - if( n0 ){ - nNew++; - if( nNew + argc > nAlloc ){ - if( nAlloc==0 ){ - nAlloc = 100 + argc; - zNew = malloc( sizeof(char*) * nAlloc ); - }else{ - nAlloc *= 2; - zNew = realloc( zNew, sizeof(char*) * nAlloc ); - } - } - if( zNew ){ - int j = nNew + index; - zNew[j] = malloc( n + 1 ); - if( zNew[j] ){ - strcpy( zNew[j], zBuf ); - } - } - } - } - newArgc = argc + nNew - 1; - for(i=0; i<=index; i++){ - zNew[i] = argv[i]; - } - for(i=nNew + index + 1; ipNext = pFile; - pTail = pFile; - }else{ - pFileList = pTail = pFile; - } - } - } - } - if( h_flag && H_flag ){ - h_flag = 0; - } - if( v_flag ){ - report = (h_flag || H_flag) ? stderr : stdout; - }else{ - report = 0; - } - if( nErr>0 ){ - return nErr; - } - for(pFile=pFileList; pFile; pFile=pFile->pNext){ - char *zFile; - - zFilename = pFile->zSrc; - if( zFilename==0 ) continue; - zFile = ReadFile(zFilename); - if( zFile==0 ){ - fprintf(stderr,"Can't read input file \"%s\"\n",zFilename); - nErr++; - continue; - } - if( strncmp(zFile,zTopLine,nTopLine)==0 ){ - pFile->zSrc = 0; - }else{ - if( report ) fprintf(report,"Reading %s...\n",zFilename); - pList = TokenizeFile(zFile,&pFile->idTable); - if( pList ){ - nErr += ParseFile(pList,pFile->flags); - FreeTokenList(pList); - }else if( zFile[0]==0 ){ - fprintf(stderr,"Input file \"%s\" is empty.\n", zFilename); - nErr++; - }else{ - fprintf(stderr,"Errors while processing \"%s\"\n", zFilename); - nErr++; - } - } - if( !doc_flag ) SafeFree(zFile); - if( doc_flag ) PrintModuleRecord(zFile,zFilename); - } - if( nErr>0 ){ - return nErr; - } -#ifdef DEBUG - if( debugMask & DECL_DUMP ){ - DumpDeclList(); - return nErr; - } -#endif - if( doc_flag ){ - DocumentationDump(); - return nErr; - } - zFilename = "--internal--"; - pList = TokenizeFile(zInit,0); - if( pList==0 ){ - return nErr+1; - } - ParseFile(pList,PS_Interface); - FreeTokenList(pList); - if( h_flag || H_flag ){ - nErr += MakeGlobalHeader(H_flag); - }else{ - for(pFile=pFileList; pFile; pFile=pFile->pNext){ - if( pFile->zSrc==0 ) continue; - nErr += MakeHeader(pFile,report,0); - } - } - return nErr; -} -#endif DELETED scripts/mkpkgindex.tcl Index: scripts/mkpkgindex.tcl ================================================================== --- scripts/mkpkgindex.tcl +++ /dev/null @@ -1,114 +0,0 @@ -#! /bin/sh -# The next line is executed by /bin/sh, but not tcl \ -exec tclsh $0 ${1+"$@"} - - -set root [file normalize [file join [file dirname [info script]] ..]] -source $root/scripts/common.tcl -if [catch {load $root/src/odielib/$::odielib(libfile) odielib} err] { - puts $err -} -set cidxfile [file join $::odie(sandbox) odielib modules odie index.tcl] -if {[file exists $cidxfile]} { - source $cidxfile -} else { - package require odie -} -set cidxfile [file join $::odie(sandbox) odielib modules codebale index.tcl] -if {[file exists $cidxfile]} { - source $cidxfile -} else { - package require codebale -} - -set stack {} -set fin [open $root/src/odielib/librarypkgindex.tcl r] -puts [read $fin] -close $fin -set result {} -puts "#ROOT: $root" -set i [string length [file join $root modules]] -set buffer {} -foreach module $argv { - if {![file exists $module]} { - set module [file join $root modules $module] - } - if {![file exists $module]} continue - puts "# SCANNED > $module" - set module [file normalize $module] - lappend result {*}[::codebale::sniffPath $module stack] - while {[llength $stack]} { - set stackpath [lindex $stack 0] - set stack [lrange $stack 1 end] - lappend result {*}[::codebale::sniffPath $stackpath stack] - } -} - -puts { -if {[file exists [file join $dir modules]]} { - set moddir [file join $dir modules] -} else { - set moddir $dir -} -} - -foreach {type file} $result { - switch $type { - parent_name { - set file [file normalize $file] - set fname [file rootname [file tail $file]] - ### - # Assume the package is correct in the filename - ### - set package [lindex [split $fname -] 0] - set version [lindex [split $fname -] 1] - set path [string trimleft [string range [file dirname $file] $i end] /] - ### - # Read the file, and override assumptions as needed - ### - set fin [open $file r] - set dat [read $fin] - close $fin - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 9] != "# Package " } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - append buffer "package ifneeded $package $version \[list source \[file join \$moddir $path [file tail $file]\]\]" - append buffer \n - } - source { - set file [file normalize $file] - if { $file == [file join $root tcl8.6 package.tcl] } continue - if { $file == [file join $root packages.tcl] } continue - if { $file == [file join $root main.tcl] } continue - if { [file tail $file] == "version_info.tcl" } continue - set fin [open $file r] - set dat [read $fin] - close $fin - if {![regexp "package provide" $dat]} continue - set fname [file rootname [file tail $file]] - set dir [string trimleft [string range [file dirname $file] $i end] /] - - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - append buffer "package ifneeded $package $version \[list source \[file join \$moddir $dir [file tail $file]\]\]" - append buffer \n - break - } - } - index { - continue - if {[file dirname $file] eq $base } continue - set dir [string trimleft [string range [file dirname $file] $i end] /] - append buffer "set dir \[file join \$dir $dir\] \; source \[file join \$moddir $dir [file tail $file]\]" - append buffer \n - } - } -} -puts $buffer DELETED scripts/mktclopts.tcl Index: scripts/mktclopts.tcl ================================================================== --- scripts/mktclopts.tcl +++ /dev/null @@ -1,75 +0,0 @@ -#! /bin/sh -# The next line is executed by /bin/sh, but not tcl \ -exec tclsh $0 ${1+"$@"} - -# -# This script scans TCL source code looking for switch statements that -# are used to implement widget methods. It then generates an include -# file that contains the variable definitions and code needed to implement -# that switch statement. -# -# -#set fullpath [file dirname [file dirname [file normalize [info script]]]] -set cfile [lindex $argv 0] -set dirname [file dirname $cfile] - -set fin [open $cfile r] -while {[gets $fin line] >= 0} { - if {[regexp {^ *case *([A-Z]+)_([A-Z0-9_]+):} $line all prefix label]} { - lappend cases($prefix) $label - } -} -close $fin - -set col 0 -proc put_item {f x} { - global col - if {$col==0} {puts -nonewline $f " "} - if {$col<2} { - puts -nonewline $f [format " %-21s" $x] - incr col - } else { - puts $f $x - set col 0 - } -} - -proc finalize {f} { - global col - if {$col>0} {puts $f {}} - set col 0 -} - - -foreach prefix [array names cases] { - set f [open [file join $dirname [string tolower $prefix]_cases.h] w] - fconfigure $f -translation crlf - puts $f "/*** Automatically Generated Header File - Do Not Edit ***/" - puts $f " const static char *${prefix}_strs\[\] = \173" - set lx [lsort -dictionary $cases($prefix)] - foreach item $lx { - put_item $f \"[string tolower $item]\", - } - put_item $f 0 - finalize $f - puts $f " \175;" - puts $f " enum ${prefix}_enum \173" - foreach name $lx { - regsub -all {@} $name {} name - put_item $f ${prefix}_[string toupper $name], - } - finalize $f - puts $f " \175;" - puts $f "\ - int index; - if( objc<2 ){ - Tcl_WrongNumArgs(interp, 1, objv, \"METHOD ?ARG ...?\"); - return TCL_ERROR; - } - if( Tcl_GetIndexFromObj(interp, objv\[1\], ${prefix}_strs,\ - \"option\", 0, &index)){ - return TCL_ERROR; - } - switch( (enum ${prefix}_enum)index )" - close $f -} DELETED scripts/mkzip.tcl Index: scripts/mkzip.tcl ================================================================== --- scripts/mkzip.tcl +++ /dev/null @@ -1,282 +0,0 @@ -# -*- tcl -*- -# mkzip.tcl -- Copyright (C) 2009 Pat Thoyts -# -# Create ZIP archives in Tcl. -# -# Create a zipkit using mkzip filename.zkit -zipkit -directory xyz.vfs -# or a zipfile using mkzip filename.zip -directory dirname -exclude "*~" -# -## BSD License -## -# Package providing commands for the generation of a zip archive. -# version 1.2 - -package require Tcl 8.6 - -namespace eval ::zipfile {} -namespace eval ::zipfile::decode {} -namespace eval ::zipfile::encode {} -namespace eval ::zipfile::mkzip {} - -proc ::zipfile::mkzip::setbinary chan { - fconfigure $chan \ - -encoding binary \ - -translation binary \ - -eofchar {} - -} - -# zip::timet_to_dos -# -# Convert a unix timestamp into a DOS timestamp for ZIP times. -# -# DOS timestamps are 32 bits split into bit regions as follows: -# 24 16 8 0 -# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ -# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| -# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ -# -proc ::zipfile::mkzip::timet_to_dos {time_t} { - set s [clock format $time_t -format {%Y %m %e %k %M %S}] - scan $s {%d %d %d %d %d %d} year month day hour min sec - expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) - | ($hour << 11) | ($min << 5) | ($sec >> 1)} -} - -# zip::pop -- -# -# Pop an element from a list -# -proc ::zipfile::mkzip::pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# zip::walk -- -# -# Walk a directory tree rooted at 'path'. The excludes list can be -# a set of glob expressions to match against files and to avoid. -# The match arg is internal. -# eg: walk library {CVS/* *~ .#*} to exclude CVS and emacs cruft. -# -proc ::zipfile::mkzip::walk {base {excludes ""} {match *} {path {}}} { - set result {} - set imatch [file join $path $match] - set files [glob -nocomplain -tails -types f -directory $base $imatch] - foreach file $files { - set excluded 0 - foreach glob $excludes { - if {[string match $glob $file]} { - set excluded 1 - break - } - } - if {!$excluded} {lappend result $file} - } - foreach dir [glob -nocomplain -tails -types d -directory $base $imatch] { - set subdir [walk $base $excludes $match $dir] - if {[llength $subdir]>0} { - set result [concat $result [list $dir] $subdir] - } - } - return $result -} - -# zipfile::encode::add_file_to_archive -- -# -# Add a single file to a zip archive. The zipchan channel should -# already be open and binary. You may provide a comment for the -# file The return value is the central directory record that -# will need to be used when finalizing the zip archive. -# -# FIX ME: should handle the current offset for non-seekable channels -# -proc ::zipfile::mkzip::add_file_to_archive {zipchan base path {comment ""}} { - set fullpath [file join $base $path] - set mtime [timet_to_dos [file mtime $fullpath]] - if {[file isdirectory $fullpath]} { - append path / - } - set utfpath [encoding convertto utf-8 $path] - set utfcomment [encoding convertto utf-8 $comment] - set flags [expr {(1<<11)}] ;# utf-8 comment and path - set method 0 ;# store 0, deflate 8 - set attr 0 ;# text or binary (default binary) - set version 20 ;# minumum version req'd to extract - set extra "" - set crc 0 - set size 0 - set csize 0 - set data "" - set seekable [expr {[tell $zipchan] != -1}] - if {[file isdirectory $fullpath]} { - set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) - } elseif {[file executable $fullpath]} { - set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) - } else { - set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) - if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { - set attr 1 ;# text - } - } - - if {[file isfile $fullpath]} { - set size [file size $fullpath] - if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} - } - - set offset [tell $zipchan] - set local [binary format a4sssiiiiss PK\03\04 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]] - append local $utfpath $extra - puts -nonewline $zipchan $local - - if {[file isfile $fullpath]} { - # If the file is under 2MB then zip in one chunk, otherwize we use - # streaming to avoid requiring excess memory. This helps to prevent - # storing re-compressed data that may be larger than the source when - # handling PNG or JPEG or nested ZIP files. - if {$size < 0x00200000} { - set fin [::open $fullpath rb] - setbinary $fin - set data [::read $fin] - set crc [::zlib crc32 $data] - set cdata [::zlib deflate $data] - if {[string length $cdata] < $size} { - set method 8 - set data $cdata - } - close $fin - set csize [string length $data] - puts -nonewline $zipchan $data - } else { - set method 8 - set fin [::open $fullpath rb] - setbinary $fin - set zlib [::zlib stream deflate] - while {![eof $fin]} { - set data [read $fin 4096] - set crc [zlib crc32 $data $crc] - $zlib put $data - if {[string length [set zdata [$zlib get]]]} { - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - } - } - close $fin - $zlib finalize - set zdata [$zlib get] - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - $zlib close - } - - if {$seekable} { - # update the header if the output is seekable - set local [binary format a4sssiiii PK\03\04 \ - $version $flags $method $mtime $crc $csize $size] - set current [tell $zipchan] - seek $zipchan $offset - puts -nonewline $zipchan $local - seek $zipchan $current - } else { - # Write a data descriptor record - set ddesc [binary format a4iii PK\7\8 $crc $csize $size] - puts -nonewline $zipchan $ddesc - } - } - - set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]\ - [string length $utfcomment] 0 $attr $attrex $offset] - append hdr $utfpath $extra $utfcomment - return $hdr -} - -# zipfile::encode::mkzip -- -# -# Create a zip archive in 'filename'. If a file already exists it will be -# overwritten by a new file. If '-directory' is used, the new zip archive -# will be rooted in the provided directory. -# -runtime can be used to specify a prefix file. For instance, -# zip myzip -runtime unzipsfx.exe -directory subdir -# will create a self-extracting zip archive from the subdir/ folder. -# The -comment parameter specifies an optional comment for the archive. -# -# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt -# -proc ::zipfile::mkzip::mkzip {filename args} { - array set opts { - -zipkit 0 -runtime "" -comment "" -directory "" - -exclude {CVS/* */CVS/* *~ ".#*" "*/.#*"} - -verbose 0 - } - - while {[string match -* [set option [lindex $args 0]]]} { - switch -exact -- $option { - -verbose { set opts(-verbose) 1} - -zipkit { set opts(-zipkit) 1 } - -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] } - -runtime { set opts(-runtime) [pop args 1] } - -directory {set opts(-directory) [file normalize [pop args 1]] } - -exclude {set opts(-exclude) [pop args 1] } - -- { pop args ; break } - default { - break - } - } - pop args - } - - set zf [::open $filename wb] - setbinary $zf - if {$opts(-runtime) ne ""} { - set rt [::open $opts(-runtime) rb] - setbinary $rt - fcopy $rt $zf - close $rt - } elseif {$opts(-zipkit)} { - set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" - append zkd "package require vfs::zip\n" - append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" - append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} \{\n" - append zkd " source \[file join \[info script\] main.tcl\]\n" - append zkd "\}\n" - append zkd \x1A - puts -nonewline $zf $zkd - } - - set count 0 - set cd "" - - if {$opts(-directory) ne ""} { - set paths [walk $opts(-directory) $opts(-exclude)] - } else { - set paths [glob -nocomplain {*}$args] - } - foreach path $paths { - if {[string is true $opts(-verbose)]} { - puts $path - } - append cd [add_file_to_archive $zf $opts(-directory) $path] - incr count - } - set cdoffset [tell $zf] - set endrec [binary format a4ssssiis PK\05\06 0 0 \ - $count $count [string length $cd] $cdoffset\ - [string length $opts(-comment)]] - append endrec $opts(-comment) - puts -nonewline $zf $cd - puts -nonewline $zf $endrec - close $zf - - return -} - -# ### ### ### ######### ######### ######### -## Ready -package provide zipfile::mkzip 1.2 DELETED scripts/practcl.tcl Index: scripts/practcl.tcl ================================================================== --- scripts/practcl.tcl +++ /dev/null @@ -1,3509 +0,0 @@ -### -# Practcl -# An object oriented templating system for stamping out Tcl API calls to C -### -package require TclOO -proc ::debug args { - ::practcl::cputs ::DEBUG_INFO $args -} - -### -# Drop in a static copy of Tcl -### -proc ::doexec args { - puts [list {*}$args] - exec {*}$args >&@ stdout -} - -proc ::dotclexec args { - puts [list [info nameofexecutable] {*}$args] - exec [info nameofexecutable] {*}$args >&@ stdout -} - -proc ::domake {args} { - puts [list make {*}$args] - exec make {*}$args >&@ stdout -} - -proc ::fossil {path args} { - set PWD [pwd] - cd $path - puts [list {*}$args] - exec fossil {*}$args >&@ stdout - cd $PWD -} - - -### -# Build utility functions -### -namespace eval ::practcl {} - -proc ::practcl::os {} { - if {[info exists ::project(TEACUP_OS)] && $::project(TEACUP_OS) ne "@TEACUP_OS@"} { - return $::project(TEACUP_OS) - } - guess - return $::project(TEACUP_OS) -} - -### -# Detect local platform -### -proc ::practcl::guess {} { - # If data is available from autoconf, defer to that - if {[info exists ::project(TEACUP_OS)] && $::project(TEACUP_OS) ne "@TEACUP_OS@"} { - return [list TEACUP_OS $::project(TEACUP_OS)] - } - # If autoconf hasn't run yet, assume we are not cross compiling - # and defer to local checks - set ::project(TEACUP_PROFILE) unknown - set ::project(TEACUP_OS) unknown - set ::project(EXEEXT) {} - if {$::tcl_platform(platform) eq "windows"} { - set system "windows" - set arch ix86 - set ::project(TEACUP_PROFILE) win32-ix86 - set ::project(TEACUP_OS) windows - set ::project(EXEEXT) .exe - } else { - set system [exec uname -s]-[exec uname -r] - set arch unknown - set ::project(TEACUP_OS) generic - } - set ::project(TEA_PLATFORM) $system - set ::project(TEA_SYSTEM) $system - switch -glob $system { - Linux* { - set ::project(TEACUP_OS) linux - set arch [exec uname -m] - set ::project(TEACUP_PROFILE) "linux-glibc2.3-$arch" - } - GNU* { - set arch [exec uname -m] - set ::project(TEACUP_OS) "gnu" - } - NetBSD-Debian { - set arch [exec uname -m] - set ::project(TEACUP_OS) "netbsd-debian" - } - OpenBSD-* { - set arch [exec arch -s] - set ::project(TEACUP_OS) "openbsd" - } - Darwin* { - set arch [exec uname -m] - set ::project(TEACUP_OS) "macosx" - if {$arch eq "x86_64"} { - set ::project(TEACUP_PROFILE) "macosx10.5-i386-x86_84" - } else { - set ::project(TEACUP_PROFILE) "macosx-universal" - } - } - OpenBSD* { - set arch [exec arch -s] - set ::project(TEACUP_OS) "openbsd" - } - } - if {$arch eq "unknown"} { - catch {set arch [exec uname -m]} - } - switch -glob $arch { - i*86 { - set arch "ix86" - } - amd64 { - set arch "x86_64" - } - } - set ::project(TEACUP_ARCH) $arch - if {$::project(TEACUP_PROFILE) eq "unknown"} { - set ::project(TEACUP_PROFILE) $::project(TEACUP_OS)-$arch - } - return $::project(TEACUP_OS) -} - -### -# Embedded Zip Wrapper -# Copied from tcllib's mkzip module -### -namespace eval ::practcl::mkzip {} -proc ::practcl::mkzip::setbinary chan { - fconfigure $chan \ - -encoding binary \ - -translation binary \ - -eofchar {} - -} - -# zip::timet_to_dos -# -# Convert a unix timestamp into a DOS timestamp for ZIP times. -# -# DOS timestamps are 32 bits split into bit regions as follows: -# 24 16 8 0 -# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ -# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| -# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ -# -proc ::practcl::mkzip::timet_to_dos {time_t} { - set s [clock format $time_t -format {%Y %m %e %k %M %S}] - scan $s {%d %d %d %d %d %d} year month day hour min sec - expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) - | ($hour << 11) | ($min << 5) | ($sec >> 1)} -} - -# zip::pop -- -# -# Pop an element from a list -# -proc ::practcl::mkzip::pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# zip::walk -- -# -# Walk a directory tree rooted at 'path'. The excludes list can be -# a set of glob expressions to match against files and to avoid. -# The match arg is internal. -# eg: walk library {CVS/* *~ .#*} to exclude CVS and emacs cruft. -# -proc ::practcl::mkzip::walk {base {excludes ""} {match *} {path {}}} { - set result {} - set imatch [file join $path $match] - set files [glob -nocomplain -tails -types f -directory $base $imatch] - foreach file $files { - set excluded 0 - foreach glob $excludes { - if {[string match $glob $file]} { - set excluded 1 - break - } - } - if {!$excluded} {lappend result $file} - } - foreach dir [glob -nocomplain -tails -types d -directory $base $imatch] { - set subdir [walk $base $excludes $match $dir] - if {[llength $subdir]>0} { - set result [concat $result [list $dir] $subdir] - } - } - return $result -} - -# zipfile::encode::add_file_to_archive -- -# -# Add a single file to a zip archive. The zipchan channel should -# already be open and binary. You may provide a comment for the -# file The return value is the central directory record that -# will need to be used when finalizing the zip archive. -# -# FIX ME: should handle the current offset for non-seekable channels -# -proc ::practcl::mkzip::add_file_to_archive {zipchan base path {comment ""}} { - set fullpath [file join $base $path] - set mtime [timet_to_dos [file mtime $fullpath]] - if {[file isdirectory $fullpath]} { - append path / - } - set utfpath [encoding convertto utf-8 $path] - set utfcomment [encoding convertto utf-8 $comment] - set flags [expr {(1<<11)}] ;# utf-8 comment and path - set method 0 ;# store 0, deflate 8 - set attr 0 ;# text or binary (default binary) - set version 20 ;# minumum version req'd to extract - set extra "" - set crc 0 - set size 0 - set csize 0 - set data "" - set seekable [expr {[tell $zipchan] != -1}] - if {[file isdirectory $fullpath]} { - set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) - } elseif {[file executable $fullpath]} { - set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) - } else { - set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) - if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { - set attr 1 ;# text - } - } - - if {[file isfile $fullpath]} { - set size [file size $fullpath] - if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} - } - - set offset [tell $zipchan] - set local [binary format a4sssiiiiss PK\03\04 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]] - append local $utfpath $extra - puts -nonewline $zipchan $local - - if {[file isfile $fullpath]} { - # If the file is under 2MB then zip in one chunk, otherwize we use - # streaming to avoid requiring excess memory. This helps to prevent - # storing re-compressed data that may be larger than the source when - # handling PNG or JPEG or nested ZIP files. - if {$size < 0x00200000} { - set fin [::open $fullpath rb] - setbinary $fin - set data [::read $fin] - set crc [::zlib crc32 $data] - set cdata [::zlib deflate $data] - if {[string length $cdata] < $size} { - set method 8 - set data $cdata - } - close $fin - set csize [string length $data] - puts -nonewline $zipchan $data - } else { - set method 8 - set fin [::open $fullpath rb] - setbinary $fin - set zlib [::zlib stream deflate] - while {![eof $fin]} { - set data [read $fin 4096] - set crc [zlib crc32 $data $crc] - $zlib put $data - if {[string length [set zdata [$zlib get]]]} { - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - } - } - close $fin - $zlib finalize - set zdata [$zlib get] - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - $zlib close - } - - if {$seekable} { - # update the header if the output is seekable - set local [binary format a4sssiiii PK\03\04 \ - $version $flags $method $mtime $crc $csize $size] - set current [tell $zipchan] - seek $zipchan $offset - puts -nonewline $zipchan $local - seek $zipchan $current - } else { - # Write a data descriptor record - set ddesc [binary format a4iii PK\7\8 $crc $csize $size] - puts -nonewline $zipchan $ddesc - } - } - - set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]\ - [string length $utfcomment] 0 $attr $attrex $offset] - append hdr $utfpath $extra $utfcomment - return $hdr -} - -# zipfile::encode::mkzip -- -# -# Create a zip archive in 'filename'. If a file already exists it will be -# overwritten by a new file. If '-directory' is used, the new zip archive -# will be rooted in the provided directory. -# -runtime can be used to specify a prefix file. For instance, -# zip myzip -runtime unzipsfx.exe -directory subdir -# will create a self-extracting zip archive from the subdir/ folder. -# The -comment parameter specifies an optional comment for the archive. -# -# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt -# -proc ::practcl::mkzip::mkzip {filename args} { - array set opts { - -zipkit 0 -runtime "" -comment "" -directory "" - -exclude {CVS/* */CVS/* *~ ".#*" "*/.#*"} - -verbose 0 - } - - while {[string match -* [set option [lindex $args 0]]]} { - switch -exact -- $option { - -verbose { set opts(-verbose) 1} - -zipkit { set opts(-zipkit) 1 } - -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] } - -runtime { set opts(-runtime) [pop args 1] } - -directory {set opts(-directory) [file normalize [pop args 1]] } - -exclude {set opts(-exclude) [pop args 1] } - -- { pop args ; break } - default { - break - } - } - pop args - } - - set zf [::open $filename wb] - setbinary $zf - if {$opts(-runtime) ne ""} { - set rt [::open $opts(-runtime) rb] - setbinary $rt - fcopy $rt $zf - close $rt - } elseif {$opts(-zipkit)} { - set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" - append zkd "package require vfs::zip\n" - append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" - append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} \{\n" - append zkd " source \[file join \[info script\] main.tcl\]\n" - append zkd "\}\n" - append zkd \x1A - puts -nonewline $zf $zkd - } - - set count 0 - set cd "" - - if {$opts(-directory) ne ""} { - set paths [walk $opts(-directory) $opts(-exclude)] - } else { - set paths [glob -nocomplain {*}$args] - } - foreach path $paths { - if {[string is true $opts(-verbose)]} { - puts $path - } - append cd [add_file_to_archive $zf $opts(-directory) $path] - incr count - } - set cdoffset [tell $zf] - set endrec [binary format a4ssssiis PK\05\06 0 0 \ - $count $count [string length $cd] $cdoffset\ - [string length $opts(-comment)]] - append endrec $opts(-comment) - puts -nonewline $zf $cd - puts -nonewline $zf $endrec - close $zf - - return -} - -### -# Convert an MSYS path to a windows native path -### -if {$::tcl_platform(platform) eq "windows"} { -proc ::practcl::msys_to_tclpath msyspath { - return [exec sh -c "cd $msyspath ; pwd -W"] -} -} else { -proc ::practcl::msys_to_tclpath msyspath { - return [file normalize $msyspath] -} -} - -### -# Bits stolen from fileutil -### -proc ::practcl::cat fname { - set fname [open $fname r] - set data [read $fname] - close $fname - return $data -} - -proc ::practcl::file_lexnormalize {sp} { - set spx [file split $sp] - - # Resolution of embedded relative modifiers (., and ..). - - if { - ([lsearch -exact $spx . ] < 0) && - ([lsearch -exact $spx ..] < 0) - } { - # Quick path out if there are no relative modifiers - return $sp - } - - set absolute [expr {![string equal [file pathtype $sp] relative]}] - # A volumerelative path counts as absolute for our purposes. - - set sp $spx - set np {} - set noskip 1 - - while {[llength $sp]} { - set ele [lindex $sp 0] - set sp [lrange $sp 1 end] - set islast [expr {[llength $sp] == 0}] - - if {[string equal $ele ".."]} { - if { - ($absolute && ([llength $np] > 1)) || - (!$absolute && ([llength $np] >= 1)) - } { - # .. : Remove the previous element added to the - # new path, if there actually is enough to remove. - set np [lrange $np 0 end-1] - } - } elseif {[string equal $ele "."]} { - # Ignore .'s, they stay at the current location - continue - } else { - # A regular element. - lappend np $ele - } - } - if {[llength $np] > 0} { - return [eval [linsert $np 0 file join]] - # 8.5: return [file join {*}$np] - } - return {} -} - -proc ::practcl::file_relative {base dst} { - # Ensure that the link to directory 'dst' is properly done relative to - # the directory 'base'. - - if {![string equal [file pathtype $base] [file pathtype $dst]]} { - return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" - } - - set base [file_lexnormalize [file join [pwd] $base]] - set dst [file_lexnormalize [file join [pwd] $dst]] - - set save $dst - set base [file split $base] - set dst [file split $dst] - - while {[string equal [lindex $dst 0] [lindex $base 0]]} { - set dst [lrange $dst 1 end] - set base [lrange $base 1 end] - if {![llength $dst]} {break} - } - - set dstlen [llength $dst] - set baselen [llength $base] - - if {($dstlen == 0) && ($baselen == 0)} { - # Cases: - # (a) base == dst - - set dst . - } else { - # Cases: - # (b) base is: base/sub = sub - # dst is: base = {} - - # (c) base is: base = {} - # dst is: base/sub = sub - - while {$baselen > 0} { - set dst [linsert $dst 0 ..] - incr baselen -1 - } - # 8.5: set dst [file join {*}$dst] - set dst [eval [linsert $dst 0 file join]] - } - - return $dst -} - -### -# Unpack the source of a fossil project into a designated location -### -proc ::practcl::fossil_sandbox {pkg args} { - if {[llength $args]==1} { - set info [lindex $args 0] - } else { - set info $args - } - set result $info - if {[dict exists $info srcroot]} { - set srcroot [dict get $info srcroot] - } elseif {[dict exists $info sandbox]} { - set srcroot [file join [dict get $info sandbox] $pkg] - } else { - set srcroot [file join [pwd] .. $pkg] - } - dict set result srcroot $srcroot - if {[dict exists $info download]} { - ### - # Source is actually a zip archive - ### - set download [dict get $info download] - if {[file exists [file join $download $pkg.zip]]} { - if {![info exists $srcroot]} { - package require zipfile::decode - ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcroot - } - return - } - } - variable fossil_dbs - if {![::info exists fossil_dbs]} { - # Get a list of local fossil databases - set fossil_dbs [exec fossil all list] - } - set CWD [pwd] - if {![dict exists $info tag]} { - set tag trunk - } else { - set tag [dict get $info tag] - } - dict set result tag $tag - try { - if {[file exists [file join $srcroot .fslckout]]} { - catch { - puts "FOSSIL UPDATE" - cd $srcroot - doexec fossil update $tag - } - } elseif {[file exists [file join $srcroot _FOSSIL_]]} { - catch { - puts "FOSSIL UPDATE" - cd $srcroot - doexec fossil update $tag - } - } else { - puts "OPEN AND UNPACK" - set fosdb {} - foreach line [split $fossil_dbs \n] { - set line [string trim $line] - if {[file rootname [file tail $line]] eq $pkg} { - set fosdb $line - break - } - } - if {$fosdb eq {}} { - set fosdb [file join $download fossil $pkg.fos] - set cloned 0 - if {[dict exists $info localmirror]} { - set localmirror [dict get $info localmirror] - catch { - doexec fossil clone $localmirror/$pkg $fosdb - set cloned 1 - } - } - if {!$cloned && [dict exists $info fossil_url]} { - set localmirror [dict get $info fossil_url] - catch { - doexec fossil clone $localmirror/$pkg $fosdb - set cloned 1 - } - } - if {!$cloned} { - doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb - } - } - file mkdir $srcroot - cd $srcroot - puts "FOSSIL OPEN [pwd]" - doexec fossil open $fosdb $tag - } - } on error {result opts} { - puts [list ERR [dict get $opts -errorinfo]] - return {*}$opts - } finally { - cd $CWD - } - return $result -} - -### -# topic: e71f3f61c348d56292011eec83e95f0aacc1c618 -# description: Converts a XXX.sh file into a series of Tcl variables -### -proc ::practcl::read_sh_subst {line info} { - regsub -all {\x28} $line \x7B line - regsub -all {\x29} $line \x7D line - - #set line [string map $key [string trim $line]] - foreach {field value} $info { - catch {set $field $value} - } - if [catch {subst $line} result] { - return {} - } - set result [string trim $result] - return [string trim $result '] -} - -### -# topic: 03567140cca33c814664c7439570f669b9ab88e6 -### -proc ::practcl::read_sh_file {filename {localdat {}}} { - set fin [open $filename r] - set result {} - if {$localdat eq {}} { - set top 1 - set local [array get ::env] - dict set local EXE {} - } else { - set top 0 - set local $localdat - } - while {[gets $fin line] >= 0} { - set line [string trim $line] - if {[string index $line 0] eq "#"} continue - if {$line eq {}} continue - catch { - if {[string range $line 0 6] eq "export "} { - set eq [string first "=" $line] - set field [string trim [string range $line 6 [expr {$eq - 1}]]] - set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] - dict set result $field [read_sh_subst $value $local] - dict set local $field $value - } elseif {[string range $line 0 7] eq "include "} { - set subfile [read_sh_subst [string range $line 7 end] $local] - foreach {field value} [read_sh_file $subfile $local] { - dict set result $field $value - } - } else { - set eq [string first "=" $line] - if {$eq > 0} { - set field [read_sh_subst [string range $line 0 [expr {$eq - 1}]] $local] - set value [string trim [string range $line [expr {$eq+1}] end] '] - #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] - dict set local $field $value - dict set result $field $value - } - } - } err opts - if {[dict get $opts -code] != 0} { - #puts $opts - puts "Error reading line:\n$line\nerr: $err\n***" - return $err {*}$opts - } - } - return $result -} - -### -# A simpler form of read_sh_file tailored -# to pulling data from (tcl|tk)Config.sh -### -proc ::practcl::read_Config.sh filename { - set fin [open $filename r] - set result {} - while {[gets $fin line] >= 0} { - set line [string trim $line] - if {[string index $line 0] eq "#"} continue - if {$line eq {}} continue - catch { - set eq [string first "=" $line] - if {$eq > 0} { - set field [string range $line 0 [expr {$eq - 1}]] - set value [string trim [string range $line [expr {$eq+1}] end] '] - #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] - dict set result $field $value - } - } err opts - if {[dict get $opts -code] != 0} { - #puts $opts - puts "Error reading line:\n$line\nerr: $err\n***" - return $err {*}$opts - } - } - return $result -} - -### -# A simpler form of read_sh_file tailored -# to pulling data from a Makefile -### -proc ::practcl::read_Makefile filename { - puts [list READING $filename] - set fin [open $filename r] - set result {} - while {[gets $fin line] >= 0} { - set line [string trim $line] - if {[string index $line 0] eq "#"} continue - if {$line eq {}} continue - catch { - set eq [string first "=" $line] - if {$eq > 0} { - set field [string trim [string range $line 0 [expr {$eq - 1}]]] - set value [string trim [string trim [string range $line [expr {$eq+1}] end] ']] - switch $field { - PKG_LIB_FILE { - dict set result libfile $value - } - srcdir { - if {$value eq "."} { - dict set result srcdir [file dirname $filename] - } else { - dict set result srcdir $value - } - } - PACKAGE_NAME { - dict set result name $value - } - PACKAGE_VERSION { - dict set result version $value - } - LIBS { - dict set result PRACTCL_LIBS $value - } - PKG_LIB_FILE { - dict set result libfile $value - } - } - } - } err opts - if {[dict get $opts -code] != 0} { - #puts $opts - puts "Error reading line:\n$line\nerr: $err\n***" - return $err {*}$opts - } - # the Compile field is about where most TEA files start getting silly - if {$field eq "compile"} { - break - } - } - foreach {var val} $result { - puts [list $var $val] - } - return $result -} - -## Append arguments to a buffer -# The command works like puts in that each call will also insert -# a line feed. Unlike puts, blank links in the interstitial are -# suppressed -proc ::practcl::cputs {varname args} { - upvar 1 $varname buffer - if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} { - - } - if {[info exist buffer]} { - if {[string index $buffer end] ne "\n"} { - append buffer \n - } - } else { - set buffer \n - } - # Trim leading \n's - append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end] -} - -proc ::practcl::_tagblock {text {style tcl} {note {}}} { - if {[string length [string trim $text]]==0} { - return {} - } - set output {} - switch $style { - tcl { - ::practcl::cputs output "# BEGIN $note" - } - c { - ::practcl::cputs output "/* BEGIN $note */" - } - default { - ::practcl::cputs output "# BEGIN $note" - } - } - ::practcl::cputs output $text - switch $style { - tcl { - ::practcl::cputs output "# END $note" - } - c { - ::practcl::cputs output "/* END $note */" - } - default { - ::practcl::cputs output "# END $note" - } - } - return $output -} - -proc ::practcl::_isdirectory name { - return [file isdirectory $name] -} - -### -# Return true if the pkgindex file contains -# any statement other than "package ifneeded" -# and/or if any package ifneeded loads a DLL -### -proc ::practcl::_pkgindex_directory {path} { - set buffer {} - set pkgidxfile [file join $path pkgIndex.tcl] - if {![file exists $pkgidxfile]} { - # No pkgIndex file, read the source - foreach file [glob -nocomplain $path/*.tm] { - set file [file normalize $file] - set fname [file rootname [file tail $file]] - ### - # We used to be able to ... Assume the package is correct in the filename - # No hunt for a "package provides" - ### - set package [lindex [split $fname -] 0] - set version [lindex [split $fname -] 1] - ### - # Read the file, and override assumptions as needed - ### - set fin [open $file r] - set dat [read $fin] - close $fin - # Look for a teapot style Package statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 9] != "# Package " } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - # Look for a package provide statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n - } - foreach file [glob -nocomplain $path/*.tcl] { - if { [file tail $file] == "version_info.tcl" } continue - set fin [open $file r] - set dat [read $fin] - close $fin - if {![regexp "package provide" $dat]} continue - set fname [file rootname [file tail $file]] - # Look for a package provide statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - if {[string index $package 0] in "\$ \["} continue - if {[string index $version 0] in "\$ \["} continue - append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n - break - } - } - return $buffer - } - set fin [open $pkgidxfile r] - set dat [read $fin] - close $fin - set thisline {} - foreach line [split $dat \n] { - append thisline $line \n - if {![info complete $thisline]} continue - set line [string trim $line] - if {[string length $line]==0} { - set thisline {} ; continue - } - if {[string index $line 0] eq "#"} { - set thisline {} ; continue - } - try { - # Ignore contditionals - if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} continue - if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} continue - if {![regexp "package.*ifneeded" $thisline]} { - # This package index contains arbitrary code - # source instead of trying to add it to the master - # package index - return {source [file join $dir pkgIndex.tcl]} - } - append buffer $thisline \n - } on error {err opts} { - puts *** - puts "GOOF: $pkgidxfile" - puts $line - puts $err - puts [dict get $opts -errorinfo] - puts *** - } finally { - set thisline {} - } - } - return $buffer -} - - -proc ::practcl::_pkgindex_path_subdir {path} { - set result {} - foreach subpath [glob -nocomplain [file join $path *]] { - if {[file isdirectory $subpath]} { - lappend result $subpath {*}[_pkgindex_path_subdir $subpath] - } - } - return $result -} -### -# Index all paths given as though they will end up in the same -# virtual file system -### -proc ::practcl::pkgindex_path args { - set stack {} - set buffer { -lappend ::PATHSTACK $dir - } - foreach base $args { - set base [file normalize $base] - set paths [::practcl::_pkgindex_path_subdir $base] - set i [string length $base] - # Build a list of all of the paths - foreach path $paths { - if {$path eq $base} continue - set path_indexed($path) 0 - } - set path_indexed($base) 1 - set path_indexed([file join $base boot tcl]) 1 - #set path_index([file join $base boot tk]) 1 - - foreach path $paths { - if {$path_indexed($path)} continue - set thisdir [file_relative $base $path] - #set thisdir [string range $path $i+1 end] - set idxbuf [::practcl::_pkgindex_directory $path] - if {[string length $idxbuf]} { - incr path_indexed($path) - append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n - append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n - } - } - } - append buffer { -set dir [lindex $::PATHSTACK end] -set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] -} - return $buffer -} - -### -# topic: 64319f4600fb63c82b2258d908f9d066 -# description: Script to build the VFS file system -### -proc ::practcl::installDir {d1 d2} { - - puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] - file delete -force -- $d2 - file mkdir $d2 - - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - installDir $f [file join $d2 $ftail] - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - if {$::tcl_platform(platform) eq {unix}} { - file attributes [file join $d2 $ftail] -permissions 0644 - } else { - file attributes [file join $d2 $ftail] -readonly 1 - } - } - } - - if {$::tcl_platform(platform) eq {unix}} { - file attributes $d2 -permissions 0755 - } else { - file attributes $d2 -readonly 1 - } -} - -proc ::practcl::copyDir {d1 d2} { - #puts [list $d1 -> $d2] - #file delete -force -- $d2 - file mkdir $d2 - - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - copyDir $f [file join $d2 $ftail] - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - } - } -} - -::oo::class create ::practcl::metaclass { - superclass ::oo::object - - method script script { - eval $script - } - - method source filename { - source $filename - } - - method initialize {} {} - - method define {submethod args} { - my variable define - switch $submethod { - dump { - return [array get define] - } - add { - set field [lindex $args 0] - if {![info exists define($field)]} { - set define($field) {} - } - foreach arg [lrange $args 1 end] { - if {$arg ni $define($field)} { - lappend define($field) $arg - } - } - return $define($field) - } - remove { - set field [lindex $args 0] - if {![info exists define($field)]} { - return - } - set rlist [lrange $args 1 end] - set olist $define($field) - set nlist {} - foreach arg $olist { - if {$arg in $rlist} continue - lappend nlist $arg - } - set define($field) $nlist - return $nlist - } - exists { - set field [lindex $args 0] - return [info exists define($field)] - } - getnull - - get - - cget { - set field [lindex $args 0] - if {[info exists define($field)]} { - return $define($field) - } - return [lindex $args 1] - } - set { - if {[llength $args]==1} { - array set define [lindex $args 0] - } else { - array set define $args - } - } - default { - array $submethod define {*}$args - } - } - } - - method graft args { - my variable organs - if {[llength $args] == 1} { - error "Need two arguments" - } - set object {} - foreach {stub object} $args { - dict set organs $stub $object - oo::objdefine [self] forward <${stub}> $object - oo::objdefine [self] export <${stub}> - } - return $object - } - - method organ {{stub all}} { - my variable organs - if {![info exists organs]} { - return {} - } - if { $stub eq "all" } { - return $organs - } - if {[dict exists $organs $stub]} { - return [dict get $organs $stub] - } - } - - method link {command args} { - my variable links - switch $command { - object { - foreach obj $args { - foreach linktype [$obj linktype] { - my link add $linktype $obj - } - } - } - add { - ### - # Add a link to an object that was externally created - ### - if {[llength $args] ne 2} { error "Usage: link add LINKTYPE OBJECT"} - lassign $args linktype object - if {[info exists links($linktype)] && $object in $links($linktype)} { - return - } - lappend links($linktype) $object - } - remove { - set object [lindex $args 0] - if {[llength $args]==1} { - set ltype * - } else { - set ltype [lindex $args 1] - } - foreach {linktype elements} [array get links $ltype] { - if {$object in $elements} { - set nlist {} - foreach e $elements { - if { $object ne $e } { lappend nlist $e } - } - set links($linktype) $nlist - } - } - } - list { - if {[llength $args]==0} { - return [array get links] - } - if {[llength $args] ne 1} { error "Usage: link list LINKTYPE"} - lassign $args linktype - if {![info exists links($linktype)]} { - return {} - } - return $links($linktype) - } - dump { - return [array get links] - } - } - } - - method select {} { - my variable define - set class {} - if {[info exists define(class)]} { - if {[info command $define(class)] ne {}} { - set class $define(class) - } elseif {[info command ::practcl::$define(class)] ne {}} { - set class ::practcl::$define(class) - } else { - switch $define(class) { - default { - set class ::practcl::object - } - } - } - } - if {$class ne {}} { - oo::objdefine [self] class $class - } - } -} - -proc ::practcl::trigger {args} { - foreach name $args { - if {[dict exists $::make_objects $name]} { - [dict get $::make_objects $name] triggers - } - } -} - -proc ::practcl::depends {args} { - foreach name $args { - if {[dict exists $::make_objects $name]} { - [dict get $::make_objects $name] check - } - } -} - -proc ::practcl::target {name info} { - set obj [::practcl::target_obj new $name $info] - dict set ::make_objects $name $obj - set ::make($name) 0 - set ::trigger($name) 0 - set filename [$obj define get filename] - if {$filename ne {}} { - set ::target($name) $filename - } -} - -### Batch Tasks - -namespace eval ::practcl::build {} - -## method DEFS -# This method populates 4 variables: -# name - The name of the package -# version - The version of the package -# defs - C flags passed to the compiler -# includedir - A list of paths to feed to the compiler for finding headers -# -proc ::practcl::build::DEFS {PROJECT DEFS namevar versionvar defsvar} { - upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs - set name [string tolower [${PROJECT} define get name [${PROJECT} define get pkg_name]]] - set NAME [string toupper $name] - set version [${PROJECT} define get version [${PROJECT} define get pkg_vers]] - if {$version eq {}} { - set version 0.1a - } - set defs {} - set NAME [string toupper $name] - foreach item $DEFS { - if {[string range $item 0 9] eq "-DPACKAGE_"} continue - set eqidx [string first = $item ] - if {$eqidx < 0} { - append defs { } $item - continue - } - set field [string range $item 0 [expr {$eqidx-1}]] - set value [string range $item [expr {$eqidx+1}] end] - set emap {} - lappend emap \x5c \x5c\x5c \x20 \x5c\x20 \x22 \x5c\x22 \x28 \x5c\x28 \x29 \x5c\x29 - if {[string is integer -strict $value]} { - append defs " ${field}=$value" - } else { -append defs " ${field}=[string map $emap $value]" - } - } - append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" - append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" -} - -proc ::practcl::build::tclkit_packages_c {filename PKG_OBJS} { - ### - # Build static package list - ### - set statpkglist {} - foreach cobj ${PKG_OBJS} { - set statpkg [$cobj define get static_pkg] - if {$statpkg eq {}} continue - dict set statpkglist $statpkg [$cobj define get initfunct] - } - if {$statpkglist eq {}} { - return - } - set fout [open $filename w] - puts $fout "#include " - foreach {statpkg initfunct} $statpkglist { - if {$initfunct eq {}} { - set initfunct [string totitle ${statpkg}]_Init - } - puts $fout "extern Tcl_PackageInitProc $initfunct\;" - append body "\n ${initfunct}(interp)\;" - append body "\n Tcl_StaticPackage(interp,\"$statpkg\",$initfunct,NULL)\;" - } - puts $fout "int Tclkit_Packages_Init(Tcl_Interp *interp) \{" - puts $fout $body - puts $fout " return TCL_OK\;" - puts $fout "\}" - puts $fout {} - close $fout -} -### -# Produce a static library -### -proc ::practcl::build::static-tclsh {outfile PROJECT TCLOBJ TKOBJ PKG_OBJS} { - array set TCL [$TCLOBJ config.sh] - array set TK [$TKOBJ config.sh] - set path [file dirname $outfile] - cd $path - ::practcl::build::DEFS $PROJECT $TCL(defs) name version defs - set NAME [string toupper $name] - set result {} - set libraries {} - set thisline {} - set OBJECTS {} - set includedir . - foreach obj $PKG_OBJS { - puts "OBJECT $obj" - $obj compile - set config($obj) [$obj config.sh] - } - - foreach include [$TCLOBJ generate-include-directory] { - set cpath [::practcl::file_relative $path [file normalize $include]] - if {$cpath ni $includedir} { - lappend includedir $cpath - } - } - lappend includedir [::practcl::file_relative $path [file normalize ../tcl/compat/zlib]] - set INCLUDES "-I[join $includedir " -I"]" - set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ -$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" - append COMPILE " " $defs - - set c_pkg_idex [file join $path build tclkit_packages.c] - puts [list BUILDING $c_pkg_idex] - ::practcl::build::tclkit_packages_c $c_pkg_idex $PKG_OBJS - ${PROJECT} add $c_pkg_idex - - ### - # Compile the C sources - ### - foreach {ofile info} [${PROJECT} compile-products] { - lappend OBJECTS $ofile - if {[dict exists $info library]} { - continue - } - # Products with no cfile aren't compiled - if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} { - continue - } - if {[file exists $ofile] && [file mtime $ofile]>[file mtime $cfile]} continue - set cmd $COMPILE - if {[dict exists $info extra]} { - append cmd " [dict get $info extra]" - } - append cmd " -c $cfile -o $ofile" - puts "COMPILE: $cmd" - exec {*}$cmd >&@ stdout - } - if {[${PROJECT} define get platform] eq "windows"} { - set RSOBJ [file join $path build tclkit.res.o] - set RCSRC [${PROJECT} define get kit_resource_file] - if {$RCSRC eq {} || ![file exists $RCSRC]} { - set RCSRC [file join $TK(src_dir) win rc wish.rc] - } - set cmd [list windres -o $RSOBJ -DSTATIC_BUILD] - lappend cmd --include [file join $TCL(src_dir) generic] \ - --include [file join $TK(src_dir) generic] \ - --include [file join $TK(src_dir) win] \ - --include [file join $TK(src_dir) win rc] - foreach item [${PROJECT} define get resource_include] { - lappend cmd --include $item - } - lappend cmd $RCSRC - doexec {*}$cmd - - lappend OBJECTS $RSOBJ - set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} - set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} - } else { - set LDFLAGS_CONSOLE {} - set LDFLAGS_WINDOW {} - } - - #if {[${PROJECT} define get platform] eq "windows"} { - # Aggregate all of the extensions into a master - # static library - # parray TCL - # set AR [$PROJECT define get AR ar] - # set RANLIB [$PROJECT define get RANLIB] - # mkdir build.pkg - # if {$RANLIB in {: {}}} { - # set RANLIB ranlib - # } - # - # set extlib [file join [file dirname $outfile] tclkit_pkgs.a] - # set cmd [subst $TCL(stlib_ld)] - # append cmd " $extlib" - # - # puts "LINK PKGS: $cmd" - # exec {*}$cmd >&@ stdout - # puts "RANLIB $extlib" - # exec $RANLIB $extlib >&@ stdout - ##} - - set cmd "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ -$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" - append cmd " $OBJECTS" - append cmd " $TCL(build_lib_spec) $TK(build_lib_spec)" - append cmd " $TCL(libs) $TK(libs)" - foreach obj $PKG_OBJS { - append cmd " [$obj linker-products $config($obj)]" - } - foreach obj $PKG_OBJS { - append cmd " [$obj linker-external $config($obj)]" - } - append cmd " $TCL(build_stub_lib_spec)" - - append cmd " $TK(build_stub_lib_spec)" - append cmd " -o $outfile $LDFLAGS_CONSOLE" - puts "LINK: $cmd" - exec {*}$cmd >&@ stdout -} - -::oo::class create ::practcl::target_obj { - superclass ::practcl::metaclass - - constructor {name info} { - my variable define triggered domake - set triggered 0 - set domake 0 - set define(name) $name - set data [uplevel 2 [list subst $info]] - array set define $data - my select - my initialize - } - - method do {} { - my variable domake - return $domake - } - - method check {} { - my variable triggered domake - if {$triggered} { - return $domake - } - set domake 0 - foreach item [my define get depends] { - if {![dict exists $::make_objects $item]} continue - set depobj [dict get $::make_objects $item] - if {[$depobj check]} { - set domake 1 - } - } - if {!$domake} { - set filename [my define get filename] - if {$filename ne {} && ![file exists $filename]} { - set domake 1 - } - } - return $domake - } - - method triggers {} { - my variable triggered domake define - if {$triggered} { - return $domake - } - foreach item [my define get depends] { - if {![dict exists $::make_objects $item]} continue - set depobj [dict get $::make_objects $item] - if {[$depobj check]} { - $depobj triggers - } - } - if {[info exists ::make($define(name))] && $::make($define(name))} { - return - } - set ::make($define(name)) 1 - ::practcl::trigger {*}[my define get triggers] - } -} - - -### -# Define the metaclass -### -::oo::class create ::practcl::object { - superclass ::practcl::metaclass - - constructor {parent args} { - my variable links define - my graft {*}[$parent child organs] - array set define [$parent child organs] - array set define [$parent child define] - array set links {} - if {[llength $args]==1 && [file exists [lindex $args 0]]} { - my InitializeSourceFile [lindex $args 0] - } elseif {[llength $args] == 1} { - set data [uplevel 1 [list subst [lindex $args 0]]] - array set define $data - my select - my initialize - } else { - array set define [uplevel 1 [list subst $args]] - my select - my initialize - } - } - - method target {method args} { - switch $method { - is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } - } - } - - method include_dir args { - my define add include_dir {*}$args - } - - method include_directory args { - my define add include_dir {*}$args - } - - method child {method} { - return {} - } - - method InitializeSourceFile filename { - my define set filename $filename - set class {} - switch [file extension $filename] { - .tcl { - set class ::practcl::dynamic - } - .h { - set class ::practcl::cheader - } - .c { - set class ::practcl::csource - } - .ini { - switch [file tail $filename] { - module.ini { - set class ::practcl::module - } - library.ini { - set class ::practcl::subproject - } - } - } - .so - - .dll - - .dylib - - .a { - set class ::practcl::clibrary - } - } - if {$class ne {}} { - oo::objdefine [self] class $class - my initialize - } - } - - - method add args { - my variable links - set object [::practcl::object new [self] {*}$args] - foreach linktype [$object linktype] { - lappend links($linktype) $object - } - return $object - } - - method go {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable links - foreach {linktype objs} [array get links] { - foreach obj $objs { - $obj go - } - } - debug [list /[self] [self method] [self class]] - } - - method code {section body} { - my variable code - ::practcl::cputs code($section) $body - } - - method Ofile filename { - return build/[my define get localpath]_[file rootname [file tail $filename]].o - } - - method compile-products {} { - set filename [my define get filename] - set result {} - if {$filename ne {}} { - if {[my define exists ofile]} { - set ofile [my define get ofile] - } else { - set ofile [my Ofile $filename] - my define set ofile $ofile - } - lappend result $ofile [list cfile $filename extra [my define get extra]] - } - foreach item [my link list subordinate] { - lappend result {*}[$item compile-products] - } - return $result - } - - method generate-include-directory {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set result [my define get include_dir] - foreach obj [my link list subordinate] { - foreach path [$obj generate-include-directory] { - lappend result $path - } - } - return $result - } - - method generate-debug {{spaces {}}} { - set result {} - ::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my define get filename]] links [my link list]]" - foreach item [my link list subordinate] { - practcl::cputs result [$item generate-debug "$spaces "] - } - return $result - } - - # Empty template methods - method generate-cheader {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code cfunct cstruct methods tcltype tclprocs - set result {} - if {[info exists code(header)]} { - ::practcl::cputs result $code(header) - } - foreach obj [my link list subordinate] { - ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cheader */" - ::practcl::cputs result [$obj generate-cheader] - ::practcl::cputs result "/* END [$obj define get filename] generate-cheader */" - } - 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]\;" - } - } - 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]\;" - } - } - } - debug [list methods [info exists methods] [my define get cclass]] - - if {[info exists methods]} { - set thisclass [my define get cclass] - foreach {name info} $methods { - if {[dict exists $info header]} { - ::practcl::cputs result "[dict get $info header]\;" - } - } - # Add the initializer wrapper for the class - ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp)\;" - } - return $result - } - - method generate-public-define {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code - set result {} - if {[info exists code(public-define)]} { - ::practcl::cputs result $code(public-define) - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list subordinate] { - ::practcl::cputs result [$mod generate-public-define] - } - return $result - } - - method generate-public-macro {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code - set result {} - if {[info exists code(public-macro)]} { - ::practcl::cputs result $code(public-macro) - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list subordinate] { - ::practcl::cputs result [$mod generate-public-macro] - } - return $result - } - - method generate-public-typedef {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code cstruct - set result {} - if {[info exists code(public-typedef)]} { - ::practcl::cputs result $code(public-typedef) - } - if {[info exists cstruct]} { - # Add defintion for native c data structures - foreach {name info} $cstruct { - ::practcl::cputs result "typedef struct $name ${name}\;" - if {[dict exists $info aliases]} { - foreach n [dict get $info aliases] { - ::practcl::cputs result "typedef struct $name ${n}\;" - } - } - } - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list subordinate] { - ::practcl::cputs result [$mod generate-public-typedef] - } - return $result - } - - method generate-public-structure {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code cstruct - set result {} - if {[info exists code(public-structure)]} { - ::practcl::cputs result $code(public-structure) - } - if {[info exists cstruct]} { - foreach {name info} $cstruct { - if {[dict exists $info comment]} { - ::practcl::cputs result [dict get $info comment] - } - ::practcl::cputs result "struct $name \{[dict get $info body]\}\;" - } - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list subordinate] { - ::practcl::cputs result [$mod generate-public-structure] - } - return $result - } - method generate-public-headers {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code tcltype - set result {} - if {[info exists code(public-header)]} { - ::practcl::cputs result $code(public-header) - } - if {[info exists tcltype]} { - foreach {type info} $tcltype { - if {![dict exists $info cname]} { - set cname [string tolower ${type}]_tclobjtype - dict set tcltype $type cname $cname - } else { - set cname [dict get $info cname] - } - ::practcl::cputs result "extern const Tcl_ObjType $cname\;" - } - } - if {[info exists code(public)]} { - ::practcl::cputs result $code(public) - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list subordinate] { - ::practcl::cputs result [$mod generate-public-headers] - } - return $result - } - - method generate-stub-function {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code cfunct tcltype - set result {} - foreach mod [my link list subordinate] { - foreach {funct def} [$mod generate-stub-function] { - dict set result $funct $def - } - } - if {[info exists cfunct]} { - foreach {funcname info} $cfunct { - if {![dict get $info export]} continue - dict set result $funcname [dict get $info header] - } - } - return $result - } - - method generate-public-function {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code cfunct tcltype - set result {} - - if {[my define get initfunc] ne {}} { - ::practcl::cputs result "int [my define get initfunc](Tcl_Interp *interp);" - } - if {[info exists cfunct]} { - foreach {funcname info} $cfunct { - if {![dict get $info public]} continue - ::practcl::cputs result "[dict get $info header]\;" - } - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach mod [my link list subordinate] { - ::practcl::cputs result [$mod generate-public-function] - } - return $result - } - - method generate-public-includes {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set includes {} - foreach item [my define get public-include] { - if {$item ni $includes} { - lappend includes $item - } - } - foreach mod [my link list subordinate] { - foreach item [$mod generate-public-includes] { - if {$item ni $includes} { - lappend includes $item - } - } - } - return $includes - } - method generate-public-verbatim {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set includes {} - foreach item [my define get public-verbatim] { - if {$item ni $includes} { - lappend includes $item - } - } - foreach mod [my link list subordinate] { - foreach item [$mod generate-public-verbatim] { - if {$item ni $includes} { - lappend includes $item - } - } - } - return $includes - } - ### - # This methods generates the contents of an amalgamated .h file - # which describes the public API of this module - ### - method generate-h {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set result {} - set includes [my generate-public-includes] - foreach inc $includes { - if {[string index $inc 0] ni {< \"}} { - ::practcl::cputs result "#include \"$inc\"" - } else { - ::practcl::cputs result "#include $inc" - } - } - foreach file [my generate-public-verbatim] { - ::practcl::cputs result "/* BEGIN $file */" - ::practcl::cputs result [::practcl::cat $file] - ::practcl::cputs result "/* END $file */" - } - foreach method { - generate-public-define - generate-public-macro - generate-public-typedef - generate-public-structure - generate-public-headers - generate-public-function - } { - ::practcl::cputs result "/* BEGIN SECTION $method */" - ::practcl::cputs result [my $method] - ::practcl::cputs result "/* END SECTION $method */" - } - return $result - } - - ### - # This methods generates the contents of an amalgamated .c file - # which implements the loader for a batch of tools - ### - method generate-c {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set result { -/* This file was generated by practcl */ - } - set includes {} - lappend headers - if {[my define get tk 0]} { - lappend headers - } - lappend headers {*}[my define get include] - - foreach mod [my link list product] { - # Signal modules to formulate final implementation - $mod go - } - foreach mod [my link list dynamic] { - foreach inc [$mod define get include] { - if {$inc ni $headers} { - lappend headers $inc - } - } - } - foreach inc $headers { - if {[string index $inc 0] ni {< \"}} { - ::practcl::cputs result "#include \"$inc\"" - } else { - ::practcl::cputs result "#include $inc" - } - } - foreach {method children} { - generate-cheader subordinate - generate-cstruct dynamic - generate-constant dynamic - generate-cfunct dynamic - generate-cmethod dynamic - } { - ::practcl::cputs result "/* BEGIN $method [my define get filename] */" - ::practcl::cputs result [my $method] - ::practcl::cputs result "/* END $method [my define get filename] */" - } - debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] - return $result - } - - ### - # This methods generates any Tcl script file - # which is required to pre-initialize the C library - ### - method generate-tcl {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set result {} - my variable code - if {[info exists code(tcl)]} { - ::practcl::cputs result $code(tcl) - } - set result [::practcl::_tagblock $result tcl [my define get filename]] - foreach mod [my link list subordinate] { - ::practcl::cputs result [$mod generate-tcl] - } - if {[my define get shared_library] ne {}} { - set LIBFILE [my define get shared_library] - set PKGINIT [my define get pkginit] - set PKG_NAME [my define get name [my define get pkg_name]] - set PKG_VERSION [my define get pkg_vers [my define get version]] - ::practcl::cputs result [string map \ - [list @LIBFILE@ $LIBFILE @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { -load [file join [file dirname [file join [pwd] [info script]]] @LIBFILE@] @PKGINIT@ -package provide @PKG_NAME@ @PKG_VERSION@ -}] - - } - return $result - } -} - -::oo::class create ::practcl::product { - superclass ::practcl::object - - method linktype {} { - return {subordinate product} - } - - method include header { - my define add include $header - } - - method cstructure {name definition {argdat {}}} { - my variable cstruct - dict set cstruct $name body $definition - foreach {f v} $argdat { - dict set cstruct $name $f $v - } - } - - method generate-cinit {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code - set result {} - if {[info exists code(cinit)]} { - ::practcl::cputs result $code(cinit) - } - if {[my define get initfunc] ne {}} { - ::practcl::cputs result " if([my define get initfunc](interp)!=TCL_OK) return TCL_ERROR\;" - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach obj [my link list subordinate] { - ::practcl::cputs result [$obj generate-cinit] - } - return $result - } -} - -### -# Dynamic blocks do not generate their own .c files, -# instead the contribute to the amalgamation -# of the main library file -### -::oo::class create ::practcl::dynamic { - superclass ::practcl::product - - method compile-products {} { - set filename [my define get cfile] - set result {} - if {$filename ne {}} { - if {[my define exists ofile]} { - set ofile [my define get ofile] - } else { - set ofile [my Ofile $filename] - my define set ofile $ofile - } - lappend result $ofile [list cfile $filename extra [my define get extra]] - } - foreach item [my link list subordinate] { - lappend result {*}[$item compile-products] - } - return $result - } - #method compile-products {} { - # set result {} - # foreach item [my link list subordinate] { - # lappend result {*}[$item compile-products] - # } - # return $result - #} - - method initialize {} { - set filename [my define get filename] - if {$filename eq {}} { - return - } - if {[my define get name] eq {}} { - my define set name [file tail [file rootname $filename]] - } - if {[my define get localpath] eq {}} { - my define set localpath [my define get localpath]_[my define get name] - } - debug [self] SOURCE $filename - my source $filename - } - - method linktype {} { - return {subordinate dynamic} - } - method compile_products {} {} - - ### - # Populate const static data structures - ### - method generate-cstruct {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code cstruct methods tcltype - set result {} - if {[info exists code(struct)]} { - ::practcl::cputs result $code(struct) - } - foreach obj [my link list dynamic] { - ::practcl::cputs result [$obj generate-cstruct] - } - return $result - } - - method generate-constant {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set result {} - my variable code cstruct methods tcltype - if {[info exists code(constant)]} { - ::practcl::cputs result "/* [my define get filename] CONSTANT */" - ::practcl::cputs result $code(constant) - } - if {[info exists cstruct]} { - foreach {name info} $cstruct { - set map {} - lappend map @NAME@ $name - lappend map @MACRO@ GET[string toupper $name] - - if {[dict exists $info deleteproc]} { - lappend map @DELETEPROC@ [dict get $info deleteproc] - } else { - lappend map @DELETEPROC@ NULL - } - if {[dict exists $info cloneproc]} { - lappend map @CLONEPROC@ [dict get $info cloneproc] - } else { - lappend map @CLONEPROC@ NULL - } - ::practcl::cputs result [string map $map { -const static Tcl_ObjectMetadataType @NAME@DataType = { - TCL_OO_METADATA_VERSION_CURRENT, - "@NAME@", - @DELETEPROC@, - @CLONEPROC@ -}; -#define @MACRO@(OBJCONTEXT) (@NAME@ *) Tcl_ObjectGetMetadata(Tcl_ObjectContextObject(objectContext),&@NAME@DataType) -}] - } - } - if {[info exists tcltype]} { - foreach {type info} $tcltype { - dict with info {} - ::practcl::cputs result "const Tcl_ObjType $cname = \{\n .freeIntRepProc = &${freeproc},\n .dupIntRepProc = &${dupproc},\n .updateStringProc = &${updatestringproc},\n .setFromAnyProc = &${setfromanyproc}\n\}\;" - } - } - - if {[info exists methods]} { - set mtypes {} - foreach {name info} $methods { - set callproc [dict get $info callproc] - set methodtype [dict get $info methodtype] - if {$methodtype in $mtypes} continue - lappend mtypes $methodtype - ### - # Build the data struct for this method - ### - ::practcl::cputs result "const static Tcl_MethodType $methodtype = \{" - ::practcl::cputs result " .version = TCL_OO_METADATA_VERSION_CURRENT,\n .name = \"$name\",\n .callProc = $callproc," - if {[dict exists $info deleteproc]} { - set deleteproc [dict get $info deleteproc] - } else { - set deleteproc NULL - } - if {$deleteproc ni { {} NULL }} { - ::practcl::cputs result " .deleteProc = $deleteproc," - } else { - ::practcl::cputs result " .deleteProc = NULL," - } - if {[dict exists $info cloneproc]} { - set cloneproc [dict get $info cloneproc] - } else { - set cloneproc NULL - } - if {$cloneproc ni { {} NULL }} { - ::practcl::cputs result " .cloneProc = $cloneproc\n\}\;" - } else { - ::practcl::cputs result " .cloneProc = NULL\n\}\;" - } - dict set methods $name methodtype $methodtype - } - } - foreach obj [my link list dynamic] { - ::practcl::cputs result [$obj generate-constant] - } - return $result - } - - ### - # Generate code that provides subroutines called by - # Tcl API methods - ### - method generate-cfunct {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code cfunct - set result {} - if {[info exists code(funct)]} { - ::practcl::cputs result $code(funct) - } - if {[info exists cfunct]} { - foreach {funcname info} $cfunct { - ::practcl::cputs result "[dict get $info header]\{[dict get $info body]\}\;" - } - } - foreach obj [my link list dynamic] { - ::practcl::cputs result [$obj generate-cfunct] - } - return $result - } - - ### - # Generate code that provides implements Tcl API - # calls - ### - method generate-cmethod {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my variable code methods tclprocs - set result {} - if {[info exists code(method)]} { - ::practcl::cputs result $code(method) - } - - if {[info exists tclprocs]} { - foreach {name info} $tclprocs { - if {![dict exists $info body]} continue - set callproc [dict get $info callproc] - set header [dict get $info header] - set body [dict get $info body] - ::practcl::cputs result "${header} \{${body}\}" - } - } - - - if {[info exists methods]} { - set thisclass [my define get cclass] - foreach {name info} $methods { - if {![dict exists $info body]} continue - set callproc [dict get $info callproc] - set header [dict get $info header] - set body [dict get $info body] - ::practcl::cputs result "${header} \{${body}\}" - } - # Build the OO_Init function - ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp) \{" - ::practcl::cputs result [string map [list @CCLASS@ $thisclass @TCLCLASS@ [my define get class]] { - /* - ** Build the "@TCLCLASS@" class - */ - Tcl_Obj* nameObj; /* Name of a class or method being looked up */ - Tcl_Object curClassObject; /* Tcl_Object representing the current class */ - Tcl_Class curClass; /* Tcl_Class representing the current class */ - - /* - * Find the wallset class, and attach an 'init' method to it. - */ - - nameObj = Tcl_NewStringObj("@TCLCLASS@", -1); - Tcl_IncrRefCount(nameObj); - if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { - Tcl_DecrRefCount(nameObj); - return TCL_ERROR; - } - Tcl_DecrRefCount(nameObj); - curClass = Tcl_GetObjectAsClass(curClassObject); -}] - if {[dict exists $methods constructor]} { - set mtype [dict get $methods constructor methodtype] - ::practcl::cputs result [string map [list @MTYPE@ $mtype] { - /* Attach the constructor to the class */ - Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &@MTYPE@, NULL)); - }] - } - foreach {name info} $methods { - dict with info {} - if {$name in {constructor destructor}} continue - ::practcl::cputs result [string map [list @NAME@ $name @MTYPE@ $methodtype] { - nameObj=Tcl_NewStringObj("@NAME@",-1); - Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); - Tcl_DecrRefCount(nameObj); -}] - if {[dict exists $info aliases]} { - foreach alias [dict get $info aliases] { - if {[dict exists $methods $alias]} continue - ::practcl::cputs result [string map [list @NAME@ $alias @MTYPE@ $methodtype] { - nameObj=Tcl_NewStringObj("@NAME@",-1); - Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); - Tcl_DecrRefCount(nameObj); -}] - } - } - } - ::practcl::cputs result " return TCL_OK\;\n\}\n" - } - foreach obj [my link list dynamic] { - ::practcl::cputs result [$obj generate-cmethod] - } - return $result - } - - ### - # Generate code that runs when the package/module is - # initialized into the interpreter - ### - method generate-cinit {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set result {} - my variable code methods tclprocs - if {[info exists code(nspace)]} { - ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" - foreach nspace $code(nspace) { - ::practcl::cputs result [string map [list @NSPACE@ $nspace] { - modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); - if(!modPtr) { - modPtr = Tcl_CreateNamespace(interp, "@NSPACE@", NULL, NULL); - } -}] - } - ::practcl::cputs result " \}" - } - if {[info exists code(tclinit)]} { - ::practcl::cputs result $code(tclinit) - } - if {[info exists code(cinit)]} { - ::practcl::cputs result $code(cinit) - } - if {[info exists code(initfuncts)]} { - foreach func $code(initfuncts) { - ::practcl::cputs result " if (${func}(interp) != TCL_OK) return TCL_ERROR\;" - } - } - if {[info exists tclprocs]} { - foreach {name info} $tclprocs { - set map [list @NAME@ $name @CALLPROC@ [dict get $info callproc]] - ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] - if {[dict exists $info aliases]} { - foreach alias [dict get $info aliases] { - set map [list @NAME@ $alias @CALLPROC@ [dict get $info callproc]] - ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] - } - } - } - } - - if {[info exists code(nspace)]} { - ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" - foreach nspace $code(nspace) { - ::practcl::cputs result [string map [list @NSPACE@ $nspace] { - modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); - Tcl_CreateEnsemble(interp, modPtr->fullName, modPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, modPtr, "[a-z]*", 1); -}] - } - ::practcl::cputs result " \}" - } - set result [::practcl::_tagblock $result c [my define get filename]] - foreach obj [my link list subordinate] { - ::practcl::cputs result [$obj generate-cinit] - } - return $result - } - - method tcltype {name argdat} { - my variable tcltype - foreach {f v} $argdat { - dict set tcltype $name $f $v - } - if {![dict exists tcltype $name cname]} { - dict set tcltype $name cname [string tolower $name]_tclobjtype - } - lappend map @NAME@ $name - set info [dict get $tcltype $name] - foreach {f v} $info { - lappend map @[string toupper $f]@ $v - } - foreach {func fpat template} { - freeproc {@Name@Obj_freeIntRepProc} {void @FNAME@(Tcl_Obj *objPtr)} - dupproc {@Name@Obj_dupIntRepProc} {void @FNAME@(Tcl_Obj *srcPtr,Tcl_Obj *dupPtr)} - updatestringproc {@Name@Obj_updateStringRepProc} {void @FNAME@(Tcl_Obj *objPtr)} - setfromanyproc {@Name@Obj_setFromAnyProc} {int @FNAME@(Tcl_Interp *interp,Tcl_Obj *objPtr)} - } { - if {![dict exists $info $func]} { - error "$name does not define $func" - } - set body [dict get $info $func] - # We were given a function name to call - if {[llength $body] eq 1} continue - set fname [string map [list @Name@ [string totitle $name]] $fpat] - my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body] - dict set tcltype $name $func $fname - } - } - method c_header body { - my variable code - ::practcl::cputs code(header) $body - } - method c_code body { - my variable code - ::practcl::cputs code(funct) $body - } - method c_function {header body} { - my variable code cfunct - foreach regexp { - {(.*) ([a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} - {(.*) (\x2a[a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} - } { - if {[regexp $regexp $header all keywords funcname arglist]} { - dict set cfunct $funcname header $header - dict set cfunct $funcname body $body - dict set cfunct $funcname keywords $keywords - dict set cfunct $funcname arglist $arglist - dict set cfunct $funcname public [expr {"static" ni $keywords}] - dict set cfunct $funcname export [expr {"STUB_EXPORT" in $keywords}] - - return - } - } - ::practcl::cputs code(header) "$header\;" - # Could not parse that block as a function - # append it verbatim to our c_implementation - ::practcl::cputs code(funct) "$header [list $body]" - } - - - method cmethod {name body {arginfo {}}} { - my variable methods code - foreach {f v} $arginfo { - dict set methods $name $f $v - } - dict set methods $name body $body - } - - method c_tclproc_nspace nspace { - my variable code - if {![info exists code(nspace)]} { - set code(nspace) {} - } - if {$nspace ni $code(nspace)} { - lappend code(nspace) $nspace - } - } - - method c_tclproc_raw {name body {arginfo {}}} { - my variable tclprocs code - - foreach {f v} $arginfo { - dict set tclprocs $name $f $v - } - dict set tclprocs $name body $body - } - - method go {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - next - my variable methods code cstruct tclprocs - if {[info exists methods]} { - debug [self] methods [my define get cclass] - set thisclass [my define get cclass] - foreach {name info} $methods { - # Provide a callproc - if {![dict exists $info callproc]} { - set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} OOMethod_${thisclass}_${name}]] - dict set methods $name callproc $callproc - } else { - set callproc [dict get $info callproc] - } - if {[dict exists $info body] && ![dict exists $info header]} { - dict set methods $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext ,int objc ,Tcl_Obj *const *objv)" - } - if {![dict exists $info methodtype]} { - set methodtype [string map {{ } _ : _} MethodType_${thisclass}_${name}] - dict set methods $name methodtype $methodtype - } - } - if {![info exists code(initfuncts)] || "${thisclass}_OO_Init" ni $code(initfuncts)} { - lappend code(initfuncts) "${thisclass}_OO_Init" - } - } - set thisnspace [my define get nspace] - - if {[info exists tclprocs]} { - debug [self] tclprocs [dict keys $tclprocs] - foreach {name info} $tclprocs { - if {![dict exists $info callproc]} { - set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} Tclcmd_${thisnspace}_${name}]] - dict set tclprocs $name callproc $callproc - } else { - set callproc [dict get $info callproc] - } - if {[dict exists $info body] && ![dict exists $info header]} { - dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])" - } - } - } - debug [list /[self] [self method] [self class]] - } -} - -::oo::class create ::practcl::cheader { - superclass ::practcl::product - - method compile-products {} {} - method generate-cinit {} {} -} - -::oo::class create ::practcl::csource { - superclass ::practcl::product -} - -::oo::class create ::practcl::clibrary { - superclass ::practcl::product - - method compile-products {} { - set filename [my define get filename] - set result {} - if {$filename ne {}} { - lappend result $filename [list library 1] - } - return $result - } -} - -### -# In the end, all C code must be loaded into a module -# This will either be a dynamically loaded library implementing -# a tcl extension, or a compiled in segment of a custom shell/app -### -::oo::class create ::practcl::module { - superclass ::practcl::dynamic - - method linktype {} { - return {subordinate dynamic module} - } - - - method initialize {} { - set filename [my define get filename] - if {$filename eq {}} { - return - } - if {[my define get name] eq {}} { - my define set name [file tail [file dirname $filename]] - } - if {[my define get localpath] eq {}} { - my define set localpath [my define get name]_[my define get name] - } - debug [self] SOURCE $filename - my source $filename - } - - method implement path { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set filename [my define get output_c] - if {$filename eq {}} { - debug [list /[self] [self method] [self class]] - return - } - file mkdir [file join $path build] - set cout [open [file join $path [file rootname $filename].c] w] - puts $cout [subst {/* -** This file is generated by the [info script] script -** any changes will be overwritten the next time it is run -*/}] - puts $cout [my generate-c] - close $cout - debug [list /[self] [self method] [self class]] - } - - method child which { - switch $which { - organs { - return [list project [my define get project] module [self]] - } - } - } -} - - -::oo::class create ::practcl::library { - superclass ::practcl::module - - constructor args { - my variable define - if {[llength $args] == 1} { - if {[catch {uplevel 1 [list subst [lindex $args 0]]} contents]} { - set contents [lindex $args 0] - } - } else { - if {[catch {uplevel 1 [list subst $args]} contents]} { - set contents $args - } - } - array set define $contents - my select - my initialize - } - - method linktype {} { - return library - } - # Create a "package ifneeded" - # Args are a list of aliases for which this package will answer to - method package-ifneeded {args} { - set result {} - set name [my define get pkg_name [my define get name]] - set version [my define get pkg_vers [my define get version]] - if {$version eq {}} { - set version 0.1a - } - set output_tcl [my define get output_tcl] - if {$output_tcl ne {}} { - set script "\[list source \[file join \$dir $output_tcl\]\]" - } elseif {[string is true -strict [my define get SHARED_BUILD]]} { - set script "\[list load \[file join \$dir [my define get shared_library]\] [my define get pkginit]\]" - } else { - # Provide a null passthrough - set script [list package provide $pkg_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 select {} {} - - method child which { - switch $which { - organs { - # A library can be a project, it can be a module. Any - # subordinate modules will indicate their existance - return [list project [self] module [self]] - } - } - } - - method go {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set name [my define getnull name] - if {$name eq {}} { - set name generic - my define name generic - } - set output_c [my define getnull output_c] - if {$output_c eq {}} { - set output_c [file rootname $name].c - my define set output_c $output_c - } - set output_h [my define getnull output_h] - if {$output_h eq {}} { - set output_h [file rootname $output_c].h - my define set output_h $output_h - } - set output_tcl [my define getnull output_tcl] - if {$output_tcl eq {}} { - set output_tcl [file rootname $output_c].tcl - my define set output_tcl $output_tcl - } - set output_mk [my define getnull output_mk] - if {$output_mk eq {}} { - set output_mk [file rootname $output_mk].mk - my define set output_mk $output_mk - } - set output_decls [my define getnull output_decls] - if {$output_decls eq {}} { - set output_decls [file rootname $output_c].decls - my define set output_decls $output_decls - } - my variable links - foreach {linktype objs} [array get links] { - foreach obj $objs { - $obj go - } - } - debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] - } - - method implement path { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - my go - foreach item [my link list subordinate] { - $item implement $path - } - set cout [open [file join $path [my define get output_c]] w] - puts $cout [subst {/* -** This file is generated by the [info script] script -** any changes will be overwritten the next time it is run -*/}] - puts $cout [my generate-c] - puts $cout [my generate-loader] - close $cout - - set macro HAVE_[string toupper [file rootname [my define get output_h]]]_H - set hout [open [file join $path [my define get output_h]] w] - puts $hout [subst {/* -** This file is generated by the [info script] script -** any changes will be overwritten the next time it is run -*/}] - puts $hout "#ifndef ${macro}" - puts $hout "#define ${macro}" - puts $hout [my generate-h] - puts $hout "#endif" - close $hout - - set tclout [open [file join $path [my define get output_tcl]] w] - puts $tclout "### -# This file is generated by the [info script] script -# any changes will be overwritten the next time it is run -###" - puts $tclout [my generate-tcl] - close $tclout - - set mkout [open [file join $path [my define get output_mk]] w] - puts $mkout "### -# This file is generated by the [info script] script -# any changes will be overwritten the next time it is run -###" - puts $mkout [my generate-make $path] - close $mkout - my generate-decls [my define get name] $path - debug [list /[self] [self method] [self class]] - } - - method generate-make {path} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - ::practcl::build::DEFS [self] [my define get DEFS] name version defs - set includedir . - foreach include [my generate-include-directory] { - set cpath [::practcl::file_relative $path [file normalize $include]] - if {$cpath ni $includedir} { - lappend includedir $cpath - } - } - set NAME [string toupper $name] - set result {} - set products {} - set libraries {} - set thisline {} - ::practcl::cputs result "${NAME}_DEFS = $defs\n" - ::practcl::cputs result "${NAME}_INCLUDES = -I\"[join $includedir "\" -I\""]\"\n" - ::practcl::cputs result "${NAME}_COMPILE = \$(CC) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" - ::practcl::cputs result "${NAME}_CPPCOMPILE = \$(CXX) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" - - foreach {ofile info} [my compile-products] { - dict set products $ofile $info - if {[dict exists $info library]} { - lappend libraries $ofile - continue - } - if {[dict exists $info depend]} { - ::practcl::cputs result "\n${ofile}: [dict get $info depend]" - } else { - ::practcl::cputs result "\n${ofile}:" - } - set cfile [dict get $info cfile] - if {[file extension $cfile] in {.c++ .cpp}} { - set cmd "\t\$\(${NAME}_CPPCOMPILE\)" - } else { - set cmd "\t\$\(${NAME}_COMPILE\)" - } - if {[dict exists $info extra]} { - append cmd " [dict get $info extra]" - } - append cmd " -c [dict get $info cfile] -o \$@\n\t" - ::practcl::cputs result $cmd - } - - set map {} - lappend map %LIBRARY_NAME% $name - lappend map %LIBRARY_VERSION% $version - lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] - lappend map %LIBRARY_PREFIX% [my define getnull libprefix] - foreach flag { - SHLIB_LD - STLIB_LD - SHLIB_LD_LIBS - SHLIB_SUFFIX - LDFLAGS_DEFAULT - } { - lappend map "%${flag}%" "\$\{${flag}\}" - } - - if {[string is true [my define get SHARED_BUILD]]} { - set outfile $::project(libfile) - } else { - set outfile [my shared_library] - } - my define set shared_library $outfile - ::practcl::cputs result " -${NAME}_SHLIB = $outfile -${NAME}_OBJS = [dict keys $products] -" - - #lappend map %OUTFILE% {\[$]@} - lappend map %OUTFILE% $outfile - lappend map %LIBRARY_OBJECTS% "\$(${NAME}_OBJS)" - ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" - ::practcl::cputs result "\t[string map $map $::project(PRACTCL_SHARED_LIB)]" - if {$::project(PRACTCL_VC_MANIFEST_EMBED_DLL) ni {: {}}} { - ::practcl::cputs result "\t[string map $map $::project(PRACTCL_VC_MANIFEST_EMBED_DLL)]" - } - ::practcl::cputs result {} - if {[string is true [my define get SHARED_BUILD]]} { - #set outfile [my static_library] - set outfile $name.a - } else { - set outfile $::project(libfile) - } - my define set static_library $outfile - dict set map %OUTFILE% $outfile - ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" - ::practcl::cputs result "\t[string map $map $::project(PRACTCL_STATIC_LIB)]" - ::practcl::cputs result {} - return $result - } - - - ### - # Produce a static library - ### - method generate-dynamic-library {outfile} { - set path [file dirname $outfile] - cd $path - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - ::practcl::build::DEFS [self] [my define get DEFS] name version defs - set NAME [string toupper $name] - set result {} - set libraries {} - set thisline {} - set OBJECTS {} - set includedir . - foreach include [my generate-include-directory] { - set cpath [::practcl::file_relative $path [file normalize $include]] - if {$cpath ni $includedir} { - lappend includedir $cpath - } - } - set INCLUDES "-I[join $includedir " -I"]" - set COMPILE "$::project(CC) $::project(PRACTCL_CFLAGS) $::project(CFLAGS_DEFAULT) $::project(CFLAGS_WARNING) $INCLUDES" - append COMPILE " " $defs - ### - # Compile the C sources - ### - foreach {ofile info} [my compile-products] { - lappend OBJECTS $ofile - if {[dict exists $info library]} { - continue - } - # Products with no cfile aren't compiled - if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} continue - if {[file exists $ofile] && [file mtime $ofile]>[file mtime $cfile]} continue - set cmd $COMPILE - if {[dict exists $info extra]} { - append cmd " [dict get $info extra]" - } - append cmd " -c $cfile -o $ofile" - puts "COMPILE: $cmd" - exec {*}$cmd >&@ stdout - } - ### - # WORKING ON AN ADVANCED MAPPING - ### - - set map {} - foreach {item value} [array get ::project] { - lappend map "\$\{$item\}" $value - lappend map "\$\($item\)" $value - } - lappend map %LIBRARY_NAME% $name - lappend map %LIBRARY_VERSION% $version - lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] - lappend map %LIBRARY_PREFIX% [my define getnull libprefix] - foreach flag { - STLIB_LD - LDFLAGS_DEFAULT - SHLIB_CFLAGS - SHLIB_LD - SHLIB_LD_LIBS - SHLIB_SUFFIX - } { - lappend map "%${flag}%" [string map $map $::project($flag)] - } - lappend map %OUTFILE% $outfile - lappend map %LIBRARY_OBJECTS% $OBJECTS - #set outfile $name.a - dict set map %OUTFILE% $outfile - file delete $outfile - doexec {*}[string map $map $::project(PRACTCL_SHARED_LIB)] - if {$::project(RANLIB) ni { {} : } } { - doexec {*}$::project(RANLIB) $outfile - } - } - - ### - # Produce a static library - ### - method generate-static-library {outfile} { - set path [file dirname $outfile] - cd $path - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - ::practcl::build::DEFS [self] [my define get DEFS] name version defs - set NAME [string toupper $name] - set result {} - set libraries {} - set thisline {} - set OBJECTS {} - set includedir . - foreach include [my generate-include-directory] { - set cpath [::practcl::file_relative $path [file normalize $include]] - if {$cpath ni $includedir} { - lappend includedir $cpath - } - } - set INCLUDES "-I[join $includedir " -I"]" - set COMPILE "$::project(CC) $::project(PRACTCL_CFLAGS) $::project(CFLAGS_DEFAULT) $::project(CFLAGS_WARNING) $INCLUDES" - append COMPILE " " $defs - ### - # Compile the C sources - ### - foreach {ofile info} [my compile-products] { - lappend OBJECTS $ofile - if {[dict exists $info library]} { - continue - } - # Products with no cfile aren't compiled - if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} continue - if {[file exists $ofile] && [file mtime $ofile]>[file mtime $cfile]} continue - set cmd $COMPILE - if {[dict exists $info extra]} { - append cmd " [dict get $info extra]" - } - append cmd " -c $cfile -o $ofile" - puts "COMPILE: $cmd" - exec {*}$cmd >&@ stdout - } - ### - # WORKING ON AN ADVANCED MAPPING - ### - - set map {} - foreach {item value} [array get ::project] { - lappend map "\$\{$item\}" $value - lappend map "\$\($item\)" $value - } - lappend map %LIBRARY_NAME% $name - lappend map %LIBRARY_VERSION% $version - lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] - lappend map %LIBRARY_PREFIX% [my define getnull libprefix] - foreach flag { - STLIB_LD - LDFLAGS_DEFAULT - } { - lappend map "%${flag}%" [string map $map $::project($flag)] - } - lappend map %OUTFILE% $outfile - lappend map %LIBRARY_OBJECTS% $OBJECTS - #set outfile $name.a - dict set map %OUTFILE% $outfile - file delete $outfile - doexec {*}[string map $map $::project(PRACTCL_STATIC_LIB)] - if {$::project(RANLIB) ni { {} : } } { - doexec {*}$::project(RANLIB) $outfile - } - } - - method shared_library {} { - set name [string tolower [my define get name [my define get pkg_name]]] - set NAME [string toupper $name] - set version [my define get version [my define get pkg_vers]] - set map {} - lappend map %LIBRARY_NAME% [string totitle $name] - lappend map %LIBRARY_VERSION% $version - lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] - lappend map %LIBRARY_PREFIX% [my define getnull libprefix] - foreach flag { - SHLIB_LD - STLIB_LD - SHLIB_LD_LIBS - SHLIB_SUFFIX - LDFLAGS_DEFAULT - } { - lappend map "%${flag}%" "\$\{${flag}\}" - } - set outfile [string map $map $::project(PRACTCL_NAME_LIBRARY)]$::project(SHLIB_SUFFIX) - return $outfile - } - - method shared_library {} { - set name [string tolower [my define get name [my define get pkg_name]]] - set NAME [string toupper $name] - set version [my define get version [my define get pkg_vers]] - set map {} - lappend map %LIBRARY_NAME% $name - lappend map %LIBRARY_VERSION% $version - lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] - lappend map %LIBRARY_PREFIX% [my define getnull libprefix] - foreach flag { - SHLIB_LD - STLIB_LD - SHLIB_LD_LIBS - SHLIB_SUFFIX - LDFLAGS_DEFAULT - } { - lappend map "%${flag}%" "\$\{${flag}\}" - } - set outfile [string map $map $::project(PRACTCL_NAME_LIBRARY)]$::project(SHLIB_SUFFIX) - return $outfile - } - - method generate-loader {} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set result {} - ::practcl::cputs result " -extern int DLLEXPORT [my define get init_funct]( Tcl_Interp *interp ) \{" - ::practcl::cputs result { - /* Initialise the stubs tables. */ - #ifdef USE_TCL_STUBS - if (Tcl_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR; - if (TclOOInitializeStubs(interp, "1.0") == NULL) return TCL_ERROR; -} - if {[my define get tk 0]} { - ::practcl::cputs result { if (Tk_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR;} - } - ::practcl::cputs result { #endif} - foreach item [my link list subordinate] { - ::practcl::cputs result [$item generate-cinit] - } - if {[my define exists pkg_name]} { - ::practcl::cputs result " if (Tcl_PkgProvide(interp, \"[my define get pkg_name]\" , \"[my define get pkg_vers]\" )) return TCL_ERROR\;" - } - ::practcl::cputs result " return TCL_OK\;\n\}\n" - return $result - } - - method generate-decls {pkgname path} { - debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] - set outfile [file join $path/$pkgname.decls] - - ### - # Build the decls file - ### - set fout [open $outfile w] - puts $fout [subst {### - # $outfile - # - # This file was generated by [info script] - ### - - library $pkgname - interface $pkgname - }] - - ### - # Generate list of functions - ### - set stubfuncts [my generate-stub-function] - set thisline {} - set functcount 0 - foreach {func header} $stubfuncts { - puts $fout [list declare [incr functcount] $header] - } - puts $fout [list export "int [my define get init_funct](Tcl_Inter *interp)"] - puts $fout [list export "char *[string totitle [my define get name]]_InitStubs(Tcl_Inter *interp, char *version, int exact)"] - - close $fout - - ### - # Build [package]Decls.h - ### - set hout [open [file join $path ${pkgname}Decls.h] w] - - close $hout - - set cout [open [file join $path ${pkgname}StubInit.c] w] -puts $cout [string map [list %pkgname% $pkgname %PkgName% [string totitle $pkgname]] { -#ifndef USE_TCL_STUBS -#define USE_TCL_STUBS -#endif -#undef USE_TCL_STUB_PROCS - -#include "tcl.h" -#include "%pkgname%.h" - - /* - ** Ensure that Tdom_InitStubs is built as an exported symbol. The other stub - ** functions should be built as non-exported symbols. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT - -%PkgName%Stubs *%pkgname%StubsPtr; - - /* - **---------------------------------------------------------------------- - ** - ** %PkgName%_InitStubs -- - ** - ** Checks that the correct version of %PkgName% is loaded and that it - ** supports stubs. It then initialises the stub table pointers. - ** - ** Results: - ** The actual version of %PkgName% that satisfies the request, or - ** NULL to indicate that an error occurred. - ** - ** Side effects: - ** Sets the stub table pointers. - ** - **---------------------------------------------------------------------- - */ - -char * -%PkgName%_InitStubs (Tcl_Interp *interp, char *version, int exact) -{ - char *actualVersion; - actualVersion = Tcl_PkgRequireEx(interp, "%pkgname%", version, exact,(ClientData *) &%pkgname%StubsPtr); - if (!actualVersion) { - return NULL; - } - if (!%pkgname%StubsPtr) { - Tcl_SetResult(interp,"This implementation of %PkgName% does not support stubs",TCL_STATIC); - return NULL; - } - return actualVersion; -} -}] - close $cout - } - - method compile-products {} { - set result {} - foreach item [my link list subordinate] { - lappend result {*}[$item compile-products] - } - set filename [my define get output_c] - if {$filename ne {}} { - set ofile build/[file rootname [file tail $filename]]_main.o - lappend result $ofile [list cfile $filename extra [my define get extra]] - } - return $result - } - - method SUBPACKAGE {pkg info {oodefine {}}} { - upvar 1 os os - set fossilinfo [list download $::project(download) tag trunk sandbox $::project(sandbox)] - if {[dict exists $info os] && ($os ni [dict get $info os])} return - # Select which tag to use here. - # For production builds: tag-release - if {[::info exists ::env(FOSSIL_MIRROR)]} { - dict set info localmirror $::env(FOSSIL_MIRROR) - } - set profile [my define get profile release]: - if {[dict exists $info profile $profile]} { - dict set info tag [dict get $info profile $profile] - } - set obj [::practcl::subproject create ::PKG.$pkg [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0] $info]] - my link object $obj - oo::objdefine $obj $oodefine - $obj go - return $obj - } -} - -::oo::class create ::practcl::tclkit { - superclass ::practcl::library - - ## method DEFS - # This method populates 4 variables: - # name - The name of the package - # version - The version of the package - # defs - C flags passed to the compiler - # includedir - A list of paths to feed to the compiler for finding headers - # - method DEFS {namevar versionvar defsvar} { - upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs - set name [string tolower [my define get name [my define get pkg_name]]] - set NAME [string toupper $name] - set version [my define get version [my define get pkg_vers]] - if {$version eq {}} { - set version 0.1a - } - set defs {} - set NAME [string toupper $name] - foreach item $::TCL(defs) { - if {[string range $item 0 9] eq "-DPACKAGE_"} continue - set eqidx [string first = $item ] - if {$eqidx < 0} { - append defs { } $item - continue - } - set field [string range $item 0 [expr {$eqidx-1}]] - set value [string range $item [expr {$eqidx+1}] end] - set emap {} - lappend emap \x5c \x5c\x5c \x20 \x5c\x20 \x22 \x5c\x22 \x28 \x5c\x28 \x29 \x5c\x29 - if {[string is integer -strict $value]} { - append defs " ${field}=$value" - } else { - append defs " ${field}=[string map $emap $value]" - } - } - append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" - append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" - } - - ## Wrap an executable - # - method wrap {PWD exename vfspath args} { - cd $PWD - if {![file exists $vfspath]} { - file mkdir $vfspath - } - foreach item [my link list core.library] { - set name [$item define get name] - set libsrcroot [$item define get srcroot] - if {[file exists [file join $libsrcroot library]]} { - ::practcl::copyDir [file join $libsrcroot library] [file join $vfspath boot $name] - } - } - if {[my define get installdir] ne {}} { - ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib] - } - foreach arg $args { - ::practcl::copyDir $arg $vfspath - } - - set fout [open [file join $vfspath packages.tcl] w] - puts $fout { - set ::PKGIDXFILE [info script] - set dir [file dirname $::PKGIDXFILE] - } - #set BASEVFS [my define get BASEVFS] - set EXEEXT [my define get EXEEXT] - - set tclkit_bare [my define get tclkit_bare] - - set buffer [::practcl::pkgindex_path $vfspath] - puts $fout $buffer - close $fout - ::practcl::mkzip::mkzip ${exename}${EXEEXT} -runtime $tclkit_bare -directory $vfspath - if { [my define get platform] ne "windows" } { - file attributes ${exename}${EXEEXT} -permissions a+x - } - } -} - -### -# Meta repository -# The default is an inert source code block -### -oo::class create ::practcl::subproject { - superclass ::practcl::object - - method compile {} {} - - method go {} { - set platform [my define get platform] - my define get USEMSVC [my define get USEMSVC] - set name [my define get name] - if {![my define exists srcroot]} { - my define set srcroot [file join [my define get sandbox] $name] - } - set srcroot [my define get srcroot] - my define set localsrcdir $srcroot - my define add include_dir [file join $srcroot generic] - my sources - } - - # Install project into the local build system - method install-local {} { - my unpack - } - - # Install project into the virtual file system - method install-vfs {} {} - - method linktype {} { - return {subordinate package} - } - - method linker-products {configdict} { - set srcdir [my define get localsrcdir] - if {[dict exists $configdict libfile]} { - return " [file join $srcdir [dict get $configdict libfile]]" - } - } - method linker-external {configdict} { - if {[dict exists $configdict PRACTCL_LIBS]} { - return [dict get $configdict PRACTCL_LIBS] - } - } - - method sources {} {} - - method unpack {} { - set name [my define get name] - puts [list UNPACK [my define get tag]] - #my define set [::practcl::fossil_sandbox $name [my define dump]] - } -} - -# -oo::class create ::practcl::subproject.practcl { - superclass ::practcl::dynamic ::practcl::library -} - -oo::class create ::practcl::subproject.sak { - superclass ::practcl::subproject - - method install {} { - ### - # Handle teapot installs - ### - set pkg [my define get pkg_name [my define get name]] - my unpack - set DEST [my define get installdir] - set prefix [string trimleft [my define get prefix] /] - set localsrcdir [my define get localsrcdir] - ::dotclexec [file join $localsrcdir installer.tcl] \ - -pkg-path [file join $DEST $prefix lib $pkg] \ - -no-examples -no-html -no-nroff \ - -no-wait -no-gui -no-apps - } -} - -### -# A binary package -### -oo::class create ::practcl::subproject.binary { - superclass ::practcl::subproject - - method compile-products {} {} - - method ConfigureOpts {} { - set opts {} - if {[my define get broken_destroot 0]} { - set PREFIX [my define get prefix_broken_destdir] - } else { - set PREFIX [my define get prefix] - } - if {[my define get HOST] != [my define get TARGET]} { - lappend opts --host=[my define get TARGET] - } - if {[my define exists tclsrcdir]} { - set TCLSRCDIR [my define get tclsrcdir] - lappend opts --with-tcl=$TCLSRCDIR --with-tclinclude=[file join $TCLSRCDIR .. generic] - } - if {[my define exists tksrcdir]} { - set TKSRCDIR [my define get tksrcdir] - lappend opts --with-tk=$TKSRCDIR --with-tkinclude=[file join $TKSRCDIR .. generic] - } - lappend opts {*}[my define get config_opts] - lappend opts --prefix=$PREFIX - #--exec_prefix=$PREFIX - if {[my define get static 1]} { - lappend opts --disable-shared - } else { - lappend opts --enable-shared - } - return $opts - } - - - ### - # find or fake a key/value list describing this project - ### - method config.sh {} { - my variable conf_result - if {[info exists conf_result]} { - return $conf_result - } - set result {} - set name [my define get name] - set localsrcdir [my define get localsrcdir] - - set filename [file join $localsrcdir practcl.rc] - # Project uses the practcl template. Use the leavings from autoconf - if {[file exists $filename]} { - set interp [namespace current]::interp - interp create $interp - $interp eval [list source [file join $localsrcdir practcl.rc]] - foreach {item value} [lsort -stride 2 -dictionary [$interp eval {array get ::project}]] { - dict set result $item $value - } - set conf_result $result - return $result - } - set filename [file join $localsrcdir ${name}Config.sh] - if {[file exists $filename]} { - set l [expr {[string length $name]+1}] - foreach {field dat} [::practcl::read_Config.sh $filename] { - set field [string tolower $field] - if {[string match ${name}_* $field]} { - set field [string range $field $l end] - } - dict set result $field $dat - } - set conf_result $result - return $result - } - ### - # Oh man... we have to guess - ### - set filename [file join $localsrcdir Makefile] - if {![file exists $filename]} { - error "Could not locate any configuration data in $localsrcdir" - } - foreach {field dat} [::practcl::read_Makefile $filename] { - dict set result $field $dat - } - set conf_result $result - return $result - } - - method PreConfigure srcroot { - if {[my define get name] eq "tclconfig"} return - if {![file exists [file join $srcroot tclconfig]]} { - # ensure we have tclconfig - if {![file exists [file join $srcroot tclconfig]]} { - set tclconfiginfo [::practcl::fossil_sandbox tclconfig [list sandbox [my define get sandbox]]] - ::practcl::copyDir [dict get $tclconfiginfo srcroot] [file join $srcroot tclconfig] - } - } - } - - method compile {} { - set PWD [pwd] - file mkdir [file join $PWD build] - set name [my define get name] - my go - set localsrcdir [my define get localsrcdir] - ### - # Build a starter VFS for both Tcl and wish - ### - my unpack - set srcroot [my define get srcroot] - if {[my define get static 1]} { - puts "BUILDING Static $name $localsrcdir" - } else { - puts "BUILDING Dynamic $name $localsrcdir" - } - cd $localsrcdir - if {[my define get USEMSVC 0]} { - doexec nmake -f makefile.vc INSTALLDIR=[my define get installdir] release - } else { - if {![file exists [file join $localsrcdir Makefile]]} { - my PreConfigure $srcroot - set opts [my ConfigureOpts] - puts [list CONFIGURE {*}$opts] - doexec sh configure {*}$opts - } - domake all - } - cd $PWD - } -} - -oo::class create ::practcl::subproject.dynamiclib { - superclass ::practcl::subproject.binary - - method install-vfs {} { - set PWD [pwd] - set PKGROOT [my define get installdir] - set PREFIX [my define get prefix] - - ### - # Handle teapot installs - ### - set pkg [my define get pkg_name [my define get name]] - if {[my define get teapot] ne {}} { - set TEAPOT [my define get teapot] - set found 0 - foreach ver [my define get pkg_vers [my define get version]] { - set teapath [file join $TEAPOT $pkg$ver] - if {[file exists $teapath]} { - set dest [file join $PKGROOT [string trimleft $PREFIX /] lib [file tail $teapath]] - ::practcl::copyDir $teapath $dest - return - } - } - } - my compile - set localsrcdir [my define get localsrcdir] - cd $localsrcdir - if {[my define get USEMSVC 0]} { - puts "[self] VFS INSTALL $PKGROOT" - doexec nmake -f makefile.vc INSTALLDIR=$PKGROOT install - } elseif {[my define get broken_destroot 0] == 0} { - # Most modern TEA projects understand DESTROOT in the makefile - puts "[self] VFS INSTALL $PKGROOT" - domake install DESTDIR=$PKGROOT - } 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 define get prefix] - set BROKENROOT [::practcl::msys_to_tclpath [my define get prefix_broken_destdir]] - file delete -force $BROKENROOT - file mkdir $BROKENROOT - domake install - ::practcl::copyDir $BROKENROOT [file join $PKGROOT [string trimleft $PREFIX /]] - file delete -force $BROKENROOT - } - cd $PWD - } -} - -oo::class create ::practcl::subproject.staticlib { - superclass ::practcl::subproject.binary -} - -oo::class create ::practcl::subproject.core { - superclass ::practcl::subproject.staticlib - - method linktype {} { - return {subordinate core.library} - } - - method PreConfigure srcroot { - } - - method go {} { - set name [my define get name] - set platform [my define get platform] - if {![my define exists srcroot]} { - my define set srcroot [file join [my define get sandbox] $name] - } - set srcroot [my define get srcroot] - my define add include_dir [file join $srcroot generic] - switch $platform { - windows { - my define set localsrcdir [file join $srcroot win] - my define add include_dir [file join $srcroot win] - } - default { - my define set localsrcdir [file join $srcroot unix] - my define add include_dir [file join $srcroot $name unix] - } - } - } -} - - -package provide practcl 0.4 DELETED scripts/rmdir.tcl Index: scripts/rmdir.tcl ================================================================== --- scripts/rmdir.tcl +++ /dev/null @@ -1,9 +0,0 @@ -### -# Script to recursively remove directories -# Needed because various packages produce characters -# in file names that the rm command in msys can't clean -# up -### -foreach path $argv { - file delete -force [file normalize $path] -} DELETED scripts/scm-move.tcl Index: scripts/scm-move.tcl ================================================================== --- scripts/scm-move.tcl +++ /dev/null @@ -1,21 +0,0 @@ -package require fileutil - -set src [lindex $argv 0] -set dest [lindex $argv 1] -catch {exec make -C $src clean} - -foreach file [::fileutil::findByPattern $src -glob *] { - set nearpath [::fileutil::stripPwd $file] - set subpath [::fileutil::relativeUrl $src $file] - set newpath [file join $dest {*}[lrange [file split $subpath] 1 end]] - #puts [list $nearpath -> $newpath] - #continue - if {[file isdirectory $file]} { - file mkdir [file dirname $newpath] - } else { - puts [list $nearpath -> $newpath] - file mkdir [file dirname $newpath] - file rename $file $newpath - exec fossil mv $nearpath $newpath - } -} DELETED scripts/teapot_index Index: scripts/teapot_index ================================================================== --- scripts/teapot_index +++ /dev/null @@ -1,556 +0,0 @@ -#! /usr/bin/env tclsh - -if {[llength $argv] != "2"} { - puts stderr "Usage: teapot_index " - exit 1 -} - -set srcdir [file normalize [lindex $argv 0]] -set dstdir [file normalize [lindex $argv 1]] - -# Define requirements for entities -## Must be sync'd with [teapot_index] -set entity_definition(package) [list name ver arch] - -# Define maping of field name to text -set entity_fieldnames([list package name]) "Name" -set entity_fieldnames([list package ver]) "Version" -set entity_fieldnames([list package arch]) "Platform" -set entity_fieldnames([list entity]) "What" - -# Index all packages -proc teapot_index {srcdir} { - array set pkginfo [list] - - foreach pkgdir [glob -directory $srcdir -type d */*/*] { - unset -nocomplain currpkginfo - set currpkginfo(pkgdir) $pkgdir - - set teapot [file join $pkgdir teapot.txt] - - set multifile 1 - if {![file exists $teapot]} { - set files [glob -directory $pkgdir *] - if {[llength $files] == 1} { - set teapot [lindex $files 0] - set multifile 0 - } else { - continue - } - } - - set currpkginfo(multifile) $multifile - if {$multifile} { - set currpkginfo(extfile) file.zip - } else { - set currpkginfo(extfile) file.tm - } - - set fd [open $teapot r] - set data [read $fd] - close $fd - - set processline $multifile - foreach line [split $data \n] { - set line [string trim $line] - if {!$multifile} { - if {$line == "# @@ Meta Begin"} { - set processline 1 - continue - } - - if {$line == "# @@ Meta End"} { - break - } - - set line [regsub {^ *# *} $line {}] - } - - if {!$processline} { - continue - } - - set cmd "INVALID" - catch { - set cmd [string toupper [lindex $line 0]] - } - - switch -- $cmd { - "PACKAGE" { - set name [lindex $line 1] - set vers [lindex $line 2] - - set currpkginfo(name) $name - set currpkginfo(vers) $vers - } - "META" { - set var [string tolower [lindex $line 1]] - set val [lrange $line 2 end] - - if {![info exists currpkginfo($var)]} { - set currpkginfo($var) "" - } - - if {[lsearch -exact $currpkginfo($var) $val] == -1} { - lappend currpkginfo($var) $val - } - } - } - } - - set pkginfo([list $currpkginfo(name) $currpkginfo(vers) $currpkginfo(platform)]) [array get currpkginfo] - } - - return [array get pkginfo] -} - -proc complete_entpath {type entinfo_arrlist} { - array set entinfo $entinfo_arrlist - - set req_fields $::entity_definition($type) - - set retval [list $type] - - foreach req_field $req_fields { - if {![info exists entinfo($req_field)]} { - return "" - } - - lappend retval $req_field $entinfo($req_field) - } - - return $retval -} - -proc generate_tpm {entlist} { - set ents [list] - foreach part $entlist { - set entinfo [list] - - foreach enttype $part { - set type [lindex $enttype 0] - set ent [lindex $enttype 1] - - if {$type == "entity"} { - # Only include the entity type if it is complete... - set work [complete_entpath $ent [join $part]] - - if {$work == ""} { - continue - } - } - - lappend entinfo $ent - } - - lappend ents $entinfo - } - - set ret {} - - return $ret -} - -proc generate_table {fields numitems} { - set ret "" - - foreach field $fields { - append ret " \n" - - unset -nocomplain entinfo - foreach enttype [lrange $field 0 [expr $numitems - 1]] { - set type [lindex $enttype 0] - set item [lindex $enttype 1] - - set entinfo($type) $item - } - - if {[info exists entinfo(entity)]} { - set entity_type $entinfo(entity) - - set req_fields $::entity_definition($entity_type) - } - - set entpath_parts [list] - - foreach enttype [lrange $field 0 [expr $numitems - 1]] { - set type [lindex $enttype 0] - set item [lindex $enttype 1] - - if {$type != "entity"} { - lappend entpath_parts $type $item - } - - set complete_entpath_parts "" - if {[info exists entity_type]} { - set complete_entpath_parts [complete_entpath $entity_type $entpath_parts] - } - - if {$complete_entpath_parts == ""} { - set entpath [join [join [list entity $entpath_parts]] /] - } else { - set entpath [join $complete_entpath_parts /] - } - - append ret " $item\n" - } - - append ret " \n" - } - - return [string range $ret 0 end-1] -} - -# Create "index.html" -proc create_output_index {dstdir pkginfo_arrlist} { - array set pkginfo $pkginfo_arrlist - - set indexfile [file join $dstdir index.html] - set altindexfile [file join $dstdir entity index.html] - - set pkglist [list] - foreach ent [array names pkginfo] { - set pkg [lindex $ent 0] - set addent [list [list name $pkg]] - if {[lsearch -exact $pkglist $addent] != -1} { - continue - } - - lappend pkglist $addent - } - - set pkglist [lsort -dictionary $pkglist] - - file mkdir [file dirname $indexfile] - set fd [open $indexfile w] - puts $fd "" - puts $fd " " - puts $fd " List of all entities" - puts $fd " " - puts $fd " " - puts $fd [generate_tpm $pkglist] - puts $fd "

List of all entities

" - puts $fd " " - puts $fd [generate_table $pkglist 1] - puts $fd "
" - puts $fd " " - puts $fd "" - close $fd - - file mkdir [file dirname $altindexfile] - file delete -force -- $altindexfile - file link -hard $altindexfile $indexfile -} - -# Create "package/list" -proc create_output_pkglist {dstdir pkginfo_arrlist} { - array set pkginfo $pkginfo_arrlist - - set pkgdir [file join $dstdir package] - catch { - file mkdir $pkgdir - } - set indexfile [file join $pkgdir list.html] - set altindexfile [file join $pkgdir list] - - set pkglist [list] - foreach ent [array names pkginfo] { - set pkg [lindex $ent 0] - set ver [lindex $ent 1] - set arch [lindex $ent 2] - - lappend pkglist [list [list entity package] [list name $pkg] [list ver $ver] [list arch $arch] [list unknown 0]] - } - - set pkglist [lsort -dictionary $pkglist] - - set fd [open $indexfile w] - puts $fd "" - puts $fd " " - puts $fd " List of all packages" - puts $fd " " - puts $fd " " - puts $fd [generate_tpm $pkglist] - puts $fd "

List of all packages

" - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd [generate_table $pkglist 4] - puts $fd "
WhatNameVersionPlatform
" - puts $fd " " - puts $fd "" - close $fd - - file delete -- $altindexfile - file link -hard $altindexfile $indexfile -} - -# Create "package/name//ver//arch//file" -proc create_output_files {dstdir pkginfo_arrlist {force 0}} { - array set pkginfo $pkginfo_arrlist - - foreach ent [array names pkginfo] { - set pkg [lindex $ent 0] - set ver [lindex $ent 1] - set arch [lindex $ent 2] - - array set currpkginfo $pkginfo($ent) - set pkgdir $currpkginfo(pkgdir) - set multifile $currpkginfo(multifile) - set extfiletail $currpkginfo(extfile) - - set workdir [file join $dstdir package name $pkg ver $ver arch $arch] - set regfile [file join $workdir file] - set extfile [file join $workdir $extfiletail] - - if {[file exists $extfile] && !$force} { - continue - } - - catch { - file mkdir $workdir - } - - if {$multifile} { - if {[catch { - cd $pkgdir - - file delete -- $extfile - exec zip -r $extfile . -x build.log - } err]} { - puts "Error while zipping: $err" - } - } else { - set origfile [lindex [glob -directory $pkgdir *] 0] - - file copy -force -- $origfile $extfile - } - - file delete -- $regfile - file link -hard $regfile $extfile - file attributes $regfile -permissions -x - file attributes $extfile -permissions -x - } -} - -proc create_entity_file {entity dstdir pkginfo_arrlist} { - array set pkginfo $pkginfo_arrlist - array set entinfo $entity - - if {![info exists entinfo(entity)]} { - return - } - - set entity_type $entinfo(entity) - set req_fields $::entity_definition($entity_type) - - set complete 1 - set pkgpat [list] - set dispfields [list] - foreach req_field $req_fields { - if {![info exists entinfo($req_field)]} { - set complete 0 - - lappend pkgpat "*" - if {![info exists pkgnextlevel]} { - set pkgnextlevel $req_field - lappend dispfields $req_field - } - } else { - lappend pkgpat $entinfo($req_field) - lappend dispfields $req_field - } - } - - if {$complete} { - set entpath_parts [list $entity_type] - - foreach req_field $req_fields { - lappend entpath_parts $req_field $entinfo($req_field) - } - } else { - set entpath_parts [list entity] - - foreach req_field $req_fields { - if {[info exists entinfo($req_field)]} { - lappend entpath_parts $req_field $entinfo($req_field) - } - } - } - - set entpath [join $entpath_parts /] - - if {[string match "/*" $entpath]} { - return - } - - set indexfile [file join $dstdir $entpath index.html] - set tmpindexfile [file join $dstdir $entpath index.html.tmp] - - catch { - file mkdir [file dirname $indexfile] - } - - set fd [open $tmpindexfile w] - - puts $fd "" - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - - set pkglist [list] - if {!$complete} { - foreach pkgent [array names pkginfo $pkgpat] { - unset -nocomplain currpkginfo - for {set idx 0} {$idx < [llength $req_fields]} {incr idx} { - set field [lindex $req_fields $idx] - set value [lindex $pkgent $idx] - set currpkginfo($field) $value - } - - set currpkgdata [list [list entity $entity_type]] - foreach dispfield $dispfields { - lappend currpkgdata [list $dispfield $currpkginfo($dispfield)] - } - - if {[lsearch -exact $pkglist $currpkgdata] != -1} { - continue - } - - lappend pkglist $currpkgdata - } - - set pkglist [lsort -dictionary $pkglist] - - puts $fd [generate_tpm $pkglist] - - puts $fd "

$pkgnextlevel

" - puts $fd " " - puts $fd " " - foreach dispfield [join [list entity $dispfields]] { - if {[info exists ::entity_fieldnames([list $entity_type $dispfield])]} { - set dispfieldheader $::entity_fieldnames([list $entity_type $dispfield]) - } else { - set dispfieldheader $::entity_fieldnames([list $dispfield]) - } - puts $fd " " - } - puts $fd " " - - puts $fd [generate_table $pkglist 10] - - puts $fd "
$dispfieldheader
" - } else { - set dispname_list [list] - set pathname_list [list $entity_type] - foreach field $req_fields { - lappend dispname_list $entinfo($field) - lappend pathname_list $field $entinfo($field) - } - set key $dispname_list - array set currpkginfo $pkginfo($key) - - set pathname_dir "[join $pathname_list /]" - set pathname_dirlocal [file join $dstdir $pathname_dir] - set pathname_tail $currpkginfo(extfile) - if {$pathname_tail == ""} { - set pathname_tail "file" - } - set pathname_uri "/$pathname_dir/$pathname_tail" - - puts $fd "

Details of $entity_type [join $dispname_list]

" - puts $fd "

Package archive

" - puts $fd "

Details

" - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - - foreach descfield [list rsk::build::date as::author as::build::date as::origin category description license platform require summary] { - if {![info exists currpkginfo($descfield)]} { - continue - } - set descval $currpkginfo($descfield) - switch -- $descfield { - "require" - "as::author" - "as::origin" { - catch { - set descval [join $descval] - } - } - } - - puts $fd " " - puts $fd " " - puts $fd " " - puts $fd " " - } - puts $fd "
KeyValue
$descfield[join $descval "
"]
" - } - - puts $fd " " - puts $fd "" - - close $fd - - file rename -force -- $tmpindexfile $indexfile -} - -proc create_all_entity_files {dstdir pkginfo_arrlist} { - set entfields $::entity_definition(package) - - for {set idx 0} {$idx < [llength $entfields]} {incr idx} { - set fieldname [lindex $entfields $idx] - set fieldname_to_idx($fieldname) $idx - } - - set enttypes_list [list] - for {set idx 1} {$idx < int(pow(2, [llength $entfields]))} {incr idx} { - set enttypes_list_cur [list] - - for {set subidx 0} {$subidx < [llength $entfields]} {incr subidx} { - if {$idx & (1 << $subidx)} { - lappend enttypes_list_cur [lindex $entfields $subidx] - } - } - - lappend enttypes_list $enttypes_list_cur - } - - array set pkginfo $pkginfo_arrlist - - set seen_entities [list] - foreach pkgdata [lsort -dictionary [array names pkginfo]] { - foreach enttypes $enttypes_list { - unset -nocomplain entity - lappend entity entity package - - foreach enttype $enttypes { - set entval [lindex $pkgdata $fieldname_to_idx($enttype)] - lappend entity $enttype - lappend entity $entval - - if {[lsearch -exact $seen_entities $entity] != -1} { - continue - } - lappend seen_entities $entity - - create_entity_file $entity $dstdir $pkginfo_arrlist - } - } - } -} - -set pkginfo [teapot_index $srcdir] -create_output_index $dstdir $pkginfo -create_output_pkglist $dstdir $pkginfo -create_output_files $dstdir $pkginfo -create_all_entity_files $dstdir $pkginfo DELETED scripts/tkdiff.tcl Index: scripts/tkdiff.tcl ================================================================== --- scripts/tkdiff.tcl +++ /dev/null @@ -1,9519 +0,0 @@ -#!/bin/sh -#-*-tcl-*- -# the next line restarts using wish \ -exec wish "$0" -- ${1+"$@"} - -############################################################################### -# -# TkDiff -- A graphical front-end to diff for Unix and Windows. -# Copyright (C) 1994-1998 by John M. Klassa. -# Copyright (C) 1999-2001 by AccuRev Inc. -# Copyright (C) 2002-2005 by John M. Klassa. -# -# TkDiff Home Page: http://tkdiff.sourceforge.net -# -# Usage: see "tkdiff -h" or "tkdiff --help" -# -# 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; either version 2 of the License, or -# (at your option) any later version. -# -# 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, write to the Free Software -# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -############################################################################### - -package require Tk 8.0 - -# Change to t for trace info on stderr -set g(debug) f - -# get this out of the way -- we want to draw the whole user interface -# behind the scenes, then pop up in all of its well-laid-out glory -set screenWidth [winfo vrootwidth .] -set screenHeight [winfo vrootheight .] -wm withdraw . - -# set a couple o' globals that we might need sooner than later -set g(name) "TkDiff" -set g(version) "4.1.4" -set g(started) 0 - -# FIXME - move to preferences -option add "*TearOff" false 100 -option add "*BorderWidth" 1 100 -option add "*ToolTip.background" LightGoldenrod1 -option add "*ToolTip.foreground" black - -# determine the windowing platform, since there are different ways to -# do this for different versions of tcl -if {[catch {tk windowingsystem} g(windowingSystem)]} { - if {"$::tcl_platform(platform)" == "windows"} { - set g(windowingSystem) "win32" - } elseif {"$::tcl_platform(platform)" == "unix"} { - set g(windowingSystem) "x11" - } elseif {"$::tcl_platform(platform)" == "aqua"} { - set g(windowingSystem) "x11" - } elseif {"$::tcl_platform(platform)" == "macintosh"} { - set g(windowingSystem) "classic" - } else { - # this should never happen, but just to be sure... - set g(windowingSystem) "x11" - } -} - -# determine the name of the temporary directory and the name of -# the rc file, both of which are dependent on the platform. -# This is overridden by the preference in .tkdiffrc except for the very first -# time you run -switch -- $::tcl_platform(platform) { -windows { - if {[info exists env(TEMP)]} { - set opts(tmpdir) [file nativename $env(TEMP)] - } else { - set opts(tmpdir) C:/temp - } - set basercfile "_tkdiff.rc" - # Native look for toolbar - set opts(fancyButtons) 1 - set opts(relief) flat - } -default { - if {[info exists env(TMPDIR)]} { - set opts(tmpdir) $env(TMPDIR) - } else { - set opts(tmpdir) /tmp - } - set basercfile ".tkdiffrc" - # Native look for toolbar - set opts(fancyButtons) 0 - set opts(relief) raised - } -} - -# compute preferences file location. Note that TKDIFFRC can hold either -# a directory or a file, though we document it as being a file name -if {[info exists env(TKDIFFRC)]} { - set rcfile $env(TKDIFFRC) - if {[file isdirectory $rcfile]} { - set rcfile [file join $rcfile $basercfile] - } -} elseif {[info exists env(HOME)]} { - set rcfile [file join $env(HOME) $basercfile] -} else { - set rcfile [file join "/" $basercfile] -} - -# Try to find a pleasing native look for each platform. -# Fonts. -set sysfont [font actual system] -#debug-info "system font: $sysfont" - -# See what the native menu font is -. configure -menu .native -menu .native -set menufont [lindex [.native configure -font] 3] -destroy .native - -# Find out what the tk default is -label .testlbl -text "LABEL" -set labelfont [lindex [.testlbl configure -font] 3] -destroy .testlbl - -text .testtext -set textfont [lindex [.testtext configure -font] 3] -destroy .testtext - -entry .testent -set w(selcolor) [lindex [.testent configure -selectbackground] 4] -set entryfont [lindex [.testent configure -font] 3] -destroy .testent -# the above results in a nearly undistinguishable darker gray for the -# selected color (rh8 with tk 8.3.3-74) "#c3c3c3" -set w(selcolor) "#b03060" - -#debug-info "menufont $menufont" -#debug-info "labelfont $labelfont" -#debug-info "textfont $textfont" -#debug-info "entryfont $entryfont" - -set fs [lindex $textfont 1] -if {$fs == ""} { - # This happens on Windows in tk8.5 - # You get {TkDefaultFont} instead of {fixed 12} or whatever - # Then when you add "bold" to it you have a bad spec - set fa [font actual $textfont] - #puts " actual font: $fa" - set fm [lindex $fa 1] - set fs [lindex $fa 3] - set textfont [list $fm $fs] -} -set font [list $textfont] -set bold [list [concat $textfont bold]] -#debug-info "font: $font" -#debug-info "bold: $bold\n" -option add *Label.font $labelfont userDefault -option add *Button.font $labelfont userDefault -option add *Menu.font $menufont userDefault -option add *Entry.font $entryfont userDefault - -# This makes tk_messageBox use our font. The default tends to be terrible -# no matter what platform -option add *Dialog.msg.font $labelfont userDefault - -# Initialize arrays -array set g { - ancfileset 0 - conflictset 0 - ancfile "" - changefile "tkdiff-change-bars.out" - destroy "" - ignore_event,1 0 - ignore_event,2 0 - ignore_hevent,1 0 - ignore_hevent,2 0 - initOK 0 - mapborder 0 - mapheight 0 - mergefile "" - returnValue 0 - showmerge 0 - started 0 - mergefileset 0 - tempfiles "" - thumbMinHeight 10 - thumbHeight 10 - thumbDeltaY 0 -} - -array set finfo { - f,1 "" - f,2 "" - pth,1 "" - pth,2 "" - revs,1 "" - revs,2 "" - lbl,1 "" - lbl,2 "" - userlbl,1 "" - userlbl,2 "" - title {} - tmp,1 0 - tmp,2 0 -} -set uniq 0 - -# These options may be changed at runtime -array set opts { - autocenter 1 - autoselect 0 - colorcbs 0 - customCode {} - diffcmd "diff" - ignoreblanksopt "-b" - ignoreblanks 0 - editor "" - geometry "80x30" - showcbs 1 - showln 1 - showmap 1 - showlineview 0 - showinline1 0 - showinline2 1 - syncscroll 1 - toolbarIcons 1 - tagcbs 0 - tagln 0 - tagtext 1 - tabstops 8 -} - -# reporting options -array set report { - doSideLeft 0 - doLineNumbersLeft 1 - doChangeMarkersLeft 1 - doTextLeft 1 - doSideRight 1 - doLineNumbersRight 1 - doChangeMarkersRight 1 - doTextRight 1 - filename "tkdiff.out" -} - -if {[string first "color" [winfo visual .]] >= 0} { - # We have color - # (but, let's not go crazy...) - - set colordel Tomato - set colorins PaleGreen - set colorchg DodgerBlue - - array set opts [subst { - textopt "-background white -foreground black -font $font" - currtag "-background Khaki" - difftag "-background gray" - deltag "-background $colordel -font $bold" - instag "-background $colorins -font $bold" - chgtag "-background LightSteelBlue" - overlaptag "-background yellow" - bytetag "-background blue -foreground white" - inlinetag "-background $colorchg -font $bold" - - "-background $colordel -foreground $colorins" - + "-background $colorins -foreground $colordel" - ! "-background $colorchg -foreground $colorchg" - ? "-background yellow -foreground yellow" - mapins "$colorins" - mapdel "$colordel" - mapchg "$colorchg" - }] - -} else { - # Assume only black and white - set bg "black" - array set opts [subst { - textopt "-background white -foreground black -font $font" - currtag "-background black -foreground white" - difftag "-background white -foreground black -font $bold" - deltag "-background black -foreground white" - instag "-background black -foreground white" - chgtag "-background black -foreground white" - overlaptag "-background black -foreground white" - bytetag "-underline 1" - inlinetag "-underline 1" - - "-background black -foreground white" - + "-background black -foreground white" - ! "-background black -foreground white" - ? "-background black -foreground white" - mapins "black" - mapdel "black" - mapchg "black" - }] -} - -# make sure wrapping is turned off. This might piss off a few people, -# but it would screw up the display to have things wrap -set opts(textopt) "$opts(textopt) -wrap none" - -# This proc is used in the rc file -proc define {name value} { - global opts - set opts($name) $value -} - -# Source the rc file, which may override some of the defaults -# Any errors will be reported. Before doing so, we need to define the -# "define" proc, which lets the rc file have a slightly more human-friendly -# interface. Old-style .rc files should still load just fine for now, though -# it ought to be noted new .rc files won't be able to be processed by older -# versions of TkDiff. That shouldn't be a problem. -if {[file exists $rcfile]} { - if {[catch {source $rcfile} error]} { - set startupError [join [list "There was an error in processing your \ - startup file." "\n$g(name) will still run, but some of your \ - preferences" "\nmay not be in effect." "\n\nFile: $rcfile" \ - "\nError: $error"] " "] - } -} - -# a hack to handle older preferences files... -# if the user has a diffopt defined in their rc file, we'll magically -# convert that to diffcmd... -if {[info exists opts(diffopt)]} { - set opts(diffcmd) "diff $opts(diffopt)" -} - -# Work-around for bad font approximations, -# as suggested by Don Libes (libes@nist.gov). -catch {tk scaling [expr {100.0 / 72}]} - -############################################################################### -# -# HERE BEGIN THE PROCS -############################################################################### - -############################################################################### -# Exit with proper code -############################################################################### -proc do-exit {{returncode {}}} { - debug-info "do-exit ($returncode)" - global g - - # we don't particularly care if del-tmp fails. - catch {del-tmp} - if {$returncode == ""} { - set returncode $g(returnValue) - } - # exit with an appropriate return value - exit $returncode -} - -############################################################################### -# Modal error dialog. -############################################################################### -proc do-error {msg} { - global g - - debug-info "do-error ($msg)" - tk_messageBox -message "$msg" -title "$g(name): Error" -icon error -type ok -} - -############################################################################### -# Throw up a modal error dialog or print a message to stderr. For -# Unix we print to stderr and exit if the main window hasn't been -# created, otherwise put up a dialog and throw an exception. -############################################################################### -proc fatal-error {msg} { - debug-info "fatal-error ($msg)" - global g tcl_platform - - if {$g(started)} { - tk_messageBox -title "Error" -icon error -type ok -message $msg - do-exit 2 - } else { - puts stderr $msg - del-tmp - do-exit 2 - } -} - -############################################################################### -# Return the name of a temporary file -############################################################################### -proc tmpfile {n} { - debug-info "tmpfile ($n)" - global g opts - global uniq - set uniq [expr ($uniq + 1) ] - set tmpdir [file nativename $opts(tmpdir)] - set tmpfile [file join $tmpdir "[pid]-$n-$uniq"] - set access [list RDWR CREAT EXCL TRUNC] - set perm 0600 - if {[catch {open $tmpfile $access $perm} fid ]} { - # something went wrong - error "Failed creating temporary file: $fid" - } - close $fid - lappend g(tempfiles) $tmpfile - return $tmpfile -} - -############################################################################### -# Execute a command. -# Returns "$stdout $stderr $exitcode" if exit code != 0 -############################################################################### -proc run-command {cmd} { - debug-info "run-command ($cmd)" - global opts errorCode - - set stderr "" - set exitcode 0 - set errfile [tmpfile "r"] - - set failed [catch "$cmd \"2>$errfile\"" stdout] - # Read stderr output - catch { - set hndl [open "$errfile" r] - set stderr [read $hndl] - close $hndl - } - if {$failed} { - switch -- [lindex $errorCode 0] { - "CHILDSTATUS" { - set exitcode [lindex $errorCode 2] - } - "POSIX" { - if {$stderr == ""} { - set stderr $stdout - } - set exitcode -1 - } - default { - set exitcode -1 - } - } - } - - catch {file delete $errfile} - return [list "$stdout" "$stderr" "$exitcode"] -} - -############################################################################### -# Execute a command. Die if unsuccessful. -############################################################################### -proc die-unless {cmd file} { - #debug-info "die-unless ($cmd $file)" - global opts errorCode - - set file [string trim $file "\""] - set result [run-command "$cmd \">$file\""] - set stdout [lindex $result 0] - set stderr [lindex $result 1] - set exitcode [lindex $result 2] - - if {$exitcode != 0} { - fatal-error "$stderr\n$stdout" - } -} - -############################################################################### -# Filter PVCS output files that have CR-CR-LF end-of-lines -############################################################################### -proc filterCRCRLF {file} { - debug-info "filterCRCLF ($file)" - set outfile [tmpfile 9] - set inp [open $file r] - set out [open $outfile w] - fconfigure $inp -translation binary - fconfigure $out -translation binary - set CR [format %c 13] - while {![eof $inp]} { - set line [gets $inp] - if {[string length $line] && ![eof $inp]} { - regsub -all "$CR$CR" $line $CR line - puts $out $line - } - } - close $inp - close $out - file rename -force $outfile $file -} - -############################################################################### -# Return the smallest of two values -############################################################################### -proc min {a b} { - return [expr {$a < $b ? $a : $b}] -} - -############################################################################### -# Return the largest of two values -############################################################################### -proc max {a b} { - return [expr {$a > $b ? $a : $b}] -} - -############################################################################### -# Toggle change bars -############################################################################### -proc do-show-changebars {{show {}}} { - debug-info "do-show-changebars ($show)" - global opts - global w - - if {$show != {}} { - set opts(showcbs) $show - } - - if {$opts(showcbs)} { - grid $w(LeftCB) -row 0 -column 2 -sticky ns - grid $w(RightCB) -row 0 -column 1 -sticky ns - } else { - grid forget $w(LeftCB) - grid forget $w(RightCB) - } -} - -############################################################################### -# Toggle ignore white spaces -############################################################################### -proc do-show-ignoreblanks {{showIgn {}}} { - global opts - global finfo - - if {$showIgn != {}} { - set opts(ignoreblanks) $showIgn - } - if {$finfo(pth,1) != {} && $finfo(pth,2) != {}} { - recompute-diff - } -} - -############################################################################### -# Toggle line numbers. -############################################################################### -proc do-show-linenumbers {{showLn {}}} { - global opts - global w - - if {$showLn != {}} { - set opts(showln) $showLn - } - - if {$opts(showln)} { - grid $w(LeftInfo) -row 0 -column 1 -sticky nsew - grid $w(RightInfo) -row 0 -column 0 -sticky nsew - } else { - grid forget $w(LeftInfo) - grid forget $w(RightInfo) - } -} - -############################################################################### -# Show line numbers in info windows -############################################################################### -proc draw-line-numbers {} { - global g - global w - - $w(LeftInfo) configure -state normal - $w(RightInfo) configure -state normal - $w(LeftCB) configure -state normal - $w(RightCB) configure -state normal - - set lines(Left) [lindex [split [$w(LeftText) index end-1lines] .] 0] - set lines(Right) [lindex [split [$w(RightText) index end-1lines] .] 0] - - # Smallest line count - set minlines [min $lines(Left) $lines(Right)] - - # cache all the blank lines for the info and cb windows, and do - # one big insert after we're done. This seems to be much quicker - # than inserting them in the widgets one line at a time. - set linestuff {} - set cbstuff {} - for {set i 1} {$i < $minlines} {incr i} { - append linestuff "$i\n" - append cbstuff " \n" ;# for now, just put in place holders... - } - - $w(LeftInfo) insert end $linestuff - $w(RightInfo) insert end $linestuff - $w(LeftCB) insert end $cbstuff - $w(RightCB) insert end $cbstuff - - # Insert remaining line numbers. We'll cache the stuff to be - # inserted so we can do just one call in to the widget. This - # should be much faster, relatively speaking, then inserting - # data one line at a time. - foreach mod {Left Right} { - set linestuff {} - set cbstuff {} - for {set i $minlines} {$i < $lines($mod)} {incr i} { - append linestuff "$i\n" - append cbstuff " \n" ;# for now, just put in place holders... - } - $w(${mod}Info) insert end $linestuff - $w(${mod}CB) insert end $cbstuff - } - - $w(LeftCB) configure -state disabled - $w(RightCB) configure -state disabled - - $w(LeftInfo) configure -state disabled - $w(RightInfo) configure -state disabled -} - -############################################################################### -# Pop up a window for file merge. -############################################################################### -proc popup-merge {{writeproc merge-write-file}} { - debug-info "popup-merge ($writeproc)" - global g - global w - - if {$g(mergefileset)} { - $writeproc - return - } - - set types { - {{Text Files} {.txt}} - {{All Files} {*}} - } - - set path [tk_getSaveFile -defaultextension "" -filetypes $types \ - -initialfile [file nativename $g(mergefile)]] - - if {[string length $path] > 0} { - set g(mergefile) $path - $writeproc - } -} - -############################################################################### -# Split a file containing CVS conflict markers into two temporary files -# name Name of file containing conflict markers -# Returns the names of the two temporary files and the names of the -# files that were merged -############################################################################### -proc split-conflictfile {name} { - debug-info "conflicts ($name)" - global g opts - - set first ${name}.1 - set second ${name}.2 - - set temp1 [tmpfile 1] - set temp2 [tmpfile 2] - - if {[catch {set input [open $name r]}]} { - fatal-error "Couldn't open file '$name'" - } - set first [open $temp1 w] - set second [open $temp2 w] - - set firstname "" - set secondname "" - set output 3 - - set firstMatch "" - set secondMatch "" - set thirdMatch "" - - while {[gets $input line] >= 0} { - if {$firstMatch == ""} { - if {[regexp {^<<<<<<<* +(.*)} $line]} { - set firstMatch {^<<<<<<<* +(.*)} - set secondMatch {^=======*} - set thirdMatch {^>>>>>>>* +(.*)} - } elseif {[regexp {^>>>>>>>* +(.*)} $line]} { - set firstMatch {^>>>>>>>* +(.*)} - set secondMatch {^<<<<<<<* +(.*)} - set thirdMatch {^=======*} - } - } - if {$firstMatch != ""} { - if {[regexp $firstMatch $line]} { - set output 2 - if {$secondname == ""} { - regexp $firstMatch $line all secondname - } - } elseif {[regexp $secondMatch $line]} { - set output 1 - if {$firstname == ""} { - regexp $secondMatch $line all firstname - } - } elseif {[regexp $thirdMatch $line]} { - set output 3 - if {$firstname == ""} { - regexp $thirdMatch $line all firstname - } - } else { - if {$output & 1} { - puts $first $line - } - if {$output & 2} { - puts $second $line - } - } - } else { - puts $first $line - puts $second $line - } - } - close $input - close $first - close $second - - if {$firstname == ""} { - set firstname "old" - } - if {$secondname == ""} { - set secondname "new" - } - - return "{$temp1} {$temp2} {$firstname} {$secondname}" -} - -############################################################################### -# Get a revision of a file -# f file name -# index index in finfo array -# r revision, "" for head revision -############################################################################### -proc get-file-rev {f index {r ""}} { - debug-info "get-file-rev ($f $index \"$r\")" - global finfo - global opts - global tcl_platform - - if {"$r" == ""} { - set rev "HEAD" - set acrev "HEAD" - set acopt "" - set cvsopt "" - set svnopt "" - set rcsopt "" - set sccsopt "" - set bkopt "" - set pvcsopt "" - set p4file "$f" - } else { - set rev "r$r" - set acrev "\"$r\"" - set acopt "-v \"$r\"" - set cvsopt "-r $r" - set svnopt "-r $r" - set rcsopt "$r" - set sccsopt "-r$r" - set bkopt "-r$r" - set pvcsopt "-r$r" - set p4file "$f#$r" - } - - set finfo(pth,$index) [tmpfile $index] - set finfo(tmp,$index) 1 - - # NB: it would probably be a Good Thing to move the definition - # of the various command to exec, to the preferences dialog. - - regsub -all {\$} $f {\$} f - set dirname [file dirname $f] - set tailname [file tail $f] - - debug-info " $f" - # For CVS, if it isn't checked out there is neither a CVS nor RCS - # directory. It will however have a ,v suffix just like rcs. - # There is not necessarily a RCS directory for RCS, either. The file - # always has a ,v suffix. - - if {[file isdirectory [file join $dirname CVS]]} { - set cmd "cvs" - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - set finfo(lbl,$index) "$f (CVS $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - die-unless "exec $cmd update -p $cvsopt \"$f\"" "\"$finfo(pth,$index)\"" - } elseif {[file isdirectory [file join $dirname .svn]]} { - set cmd "svn" - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - if {"$r" == "" || "$rev" == "rBASE"} { - set finfo(lbl,$index) "$f (SVN BASE)" - debug-info " Setting lbl $finfo(lbl,$index)" - die-unless "exec cat \"$dirname/.svn/text-base/$tailname.svn-base\"" \ - $finfo(pth,$index) - } else { - set finfo(lbl,$index) "$f (SVN $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - die-unless "exec $cmd cat $svnopt \"$f\"" $finfo(pth,$index) - } - } elseif {[regexp {://} $f]} { - # Subversion command can have the form - # svn diff OLD-URL[@OLDREV] NEW-URL[@NEWREV] - if {![regsub {^.*@} $f {} rev]} { - set rev "HEAD" - } - regsub {@\d+$} $f {} path - set finfo(lbl,$index) "$f" - set cmd "svn" - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - if {"$rev" == ""} { - set command "$cmd cat $path" - } else { - set command "$cmd cat -r$rev $path" - } - die-unless "exec $command" $finfo(pth,$index) - } elseif {[file isdirectory [file join $dirname SCCS]]} { - if {[sccs-is-bk]} { - set cmd "bk" - set opt $bkopt - set finfo(lbl,$index) "$f (bitkeeper $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - } else { - set finfo(lbl,$index) "$f (SCCS $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - set opt $sccsopt - set cmd "sccs" - } - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - die-unless "exec $cmd get -p $opt \"$f\"" "\"$finfo(pth,$index)\"" - } elseif {[file isdirectory [file join $dirname RCS]]} { - set cmd "co" - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - set finfo(lbl,$index) "$f (RCS $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - die-unless "exec $cmd -p$rcsopt \"$f\"" "\"$finfo(pth,$index)\"" - } elseif {[file exists [file join $dirname $tailname,v]]} { - set cmd "co" - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - set finfo(lbl,$index) "$f (RCS $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - die-unless "exec $cmd -p$rcsopt \"$f\"" \""$finfo(pth,$index)\"" - } elseif {[file exists [file join $dirname vcs.cfg]]} { - set cmd "get" - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - set finfo(lbl,$index) "$f (PVCS $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - die-unless "exec $cmd -p $pvcsopt \"$f\"" "\"$finfo(pth,$index)\"" - filterCRCRLF $finfo(pth,$index) - } elseif {[info exists ::env(P4CLIENT)] || [info exists ::env(P4CONFIG)]} { - set cmd "p4" - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - set finfo(lbl,$index) "$f (Perforce $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - die-unless "exec $cmd print -q \"$p4file\"" "\"$finfo(pth,$index)\"" - } elseif {[info exists ::env(ACCUREV_BIN)]} { - set cmd "accurev" - if {$::tcl_platform(platform) == "windows"} { - append cmd ".exe" - } - set finfo(lbl,$index) "$f ($acrev)" - debug-info " Setting lbl $finfo(lbl,$index)" - die-unless "exec $cmd cat $acopt \"$f\"" "\"$finfo(pth,$index)\"" - } elseif {[info exists ::env(CLEARCASE_ROOT)]} { - set cmd "cleartool" - set finfo(lbl,$index) "$f (ClearCase $rev)" - debug-info " Setting lbl $finfo(lbl,$index)" - catch {exec $cmd ls -s $f} ctls - # get the path name to file minus the revision info - # (either CHECKEDOUT or a number) - if {![regexp {(\S+)/([^/]+)$} $ctls dummy path checkedout]} { - puts "Couldn't parse ct ls output '$ctls'" - exit - } - catch {exec $cmd lshistory -last 50 $f} ctlshistory - set lines [split $ctlshistory "\n"] - set predecessor "" - # find the previous version - if {$checkedout == "CHECKEDOUT" || $checkedout == 0} { - if {$checkedout == 0} { - set path [file dirname $path] - } - set pattern "create version \"($path/\[^/\]+)\"" - } else { - incr checkedout -1 - set pattern "create version \"($path/$checkedout)\"" - } - # search the history of the file for the latest version on our branch - foreach l $lines { - if {[regexp $pattern $l dummy predecessor]} { - break - } - } - if {$predecessor != ""} { - set finfo(pth,$index) $predecessor - debug-info " Setting lbl from predecessor $finfo(lbl,$index)" - } else { - puts "Couldn't deal with $f, exiting..." - exit - } - } else { - fatal-error "File '$f' is not part of a revision control system" - } - # Header above each file - if user has specified -L, override - #debug-info " $finfo(lbl,$index)" - if {$finfo(userlbl,$index) != {}} { - set finfo(lbl,$index) $finfo(userlbl,$index) - debug-info " User label: $finfo(lbl,$index)" - } -} - -proc sccs-is-bk {} { - set cmd [auto_execok "bk"] - set result 0 - if {[string length $cmd] > 0} { - if {![catch {exec bk root} error]} { - set result 1 - } - } - return $result -} - -############################################################################### -# Setup ordinary file -# f file name -# index index in finfo array -############################################################################### -proc get-file {f index} { - debug-info "get-file ($f $index)" - global finfo - - #set finfo(f,$index) $f - if {[file exists $f] != 1} { - fatal-error "File '$f' does not exist" - return 1 - } - if {[file isdirectory $f]} { - fatal-error "'$f' is a directory" - return 1 - } - - # Header above each file - use filename unless - # user has specified one with -L - set finfo(lbl,$index) "$f" - debug-info " Setting lbl $finfo(lbl,$index)" - if {$finfo(userlbl,$index) != {}} { - set finfo(lbl,$index) $finfo(userlbl,$index) - debug-info " User label: $finfo(lbl,$index)" - } - set finfo(pth,$index) "$f" - set finfo(tmp,$index) 0 - return 0 -} - -############################################################################### -# Read the commandline -############################################################################### -proc commandline {} { - debug-info "commandline" - global argv - global argc - debug-info " argv: $argv" - global finfo - global opts - global g - - set g(initOK) 0 - set argindex 0 - set revs 0 - set pths 0 - set lbls 0 - - # Loop through argv, storing revision args in rev and file args in - # finfo. revs and pths are counters. - while {$argindex < $argc} { - set arg [lindex $argv $argindex] - switch -regexp -- $arg { - "^-h" - - "^--help" { - do-usage cline - exit 0 - } - "^-a$" { - incr argindex - set g(ancfile) [lindex $argv $argindex] - } - "^-a.*" { - set g(ancfile) [string range $arg 2 end] - } - "^-v$" - - "^-r$" { - incr argindex - incr revs - set finfo(revs,$revs) [lindex $argv $argindex] - } - "^-v.*" - - "^-r.*" { - incr revs - set finfo(revs,$revs) [string range $arg 2 end] - } - "^-L$" { - incr argindex - incr lbls - set finfo(userlbl,$lbls) [lindex $argv $argindex] - } - "^-L.*" { - incr lbls - set finfo(userlbl,$lbls) [string range $arg 2 end] - } - "^-conflict$" { - set g(conflictset) 1 - } - "^-o$" { - incr argindex - set g(mergefile) [lindex $argv $argindex] - } - "^-o.*" { - set g(mergefile) [string range $arg 2 end] - } - "^-u$" { - # Ignore flag from "svn diff --diff-cmd=tkdiff" - } - "^-psn" { - # Ignore the Carbon Process Serial Number - set argv [lreplace $argv $argindex $argindex] - incr argc -1 - incr argindex - } - "^-" { - append opts(diffcmd) " $arg " - } - default { - incr pths - set finfo(pth,$pths) $arg - set finfo(f,$pths) $arg - } - } - incr argindex - } - - # Add our counters to the global array - # Now check how many revision and file args we have. - debug-info " $pths files, $revs revisions" - # Maybe adjustment is needed - if {$revs == 1 && $pths == 0} { - # tkdiff -r FILE; same as tkdiff FILE - set finfo(pths,1) $finfo(revs,1) - set finfo(f,1) $finfo(revs,1) - incr pths 1 - incr revs -1 - unset finfo(revs,1) - } elseif {$revs == 2 && $pths == 0} { - # tkdiff -rREV -r FILE; same as tkdiff -rREV FILE - set finfo(pths,1) $finfo(revs,2) - set finfo(f,1) $finfo(revs,2) - incr pths 1 - incr revs -1 - unset finfo(revs,2) - } - # What have we got now? - debug-info " $pths files, $revs revisions" - if {$revs == 0 && $pths == 0} { - # Return "empty" flag, and we'll do a pop-up - return 1 - } elseif {$revs > 1 && $pths != 1} { - puts stderr "Error: you specified $pths file(s) and $revs revision(s)" - do-usage cline - exit 1 - } - - if {$g(mergefile) != ""} { - set g(mergefileset) 1 - } - return 0 -} - -############################################################################### -# Process the arguments, whether from the command line or from the dialog -############################################################################### -proc assemble-args {} { - debug-info "assemble-args" - global finfo - global opts - global g - - if {$g(ancfile) != ""} { - set g(ancfileset) 1 - } - debug-info " conflict: $g(conflictset)" - debug-info " ancestor: $g(ancfileset) $g(ancfile)" - debug-info " mergefile set: $g(mergefileset) $g(mergefile)" - debug-info " diff command: $opts(diffcmd) " - - # Count up how many files and revs we got from the GUI or commandline - set pths 0 - foreach p [array names finfo f,*] { - if {$finfo($p) != ""} { - incr pths - } - } - set revs 0 - foreach r [array names finfo revs,*] { - if {$finfo($r) != ""} { - incr revs - } - } - - debug-info " $pths files, $revs revisions" - if {$revs == 0 && $pths == 0} { - return - } - if {$g(conflictset)} { - if {$revs == 0 && $pths == 1} { - ############################################################ - # tkdiff -conflict FILE - ############################################################ - set files [split-conflictfile "$finfo(f,1)"] - if {[get-file [lindex "$files" 0] 1]} {return} - if {[get-file [lindex "$files" 1] 2]} {return} - # A conflict file may come from merge, cvs, or vmrg. The - # names of the files/revisions depend on how it was made and - # are taken from the <<<<<<< and >>>>>>> lines inside it. - set finfo(lbl,1) [lindex "$files" 2] - set finfo(lbl,2) [lindex "$files" 3] - } else { - fatal-error "Usage: tkdiff -conflict FILE" - } - } else { - if {$revs == 2 && $pths == 1} { - ############################################################ - # tkdiff -rREV1 -rREV2 FILE - ############################################################ - set f $finfo(f,1) - get-file-rev "$f" 1 "$finfo(revs,1)" - get-file-rev "$f" 2 "$finfo(revs,2)" - - } elseif {$revs == 1 && $pths == 1} { - ############################################################ - # tkdiff -rREV FILE - ############################################################ - set f $finfo(f,1) - get-file-rev "$f" 1 "$finfo(revs,1)" - if {[get-file "$f" 2]} {return} - - } elseif {$revs == 0 && $pths == 2} { - ############################################################ - # tkdiff FILE1 FILE2 - ############################################################ - set f1 $finfo(f,1) - set f2 $finfo(f,2) - if {[file isdirectory $f1] && [file isdirectory $f2]} { - fatal-error "Cannot diff two directories" - } - - if {[file isdirectory $f1]} { - set f1 [file join $f1 [file tail $f2]] - } elseif {[file isdirectory $f2]} { - set f2 [file join $f2 [file tail $f1]] - } - - # Maybe they're Subversion URL paths, not local files - if {[regexp {://} $f1]} { - get-file-rev "$f1" 1 - } else { - if {[get-file "$f1" 1]} {return} - } - if {[regexp {://} $f2]} { - get-file-rev "$f2" 2 - } else { - if {[get-file "$f2" 2]} {return} - } - - - } elseif {$revs == 0 && $pths == 1} { - ############################################################ - # tkdiff FILE - ############################################################ - set f $finfo(f,1) - get-file-rev "$f" 1 - if {[get-file "$f" 2]} {return} - - } else { - do-error "Error: you specified $pths file(s) and $revs revision(s)" - do-usage gui - tkwait window .usage - return 1 - } - } - - set finfo(title) "[file tail $finfo(lbl,1)] vs. [file tail $finfo(lbl,2)]" - debug-info " Setting title $finfo(title)" - set rootname [file rootname $finfo(pth,1)] - # set path [file dirname $finfo(pth,1)] - set path [pwd] - set suffix [file extension $finfo(pth,1)] - if {! $g(mergefileset)} { - set g(mergefile) [file join $path "${rootname}-merge$suffix"] - } - set g(initOK) 1 - foreach inf [lsort [array names finfo]] { - debug-info " $inf: $finfo($inf)" - } - debug-info " $revs revs $pths files" - - wm title . "$finfo(title) - $g(name) $g(version)" - return 0 -} - -############################################################################### -# Set up the display -############################################################################### -proc create-display {} { - debug-info "create-display" - - global g opts bg tk_version - global w - global tmpopts - - # these are the four major areas of the GUI: - # menubar - the menubar (duh) - # toolbar - the toolbar (duh, again) - # client - the area with the text widgets and the graphical map - # status us - a bottom status line - - # this block of destroys is only for stand-alone testing of - # the GUI code, and can be blown away (or not, if we want to - # be able to call this routine to recreate the display...) - catch { - destroy .menubar - destroy .toolbar - destroy .client - destroy .map - destroy .status - } - - # create the top level frames and store them in a global - # array.. - set w(client) .client - set w(menubar) .menubar - set w(toolbar) .toolbar - set w(status) .status - - # other random windows... - set w(preferences) .pref - set w(findDialog) .findDialog - set w(popupMenu) .popupMenu - - # now, simply build all the pieces - build-menubar - build-toolbar - build-client - build-status - build-popupMenu - - frame .separator1 -height 2 -borderwidth 2 -relief groove - frame .separator2 -height 2 -borderwidth 2 -relief groove - - # ... and fit it all together... - . configure -menu $w(menubar) - pack $w(toolbar) -side top -fill x -expand n - pack .separator1 -side top -fill x -expand n - - pack $w(client) -side top -fill both -expand y - pack .separator2 -side top -fill x -expand n - - pack $w(status) -side bottom -fill x -expand n - - # apply user preferences by calling the proc that gets - # called when the user presses "Apply" from the preferences - # window. That proc uses a global variable named "tmpopts" - # which should have the values from the dialog. Since we - # aren't using the dialog, we need to populate this array - # manually - foreach key [array names opts] { - set ::tmpopts($key) $opts($key) - } - apply 0 - - # Make sure temporary files get deleted - #bind . {del-tmp} - - # other misc. bindings - common-navigation $w(LeftText) $w(LeftInfo) $w(LeftCB) $w(RightText) \ - $w(RightInfo) $w(RightCB) - - # normally, keyboard traversal using tab and shift-tab isn't - # enabled for text widgets, since the default binding for these - # keys is to actually insert the tab character. Because all of - # our text widgets are for display only, let's redefine the - # default binding so the global and bindings - # are used. - bind Text {continue} - bind Text {continue} - - # if the user toggles scrollbar syncing, we want to make sure - # they sync up immediately - trace variable opts(syncscroll) w toggleSyncScroll - wm deiconify . - focus -force $w(RightText) - update idletasks - # Need this to make the pane-resizing behave - grid propagate $w(client) f -} - -############################################################################### -# when the user changes the "sync scrollbars" option, we want to -# sync up the left scrollbar with the right if they turn the option on -############################################################################### -proc toggleSyncScroll {args} { - global opts - global w - - if {$opts(syncscroll) == 1} { - eval vscroll-sync {{}} 2 [$w(RightText) yview] - } -} - -############################################################################### -# show the popup menu, optionally changing some of the entries based on -# where the user clicked -############################################################################### -proc show-popupMenu {x y} { - global w - global g - - set window [winfo containing $x $y] - if {[winfo class $window] == "Text"} { - $w(popupMenu) entryconfigure "Find..." -state normal - $w(popupMenu) entryconfigure "Find Nearest*" -state normal - $w(popupMenu) entryconfigure "Edit*" -state normal - - if {$window == $w(LeftText) || $window == $w(LeftInfo) || $window == \ - $w(LeftCB)} { - $w(popupMenu) configure -title "File 1" - set g(activeWindow) $w(LeftText) - } else { - $w(popupMenu) configure -title "File 2" - set g(activeWindow) $w(RightText) - } - - } else { - $w(popupMenu) entryconfigure "Find..." -state disabled - $w(popupMenu) entryconfigure "Find Nearest*" -state disabled - $w(popupMenu) entryconfigure "Edit*" -state disabled - } - tk_popup $w(popupMenu) $x $y -} - -############################################################################### -# build the right-click popup menu -############################################################################### -proc build-popupMenu {} { - debug-info "build-popupMenu" - global w g - - # this routine assumes the other windows already exist... - menu $w(popupMenu) - foreach win [list LeftText RightText LeftInfo RightInfo LeftCB RightCB \ - mapCanvas] { - bind $w($win) <3> {show-popupMenu %X %Y} - } - - set m $w(popupMenu) - $m add command -label "First Diff" -underline 0 -command [list popupMenu \ - first] -accelerator "f" - $m add command -label "Previous Diff" -underline 0 -command \ - [list popupMenu previous] -accelerator "p" - $m add command -label "Center Current Diff" -underline 0 -command \ - [list popupMenu center] -accelerator "c" - $m add command -label "Next Diff" -underline 0 -command [list popupMenu \ - next] -accelerator "n" - $m add command -label "Last Diff" -underline 0 -command [list popupMenu \ - last] -accelerator "l" - $m add separator - $m add command -label "Find Nearest Diff" -underline 0 -command \ - [list popupMenu nearest] -accelerator "Double-Click" - $m add separator - $m add command -label "Find..." -underline 0 -command [list popupMenu find] - $m add command -label "Edit" -underline 0 -command [list popupMenu edit] -} - -############################################################################### -# handle popup menu commands -############################################################################### -proc popupMenu {command args} { - debug-info "popupMenu ($command $args)" - global g - global w - - switch -- $command { - center { - center - } - edit { - do-edit - } - find { - do-find - } - first { - move first - } - last { - move last - } - next { - move 1 - } - previous { - move -1 - } - nearest { - moveNearest $g(activeWindow) xy [winfo pointerx $g(activeWindow)] \ - [winfo pointery $g(activeWindow)] - } - } -} - -# Resize the text windows relative to each other. The 8.4 method works -# much better. -proc pane_drag {win x} { - global w - global finfo - global tk_version - - set relX [expr $x - [winfo rootx $win]] - set maxX [winfo width $win] - set frac [expr int((double($relX) / $maxX) * 100)] - if {$tk_version < 8.4} { - if {$frac < 15} { set frac 15 } - if {$frac > 85} { set frac 85 } - #debug-info "frac $frac" - set L $frac - set R [expr 100 - $frac] - .client.leftlabel configure -width [expr $L * 2] - .client.rightlabel configure -width [expr $R * 2] - } else { - if {$frac < 5} { set frac 5 } - if {$frac > 95} { set frac 95 } - #debug-info "frac $frac" - set L $frac - set R [expr 100 - $frac] - grid columnconfigure $win 0 -weight $L - grid columnconfigure $win 2 -weight $R - } - #debug-info " new: $L $R" -} - -############################################################################### -# build the main client display (the text widgets, scrollbars, that -# sort of fluff) -############################################################################### -proc build-client {} { - debug-info "build-client" - global g - global w - global opts - global map - global tk_version - - frame $w(client) -bd 2 -relief flat - - # set up global variables to reference the widgets, so - # we don't have to use hardcoded widget paths elsewhere - # in the code - # - # Text - holds the text of the file - # Info - sort-of "invisible" text widget which is kept in sync - # with the text widget and holds line numbers - # CB - contains changebars or status or something like that... - # VSB - vertical scrollbar - # HSB - horizontal scrollbar - # Label - label to hold the name of the file - set w(LeftText) $w(client).left.text - set w(LeftInfo) $w(client).left.info - set w(LeftCB) $w(client).left.changeBars - set w(LeftVSB) $w(client).left.vsb - set w(LeftHSB) $w(client).left.hsb - set w(LeftLabel) $w(client).leftlabel - - set w(RightText) $w(client).right.text - set w(RightInfo) $w(client).right.info - set w(RightCB) $w(client).right.changeBars - set w(RightVSB) $w(client).right.vsb - set w(RightHSB) $w(client).right.hsb - set w(RightLabel) $w(client).rightlabel - - set w(BottomText) $w(client).bottomtext - - set w(map) $w(client).map - set w(mapCanvas) $w(map).canvas - - # these don't need to be global... - set leftFrame $w(client).left - set rightFrame $w(client).right - - # we'll create each widget twice; once for the left side - # and once for the right. - debug-info " Assigning labels to headers" - scan $opts(geometry) "%dx%d" width height - label $w(LeftLabel) -bd 1 -relief flat -textvariable finfo(lbl,1) -width $width - label $w(RightLabel) -bd 1 -relief flat -textvariable finfo(lbl,2) -width $width - - # this holds the text widgets and the scrollbars. The reason - # for the frame is purely for aesthetics. It just looks - # nicer, IMHO, to "embed" the scrollbars within the text - # widget - frame $leftFrame -bd 1 -relief sunken - - frame $rightFrame -bd 1 -relief sunken - - scrollbar $w(LeftHSB) -borderwidth 1 -orient horizontal -command \ - [list $w(LeftText) xview] - - scrollbar $w(RightHSB) -borderwidth 1 -orient horizontal -command \ - [list $w(RightText) xview] - - scrollbar $w(LeftVSB) -borderwidth 1 -orient vertical -command \ - [list $w(LeftText) yview] - - scrollbar $w(RightVSB) -borderwidth 1 -orient vertical -command \ - [list $w(RightText) yview] - - - text $w(LeftText) -padx 0 -wrap none -width $width -height $height \ - -borderwidth 0 -setgrid 1 -yscrollcommand [list vscroll-sync \ - "$w(LeftInfo) $w(LeftCB)" 1] -xscrollcommand [list hscroll-sync 1] - - text $w(RightText) -padx 0 -wrap none -width $width -height $height \ - -borderwidth 0 -setgrid 1 -yscrollcommand [list vscroll-sync \ - "$w(RightInfo) $w(RightCB)" 2] -xscrollcommand [list hscroll-sync 2] - - text $w(LeftInfo) -height 0 -padx 0 -width 6 -borderwidth 0 -setgrid 1 \ - -yscrollcommand [list vscroll-sync "$w(LeftCB) $w(LeftText)" 1] - - text $w(RightInfo) -height 0 -padx 0 -width 6 -borderwidth 0 -setgrid 1 \ - -yscrollcommand [list vscroll-sync "$w(RightCB) $w(RightText)" 2] - - # each and every line in a text window will have a corresponding line - # in this widget. And each line in this widget will be composed of - # a single character (either "+", "-" or "!" for insertion, deletion - # or change, respectively - text $w(LeftCB) -height 0 -padx 0 -highlightthickness 0 -wrap none \ - -foreground white -width 1 -borderwidth 0 -yscrollcommand \ - [list vscroll-sync "$w(LeftInfo) $w(LeftText)" 1] - - text $w(RightCB) -height 0 -padx 0 -highlightthickness 0 -wrap none \ - -background white -foreground white -width 1 -borderwidth 0 \ - -yscrollcommand [list vscroll-sync "$w(RightInfo) $w(RightText)" 2] - - # this widget is the two line display showing the current line, so - # one can compare character by character if necessary. - text $w(BottomText) -wrap none -borderwidth 1 -height 2 -width 0 - - # this is how we highlight bytes that are different... - # the bottom window (lineview) uses reverse video to highlight - # diffs, so we need to figure out what reverse video is, and - # define the tag appropriately - eval $w(BottomText) tag configure diff $opts(bytetag) - - # Set up text tags for the 'current diff' (the one chosen by the 'next' - # and 'prev' buttons) and any ol' diff region. All diff regions are - # given the 'diff' tag initially... As 'next' and 'prev' are \ - pressed, - # to scroll through the differences, one particular diff region is - # always chosen as the 'current diff', and is set off from the others - # via the 'diff' tag -- in particular, so that it's obvious which diffs - # in the left and right-hand text widgets match. - - foreach widget [list $w(LeftText) $w(LeftInfo) $w(LeftCB) $w(RightText) \ - $w(RightInfo) $w(RightCB)] { - eval "$widget configure $opts(textopt)" - foreach tag {difftag currtag inlinetag deltag instag chgtag \ - overlaptag + - ! ?} { - eval "$widget tag configure $tag $opts($tag)" - } - } - - # adjust the tag priorities a bit... - foreach window [list LeftText RightText LeftCB RightCB LeftInfo RightInfo] { - $w($window) tag raise deltag currtag - $w($window) tag raise chgtag currtag - $w($window) tag raise instag currtag - $w($window) tag raise currtag difftag - $w($window) tag raise inlinetag - } - - # these tags are specific to change bars - foreach widget [list $w(LeftCB) $w(RightCB)] { - eval "$widget tag configure + $opts(+)" - eval "$widget tag configure - $opts(-)" - eval "$widget tag configure ! $opts(!)" - eval "$widget tag configure ? $opts(?)" - } - - # build the map... - # we want the map to be the same width as a scrollbar, so we'll - # steal some information from one of the scrollbars we just - # created... - set cwidth [winfo reqwidth $w(LeftVSB)] - set ht [$w(LeftVSB) cget -highlightthickness] - set cwidth [expr {$cwidth -($ht*2)}] - set color [$w(LeftVSB) cget -troughcolor] - - set map [frame $w(client).map -bd 1 -relief sunken -takefocus 0 \ - -highlightthickness 0] - - # now for the real map... - image create photo map - - canvas $w(mapCanvas) -width [expr {$cwidth + 1}] \ - -yscrollcommand map-resize -background $color -borderwidth 0 \ - -relief sunken -highlightthickness 0 - $w(mapCanvas) create image 1 1 -image map -anchor nw - pack $w(mapCanvas) -side top -fill both -expand y - - # I'm not too pleased with these bindings -- it results in a rather - # jerky, cpu-intensive maneuver since with each move of the mouse - # we are finding and tagging the nearest diff. But, what *should* - # it do? - # - # I think what I *want* it to do is update the combobox and status - # bar so the user can see where in the scheme of things they are, - # but not actually select anything until they release the mouse. - bind $w(mapCanvas) [list handleMapEvent B1-Press %y] - bind $w(mapCanvas) [list handleMapEvent B1-Motion %y] - bind $w(mapCanvas) [list handleMapEvent B1-Release %y] - - # this is a grip for resizing the sides relative to each other. - button $w(client).grip -borderwidth 3 -relief raised \ - -cursor sb_h_double_arrow -image resize - bind $w(client).grip {pane_drag $w(client) %X} - - # use grid to manage the widgets in the left side frame - grid $w(LeftVSB) -row 0 -column 0 -sticky ns - grid $w(LeftInfo) -row 0 -column 1 -sticky nsew - grid $w(LeftCB) -row 0 -column 2 -sticky ns - grid $w(LeftText) -row 0 -column 3 -sticky nsew - grid $w(LeftHSB) -row 1 -column 1 -sticky ew -columnspan 3 - - grid rowconfigure $leftFrame 0 -weight 1 - grid rowconfigure $leftFrame 1 -weight 0 - - grid columnconfigure $leftFrame 0 -weight 0 - grid columnconfigure $leftFrame 1 -weight 0 - grid columnconfigure $leftFrame 2 -weight 0 - grid columnconfigure $leftFrame 3 -weight 1 - - # likewise for the right... - grid $w(RightVSB) -row 0 -column 3 -sticky ns - grid $w(RightInfo) -row 0 -column 0 -sticky nsew - grid $w(RightCB) -row 0 -column 1 -sticky ns - grid $w(RightText) -row 0 -column 2 -sticky nsew - grid $w(RightHSB) -row 1 -column 0 -sticky ew -columnspan 3 - - grid rowconfigure $rightFrame 0 -weight 1 - grid rowconfigure $rightFrame 1 -weight 0 - - grid columnconfigure $rightFrame 0 -weight 0 - grid columnconfigure $rightFrame 1 -weight 0 - grid columnconfigure $rightFrame 2 -weight 1 - grid columnconfigure $rightFrame 3 -weight 0 - - # use grid to manage the labels, frames and map. We're going to - # toss in an extra row just for the benefit of our dummy frame. - # the intent is that the dummy frame will match the height of - # the horizontal scrollbars so the map stops at the right place... - grid $w(LeftLabel) -row 0 -column 0 -sticky ew - grid $w(RightLabel) -row 0 -column 2 -sticky ew - grid $leftFrame -row 1 -column 0 -sticky nsew -rowspan 2 - grid $map -row 1 -column 1 -stick ns - grid $w(client).grip -row 2 -column 1 - grid $rightFrame -row 1 -column 2 -sticky nsew -rowspan 2 - - grid rowconfigure $w(client) 0 -weight 0 - grid rowconfigure $w(client) 1 -weight 1 - grid rowconfigure $w(client) 2 -weight 0 - grid rowconfigure $w(client) 3 -weight 0 - - if {$tk_version < 8.4} { - grid columnconfigure $w(client) 0 -weight 1 - grid columnconfigure $w(client) 2 -weight 1 - } else { - grid columnconfigure $w(client) 0 -weight 100 -uniform a - grid columnconfigure $w(client) 2 -weight 100 -uniform a - } - grid columnconfigure $w(client) 1 -weight 0 - - # this adjusts the variable g(activeWindow) to be whatever text - # widget has the focus... - bind $w(LeftText) <1> {set g(activeWindow) $w(LeftText)} - bind $w(RightText) <1> {set g(activeWindow) $w(RightText)} - - set g(activeWindow) $w(LeftText) ;# establish a default - - rename $w(RightText) $w(RightText)_ - rename $w(LeftText) $w(LeftText)_ - - proc $w(RightText) {command args} $::text_widget_proc - proc $w(LeftText) {command args} $::text_widget_proc -} - -############################################################################### -# Functionality: Inline diffs -# Athr: Michael D. Beynon : mdb - beynon@yahoo.com -# Date: 04/08/2003 : mdb - Added inline character diffs. -# 04/16/2003 : mdb - Rewrote longest-common-substring to be faster. -# - Added byte-by-byte algorithm. -# -# the recursive version is derived from the Ratcliff/Obershelp pattern -# recognition algorithm (Dr Dobbs July 1988), where we search for a -# longest common substring between two strings. This match is used as -# an archor, around which we recursively do the same for the two left -# and two right remaining pieces (omitting the anchor). This -# precisely determines the location of the intraline tags. -################################################################################# -proc longest-common-substring {s1 off1 len1 s2 off2 len2 lcsoff1_ref \ - lcsoff2_ref} { - upvar $lcsoff1_ref lcsoff1 - upvar $lcsoff2_ref lcsoff2 - set snippet "" - - set snippetlen 0 - set longestlen 0 - - # extract just the search regions for efficiency in string searching - set s1 [string range $s1 $off1 [expr $off1+$len1-1]] - set s2 [string range $s2 $off2 [expr $off2+$len2-1]] - - set j 0 - - while {1} { - # increase size of matching snippet - while {$snippetlen < $len2-$j} { - set tmp "$snippet[string index $s2 [expr $j+$snippetlen]]" - if {[string first $tmp $s1] == -1} { - break - } - set snippet $tmp - incr snippetlen - } - if {$snippetlen == 0} { - # nothing starting at this position - incr j - if {$snippetlen >= $len2-$j} { - break - } - } else { - set tmpoff [string first $snippet $s1] - if {$tmpoff != -1 && $snippetlen > $longestlen} { - # new longest? - set longest $snippet - set longestlen $snippetlen - set lcsoff1 [expr $off1+$tmpoff] - set lcsoff2 [expr $off2+$j] - } - # drop 1st char of prefix, but keep size the same as longest - if {$snippetlen >= $len2-$j} { - break - } - set snippet "[string range $snippet 1 end][string index $s2 \ - [expr $j+$snippetlen]]" - incr j - } - } - return $longestlen -} - -proc fid-ratcliff-aux {pos l1 l2 s1 off1 len1 s2 off2 len2} { - global g - - if {$len1 <= 0 || $len2 <= 0} { - if {$len1 == 0} { - set g(scrinline,$pos,$g(scrinline,$pos)) [list r $l2 $off2 \ - [expr $off2+$len2]] - incr g(scrinline,$pos) - } elseif {$len2 == 0} { - set g(scrinline,$pos,$g(scrinline,$pos)) [list l $l1 $off1 \ - [expr $off1+$len1]] - incr g(scrinline,$pos) - } - return 0 - } - set cnt 0 - set lcsoff1 -1 - set lcsoff2 -1 - - set ret [longest-common-substring $s1 $off1 $len1 $s2 $off2 $len2 lcsoff1 \ - lcsoff2] - - - if {$ret > 0} { - set rightoff1 [expr $lcsoff1+$ret] - set rightoff2 [expr $lcsoff2+$ret] - - incr cnt [expr 2*$ret] - if {$lcsoff1 > $off1 || $lcsoff2 > $off2} { - # left - incr cnt [fid-ratcliff-aux $pos $l1 $l2 $s1 $off1 \ - [expr $lcsoff1-$off1] $s2 $off2 [expr $lcsoff2-$off2]] - - } - if {$rightoff1<$off1+$len1 || $rightoff2<$off2+$len2} { - # right - incr cnt [fid-ratcliff-aux $pos $l1 $l2 $s1 $rightoff1 \ - [expr $off1+$len1-$rightoff1] $s2 $rightoff2 \ - [expr $off2+$len2-$rightoff2]] - } - } else { - set g(scrinline,$pos,$g(scrinline,$pos)) [list r $l2 $off2 \ - [expr $off2+$len2]] - incr g(scrinline,$pos) - set g(scrinline,$pos,$g(scrinline,$pos)) [list l $l1 $off1 \ - [expr $off1+$len1]] - incr g(scrinline,$pos) - } - return $cnt -} - -proc find-inline-diff-ratcliff {pos l1 l2 s1 s2} { - global g - - set len1 [string length $s1] - set len2 [string length $s2] - if {$len1 == 0 || $len2 == 0} { - return 0 - } - return [fid-ratcliff-aux $pos $l1 $l2 $s1 0 $len1 $s2 0 $len2] -} - -proc find-inline-diff-byte {pos l1 l2 s1 s2} { - global g - - set len1 [string length $s1] - set len2 [string length $s2] - if {$len1 == 0 || $len2 == 0} { - return 0 - } - - set cnt 0 - - set lenmin [min $len1 $len2] - set size 0 - for {set i 0} {$i < $lenmin} {incr i} { - if {$size > 0} { - # in a diff section - if {[string index $s1 $i] == [string index $s2 $i]} { - # end of diff region - set g(scrinline,$pos,$g(scrinline,$pos)) [list r $l2 \ - [expr $i-$size] $i] - incr g(scrinline,$pos) - set g(scrinline,$pos,$g(scrinline,$pos)) [list l $l1 \ - [expr $i-$size] $i] - incr g(scrinline,$pos) - set size 0 - incr cnt - } else { - incr size - } - } else { - if {[string index $s1 $i] != [string index $s2 $i]} { - set size 1 - } - } - } - if {$size > 0} { - # end of diff region - set g(scrinline,$pos,$g(scrinline,$pos)) [list r $l2 [expr $i-$size] \ - $len2] - incr g(scrinline,$pos) - set g(scrinline,$pos,$g(scrinline,$pos)) [list l $l1 [expr $i-$size] \ - $len1] - incr g(scrinline,$pos) - incr cnt - } - return $cnt -} - -############################################################################### -# the following code is used as the replacement body for the left and -# right widget procs. The purpose is to catch when the insertion point -# changes so we can update the line comparison window -############################################################################### - -set text_widget_proc { - global w - set real "[lindex [info level [info level]] 0]_" - set result [eval $real $command $args] - if {$command == "mark"} { - if {[lindex $args 0] == "set" && [lindex $args 1] == "insert"} { - set i [lindex $args 2] - set i0 "$i linestart" - set i1 "$i lineend" - set left [$w(LeftText)_ get $i0 $i1] - set right [$w(RightText)_ get $i0 $i1] - $w(BottomText) delete 1.0 end - $w(BottomText) insert end "< $left\n> $right" - # find characters that are different, and underline them - if {$left != $right} { - set left [split $left {}] - set right [split $right {}] - # n.b. we set c to an offset equal to whatever we have - # prepended to the data... - set c 2 - foreach l $left r $right { - if {[string compare $l $r] != 0} { - $w(BottomText) tag add diff 1.$c "1.$c+1c" - $w(BottomText) tag add diff 2.$c "2.$c+1c" - } - incr c - } - $w(BottomText) tag remove diff "1.0 lineend" - $w(BottomText) tag remove diff "2.0 lineend" - } - } - } - return $result -} - -############################################################################### -# create (if necessary) and show the find dialog -############################################################################### -proc show-find {} { - debug-info "show-find" - global w g - global tcl_platform - - if {![winfo exists $w(findDialog)]} { - toplevel $w(findDialog) - wm group $w(findDialog) . - wm transient $w(findDialog) . - wm title $w(findDialog) "$g(name) Find" - - if {$g(windowingSystem) == "aqua"} { - setAquaDialogStyle $w(findDialog) - } - - # we don't want the window to be deleted, just hidden from view - wm protocol $w(findDialog) WM_DELETE_WINDOW [list wm withdraw \ - $w(findDialog)] - - wm withdraw $w(findDialog) - update idletasks - - frame $w(findDialog).content -bd 2 -relief groove - pack $w(findDialog).content -side top -fill both -expand y -padx 0 \ - -pady 5 - - frame $w(findDialog).buttons - pack $w(findDialog).buttons -side bottom -fill x -expand n - - button $w(findDialog).buttons.doit -text "Find Next" -command do-find - button $w(findDialog).buttons.dismiss -text "Dismiss" -command \ - "wm withdraw $w(findDialog)" - pack $w(findDialog).buttons.dismiss -side right -pady 5 -padx 0 - pack $w(findDialog).buttons.doit -side right -pady 5 -padx 1 - - set ff $w(findDialog).content.findFrame - frame $ff -height 100 -bd 2 -relief flat - pack $ff -side top -fill x -expand n -padx 0 -pady 5 - - label $ff.label -text "Find what:" -underline 2 - - entry $ff.entry -textvariable g(findString) - - checkbutton $ff.searchCase -text "Ignore Case" -offvalue 0 -onvalue 1 \ - -indicatoron true -variable g(findIgnoreCase) - - grid $ff.label -row 0 -column 0 -sticky e - grid $ff.entry -row 0 -column 1 -sticky ew - grid $ff.searchCase -row 0 -column 2 -sticky w - grid columnconfigure $ff 0 -weight 0 - grid columnconfigure $ff 1 -weight 1 - grid columnconfigure $ff 2 -weight 0 - - # we need this in other places... - set w(findEntry) $ff.entry - - bind $ff.entry do-find - - set of $w(findDialog).content.optionsFrame - frame $of -bd 2 -relief flat - pack $of -side top -fill y -expand y -padx 10 -pady 10 - - label $of.directionLabel -text "Search Direction:" -anchor e - radiobutton $of.directionForward -indicatoron true -text "Down" \ - -value "-forward" -variable g(findDirection) - radiobutton $of.directionBackward -text "Up" -value "-backward" \ - -indicatoron true -variable g(findDirection) - - - label $of.windowLabel -text "Window:" -anchor e - radiobutton $of.windowLeft -indicatoron true -text "Left" \ - -value $w(LeftText) -variable g(activeWindow) - radiobutton $of.windowRight -indicatoron true -text "Right" \ - -value $w(RightText) -variable g(activeWindow) - - - label $of.searchLabel -text "Search Type:" -anchor e - radiobutton $of.searchExact -indicatoron true -text "Exact" \ - -value "-exact" -variable g(findType) - radiobutton $of.searchRegexp -text "Regexp" -value "-regexp" \ - -indicatoron true -variable g(findType) - - grid $of.directionLabel -row 1 -column 0 -sticky w - grid $of.directionForward -row 1 -column 1 -sticky w - grid $of.directionBackward -row 1 -column 2 -sticky w - - grid $of.windowLabel -row 0 -column 0 -sticky w - grid $of.windowLeft -row 0 -column 1 -sticky w - grid $of.windowRight -row 0 -column 2 -sticky w - - grid $of.searchLabel -row 2 -column 0 -sticky w - grid $of.searchExact -row 2 -column 1 -sticky w - grid $of.searchRegexp -row 2 -column 2 -sticky w - - grid columnconfigure $of 0 -weight 0 - grid columnconfigure $of 1 -weight 0 - grid columnconfigure $of 2 -weight 1 - - set g(findDirection) "-forward" - set g(findType) "-exact" - set g(findIgnoreCase) 1 - set g(lastSearch) "" - if {$g(activeWindow) == ""} { - set g(activeWindow) [focus] - if {$g(activeWindow) != $w(LeftText) && $g(activeWindow) != \ - $w(RightText)} { - set g(activeWindow) $w(LeftText) - } - } - } - - centerWindow $w(findDialog) - wm deiconify $w(findDialog) - raise $w(findDialog) - after idle focus $w(findEntry) -} - - -############################################################################### -# do the "Edit->Copy" functionality, by copying the current selection -# to the clipboard -############################################################################### -proc do-copy {} { - clipboard clear -displayof . - # figure out which window has the selection... - catch { - clipboard append [selection get -displayof .] - } -} - -############################################################################### -# search for the text in the find dialog -############################################################################### -proc do-find {} { - global g - global w - - if {![winfo exists $w(findDialog)] || ![winfo ismapped $w(findDialog)]} { - show-find - return - } - - set win $g(activeWindow) - if {$win == ""} { - set win $w(LeftText) - } - if {$g(lastSearch) != ""} { - if {$g(findDirection) == "-forward"} { - set start [$win index "insert +1c"] - } else { - set start insert - } - } else { - set start 1.0 - } - - if {$g(findIgnoreCase)} { - set result [$win search $g(findDirection) $g(findType) -nocase \ - -- $g(findString) $start] - } else { - set result [$win search $g(findDirection) $g(findType) \ - -- $g(findString) $start] - } - if {[string length $result] > 0} { - # if this is a regular expression search, get the whole line and try - # to figure out exactly what matched; otherwise we know we must - # have matched the whole string... - if {$g(findType) == "-regexp"} { - set line [$win get $result "$result lineend"] - regexp $g(findString) $line matchVar - set length [string length $matchVar] - } else { - set length [string length $g(findString)] - } - set g(lastSearch) $result - $win mark set insert $result - $win tag remove sel 1.0 end - $win tag add sel $result "$result + ${length}c" - $win see $result - focus $win - # should I somehow snap to the nearest diff? Probably not... - } else { - bell - - } -} - -############################################################################### -# Build the menu bar -############################################################################### -proc build-menubar {} { - debug-info "build-menubar" - global g - global opts - global w - - menu $w(menubar) - - # this is just temporary shorthand ... - set menubar $w(menubar) - - - # First, the menu buttons... - set fileMenu $w(menubar).file - set viewMenu $w(menubar).view - set helpMenu $w(menubar).help - set editMenu $w(menubar).edit - set mergeMenu $w(menubar).window - set markMenu $w(menubar).marks - - $w(menubar) add cascade -label "File" -menu $fileMenu -underline 0 - $w(menubar) add cascade -label "Edit" -menu $editMenu -underline 0 - $w(menubar) add cascade -label "View" -menu $viewMenu -underline 0 - $w(menubar) add cascade -label "Mark" -menu $markMenu -underline 3 - $w(menubar) add cascade -label "Merge" -menu $mergeMenu -underline 0 - $w(menubar) add cascade -label "Help" -menu $helpMenu -underline 0 - - # these, however, are used in other places.. - set w(fileMenu) $fileMenu - set w(viewMenu) $viewMenu - set w(helpMenu) $helpMenu - set w(editMenu) $editMenu - set w(mergeMenu) $mergeMenu - set w(markMenu) $markMenu - - # Now, the menus... - - # Mark menu... - menu $markMenu - $markMenu add command -label "Mark Current Diff" -command [list diffmark \ - mark] -underline 0 - $markMenu add command -label "Clear Current Diff Mark" -command \ - [list diffmark clear] -underline 0 - - set "g(tooltip,Mark Current Diff)" "Create a marker for the current \ - difference record" - set "g(tooltip,Clear Current Diff Mark)" "Clear the marker for the \ - current difference record" - - # File menu... - menu $fileMenu - $fileMenu add command -label "New..." -underline 0 -command {do-new-diff} - $fileMenu add separator - $fileMenu add command -label "Recompute Diffs" -underline 0 \ - -accelerator r -command recompute-diff - $fileMenu add command -label "Write Report..." -command \ - [list write-report popup] -underline 0 - $fileMenu add separator - $fileMenu add command -label "Exit" -underline 1 -accelerator q \ - -command do-exit - - # Edit menu... If you change, add or remove labels, be sure and - # update the tooltips. - menu $editMenu - $editMenu add command -label "Copy" -underline 0 -command do-copy - $editMenu add separator - $editMenu add command -label "Find..." -underline 0 -command show-find - $editMenu add separator - $editMenu add command -label "Edit File 1" -command { - set g(activeWindow) $w(LeftText) - do-edit - } -underline 10 - $editMenu add command -label "Edit File 2" -command { - set g(activeWindow) $w(RightText) - do-edit - } -underline 10 - $editMenu add separator - $editMenu add command -label "Preferences..." -underline 0 \ - -command customize - - set "g(tooltip,Copy)" "Copy the currently selected text to the clipboard" - set "g(tooltip,Find...)" "Pop up a dialog to search for a string within \ - either file" - set "g(tooltip,Edit File 1)" "Launch an editor on the file on the left \ - side of the window" - set "g(tooltip,Edit File 2)" "Launch an editor on the file on the right \ - side of the window" - set "g(tooltip,Preferences...)" "Pop up a window to customize $g(name)" - - # View menu... If you change, add or remove labels, be sure and - # update the tooltips. - menu $viewMenu - $viewMenu add checkbutton -label "Ignore White Spaces" -underline 8 \ - -selectcolor $w(selcolor) -variable opts(ignoreblanks) \ - -command do-show-ignoreblanks - - $viewMenu add checkbutton -label "Show Line Numbers" -underline 12 \ - -selectcolor $w(selcolor) -variable opts(showln) \ - -command do-show-linenumbers - - $viewMenu add checkbutton -label "Show Change Bars" -underline 12 \ - -selectcolor $w(selcolor) -variable opts(showcbs) \ - -command do-show-changebars - - $viewMenu add checkbutton -label "Show Diff Map" -underline 5 \ - -selectcolor $w(selcolor) -variable opts(showmap) -command do-show-map - - $viewMenu add checkbutton -label "Show Line Comparison Window" \ - -underline 11 -selectcolor $w(selcolor) -variable opts(showlineview) \ - -command do-show-lineview - - $viewMenu add checkbutton -label "Show Inline Comparison (byte)" \ - -selectcolor $w(selcolor) -variable opts(showinline1) \ - -command do-show-inline1 - - $viewMenu add checkbutton -label "Show Inline Comparison (recursive)" \ - -selectcolor $w(selcolor) -variable opts(showinline2) \ - -command do-show-inline2 - - $viewMenu add separator - - $viewMenu add checkbutton -label "Synchronize Scrollbars" -underline 0 \ - -selectcolor $w(selcolor) -variable opts(syncscroll) - $viewMenu add checkbutton -label "Auto Center" -underline 0 \ - -selectcolor $w(selcolor) -variable opts(autocenter) -command {if \ - {$opts(autocenter)} {center}} - $viewMenu add checkbutton -label "Auto Select" -underline 1 \ - -selectcolor $w(selcolor) -variable opts(autoselect) - - $viewMenu add separator - - $viewMenu add command -label "First Diff" -underline 0 -command \ - {move first} -accelerator "F" - $viewMenu add command -label "Previous Diff" -underline 0 -command {move \ - -1} -accelerator "P" - $viewMenu add command -label "Center Current Diff" -underline 0 \ - -command {center} -accelerator "C" - $viewMenu add command -label "Next Diff" -underline 0 -command {move 1} \ - -accelerator "N" - $viewMenu add command -label "Last Diff" -underline 0 -command \ - {move last} -accelerator "L" - - set "g(tooltip,Show Change Bars)" "If set, show the changebar column for \ - each line of each file" - set "g(tooltip,Show Line Numbers)" "If set, show line numbers beside each \ - line of each file" - set "g(tooltip,Synchronize Scrollbars)" "If set, scrolling either window \ - will scroll both windows" - set "g(tooltip,Diff Map)" "If set, display the graphical \"Difference \ - Map\" in the center of the display" - set "g(tooltip,Show Line Comparison Window)" "If set, display the window \ - with byte-by-byte differences" - set "g(tooltip,Show Inline Comparison (byte))" "If set, display inline \ - byte-by-byte differences" - set "g(tooltip,Show Inline Comparison (recursive))" "If set, display \ - inline differences based on recursive matching regions" - set "g(tooltip,Auto Select)" "If set, automatically selects the nearest \ - diff record while scrolling" - set "g(tooltip,Auto Center)" "If set, moving to another diff record will \ - center the diff on the screen" - set "g(tooltip,Center Current Diff)" "Center the display around the \ - current diff record" - set "g(tooltip,First Diff)" "Go to the first difference" - set "g(tooltip,Last Diff)" "Go to the last difference" - set "g(tooltip,Previous Diff)" "Go to the diff record just prior to the \ - current diff record" - set "g(tooltip,Next Diff)" "Go to the diff record just after the current \ - diff record" - set "g(tooltip,Ignore White Spaces)" "If set, changes in whitespaces are \ - ignored" - - # Merge menu. If you change, add or remove labels, be sure and - # update the tooltips. - menu $mergeMenu - $mergeMenu add checkbutton -label "Show Merge Window" -underline 9 \ - -selectcolor $w(selcolor) -variable g(showmerge) -command "do-show-merge 1" - $mergeMenu add command -label "Write Merge File..." -underline 6 \ - -command popup-merge - set "g(tooltip,Show Merge Window)" "Pops up a window showing the current \ - merge results" - set "g(tooltip,Write Merge File)" "Write the merge file to disk. You will \ - be prompted for a filename" - - # Help menu. If you change, add or remove labels, be sure and - # update the tooltips. - menu $helpMenu - $helpMenu add command -label "On GUI" -underline 3 -command do-help - $helpMenu add command -label "On Command Line" -underline 3 \ - -command "do-usage gui" - $helpMenu add command -label "On Preferences" -underline 3 \ - -command do-help-preferences - $helpMenu add separator - $helpMenu add command -label "About $g(name)" -underline 0 -command do-about - - bind $fileMenu <> {showTooltip menu %W} - bind $editMenu <> {showTooltip menu %W} - bind $viewMenu <> {showTooltip menu %W} - bind $markMenu <> {showTooltip menu %W} - bind $mergeMenu <> {showTooltip menu %W} - bind $helpMenu <> {showTooltip menu %W} - - set "g(tooltip,On Preferences)" "Show help on the user-settable preferences" - set "g(tooltip,On GUI)" "Show help on how to use the Graphical User \ - Interface" - set "g(tooltip,On Command Line)" "Show help on the command line arguments" - set "g(tooltip,About $g(name))" "Show information about this application" -} - -############################################################################### -# Show explanation of item in the status bar at the bottom. -# Now used only for menu items -############################################################################### -proc showTooltip {which w} { - global tooltip - global g - switch -- $which { - menu { - if {[catch {$w entrycget active -label} label]} { - set label "" - } - if {[info exists g(tooltip,$label)]} { - set g(statusInfo) $g(tooltip,$label) - } else { - set g(statusInfo) $label - } - update idletasks - } - button { - if {[info exists g(tooltip,$w)]} { - set g(statusInfo) $g(tooltip,$w) - } else { - set g(statusInfo) "" - } - update idletasks - } - } -} - -############################################################################### -# Build the toolbar, in text or image mode -############################################################################### -proc build-toolbar {} { - debug-info "build-toolbar" - global w g - global opts - - frame $w(toolbar) -bd 0 - - set toolbar $w(toolbar) - - # these are used in other places.. - set w(combo) $toolbar.combo - set w(rediff_im) $toolbar.rediff_im - set w(rediff_tx) $toolbar.rediff_tx - set w(find_im) $toolbar.find_im - set w(find_tx) $toolbar.find_tx - set w(mergeChoiceLabel) $toolbar.mergechoicelbl - set w(mergeChoice1_im) $toolbar.m1_im - set w(mergeChoice1_tx) $toolbar.m1_tx - set w(mergeChoice2_im) $toolbar.m2_im - set w(mergeChoice2_tx) $toolbar.m2_tx - set w(mergeChoice12_im) $toolbar.m12_im - set w(mergeChoice12_tx) $toolbar.m12_tx - set w(mergeChoice21_im) $toolbar.m21_im - set w(mergeChoice21_tx) $toolbar.m21_tx - set w(diffNavLabel) $toolbar.diffnavlbl - set w(prevDiff_im) $toolbar.prev_im - set w(prevDiff_tx) $toolbar.prev_tx - set w(firstDiff_im) $toolbar.first_im - set w(firstDiff_tx) $toolbar.first_tx - set w(lastDiff_im) $toolbar.last_im - set w(lastDiff_tx) $toolbar.last_tx - set w(nextDiff_im) $toolbar.next_im - set w(nextDiff_tx) $toolbar.next_tx - set w(centerDiffs_im) $toolbar.center_im - set w(centerDiffs_tx) $toolbar.center_tx - set w(markLabel) $toolbar.bkmklbl - set w(markSet_im) $toolbar.bkmkset_im - set w(markSet_tx) $toolbar.bkmkset_tx - set w(markClear_im) $toolbar.bkmkclear_im - set w(markClear_tx) $toolbar.bkmkclear_tx - - # separators - toolsep $toolbar.sep1 - toolsep $toolbar.sep2 - toolsep $toolbar.sep3 - toolsep $toolbar.sep4 - toolsep $toolbar.sep5 - toolsep $toolbar.sep6 - - # The combo box - ::combobox::combobox $toolbar.combo -borderwidth 1 -editable false \ - -command moveTo -width 20 - - # rediff... - toolbutton $toolbar.rediff_im -image rediffImage -command recompute-diff \ - -bd 1 - toolbutton $toolbar.rediff_tx -text "Rediff" -command recompute-diff \ - -bd 1 -pady 1 - - # find... - toolbutton $toolbar.find_im -image findImage -command do-find -bd 1 - toolbutton $toolbar.find_tx -text "Find" -command do-find -bd 1 -pady 1 - - # navigation widgets - label $toolbar.diffnavlbl -text "Diff:" -pady 0 -bd 2 -relief groove - - toolbutton $toolbar.prev_im -image prevDiffImage -command [list move -1] \ - -bd 1 - toolbutton $toolbar.prev_tx -text "Prev" -command [list move -1] -bd 1 \ - -pady 1 - - toolbutton $toolbar.next_im -image nextDiffImage -command [list move 1] \ - -bd 1 - toolbutton $toolbar.next_tx -text "Next" -command [list move 1] -bd 1 \ - -pady 1 - - toolbutton $toolbar.first_im -image firstDiffImage -command [list move \ - first] -bd 1 - toolbutton $toolbar.first_tx -text "First" -command [list move first] \ - -bd 1 -pady 1 - - toolbutton $toolbar.last_im -image lastDiffImage -command [list move \ - last] -bd 1 - toolbutton $toolbar.last_tx -text "Last" -command [list move last] -bd 1 \ - -pady 1 - - toolbutton $toolbar.center_im -image centerDiffsImage -command center -bd 1 - toolbutton $toolbar.center_tx -text "Center" -command center -bd 1 -pady 1 - - # the merge widgets - label $toolbar.mergechoicelbl -text "Merge:" -pady 0 -bd 2 -relief groove - - radiobutton $toolbar.m2_im -borderwidth 1 -indicatoron false \ - -image mergeChoice2Image -value 2 -variable g(toggle) -command \ - [list do-merge-choice 2] -takefocus 0 - radiobutton $toolbar.m2_tx -borderwidth 1 -indicatoron true -text "R" \ - -value 2 -variable g(toggle) -command [list do-merge-choice 2] \ - -takefocus 0 - - radiobutton $toolbar.m1_im -borderwidth 1 -indicatoron false \ - -image mergeChoice1Image -value 1 -variable g(toggle) -command \ - [list do-merge-choice 1] -takefocus 0 - radiobutton $toolbar.m1_tx -borderwidth 1 -indicatoron true -text "L" \ - -value 1 -variable g(toggle) -command [list do-merge-choice 1] \ - -takefocus 0 - - radiobutton $toolbar.m12_im -borderwidth 1 -indicatoron false \ - -image mergeChoice12Image -value 12 -variable g(toggle) -command \ - [list do-merge-choice 12] -takefocus 0 - radiobutton $toolbar.m12_tx -borderwidth 1 -indicatoron true -text "LR" \ - -value 12 -variable g(toggle) -command [list do-merge-choice 12] \ - -takefocus 0 - - radiobutton $toolbar.m21_im -borderwidth 1 -indicatoron false \ - -image mergeChoice21Image -value 21 -variable g(toggle) -command \ - [list do-merge-choice 21] -takefocus 0 - radiobutton $toolbar.m21_tx -borderwidth 1 -indicatoron true -text "RL" \ - -value 21 -variable g(toggle) -command [list do-merge-choice 21] \ - -takefocus 0 - - # The bookmarks - label $toolbar.bkmklbl -text "Mark:" -pady 0 -bd 2 -relief groove - - toolbutton $toolbar.bkmkset_im -image markSetImage -command \ - [list diffmark mark] -bd 1 - toolbutton $toolbar.bkmkset_tx -text "Set" -command [list diffmark mark] \ - -bd 1 -pady 1 - - toolbutton $toolbar.bkmkclear_im -image markClearImage -command \ - [list diffmark clear] -bd 1 - toolbutton $toolbar.bkmkclear_tx -text "Clear" -command [list diffmark \ - clear] -bd 1 -pady 1 - - set_tooltips $w(find_im) {"Pop up a dialog to search for a string within \ - either file"} - set_tooltips $w(find_tx) {"Pop up a dialog to search for a string within \ - either file"} - set_tooltips $w(rediff_im) {"Recompute and redisplay the difference \ - records"} - set_tooltips $w(rediff_tx) {"Recompute and redisplay the difference \ - records"} - set_tooltips $w(mergeChoice12_im) {"select the diff on the left then \ - right for merging"} - set_tooltips $w(mergeChoice12_tx) {"select the diff on the left then \ - right for merging"} - set_tooltips $w(mergeChoice1_im) {"select the diff on the left for merging"} - set_tooltips $w(mergeChoice1_tx) {"select the diff on the left for merging"} - set_tooltips $w(mergeChoice2_im) {"select the diff on the right for \ - merging"} - set_tooltips $w(mergeChoice2_tx) {"select the diff on the right for \ - merging"} - set_tooltips $w(mergeChoice21_im) {"select the diff on the right then \ - left for merging"} - set_tooltips $w(mergeChoice21_tx) {"select the diff on the right then \ - left for merging"} - set_tooltips $w(prevDiff_im) {"Previous Diff"} - set_tooltips $w(prevDiff_tx) {"Previous Diff"} - set_tooltips $w(nextDiff_im) {"Next Diff"} - set_tooltips $w(nextDiff_tx) {"Next Diff"} - set_tooltips $w(firstDiff_im) {"First Diff"} - set_tooltips $w(firstDiff_tx) {"First Diff"} - set_tooltips $w(lastDiff_im) {"Last Diff"} - set_tooltips $w(lastDiff_tx) {"Last Diff"} - set_tooltips $w(markSet_im) {"Mark current diff"} - set_tooltips $w(markSet_tx) {"Mark current diff"} - set_tooltips $w(markClear_im) {"Clear current diff mark"} - set_tooltips $w(markClear_tx) {"Clear current diff mark"} - set_tooltips $w(centerDiffs_im) {"Center Current Diff"} - set_tooltips $w(centerDiffs_tx) {"Center Current Diff"} - - pack-toolbuttons $toolbar -} - -proc pack-toolbuttons {toolbar} { - #debug-info "pack-toolbuttons ($toolbar)" - global opts - - if {$opts(toolbarIcons)} { - set bp "im" - } else { - set bp "tx" - } - - pack $toolbar.combo -side left -padx 2 - pack $toolbar.sep1 -side left -fill y -pady 2 -padx 2 - pack $toolbar.rediff_$bp -side left -padx 2 - pack $toolbar.find_$bp -side left -padx 2 - pack $toolbar.sep2 -side left -fill y -pady 2 -padx 2 - pack $toolbar.mergechoicelbl -side left -padx 2 - pack $toolbar.m12_$bp $toolbar.m1_$bp $toolbar.m2_$bp $toolbar.m21_$bp \ - -side left -padx 2 - pack $toolbar.sep3 -side left -fill y -pady 2 -padx 2 - pack $toolbar.diffnavlbl -side left -pady 2 -padx 2 - pack $toolbar.first_$bp $toolbar.last_$bp $toolbar.prev_$bp \ - $toolbar.next_$bp -side left -pady 2 -padx 2 - pack $toolbar.sep4 -side left -fill y -pady 2 -padx 2 - pack $toolbar.center_$bp -side left -pady 2 -padx 1 - pack $toolbar.sep5 -side left -fill y -pady 2 -padx 2 - pack $toolbar.bkmklbl -side left -padx 2 - pack $toolbar.bkmkset_$bp $toolbar.bkmkclear_$bp -side left -pady 2 -padx 2 - pack $toolbar.sep6 -side left -fill y -pady 2 -padx 2 - - foreach b [info commands $toolbar.mark*] { - pack $b -side left -fill y -pady 2 -padx 2 - } - - foreach b [info commands $toolbar.mark*] { - $b configure -relief $opts(relief) - } - foreach b [info commands $toolbar.*_$bp] { - $b configure -relief $opts(relief) - } - - # Radiobuttons ignore relief configuration if they have an image, so we - # set their borderwidth to 0 if we want them flat. - if {$opts(relief) == "flat" && $opts(toolbarIcons)} { - set bord 0 - } else { - set bord 1 - } - foreach b [info commands $toolbar.m1*] { - $b configure -bd $bord - } - foreach b [info commands $toolbar.m2*] { - $b configure -bd $bord - } -} - -proc reconfigure-toolbar {} { - debug-info "reconfigure-toolbar" - global w - - foreach button [winfo children $w(toolbar)] { - pack forget $button - } - - pack-toolbuttons $w(toolbar) -} - -proc build-status {} { - debug-info "build-status" - global w - global g - - frame $w(status) -bd 0 - - set w(statusLabel) $w(status).label - set w(statusCurrent) $w(status).current - - # MacOS has a resize handle in the bottom right which will sit - # on top of whatever is placed there. So, we'll add a little bit - # of whitespace there. It's harmless, so we'll do it on all of the - # platforms. - label $w(status).blank -image nullImage -width 16 -bd 1 -relief sunken - - label $w(statusCurrent) -textvariable g(statusCurrent) -anchor e \ - -width 14 -borderwidth 1 -relief sunken -padx 4 -pady 2 - label $w(statusLabel) -textvariable g(statusInfo) -anchor w -width 1 \ - -borderwidth 1 -relief sunken -pady 2 - pack $w(status).blank -side right -fill y - - pack $w(statusCurrent) -side right -fill y -expand n - pack $w(statusLabel) -side left -fill both -expand y -} - -############################################################################### -# handles events over the map -############################################################################### -proc handleMapEvent {event y} { - global opts - global w - global g - #debug-info "handleMapEvent $event $y" - - switch -- $event { - B1-Press { - set ty1 [lindex $g(thumbBbox) 1] - set ty2 [lindex $g(thumbBbox) 3] - if {$y >= $ty1 && $y <= $ty2} { - set g(mapScrolling) 1 - - # this captures the negative delta between the mouse press \ - and the top - # of the thumbbox. It's used so when we scroll by moving the - # mouse, we can keep this distance constant. This is how all - # scrollbars work, and it's what the user expects. - set g(thumbDeltaY) [expr -1 * ($y - $ty1 - 2)] - - } - } - B1-Motion { - if {[info exists g(mapScrolling)]} { - incr y $g(thumbDeltaY) - - map-seek $y - } - } - B1-Release { - show-info "" - set ty1 [lindex $g(thumbBbox) 1] - set ty2 [lindex $g(thumbBbox) 3] - # if we release over the trough (*not* over the thumb) - # just scroll by the size of the thumb - if {$y < $ty1 || $y > $ty2} { - if {$y < $ty1} { - # if vertical scrollbar syncing is turned on, - # all the other windows should toe the line - # appropriately... - $w(RightText) yview scroll -1 pages - } else { - $w(RightText) yview scroll 1 pages - } - - } else { - # do nothing - } - - catch {unset g(mapScrolling)} - } - } -} - -# makes a toolbar "separator" -proc toolsep {w} { - label $w -image [image create photo] -highlightthickness 0 -bd 1 -width 0 \ - -relief groove - return $w -} - -proc toolbutton {w args} { - global tcl_platform - global opts - global g - - # create the button - eval button $w $args - - # add minimal tooltip-like support - bind $w [list toolbutton:handleEvent %W] - bind $w [list toolbutton:handleEvent %W] - bind $w [list toolbutton:handleEvent %W] - bind $w [list toolbutton:handleEvent %W] - - $w configure -relief $opts(relief) - - return $w -} - -# handle events in our fancy toolbuttons... -proc toolbutton:handleEvent {event w {isToolbutton 1}} { - global g - global opts - - switch -- $event { - "" { - showTooltip button $w - if {$opts(fancyButtons) && $isToolbutton && [$w cget -state] == \ - "normal"} { - $w configure -relief raised - } - } - "" { - set g(statusInfo) "" - if {$opts(fancyButtons) && $isToolbutton} { - $w configure -relief flat - } - } - "" { - showTooltip button $w - if {$opts(fancyButtons) && $isToolbutton && [$w cget -state] == \ - "normal"} { - $w configure -relief raised - } - } - "" { - set g(statusInfo) "" - if {$opts(fancyButtons) && $isToolbutton} { - $w configure -relief flat - } - } - } -} - -############################################################################### -# move the map thumb to correspond to current shown merge... -############################################################################### -proc map-move-thumb {y1 y2} { - global g - global w - - set thumbheight [expr {($y2 - $y1) * $g(mapheight)}] - if {$thumbheight < $g(thumbMinHeight)} { - set thumbheight $g(thumbMinHeight) - } - - if {![info exists g(mapwidth)]} { - set g(mapwidth) 0 - } - set x1 1 - set x2 [expr {$g(mapwidth) - 3}] - - # why -2? it's the thickness of our border... - set y1 [expr {int(($y1 * $g(mapheight)) - 2)}] - if {$y1 < 0} { - set y1 0 - } - - set y2 [expr {$y1 + $thumbheight}] - if {$y2 > $g(mapheight)} { - set y2 $g(mapheight) - set y1 [expr {$y2 - $thumbheight}] - } - - set dx1 [expr {$x1 + 1}] - set dx2 [expr {$x2 - 1}] - set dy1 [expr {$y1 + 1}] - set dy2 [expr {$y2 - 1}] - - $w(mapCanvas) coords thumbUL $x1 $y2 $x1 $y1 $x2 $y1 $dx2 $dy1 $dx1 $dy1 \ - $dx1 $dy2 - $w(mapCanvas) coords thumbLR $dx1 $y2 $x2 $y2 $x2 $dy1 $dx2 $dy1 $dx2 \ - $dy2 $dx1 $dy2 - - set g(thumbBbox) [list $x1 $y1 $x2 $y2] - set g(thumbHeight) $thumbheight -} - -############################################################################### -# Bind keys for Next, Prev, Center, Merge choices 1 and 2 -# -# N.B. This is GROSS! It might have been necessary in earlier versions, -# but now I think it needs a serious rewriite. We are now overriding -# the text widget, so we can probably just disable the insert and delete -# commands, and use something like insert_ and delete_ internally. -############################################################################### -proc common-navigation {args} { - global w - - bind . do-find - - foreach widget $args { - # this effectively disables the widget, without having to - # resort to actually disabling the widget (the latter which - # has some annoying side effects). What we really want is to - # only disable keys that get inserted, but that's difficult - # to do, and this works almost as well... - bind $widget {break} - - bind $widget {continue} - - bind $widget <> {break} - - - # ... but now we need to restore some navigation key bindings - # which got lost because we disable all keys. Since we are - # attaching bindings that duplicate class bindings, we need - # to be sure and include the break, so the events don't fire - # twice (once for the widget, once for the class). There is - # probably a much better way to do all this, but I'm too - # lazy to figure it out... - foreach event [list Next Prior Up Down Left Right Home End] { - foreach modifier [list {} Shift Control Shift-Control] { - set binding [bind Text <${modifier}${event}>] - if {[string length $binding] > 0} { - bind $widget "<${modifier}${event}>" " - ${binding} - break - " - } - } - } - - # these bindings allow control-f, tab and shift-tab to work - # in spite of the fact we bound Any-KeyPress to a null action - bind $widget continue - - bind $widget continue - - bind $widget continue - - - bind $widget " - center - break - " - bind $widget " - move 1 - break - " - bind $widget

" - move -1 - break - " - bind $widget " - move first - break - " - bind $widget " - move last - break - " - bind $widget " - do-exit - break - " - bind $widget " - recompute-diff - break - " - bind $widget " - moveNearest $widget mark insert - break - " - - # these bindings keep Alt- modified keys from triggering - # the above actions. This way, any Alt combinations that - # should open a menu will... - foreach key [list c n p f l] { - bind $widget {continue} - } - - bind $widget " - moveNearest $widget xy %x %y - break - " - - bind $widget " - do-merge-choice 1 - break - " - bind $widget " - do-merge-choice 2 - break - " - bind $widget " - do-merge-choice 12 - break - " - bind $widget " - do-merge-choice 21 - break - " - } -} - -############################################################################### -# set or clear a "diff mark" -- a hot button to move to a particular diff -############################################################################### -proc diffmark {option {diff -1}} { - debug-info "diffmark ($option $diff)" - global g - global w - - if {$diff == -1} { - set diff $g(pos) - } - - set widget $w(toolbar).mark$diff - - switch -- $option { - activate { - move $diff 0 1 - } - mark { - if {![winfo exists $widget]} { - toolbutton $widget -text "\[$diff\]" -command [list diffmark \ - activate $diff] -bd 1 -pady 1 - pack $widget -side left -padx 2 - set g(tooltip,$widget) "Diff Marker: Jump to diff record \ - number $diff" - } - update-display - } - clear { - if {[winfo exists $widget]} { - destroy $widget - catch {unset g(tooltip,$widget)} - } - update-display - } - clearall { - set bookmarks [info commands $w(toolbar).mark*] - if {[llength $bookmarks] > 0} { - foreach widget $bookmarks { - destroy $widget - catch {unset g(tooltip,$widget)} - } - } - update-display - } - } -} - -############################################################################### -# Customize the display (among other things). -############################################################################### -proc customize {} { - debug-info "customize" - global pref - global g - global w - global opts - global tmpopts - global tcl_platform - - catch {destroy $w(preferences)} - toplevel $w(preferences) - - wm title $w(preferences) "$g(name) Preferences" - wm transient $w(preferences) . - wm group $w(preferences) . - - if {$g(windowingSystem) == "aqua"} { - setAquaDialogStyle $w(preferences) - } - - wm withdraw $w(preferences) - - # the button frame... - frame $w(preferences).buttons -bd 0 - button $w(preferences).buttons.dismiss -width 8 -text "Dismiss" \ - -command {destroy $w(preferences)} - button $w(preferences).buttons.apply -width 8 -text "Apply" \ - -command {apply 1} - button $w(preferences).buttons.save -width 8 -text "Save" -command save - - button $w(preferences).buttons.help -width 8 -text "Help" \ - -command do-help-preferences - - pack $w(preferences).buttons -side bottom -fill x - pack $w(preferences).buttons.dismiss -side right -padx 10 -pady 5 - pack $w(preferences).buttons.help -side right -padx 10 -pady 5 - pack $w(preferences).buttons.save -side right -padx 1 -pady 5 - pack $w(preferences).buttons.apply -side right -padx 1 -pady 5 - - # a series of checkbuttons to act as a poor mans notebook tab - frame $w(preferences).notebook -bd 0 - pack $w(preferences).notebook -side top -fill x -pady 4 - set pagelist {} - - # Radiobuttons without indicators look rather sucky on MacOSX, so - # we'll tweak the style for that platform - if {$::tcl_platform(os) == "Darwin"} { - set indicatoron true - } else { - set indicatoron false - } - - foreach page [list General Display Appearance] { - set frame $w(preferences).f$page - lappend pagelist $frame - set rb $w(preferences).notebook.f$page - radiobutton $rb -command "customize-selectPage $frame" \ - -variable g(prefPage) -value $frame -height 2 -text $page \ - -indicatoron $indicatoron -width 10 -borderwidth 1 - - pack $rb -side left - - frame $frame -bd 2 -relief groove -width 400 -height 300 - } - set g(prefPage) $w(preferences).fGeneral - - # make sure our labels are defined - customize-initLabels - - # this is an option that we support internally, but don't give - # the user a way to directly edit (right now, anyway). But we - # need to make sure tmpopts knows about it - set tmpopts(customCode) $opts(customCode) - - # General - set count 0 - set frame $w(preferences).fGeneral - foreach key {diffcmd ignoreblanksopt tmpdir editor geometry} { - label $frame.l$count -text "$pref($key): " -anchor w - set tmpopts($key) $opts($key) - entry $frame.e$count -textvariable tmpopts($key) -width 50 -bd 2 \ - -relief sunken - - grid $frame.l$count -row $count -column 0 -sticky w -padx 5 -pady 2 - grid $frame.e$count -row $count -column 1 -sticky ew -padx 5 -pady 2 - - incr count - } - - # this is just for filler... - label $frame.filler -text {} - grid $frame.filler -row $count - incr count - - foreach key {fancyButtons toolbarIcons autocenter syncscroll autoselect} { - label $frame.l$count -text "$pref($key): " -anchor w - set tmpopts($key) $opts($key) - checkbutton $frame.c$count -indicatoron true -text "$pref($key)" \ - -justify left -onvalue 1 -offvalue 0 -variable tmpopts($key) - - set tmpopts($key) $opts($key) - - if {$key == "fancyButtons" && $g(windowingSystem) == "aqua"} { - # Skipit - nothing to do - incr count - continue - } - - grid $frame.c$count -row $count -column 0 -columnspan 2 -sticky w \ - -padx 5 - - incr count - } - - grid columnconfigure $frame 0 -weight 0 - grid columnconfigure $frame 1 -weight 1 - - # this, in effect, adds a hidden row at the bottom which takes - # up any extra room - - grid rowconfigure $frame $count -weight 1 - - # pack this window for a brief moment, and compute the window - # size. We'll do this for each "page" and find the largest - # size to be the size of the dialog - pack $frame -side right -fill both -expand y - update idletasks - set maxwidth [winfo reqwidth $w(preferences)] - set maxheight [winfo reqheight $w(preferences)] - pack forget $frame - - # Appearance - set frame $w(preferences).fAppearance - set count 0 - foreach key {textopt difftag deltag instag chgtag currtag bytetag \ - inlinetag overlaptag} { - label $frame.l$count -text "$pref($key): " -anchor w - set tmpopts($key) $opts($key) - entry $frame.e$count -textvariable tmpopts($key) -bd 2 -relief sunken - - grid $frame.l$count -row $count -column 0 -sticky w -padx 5 -pady 2 - grid $frame.e$count -row $count -column 1 -sticky ew -padx 5 -pady 2 - - incr count - } - grid columnconfigure $frame 0 -weight 0 - grid columnconfigure $frame 1 -weight 1 - - # tabstops are placed after a little extra whitespace, since it is - # slightly different than all of the other options (ie: it's not - # a list of widget options) - frame $frame.sep$count -bd 0 -height 4 - grid $frame.sep$count -row $count -column 0 -stick ew -columnspan 2 \ - -padx 5 -pady 2 - incr count - - set key "tabstops" - set tmpopts($key) $opts($key) - label $frame.l$count -text "$pref($key):" -anchor w - set tmpopts($key) $opts($key) - entry $frame.e$count -textvariable tmpopts($key) -bd 2 -relief sunken \ - -width 3 - grid $frame.l$count -row $count -column 0 -sticky w -padx 5 -pady 2 - grid $frame.e$count -row $count -column 1 -sticky w -padx 5 -pady 2 - incr count - - # add a tiny bit of validation, so the user can only enter numbers - trace variable tmpopts($key) w [list validate integer] - - # this, in effect, adds a hidden row at the bottom which takes - # up any extra room - - grid rowconfigure $frame $count -weight 1 - - pack $frame -side right -fill both -expand y - update idletasks - set maxwidth [max $maxwidth [winfo reqwidth $w(preferences)]] - set maxheight [max $maxheight [winfo reqheight $w(preferences)]] - pack forget $frame - - # Display - set frame $w(preferences).fDisplay - set row 0 - - # Option fields - # Note that the order of the list is used to determine - # the layout. So, if you add something to the list pay - # attention to how it affects things. - # - # an x means an empty column; a - means an empty row - set col 0 - foreach key [list showln tagln showcbs tagcbs showmap colorcbs \ - showlineview tagtext ignoreblanks showinline1 x showinline2 x] { - - if {$key == "x"} { - set col [expr {$col ? 0 : 1}] - if {$col == 0} { - incr row - } - continue - } - - if {$key == "-"} { - frame $frame.f${row} -bd 0 -height 4 - grid $frame.f${row} -row $row -column 0 -columnspan 2 -padx 20 \ - -pady 4 -sticky nsew - set col 1 ;# will force next column to zero and incr row - - } else { - - checkbutton $frame.c${row}${col} -indicatoron true \ - -text "$pref($key)" -onvalue 1 -offvalue 0 -variable tmpopts($key) - - set tmpopts($key) $opts($key) - - grid $frame.c${row}$col -row $row -column $col -sticky w -padx 5 - } - - set col [expr {$col ? 0 : 1}] - if {$col == 0} { - incr row - } - } - - grid columnconfigure $frame 0 -weight 0 - grid columnconfigure $frame 1 -weight 0 - grid columnconfigure $frame 2 -weight 0 - grid columnconfigure $frame 3 -weight 0 - grid columnconfigure $frame 4 -weight 1 - - # add validation to make only one of the showinline# options are set - trace variable tmpopts(showinline1) w [list validate-inline showinline1] - trace variable tmpopts(showinline2) w [list validate-inline showinline2] - - # this, in effect, adds a hidden row at the bottom which takes - # up any extra room - - grid rowconfigure $frame $row -weight 1 - - pack $frame -side right -fill both -expand y - update idletasks - set maxwidth [max $maxwidth [winfo reqwidth $w(preferences)]] - set maxheight [max $maxheight [winfo reqheight $w(preferences)]] - pack forget $frame - - customize-selectPage - - # compute a reasonable location for the window... - centerWindow $w(preferences) [list $maxwidth $maxheight] - - wm deiconify $w(preferences) -} - -proc validate {type name index op} { - global tmpopts - - # if we fail the check, attempt to do something clever - if {![string is $type $tmpopts($index)]} { - bell - - switch -- $type { - integer { - regsub -all {[^0-9]} $tmpopts($index) {} tmpopts($index) - } - default { - # this should never happen. If you use this routine, - # make sure you add cases to handle all possible - # values of $type used by this program. - set tmpopts($index) "" - } - } - } -} - -proc validate-inline {option name index op} { - global tmpopts - - if {$tmpopts($index)} { - if {$index == "showinline1"} { - set tmpopts(showinline2) 0 - } elseif {$index == "showinline2"} { - set tmpopts(showinline1) 0 - } - } -} - -proc customize-selectPage {{frame {}}} { - global g w - - if {$frame == ""} { - set frame $g(prefPage) - } - - pack forget $w(preferences).fGeneral - pack forget $w(preferences).fAppearance - pack forget $w(preferences).fDisplay - pack forget $w(preferences).fBehavior - pack $frame -side right -fill both -expand y -} - -############################################################################### -# define the labels for the preferences. This is done outside of -# the customize proc since the labels are used in the help text. -############################################################################### -proc customize-initLabels {} { - global pref - - set pref(diffcmd) {diff command} - set pref(ignoreblanksopt) {Ignore blanks option} - set pref(ignoreblanks) {Ignore blanks when diffing} - set pref(textopt) {Text widget options} - set pref(bytetag) {Tag options for characters in line view} - set pref(difftag) {Tag options for diff regions} - set pref(currtag) {Tag options for the current diff region} - set pref(inlinetag) {Tag options for diff region inline differences} - set pref(deltag) {Tag options for deleted diff region} - set pref(instag) {Tag options for inserted diff region} - set pref(chgtag) {Tag options for changed diff region} - set pref(overlaptag) {Tag options for overlap diff region} - set pref(geometry) {Text window size} - set pref(tmpdir) {Directory for scratch files} - set pref(editor) {Program for editing files} - - set pref(fancyButtons) {Windows-style toolbar buttons} - set pref(showlineview) {Show current line comparison window} - set pref(showinline1) {Show inline diffs (byte comparisons)} - set pref(showinline2) {Show inline diffs (recursive matching algorithm)} - set pref(showmap) {Show graphical map of diffs} - set pref(showln) {Show line numbers} - set pref(showcbs) {Show change bars} - set pref(autocenter) {Automatically center current diff region} - set pref(syncscroll) {Synchronize scrollbars} - set pref(toolbarIcons) {Use icons instead of labels in the toolbar} - - set pref(colorcbs) {Color change bars to match the diff map} - set pref(tagtext) {Highlight file contents} - set pref(tagcbs) {Highlight change bars} - set pref(tagln) {Highlight line numbers} - set pref(tabstops) {Tab stops} - - set pref(autoselect) "Automatically select the nearest diff region while \ - scrolling" -} - -############################################################################### -# Apply customization changes. -############################################################################### -proc apply {{remark 0}} { - debug-info "apply ($remark)" - global opts - global tmpopts - global w - global pref - global screenWidth - global screenHeight - global tk_version - - grid propagate $w(client) t - if {! [file isdirectory $tmpopts(tmpdir)]} { - do-error "Invalid temporary directory $tmpopts(tmpdir)" - } - - if {[catch " - $w(LeftText) configure $tmpopts(textopt) - $w(RightText) configure $tmpopts(textopt) - $w(BottomText) configure $tmpopts(textopt) - "]} { - do-error "Invalid text widget setting: \n\n'$tmpopts(textopt)'" - eval "$w(LeftText) configure $opts(textopt)" - eval "$w(RightText) configure $opts(textopt)" - eval "$w(BottomText) configure $opts(textopt)" - return - } - - # the text options must be ok. Configure the other text widgets - # similarly - eval "$w(LeftCB) configure $tmpopts(textopt)" - eval "$w(LeftInfo) configure $tmpopts(textopt)" - eval "$w(RightCB) configure $tmpopts(textopt)" - eval "$w(RightInfo) configure $tmpopts(textopt)" - - set gridsize [wm grid .] - set gridx [lindex $gridsize 2] - set gridy [lindex $gridsize 3] - debug-info " wm grid is $gridx x $gridy" - - set maxunitsx [expr {$screenWidth / $gridx}] - set maxunitsy [expr {$screenHeight / $gridy}] - debug-info " max X is $maxunitsx units" - debug-info " max Y is $maxunitsy units" - set halfmax [expr {$maxunitsx / 2}] - - if {$tmpopts(geometry) == "" || [catch {scan $tmpopts(geometry) \ - "%dx%d" width height} result]} { - do-error "invalid geometry setting: $tmpopts(geometry)" - return - } - debug-info " width $width halfmax $halfmax" - set maxw [expr {$halfmax - 18}] - debug-info " maxw $maxw" - if {$width > $maxw} { - set width $maxw - } - # re-center map - if {$tk_version < 8.4} { - grid columnconfigure $w(client) 0 -weight 1 - grid columnconfigure $w(client) 2 -weight 1 - } else { - grid columnconfigure $w(client) 0 -weight 100 -uniform a - grid columnconfigure $w(client) 2 -weight 100 -uniform a - } - - if {[catch {$w(LeftText) configure -width $width -height $height} result]} { - do-error "invalid geometry setting: $tmpopts(geometry)" - return - } - $w(RightText) configure -width $width -height $height - - $w(LeftLabel) configure -width $width - $w(RightLabel) configure -width $width - - grid forget $w(LeftLabel) - grid forget $w(RightLabel) - grid $w(LeftLabel) -row 0 -column 0 -sticky ew - grid $w(RightLabel) -row 0 -column 2 -sticky ew - - foreach tag {difftag currtag inlinetag deltag instag chgtag overlaptag} { - foreach win [list $w(LeftText) $w(LeftInfo) $w(LeftCB) $w(RightText) \ - $w(RightInfo) $w(RightCB)] { - if {[catch "$win tag configure $tag $tmpopts($tag)"]} { - do-error "Invalid settings for \"$pref($tag)\": \ - \n\n'$tmpopts($tag)' is not a valid option string" - eval "$win tag configure $tag $opts($tag)" - return - } - } - } - - if {[catch "$w(BottomText) tag configure diff $tmpopts(bytetag)"]} { - do-error "Invalid settings for \"$pref(bytetag)\": \ - \n\n'$tmpopts(bytetag)' is not a valid option string" - eval "$w(BottomText) tag configure diff $opts(bytetag)" - return - } - - # tabstops require a little extra work. We need to figure out - # the width of an "m" in the widget's font, then multiply that - # by the tab stop width. For the bottom text widget the first tabstop - # is adjusted by two to take into consideration the fact that we - # add two bytes to each line (ie: "< " or "> "). - set cwidth [font measure [$w(LeftText) cget -font] "m"] - set tabstops [expr {$cwidth * $tmpopts(tabstops)}] - $w(LeftText) configure -tabs $tabstops - $w(RightText) configure -tabs $tabstops - - $w(BottomText) configure -tabs [list [expr {$tabstops +($cwidth * 2)}] \ - [expr {2*$tabstops +($cwidth * 2)}]] - - if {[info exists w(mergeText)] && [winfo exists $w(mergeText)]} { - $w(mergeText) configure -tabs $tabstops - } - - # set opts to the values from tmpopts - foreach key {autocenter autoselect chgtag colorcbs currtag deltag diffcmd \ - difftag inlinetag editor fancyButtons geometry ignoreblanks \ - ignoreblanksopt instag overlaptag showcbs showlineview showln showmap \ - syncscroll tabstops tagcbs tagln tagtext textopt tmpdir toolbarIcons} { - set opts($key) $tmpopts($key) - } - if {$opts(fancyButtons)} { - set opts(relief) flat - } else { - set opts(relief) raised - } - - # determine if we need to redo the inline diffs to avoid needless rediff - if {$opts(showinline1) != $tmpopts(showinline1) || $opts(showinline2) != \ - $tmpopts(showinline2)} { - set opts(showinline1) $tmpopts(showinline1) - set opts(showinline2) $tmpopts(showinline2) - recompute-diff - } - - # reconfigure the toolbar buttons - reconfigure-toolbar - - # remark all the diff regions, show (or hide) the line numbers, - # change bars and diff map, and we are done - if {$remark} { - remark-diffs - } - - do-show-linenumbers - do-show-changebars - do-show-map - do-show-lineview - do-show-ignoreblanks - grid propagate $w(client) f -} - -############################################################################### -# Save customization changes. -############################################################################### -proc save {} { - debug-info "save" - global g - global tmpopts rcfile tcl_platform - global pref - - if {[file exists $rcfile]} { - file rename -force $rcfile "$rcfile~" - } - - set fid [open $rcfile w] - - # put the tkdiff version in the file. It might be handy later - puts $fid "# This file was generated by $g(name) $g(version)" - puts $fid "# [clock format [clock seconds]]\n" - puts $fid "set prefsFileVersion {$g(version)}\n" - - # now, put all of the preferences in the file - foreach key [lsort [array names pref]] { - regsub "\n" $pref($key) "\n# " comment - puts $fid "# $comment" - puts $fid "define $key {$tmpopts($key)}\n" - } - - # ... and any custom code - puts $fid "# custom code" - puts $fid "# put any custom code you want to be executed in the" - puts $fid "# following block. This code will be automatically executed" - puts $fid "# after the GUI has been set up but before the diff is " - puts $fid "# performed. Use this code to customize the interface if" - puts $fid "# you so desire." - puts $fid "# " - puts $fid "# Even though you can't (as of version 3.09) edit this " - puts $fid "# code via the preferences dialog, it will be automatically" - puts $fid "# saved and restored if you do a SAVE from that dialog." - puts $fid "" - puts $fid "# Unless you really know what you are doing, it is probably" - puts $fid "# wise to leave this unmodified." - puts $fid "" - puts $fid "define customCode {\n[string trim $tmpopts(customCode) \n]\n}\n" - - close $fid - - if {$::tcl_platform(platform) == "windows"} { - file attribute $rcfile -hidden 1 - } -} - -############################################################################### -# Text has scrolled, update scrollbars and synchronize windows -############################################################################### -proc hscroll-sync {id args} { - global g opts - global w - - # If ignore_event is true, we've already taken care of scrolling. - # We're only interested in the first event. - if {$g(ignore_hevent,$id)} { - return - } - - # Scrollbar sizes - set size1 [expr {[lindex [$w(LeftText) xview] 1] - [lindex \ - [$w(LeftText) xview] 0]}] - set size2 [expr {[lindex [$w(RightText) xview] 1] - [lindex \ - [$w(RightText) xview] 0]}] - - if {$opts(syncscroll) || $id == 1} { - set start [lindex $args 0] - - if {$id != 1} { - set start [expr {$start * $size2 / $size1}] - } - $w(LeftHSB) set $start [expr {$start + $size1}] - $w(LeftText) xview moveto $start - set g(ignore_hevent,1) 1 - } - if {$opts(syncscroll) || $id == 2} { - set start [lindex $args 0] - if {$id != 2} { - set start [expr {$start * $size1 / $size2}] - } - $w(RightHSB) set $start [expr {$start + $size2}] - $w(RightText) xview moveto $start - set g(ignore_hevent,2) 1 - } - - # This forces all the event handlers for the view alterations - # above to trigger, and we lock out the recursive (redundant) - # events using ignore_event. - update idletasks - - # Restore to normal - set g(ignore_hevent,1) 0 - set g(ignore_hevent,2) 0 -} - -############################################################################### -# Text has scrolled, update scrollbars and synchronize windows -############################################################################### -proc vscroll-sync {windowlist id y0 y1} { - global g opts - global w - - if {$id == 1} { - $w(LeftVSB) set $y0 $y1 - } else { - $w(RightVSB) set $y0 $y1 - } - - # if syncing is disabled, we're done. This prevents a nasty - # set of recursive calls - if {[info exists g(disableSyncing)]} { - return - } - - # set the flag; this makes sure we only get called once - set g(disableSyncing) 1 - - # scroll the other windows on the same side as this window - foreach window $windowlist { - $window yview moveto $y0 - } - - eval map-move-thumb $y0 $y1 - - # Select nearest visible diff region, if the appropriate - # options are set - if {$opts(syncscroll) && $opts(autoselect) && $g(count) > 0} { - set winhalf [expr {[winfo height $w(RightText)] / 2}] - set result [find-diff [expr {int([$w(RightText) index @1,$winhalf])}]] - set i [lindex $result 0] - - # have we found a diff other than the current diff? - if {$i != $g(pos)} { - # Also, make sure the diff is visible. If not, we won't - # change the current diff region... - set topline [$w(RightText) index @0,0] - set bottomline [$w(RightText) index @0,10000] - foreach {line s1 e1 s2 e2 type} $g(scrdiff,$i) { } - if {$s1 >= $topline && $s1 <= $bottomline} { - move $i 0 1 - } - } - } - - # if syncing is turned on, scroll other windows. - # Annoyingly, sometimes the *Text windows won't scroll properly, - # at least under windows. And I can't for the life of me figure - # out why. Maybe a bug in tk? - if {$opts(syncscroll)} { - if {$id == 1} { - - $w(RightText) yview moveto $y0 - $w(RightInfo) yview moveto $y0 - $w(RightCB) yview moveto $y0 - $w(RightVSB) set $y0 $y1 - - } else { - - $w(LeftText) yview moveto $y0 - $w(LeftInfo) yview moveto $y0 - $w(LeftCB) yview moveto $y0 - $w(LeftVSB) set $y0 $y1 - } - } - - # we apparently automatically process idle events after this - # proc is called. Once that is done we'll unset our flag - after idle {catch {unset g(disableSyncing)}} -} - -############################################################################### -# Make a miniature map of the diff regions -############################################################################### -proc create-map {name mapwidth mapheight} { - global g - global w - global map - global opts - - set map $name - - # Text widget always contains blank line at the end - set lines [expr {double([$w(LeftText) index end]) - 2}] - set factor [expr {$mapheight / $lines}] - - # We add some transparent stuff to make the map fill the canvas - # in order to receive mouse events at the very bottom. - $map blank - $map put \#000 -to 0 $mapheight $mapwidth $mapheight - - # Line numbers start at 1, not at 0. - for {set i 1} {$i <= $g(count)} {incr i} { - # scan $g(scrdiff,$i) "%s %d %d %d %d %s" line s1 e1 s2 e2 type - foreach {line s1 e1 s2 e2 type} $g(scrdiff,$i) { } - - set y [expr {int(($s2 - 1) * $factor) + $g(mapborder)}] - set size [expr {round(($e2 - $s2 + 1) * $factor)}] - if {$size < 1} { - set size 1 - } - switch -- $type { - "d" { - set color $opts(mapdel) - } - "a" { - set color $opts(mapins) - } - "c" { - set color $opts(mapchg) - } - } - if {[info exists g(overlap$i)]} { - set color yellow - } - - $map put $color -to 0 $y $mapwidth [expr {$y + $size}] - - } - - # let's draw a rectangle to simulate a scrollbar thumb. The size - # isn't important since it will get resized when map-move-thumb - # is called... - $w(mapCanvas) create line 0 0 0 0 -width 1 -tags thumbUL -fill white - $w(mapCanvas) create line 1 1 1 1 -width 1 -tags thumbLR -fill black - $w(mapCanvas) raise thumb - - # now, move the thumb - eval map-move-thumb [$w(LeftText) yview] - -} - -############################################################################### -# Resize map to fit window size -############################################################################### -proc map-resize {args} { - global g opts - global w - - set mapwidth [winfo width $w(map)] - set g(mapborder) [expr {[$w(map) cget -borderwidth] + [$w(map) cget \ - -highlightthickness]}] - set mapheight [expr {[winfo height $w(map)] - $g(mapborder) * 2}] - - # We'll get a couple of "resize" events, so don't draw a map - # unless we've got the diffs and the map size has changed - if {$g(count) == 0 || $mapheight == $g(mapheight)} { - return - } - - # If we don't have a map and don't want one, don't make one - if {$g(mapheight) == 0 && $opts(showmap) == 0} { - return - } - - # This seems to happen on Windows!? _After_ the map is drawn the first time - # another event triggers and [winfo height $w(map)] is then 0... - if {$mapheight < 1} { - return - } - - set g(mapheight) $mapheight - set g(mapwidth) $mapwidth - create-map map $mapwidth $mapheight -} - -############################################################################### -# scroll to diff region nearest to y -############################################################################### -proc map-scroll {y} { - global g - global w - global opts - - set yview [expr {double($y) / double($g(mapheight))}] - # Show text corresponding to map - catch {$w(RightText) yview moveto $yview} result - update idletasks - - # Select the diff region closest to the middle of the screen - set winhalf [expr {[winfo height $w(RightText)] / 2}] - set result [find-diff [expr {int([$w(RightText) index @1,$winhalf])}]] - move [lindex $result 0] 0 0 - - if {$opts(autocenter)} { - center - } - - if {$g(showmerge)} { - merge-center - } -} - -############################################################################### -# Toggle showing the line comparison window -############################################################################### -proc do-show-lineview {{showLineview {}}} { - global opts - global w - - if {$showLineview != {}} { - set opts(showlineview) $showLineview - } - - if {$opts(showlineview)} { - grid $w(BottomText) -row 3 -column 0 -sticky ew -columnspan 4 - } else { - grid forget $w(BottomText) - } -} - -############################################################################### -# Toggle showing inline comparison -############################################################################### -proc do-show-inline1 {{showInline1 {}}} { - global opts - - if {$showInline1 != {}} { - puts "passed in value=$showInline1" - set opts(showinline1) $showInline1 - } - - # mutually disjoint options - if {$opts(showinline1)} { - set opts(showinline2) 0 - } - recompute-diff -} - -proc do-show-inline2 {{showInline2 {}}} { - global opts - - if {$showInline2 != {}} { - set opts(showinline2) $showInline2 - } - - # mutually disjoint options - if {$opts(showinline2)} { - set opts(showinline1) 0 - } - recompute-diff -} - -############################################################################### -# Toggle showing map or not -############################################################################### -proc do-show-map {{showMap {}}} { - global opts - global w - - if {$showMap != {}} { - set opts(showmap) $showMap - } - - if {$opts(showmap)} { - grid $w(map) -row 1 -column 1 -stick ns - } else { - grid forget $w(map) - } -} - -############################################################################### -# Find the diff nearest to $line. -# Returns "$i $newtop" where $i is the index of the diff region -# and $newtop is the new top line in the window to the right. -############################################################################### -proc find-diff {line} { - global g - global w - - set top $line - set newtop [expr {$top - int([$w(LeftText) index end]) + \ - int([$w(RightText) index end])}] - - for {set low 1; set high $g(count); set i [expr {($low + $high) / 2}]} \ - {$i >= $low} {set i [expr {($low + $high) / 2}]} { - - foreach {line s1 e1 s2 e2 type} $g(scrdiff,$i) { } - - if {$s1 > $top} { - set newtop [expr {$top - $s1 + $s2}] - set high [expr {$i-1}] - } else { - set low [expr {$i+1}] - } - } - - # do some range checking... - set i [max 1 [min $i $g(count)]] - - # If next diff is closer than the one found, use it instead - if {$i > 0 && $i < $g(count)} { - set nexts1 [lindex $g(scrdiff,[expr {$i + 1}]) 1] - set e1 [lindex $g(scrdiff,$i) 2] - if {$nexts1 - $top < $top - $e1} { - incr i - } - } - - return [list $i $newtop] -} - -############################################################################### -# Calculate number of lines in diff region -# pos Diff number -# version 1 or 2, left or right window version -# screen 1 for screen size, 0 for original diff size -############################################################################### -proc diff-size {pos version {screen 0}} { - global g - - if {$screen} { - set diff scrdiff - } else { - set diff pdiff - } - - foreach {thisdiff s(1) e(1) s(2) e(2) type} $g($diff,$pos) { } - - switch -- $version { - 1 { - set lines [expr {$e(1) - $s(1) + 1}] - if {$type == "a"} { - incr lines -1 - } - } - 2 { - set lines [expr {$e(2) - $s(2) + 1}] - if {$type == "d"} { - incr lines -1 - } - } - 12 - - 21 { - set lines [expr {$e(1) - $s(1) + $e(2) - $s(2) + 1}] - } - } - return $lines -} - -############################################################################### -# Toggle showing merge preview or not -############################################################################### -proc do-show-merge {{showMerge ""}} { - debug-info "do-show-merge ($showMerge)" - global g - global w - - if {$showMerge != ""} { - set g(showmerge) $showMerge - } - - if {$g(showmerge)} { - watch-cursor - if {! [info exists w(mergeText]} { - merge-read-file - merge-add-marks - } - wm deiconify .merge - $w(mergeText) configure -state disabled - focus -force $w(mergeText) - merge-center - } else { - wm withdraw $w(merge) - } - debug-info " ...restore-cursor from do-show-merge" - restore-cursor -} - -############################################################################### -# Create Merge preview window -############################################################################### -proc merge-create-window {} { - debug-info "merge-create-window" - global opts - global w - global g - - set top .merge - set w(merge) $top - - catch {destroy $top} - - toplevel $top - set rx [winfo rootx .] - set ry [winfo rooty .] - set px [winfo width .] - set py [winfo height .] - #debug-info " rx $rx ry $ry px $px py $py" - set x [expr {$rx + $px / 4}] - set y [expr {$ry + $py / 2}] - wm geometry $top "+${x}+$y" - - wm group $top . - wm title $top "$g(name) Merge Preview" - - frame $top.frame -bd 1 -relief sunken - pack $top.frame -side top -fill both -expand y -padx 10 -pady 10 - - set w(mergeText) $top.frame.text - set w(mergeVSB) $top.frame.vsb - set w(mergeHSB) $top.frame.hsb - set w(mergeDismiss) $top.dismiss - set w(mergeWrite) $top.mergeWrite - set w(mergeWriteAndExit) $top.mergeWriteAndExit - set w(mergeExit) $top.mergeExit - set w(mergeRecenter) $top.mergeRecenter - - # Window and scrollbars - scrollbar $w(mergeHSB) -orient horizontal -command [list $w(mergeText) \ - xview] - scrollbar $w(mergeVSB) -orient vertical -command [list $w(mergeText) yview] - - text $w(mergeText) -bd 0 -takefocus 1 -yscrollcommand [list $w(mergeVSB) \ - set] -xscrollcommand [list $w(mergeHSB) set] - - grid $w(mergeText) -row 0 -column 0 -sticky nsew - grid $w(mergeVSB) -row 0 -column 1 -sticky ns - grid $w(mergeHSB) -row 1 -column 0 -sticky ew - - grid rowconfigure $top.frame 0 -weight 1 - grid rowconfigure $top.frame 1 -weight 0 - - grid columnconfigure $top.frame 0 -weight 1 - grid columnconfigure $top.frame 1 -weight 0 - - # buttons - button $w(mergeRecenter) -width 8 -text "ReCenter" -underline 0 \ - -command merge-center - - button $w(mergeDismiss) -width 8 -text "Dismiss" -underline 0 \ - -command "do-show-merge 0" - - if {$g(mergefileset)} { - button $w(mergeWrite) -width 8 -text "Save" -underline 0 \ - -command [list popup-merge merge-write-file] - button $w(mergeWriteAndExit) -width 8 -text "Save & Exit" \ - -underline 8 -command { - popup-merge merge-write-file - exit - } - } else { - button $w(mergeWrite) -width 8 -text "Save..." -underline 0 \ - -command [list popup-merge merge-write-file] - button $w(mergeWriteAndExit) -width 10 -text "Save & Exit..." \ - -underline 8 -command { - popup-merge merge-write-file - exit - } - } - button $w(mergeExit) -width 8 -text "Exit $g(name)" -underline 0 \ - -command {exit} - - pack $w(mergeDismiss) -side right -pady 5 -padx 10 - pack $w(mergeRecenter) -side right -pady 5 -padx 1 - pack $w(mergeWrite) -side right -pady 5 -padx 1 - pack $w(mergeWriteAndExit) -side right -pady 5 -padx 1 - pack $w(mergeExit) -side right -pady 5 -padx 1 - - eval $w(mergeText) configure $opts(textopt) - foreach tag {difftag currtag} { - eval $w(mergeText) tag configure $tag $opts($tag) - } - - # adjust the tabstops - set cwidth [font measure [$w(mergeText) cget -font] "m"] - set tabstops [expr {$cwidth * $opts(tabstops)}] - $w(mergeText) configure -tabs $tabstops - - wm protocol $w(merge) WM_DELETE_WINDOW {do-show-merge 0} - - # adjust the tag priorities a bit... - $w(mergeText) tag raise sel - $w(mergeText) tag raise currtag difftag - - common-navigation $w(mergeText) - - if {! $g(showmerge)} { - wm withdraw $w(merge) - } -} - -############################################################################### -# Read original file (Left window file) into merge preview window. -# Not so good if it has changed. -############################################################################### -proc merge-read-file {} { - debug-info "merge-read-file" - global finfo - global w - - # hack; need to find a cleaner way... - catch {destroy .merge} - merge-create-window - - set hndl [open "$finfo(pth,1)" r] - $w(mergeText) configure -state normal - $w(mergeText) delete 1.0 end - $w(mergeText) insert 1.0 [read $hndl] - close $hndl - - # If last line doesn't end with a newline, add one. Important when - # writing out the merge preview. - if {![regexp {\.0$} [$w(mergeText) index "end-1lines lineend"]]} { - $w(mergeText) insert end "\n" - } - $w(mergeText) configure -state disabled -} - -############################################################################### -# Write merge preview to file -############################################################################### -proc merge-write-file {} { - global g - global w - - set hndl [open "$g(mergefile)" w] - set text [$w(mergeText) get 1.0 end-1lines] - puts -nonewline $hndl $text - close $hndl -} - -############################################################################### -# Add a mark where each diff begins and tag diff regions so they are visible. -# Assumes text is initially the bare original (Left) version. -############################################################################### -proc merge-add-marks {} { - global g - global w - - # mark all lines first, so selection won't mess up line numbers - for {set i 1} {$i <= $g(count)} {incr i} { - foreach [list thisdiff s1 e1 s2 e2 type] $g(pdiff,$i) { } - # set delta [expr {$type == "a" ? 1 : 0}] - # $w(mergeText) mark set mark$i $s1.0+${delta}lines - if {$type == "a"} { - incr s1 - } - $w(mergeText) mark set mark$i $s1.0 - $w(mergeText) mark gravity mark$i left - } - - # if a 3-way merge, select right window as needed - if {$g(ancfileset) && $g(count) > 0} { - # - # If there was something different between file1 - # and the ancestor, pick the left window, but... - # - for {set i 1} {$i <= $g(count)} {incr i} { - set s1 [lindex $g(pdiff,$i) 1] - set s2 [lindex $g(pdiff,$i) 2] - for {set p $s1} {$p <= $s2} {incr p} { - if {[info exists g(diff3l$p)]} { - set g(merge$i) 1 - break - } - } - } - - # - # ... if there was a diff between file2 and the ancestor, - # then file2 takes precedence - # - for {set i 1} {$i <= $g(count)} {incr i} { - set s1 [lindex $g(pdiff,$i) 3] - set s2 [lindex $g(pdiff,$i) 4] - for {set p $s1} {$p <= $s2} {incr p} { - if {[info exists g(diff3r$p)]} { - set g(merge$i) 2 - break - } - } - } - } - - # select merged lines - for {set i 1} {$i <= $g(count)} {incr i} { - foreach [list thisdiff s1 e1 s2 e2 type] $g(pdiff,$i) { } - - if {$g(merge$i) == 1} { - # (If it's an insert it's not visible) - if {$type != "a"} { - set lines [expr {$e1 - $s1 + 1}] - $w(mergeText) tag add difftag mark$i mark$i+${lines}lines - } - } else { - # Insert right window version - merge-select-version $i 1 2 - } - } - - # Tag current - if {$g(count) > 0} { - set pos $g(pos) - set lines [diff-size $pos $g(merge$pos)] - $w(mergeText) tag add currtag mark$pos "mark$pos+${lines}lines" - } -} - -############################################################################### -# Add a mark where each diff begins -# pos diff index -# oldversion 1 or 2, previous merge choice -# newversion 1 or 2, new merge choice -############################################################################### -proc merge-select-version {pos oldversion newversion} { - global g - global w - - catch { - switch -- $oldversion { - 1 - - 2 {set oldlines [diff-size $pos $oldversion]} - 12 - - 21 {set oldlines [expr {[diff-size $pos 1] + [diff-size $pos 2]}]} - } - $w(mergeText) configure -state normal - $w(mergeText) delete mark$pos "mark${pos}+${oldlines}lines" - $w(mergeText) configure -state disabled - } - - # Screen coordinates - foreach {thisdiff s(1) e(1) s(2) e(2) type} $g(scrdiff,$pos) { } - - # Get the text directly from window - switch -- $newversion { - 1 { - set newlines [diff-size $pos 1] - set newtext [$w(LeftText) get $s(1).0 $s(1).0+${newlines}lines] - } - 2 { - set newlines [diff-size $pos 2] - set newtext [$w(RightText) get $s(2).0 $s(2).0+${newlines}lines] - } - 12 { - set newlines [diff-size $pos 1] - set newtext [$w(LeftText) get $s(1).0 $s(1).0+${newlines}lines] - set newlines [diff-size $pos 2] - append newtext [$w(RightText) get $s(2).0 $s(2).0+${newlines}lines] - incr newlines [diff-size $pos 1] - } - 21 { - set newlines [diff-size $pos 2] - set newtext [$w(RightText) get $s(2).0 $s(2).0+${newlines}lines] - set newlines [diff-size $pos 1] - append newtext [$w(LeftText) get $s(1).0 $s(1).0+${newlines}lines] - incr newlines [diff-size $pos 2] - } - } - - # Insert it - $w(mergeText) configure -state normal - $w(mergeText) insert mark$pos $newtext diff - $w(mergeText) configure -state disabled - if {$pos == $g(pos)} { - $w(mergeText) tag add currtag mark$pos "mark${pos}+${newlines}lines" - } -} - -############################################################################### -# Center the merge region in the merge window -############################################################################### -proc merge-center {} { - global g - global w - - # bail if there are no diffs - if {$g(count) == 0} { - return - } - # Size of diff in lines of text - set difflines [diff-size $g(pos) $g(merge$g(pos))] - set yview [$w(mergeText) yview] - # Window height in percent - set ywindow [expr {[lindex $yview 1] - [lindex $yview 0]}] - # First line of diff - set firstline [$w(mergeText) index mark$g(pos)] - # Total number of lines in window - set totallines [$w(mergeText) index end] - - if {$difflines / $totallines < $ywindow} { - # Diff fits in window, center it - $w(mergeText) yview moveto [expr {($firstline + $difflines / 2) / \ - $totallines - $ywindow / 2}] - } else { - # Diff too big, show top part - $w(mergeText) yview moveto [expr {($firstline - 1) / $totallines}] - } -} - -############################################################################### -# Update the merge preview window with the current merge choice -# newversion 1 or 2, new merge choice -############################################################################### -proc do-merge-choice {newversion} { - debug-info "do-merge-choice ($newversion)" - global g opts - global w - - if {! [info exists w(mergeText)] || ! [winfo exists $w(mergeText)]} { - return - } - $w(mergeText) configure -state normal - merge-select-version $g(pos) $g(merge$g(pos)) $newversion - $w(mergeText) configure -state disabled - - set g(merge$g(pos)) $newversion - if {$g(showmerge) && $opts(autocenter)} { - merge-center - } - set g(toggle) $newversion -} - -############################################################################### -# Extract the start and end lines for file1 and file2 from the diff -# stored in "line". -############################################################################### -proc extract {line} { - # the line darn well better be of the form , - # where op is one of "a","c" or "d". range will either be a - # single number or two numbers separated by a comma. - - # is this a cool regular expression, or what? :-) - regexp {([0-9]*)(,([0-9]*))?([a-z])([0-9]*)(,([0-9]*))?} $line matchvar \ - s1 x e1 op s2 x e2 - if {[string length $e1] == 0} { - set e1 $s1 - } - if {[string length $e2] == 0} { - set e2 $s2 - } - - if {[info exists s1] && [info exists s2]} { - # return "$line $s1 $e1 $s2 $e2 $op" - return [list $line $s1 $e1 $s2 $e2 $op] - } else { - fatal-error "Cannot parse output from diff:\n$line" - } - -} - -############################################################################### -# Insert blank lines to match added/deleted lines in other file -############################################################################### -proc add-lines {pos} { - global g - global w - global opts - - # Figure out which lines we need to address... - foreach [list thisdiff s1 e1 s2 e2 type] $g(pdiff,$pos) { } - - set size(1) [expr {$e1 - $s1}] - set size(2) [expr {$e2 - $s2}] - - incr s1 $g(delta,1) - incr s2 $g(delta,2) - - # Figure out what kind of diff we're dealing with - switch -- $type { - "a" { - set lefttext " " ;# insert - set righttext "+" - set idx 1 - set count [expr {$size(2) + 1}] - - incr s1 - incr size(2) - } - "d" { - set lefttext "-" ;# delete - set righttext " " - set idx 2 - set count [expr {$size(1) + 1}] - - incr s2 - incr size(1) - } - "c" { - set lefttext "!" ;# change - set righttext "!" ;# change - if {$g(ancfileset)} { - set change $g(pdiff,$g(count)) - set leftBegin [lindex $change 1] - set leftEnd [lindex $change 2] - set rightBegin [lindex $change 3] - set rightEnd [lindex $change 4] - - set changeLeft 0 - set changeRight 0 - for {set i $leftBegin} {$i <= $leftEnd} {incr i} { - if {[info exists g(diff3l$i)]} { - set changeLeft 1 - break - } - } - if {$changeLeft} { - for {set i $rightBegin} {$i <= $rightEnd} {incr i} { - if {[info exists g(diff3r$i)]} { - set changeRight 1 - break - } - } - } - if {$changeLeft && $changeRight} { - set lefttext "?" ;# overlap - set righttext "?" ;# overlap - set g(overlap$pos) 1 - } - } - set idx [expr {$size(1) < $size(2) ? 1 : 2}] - set count [expr {abs($size(1) - $size(2))}] - - incr size(1) - incr size(2) - } - } - - # Put plus signs in left info column - if {$idx == 1} { - set textWidget $w(LeftText) - set infoWidget $w(LeftInfo) - set cbWidget $w(LeftCB) - # set blank "++++++\n" - set blank " \n" - } else { - set textWidget $w(RightText) - set infoWidget $w(RightInfo) - set cbWidget $w(RightCB) - set blank " \n" - } - - # Insert blank lines to match other window - set line [expr {$s1 + $size($idx)}] - for {set i 0} {$i < $count} {incr i} { - $textWidget insert $line.0 "\n" - $infoWidget insert $line.0 $blank - $cbWidget insert $line.0 "\n" - } - - incr size($idx) $count - set e1 [expr {$s1 + $size(1) - 1}] - set e2 [expr {$s2 + $size(2) - 1}] - incr g(delta,$idx) $count - - # Insert change bars or text to show what has changed. - $w(RightCB) configure -state normal - $w(LeftCB) configure -state normal - for {set i $s1} {$i <= $e1} {incr i} { - $w(LeftCB) insert $i.0 $lefttext - $w(RightCB) insert $i.0 $righttext - } - - # Save the diff block in window coordinates - set g(scrdiff,$g(count)) [list $thisdiff $s1 $e1 $s2 $e2 $type] - - set g(scrinline,$pos) 0 - if {$opts(showinline1) || $opts(showinline2)} { - if {$type == "c"} { - set numlines [max [expr {$e1-$s1+1}] [expr {$e2-$s2+1}]] - for {set i 0} {$i < $numlines} {incr i} { - set l1 [expr $s1+$i] - set l2 [expr $s2+$i] - if {$opts(showinline1)} { - find-inline-diff-byte $pos $l1 $l2 [$w(LeftText) get \ - $l1.0 $l1.end] [$w(RightText) get $l2.0 $l2.end] - } else { - find-inline-diff-ratcliff $pos $l1 $l2 [$w(LeftText) get \ - $l1.0 $l1.end] [$w(RightText) get $l2.0 $l2.end] - } - } - } - } -} - -############################################################################### -# Add a tag to a region. -############################################################################### -proc add-tag {wgt tag start end type new {exact 0}} { - global g - - $wgt tag add $tag $start.0 [expr {$end + 1}].0 - -} - -proc add-inline-tag {wgt tag line startcol endcol} { - $wgt tag add $tag $line.$startcol $line.$endcol -} - -############################################################################### -# Change the tag for a diff region. -# 'pos' is the index in the diff array -# If 'oldtag' is present, first remove it from the region -# If 'setpos' is non-zero, make sure the region is visible. -# Returns the diff expression. -############################################################################### -proc set-tag {pos newtag {oldtag ""} {setpos 0}} { - global g opts - global w - - # Figure out which lines we need to address... - if {![info exists g(scrdiff,$pos)]} { - return - } - foreach {thisdiff s1 e1 s2 e2 dt} $g(scrdiff,$pos) { } - - # Remove old tag - if {"$oldtag" != ""} { - set e1next "[expr {$e1 + 1}].0" - set e2next "[expr {$e2 + 1}].0" - $w(LeftText) tag remove $oldtag $s1.0 $e1next - $w(LeftInfo) tag remove $oldtag $s1.0 $e1next - $w(RightText) tag remove $oldtag $s2.0 $e2next - $w(RightInfo) tag remove $oldtag $s2.0 $e2next - $w(LeftCB) tag remove $oldtag $s1.0 $e1next - $w(RightCB) tag remove $oldtag $s2.0 $e2next - catch { - set lines [diff-size $pos $g(merge$pos)] - $w(mergeText) tag remove $oldtag mark$pos "mark${pos}+${lines}lines" - } - } - - switch -- $dt { - "d" { - set coltag deltag - set rcbtag " " - set lcbtag "-" - } - "a" { - set coltag instag - set rcbtag "+" - set lcbtag " " - } - "c" { - set coltag chgtag - set rcbtag "!" - set lcbtag "!" - } - } - if {[info exists g(overlap$pos)]} { - set coltag overlaptag - set rcbtag "?" - set lcbtag "?" - } - # Add new tag - if {$opts(tagtext)} { - add-tag $w(LeftText) $newtag $s1 $e1 $dt 1 - add-tag $w(RightText) $newtag $s2 $e2 $dt 1 - add-tag $w(RightText) $coltag $s2 $e2 $dt 1 - } - if {$opts(tagcbs)} { - if {$opts(colorcbs)} { - add-tag $w(LeftCB) $lcbtag $s1 $e1 $dt 1 - add-tag $w(RightCB) $rcbtag $s2 $e2 $dt 1 - } else { - add-tag $w(LeftCB) $newtag $s1 $e1 $dt 1 - add-tag $w(RightCB) $newtag $s2 $e2 $dt 1 - add-tag $w(RightCB) $coltag $s2 $e2 $dt 1 - } - - } - if {$opts(tagln)} { - add-tag $w(LeftInfo) $newtag $s1 $e1 $dt 1 - add-tag $w(RightInfo) $newtag $s2 $e2 $dt 1 - add-tag $w(RightInfo) $coltag $s2 $e2 $dt 1 - } - - catch { - set lines [diff-size $pos $g(merge$pos)] - $w(mergeText) tag add $newtag mark$pos "mark${pos}+${lines}lines" - } - - # Move the view on both text widgets so that the new region is - # visible. - if {$setpos} { - if {$opts(autocenter)} { - center - } else { - $w(LeftText) see $s1.0 - $w(RightText) see $s2.0 - $w(LeftText) mark set insert $s1.0 - $w(RightText) mark set insert $s2.0 - - if {$g(showmerge)} { - $w(mergeText) see mark$pos - } - } - } - - # make sure the sel tag has the highest priority - foreach window [list LeftText RightText LeftCB RightCB LeftInfo RightInfo] { - $w($window) tag raise sel - $w($window) tag raise inlinetag - } - - return $thisdiff -} - -############################################################################### -# moves to the diff nearest the insertion cursor or the mouse click, -# depending on $mode (which should be either "xy" or "mark") -############################################################################### -proc moveNearest {window mode args} { - switch -- $mode { - "xy" { - set x [lindex $args 0] - set y [lindex $args 1] - set index [$window index @$x,$y] - - set line [expr {int($index)}] - set diff [find-diff $line] - } - "mark" { - set index [$window index [lindex $args 0]] - set line [expr {int($index)}] - set diff [find-diff $line] - } - } - - # ok, we have an index - move [lindex $diff 0] 0 1 -} - -############################################################################### -############################################################################### -proc moveTo {window value} { - global w - global g - # we know that the value is prefixed by the nunber/index of - # the diff the user wants. So, just grab that out of the string - regexp {([0-9]+) *:} $value matchVar index - move $index 0 1 -} - -############################################################################### -# this is called when the user scrolls the map thumb interactively. -############################################################################### -proc map-seek {y} { - global g - global w - - set yview [expr {(double($y) / double($g(mapheight)))}] - - # Show text corresponding to map; - $w(RightText) yview moveto $yview -} - -############################################################################### -# Move the "current" diff indicator (i.e. go to the next or previous diff -# region if "relative" is 1; go to an absolute diff number if "relative" -# is 0). -############################################################################### -proc move {value {relative 1} {setpos 1}} { - #debug-info "move $value $relative $setpos" - global g - global w - - if {$value == "first"} { - set value 1 - set relative 0 - } - if {$value == "last"} { - set value $g(count) - set relative 0 - } - - # Remove old 'curr' tag - set-tag $g(pos) difftag currtag - - # Bump 'pos' (one way or the other). - if {$relative} { - set g(pos) [expr {$g(pos) + $value}] - } else { - set g(pos) $value - } - - # Range check 'pos'. - set g(pos) [max $g(pos) 1] - set g(pos) [min $g(pos) $g(count)] - - # Set new 'curr' tag - set g(currdiff) [set-tag $g(pos) currtag "" $setpos] - - # update the buttons.. - #debug-info " ...update-display from move" - update-display - -} - -proc update-display {} { - #debug-info "update-display" - global g - global w - - #debug-info " init_OK $g(initOK)" - #debug-info " started $g(started)" - #if {!$g(started)} return - if {!$g(initOK)} { - # disable darn near everything - - foreach b [list rediff find prevDiff firstDiff nextDiff lastDiff \ - centerDiffs mergeChoice1 mergeChoice2 mergeChoice12 mergeChoice21] { - $w(${b}_im) configure -state disabled - $w(${b}_tx) configure -state disabled - } - foreach menu [list $w(popupMenu) $w(viewMenu)] { - $menu entryconfigure "Previous*" -state disabled - $menu entryconfigure "First*" -state disabled - $menu entryconfigure "Next*" -state disabled - $menu entryconfigure "Last*" -state disabled - $menu entryconfigure "Center*" -state disabled - } - $w(popupMenu) entryconfigure "Find..." -state disabled - $w(popupMenu) entryconfigure "Find Nearest*" -state disabled - $w(popupMenu) entryconfigure "Edit*" -state disabled - - $w(editMenu) entryconfigure "Find*" -state disabled - $w(editMenu) entryconfigure "Edit File 1" -state disabled - $w(editMenu) entryconfigure "Edit File 2" -state disabled - - $w(fileMenu) entryconfigure "Write*" -state disabled - $w(fileMenu) entryconfigure "Recompute*" -state disabled - - $w(mergeMenu) entryconfigure "Show*" -state disabled - $w(mergeMenu) entryconfigure "Write*" -state disabled - - $w(markMenu) entryconfigure "Mark*" -state disabled - $w(markMenu) entryconfigure "Clear*" -state disabled - - } else { - # these are always enabled, assuming we have properly - # diffed a couple of files - $w(popupMenu) entryconfigure "Find..." -state normal - $w(popupMenu) entryconfigure "Find Nearest*" -state normal - $w(popupMenu) entryconfigure "Edit*" -state normal - - foreach b [list rediff find prevDiff firstDiff nextDiff lastDiff \ - centerDiffs] { - $w(${b}_im) configure -state normal - $w(${b}_tx) configure -state normal - } - foreach b [list mergeChoice1 mergeChoice2 mergeChoice12 mergeChoice21] { - $w(${b}_im) configure -state normal - $w(${b}_tx) configure -state normal - } - - $w(editMenu) entryconfigure "Find*" -state normal - $w(editMenu) entryconfigure "Edit File 1" -state normal - $w(editMenu) entryconfigure "Edit File 2" -state normal - - $w(fileMenu) entryconfigure "Write*" -state normal - $w(fileMenu) entryconfigure "Recompute*" -state normal - - $w(mergeMenu) entryconfigure "Show*" -state normal - $w(mergeMenu) entryconfigure "Write*" -state normal - - $w(find_im) configure -state normal - $w(find_tx) configure -state normal - - # Hmmm.... on my Mac the combobox flashes if we don't add this - # check. Is this a bug in AquaTk, or in my combobox... :-| - if {[$w(combo) cget -state] != "normal"} { - $w(combo) configure -state normal - } - } - - # Update the toggles. - if {$g(count)} { - set g(toggle) $g(merge$g(pos)) - } - - # update the status line - set g(statusCurrent) "$g(pos) of $g(count)" - show-info $g(statusCurrent) - - # update the combobox. We don't want its command to fire, so - # we'll disable it temporarily - $w(combo) configure -commandstate "disabled" - set i [expr {$g(pos) - 1}] - $w(combo) configure -value [lindex [$w(combo) list get 0 end] $i] - $w(combo) selection clear - $w(combo) configure -commandstate "normal" - - # update the widgets - if {$g(pos) <= 1} { - foreach buttonpref {im tx} { - $w(prevDiff_$buttonpref) configure -state disabled - $w(firstDiff_$buttonpref) configure -state disabled - } - $w(popupMenu) entryconfigure "Previous*" -state disabled - $w(popupMenu) entryconfigure "First*" -state disabled - $w(viewMenu) entryconfigure "Previous*" -state disabled - $w(viewMenu) entryconfigure "First*" -state disabled - } else { - foreach buttonpref {im tx} { - $w(prevDiff_$buttonpref) configure -state normal - $w(firstDiff_$buttonpref) configure -state normal - } - $w(popupMenu) entryconfigure "Previous*" -state normal - $w(popupMenu) entryconfigure "First*" -state normal - $w(viewMenu) entryconfigure "Previous*" -state normal - $w(viewMenu) entryconfigure "First*" -state normal - } - - if {$g(pos) >= $g(count)} { - foreach buttonpref {im tx} { - $w(nextDiff_$buttonpref) configure -state disabled - $w(lastDiff_$buttonpref) configure -state disabled - } - $w(popupMenu) entryconfigure "Next*" -state disabled - $w(popupMenu) entryconfigure "Last*" -state disabled - $w(viewMenu) entryconfigure "Next*" -state disabled - $w(viewMenu) entryconfigure "Last*" -state disabled - } else { - foreach buttonpref {im tx} { - $w(nextDiff_$buttonpref) configure -state normal - $w(lastDiff_$buttonpref) configure -state normal - } - $w(popupMenu) entryconfigure "Next*" -state normal - $w(popupMenu) entryconfigure "Last*" -state normal - $w(viewMenu) entryconfigure "Next*" -state normal - $w(viewMenu) entryconfigure "Last*" -state normal - } - - if {$g(count) > 0} { - $w(popupMenu) entryconfigure "Center*" -state normal - $w(viewMenu) entryconfigure "Center*" -state normal - $w(markMenu) entryconfigure "Mark*" -state normal - - foreach buttonpref {im tx} { - $w(centerDiffs_$buttonpref) configure -state normal - $w(mergeChoice1_$buttonpref) configure -state normal - $w(mergeChoice2_$buttonpref) configure -state normal - $w(mergeChoice12_$buttonpref) configure -state normal - $w(mergeChoice21_$buttonpref) configure -state normal - } - catch { $w(mergeChoiceLabel) configure -state normal } - - } else { - foreach buttonpref {im tx} { - $w(centerDiffs_$buttonpref) configure -state disabled - $w(mergeChoice1_$buttonpref) configure -state disabled - $w(mergeChoice2_$buttonpref) configure -state disabled - $w(mergeChoice12_$buttonpref) configure -state disabled - $w(mergeChoice21_$buttonpref) configure -state disabled - } - catch { $w(mergeChoiceLabel) configure -state disabled } - $w(popupMenu) entryconfigure "Center*" -state disabled - $w(viewMenu) entryconfigure "Center*" -state disabled - - $w(markMenu) entryconfigure "Mark*" -state disabled - } - - # the mark clear button should only be enabled if there is - # presently a mark at the current diff record - set widget $w(toolbar).mark$g(pos) - if {[winfo exists $widget]} { - $w(markMenu) entryconfigure "Clear*" -state normal - $w(markMenu) entryconfigure "Mark*" -state disabled - foreach buttonpref {im tx} { - $w(markClear_$buttonpref) configure -state normal - $w(markSet_$buttonpref) configure -state disabled - } - } else { - $w(markMenu) entryconfigure "Clear*" -state disabled - $w(markMenu) entryconfigure "Mark*" -state normal - foreach buttonpref {im tx} { - $w(markClear_$buttonpref) configure -state disabled - $w(markSet_$buttonpref) configure -state normal - } - } -} - -############################################################################### -# Center the top line of the CDR in each window. -############################################################################### -proc center {} { - global g - global w - - if {! [info exists g(scrdiff,$g(pos))]} {return} - #scan $g(scrdiff,$g(pos)) "%s %d %d %d %d %s" dummy s1 e1 s2 e2 dt - foreach {dummy s1 e1 s2 e2 dt} $g(scrdiff,$g(pos)) { } - - # Window requested height in pixels - set opix [winfo reqheight $w(LeftText)] - # Window requested lines - set olin [$w(LeftText) cget -height] - # Current window height in pixels - set npix [winfo height $w(LeftText)] - - # Visible lines - set winlines [expr {$npix * $olin / $opix}] - # Lines in diff - set diffsize [max [expr {$e1 - $s1 + 1}] [expr {$e2 - $s2 + 1}]] - - if {$diffsize < $winlines} { - set h [expr {($winlines - $diffsize) / 2}] - } else { - set h 2 - } - - set o [expr {$s1 - $h}] - if {$o < 0} { - set o 0 - } - set n [expr {$s2 - $h}] - if {$n < 0} { - set n 0 - } - - $w(LeftText) mark set insert $s1.0 - $w(RightText) mark set insert $s2.0 - $w(LeftText) yview $o - $w(RightText) yview $n - - if {$g(showmerge)} { - merge-center - } -} - -############################################################################### -# Change the state on all of the diff-sensitive buttons. -############################################################################### -proc buttons {{newstate "normal"}} { - global w - $w(combo) configure -state $newstate - foreach buttonpref {im tx} { - $w(prevDiff_$buttonpref) configure -state $newstate - $w(nextDiff_$buttonpref) configure -state $newstate - $w(firstDiff_$buttonpref) configure -state $newstate - $w(lastDiff_$buttonpref) configure -state $newstate - $w(centerDiffs_$buttonpref) configure -state $newstate - } -} - -############################################################################### -# Wipe the slate clean... -############################################################################### -proc wipe {} { - debug-info "wipe" - global g - - set g(pos) 0 - set g(count) 0 - set g(diff) "" - set g(currdiff) "" - - set g(delta,1) 0 - set g(delta,2) 0 -} - -############################################################################### -# Wipe all data and all windows -############################################################################### -proc wipe-window {} { - debug-info "wipe-window" - global g - global w - - wipe - - foreach mod {Left Right} { - $w(${mod}Text) configure -state normal - $w(${mod}Text) tag remove difftag 1.0 end - $w(${mod}Text) tag remove currtag 1.0 end - $w(${mod}Text) tag remove inlinetag 1.0 end - $w(${mod}Text) delete 1.0 end - - $w(${mod}Info) configure -state normal - $w(${mod}Info) delete 1.0 end - $w(${mod}CB) configure -state normal - $w(${mod}CB) delete 1.0 end - } - - catch { - $w(mergeText) configure -state normal - $w(mergeText) delete 1.0 end - eval $w(mergeText) tag delete [$w(mergeText) tag names] - $w(mergeText) configure -state disabled - } - - if {[string length $g(destroy)] > 0} { - eval $g(destroy) - set g(destroy) "" - } - - $w(combo) list delete 0 end - buttons disabled - - diffmark clearall -} - -############################################################################### -# Mark difference regions and build up the combobox -############################################################################### -proc mark-diffs {} { - debug-info "mark-diffs" - global g - global w - - set numdiff [llength "$g(diff)"] - - set g(count) 0 - - - # ain't this clever? We want to update the display as soon as - # we've marked enough diffs to fill the display so the user will - # have the impression we're fast. But, we don't want this - # want this code to slow us down too much, so we'll put the - # code in a variable and delete it when its no longer needed. - set hack { - # for now, just pick a number out of thin air. Ideally - # we'd compute the number of lines that are visible and - # use that, but I'm too lazy today... - if {$g(count) > 25} { - update idletasks - set hack {} - } - } - - foreach d $g(diff) { - set result [extract $d] - if {$result != ""} { - incr g(count) - set g(merge$g(count)) 1 - - set g(pdiff,$g(count)) "$result" - add-lines $g(count) - - $w(combo) list insert end [format "%-6d: %s" $g(count) $d] - - eval $hack - } - - } - - remark-diffs - return $g(count) -} - -############################################################################### -# start a new diff from the popup dialog -############################################################################### -proc do-new-diff {} { - global g - global finfo - - debug-info "do-new-diff" - - set g(mergefileset) 0 - set g(mergefile) "" - set finfo(pth,1) "" - set finfo(pth,2) "" - set finfo(tmp,1) 0 - set finfo(tmp,2) 0 - - #foreach inf [lsort [array names finfo]] { debug-info " $inf: \ - $finfo($inf)" } - # Pop up the dialog to collect the args - newDiffDialog - - # Put them together into a command - if {[assemble-args] != 0} return - - foreach inf [lsort [array names finfo]] { - debug-info " $inf: $finfo($inf)" - } - - set g(disableSyncing) 1 ;# turn off syncing until things settle down - - # remove all evidence of previous diff - #wipe-window - #update idletasks - - watch-cursor - # do the diff - do-diff - - debug-info " move first 1 1 from do-new-diff" - move first 1 1 - - #debug-info " ...restore-cursor from do-new-diff" - restore-cursor - - #debug-info " ...update-display from do-new-diff" - update-display - catch {unset g(disableSyncing)} -} - -############################################################################### -# Remark difference regions... -############################################################################### -proc remark-diffs {} { - debug-info "remark-diffs" - global g - global w - global opts - global pref - - # delete all known tags. - foreach window [list $w(LeftText) $w(LeftInfo) $w(LeftCB) $w(RightText) \ - $w(RightInfo) $w(RightCB)] { - eval $window tag delete [$window tag names] - } - if {[winfo exists .merge]} { - eval $window tag delete [$w(mergeText) tag names] - } - - # reconfigure all the tags based on the current options - # first, the common tags: - foreach tag {difftag currtag inlinetag deltag instag chgtag overlaptag} { - foreach win [list $w(LeftText) $w(LeftInfo) $w(LeftCB) $w(RightText) \ - $w(RightInfo) $w(RightCB)] { - if {[catch "$win tag configure $tag $opts($tag)"]} { - do-error "Invalid settings for \"$pref($tag)\": \ - \n\n'$opts($tag)' is not a valid option string." - eval "$win tag configure $tag $opts($tag)" - return - } - } - } - - # next, changebar-specific tags - foreach widget [list $w(LeftCB) $w(RightCB)] { - eval $widget tag configure + $opts(+) - eval $widget tag configure - $opts(-) - eval $widget tag configure ! $opts(!) - eval $widget tag configure ? $opts(?) - } - - # ... and the merge text window - if {[winfo exists .merge]} { - foreach tag {difftag currtag} { - eval $w(mergeText) tag configure $tag $opts($tag) - } - } - - # now, reapply the tags to all the diff regions - for {set i 1} {$i <= $g(count)} {incr i} { - set-tag $i difftag - # add the inline annotation - for {set j 0} {$j < $g(scrinline,$i)} {incr j} { - foreach {side line startcol endcol} $g(scrinline,$i,$j) { } - if {$side == "l"} { - add-inline-tag $w(LeftText) inlinetag $line $startcol $endcol - } else { - add-inline-tag $w(RightText) inlinetag $line $startcol $endcol - } - } - } - - # finally, reset the current diff - set-tag $g(pos) currtag "" 0 -} - - -############################################################################### -# Put up some informational text. -############################################################################### -proc show-info {message} { - global g - - set g(statusInfo) $message - debug-info "show-info: $message" - update idletasks -} - - -############################################################################### -# Trace output, enabled by a global variable -############################################################################### -proc debug-info {message} { - global g - - if {$g(debug)} { - puts "$message" - } -} - -############################################################################### -# Compute differences (start over, basically). -############################################################################### -proc rediff {} { - debug-info "\nrediff" - global g - global opts - global finfo - global w - - buttons disabled - - # Read the files into their respective widgets & add line numbers. - foreach mod {1 2} { - if {$mod == 1} { - set text $w(LeftText) - } else { - set text $w(RightText) - } - show-info "reading $finfo(pth,$mod)..." - if {[catch {set hndl [open "$finfo(pth,$mod)" r]}]} { - fatal-error "Failed to open file: $finfo(pth,$mod)" - } - $text insert 1.0 [read $hndl] - close $hndl - } - - # Diff the two files and store the summary lines into 'g(diff)'. - if {$opts(ignoreblanks) == 1} { - set diffcmd "$opts(diffcmd) $opts(ignoreblanksopt) {$finfo(pth,1)} \ - {$finfo(pth,2)}" - } else { - set diffcmd "$opts(diffcmd) {$finfo(pth,1)} {$finfo(pth,2)}" - } - show-info "Executing \"$diffcmd\"" - - set result [run-command "exec $diffcmd"] - set stdout [lindex $result 0] - set stderr [lindex $result 1] - set exitcode [lindex $result 2] - set g(returnValue) $exitcode - - # The exit code is 0 if there are no differences and 1 if there - # are differences. Any other exit code means trouble - if {$exitcode < 0 || $exitcode > 1 || $stderr != ""} { - do-error "diff failed:\n$stderr" - } - - set g(diff) {} - set lines [split $stdout "\n"] - - # If there is no output and we got this far the files are equal, - # otherwise check if the first line begins with a line number. If - # not there was trouble and we abort. For instance, using a binary - # file results in the message "Binary files ..." etc on stdout, - # exit code 1. The message may wary depending on locale. - if {$lines != "" && [string match {[0-9]*} $lines] != 1} { - fatal-error "diff failed:\n$stdout" - } - - # Collect all lines containing line numbers - foreach line $lines { - if {[string match {[0-9]*} $line]} { - lappend g(diff) $line - } - } - - if {$g(ancfileset)} { - - # 3-way merge - compare 1st file (left: diff3l) with ancestor - if {$opts(ignoreblanks) == 1} { - set diffcmd "$opts(diffcmd) $opts(ignoreblanksopt) \ - {$finfo(pth,1)} {$g(ancfile)}" - } else { - set diffcmd "$opts(diffcmd) {$finfo(pth,1)} {$g(ancfile)}" - } - show-info "Executing \"$diffcmd\"" - set result [run-command "exec $diffcmd"] - set stdout [lindex $result 0] - set stderr [lindex $result 1] - set exitcode [lindex $result 2] - if {$exitcode < 0 || $exitcode > 1 || $stderr != ""} { - fatal-error "diff3 failed:\n$stderr" - } - set lines [split $stdout "\n"] - set g(diff3l) {} - foreach line $lines { - if {[string match {[0-9]*} $line]} { - if {[regexp {^[0-9]*,} $line match]} { - regexp {([0-9]*),([0-9]*).*} $line matchvar s1 s2 - } else { - regexp {([0-9]*).*} $line matchvar s1 - set s2 $s1 - } - - lappend g(diff3l) $s1 - for {set i $s1} {$i <= $s2} {incr i} { - set g(diff3l$i) 1 - } - } - } - - # 3-way merge - compare 2nd file (right: diff3r) with ancestor - if {$opts(ignoreblanks) == 1} { - set diffcmd "$opts(diffcmd) $opts(ignoreblanksopt) \ - {$finfo(pth,2)} {$g(ancfile)}" - } else { - set diffcmd "$opts(diffcmd) {$finfo(pth,2)} {$g(ancfile)}" - } - show-info "Executing \"$diffcmd\"" - set result [run-command "exec $diffcmd"] - set stdout [lindex $result 0] - set stderr [lindex $result 1] - set exitcode [lindex $result 2] - if {$exitcode < 0 || $exitcode > 1 || $stderr != ""} { - fatal-error "diff3 failed:\n$stderr" - } - set lines [split $stdout "\n"] - set g(diff3r) {} - foreach line $lines { - if {[string match {[0-9]*} $line]} { - if {[regexp {^[0-9]*,} $line match]} { - regexp {([0-9]*),([0-9]*).*} $line matchvar s1 s2 - } else { - regexp {([0-9]*).*} $line matchvar s1 - set s2 $s1 - } - - lappend g(diff3r) $s1 - for {set i $s1} {$i <= $s2} {incr i} { - set g(diff3r$i) 1 - } - } - } - } - - # Mark up the two text widgets and go to the first diff (if there is one). - draw-line-numbers - - show-info "Marking differences..." - - $w(LeftInfo) configure -state normal - $w(RightInfo) configure -state normal - $w(LeftCB) configure -state normal - $w(RightCB) configure -state normal - - if {[mark-diffs]} { - set g(pos) 1 - move 1 0 1 - buttons normal - } else { - after idle {show-info "Files are identical"} - buttons disabled - } - - # Prevent tampering in the line number widgets. The text - # widgets are already taken care of - $w(LeftInfo) configure -state disabled - $w(RightInfo) configure -state disabled - $w(LeftCB) configure -state disabled - $w(RightCB) configure -state disabled -} - -############################################################################### -# Set the X cursor to "watch" for a window and all of its descendants. -############################################################################### -proc watch-cursor {args} { - debug-info "-> watch-cursor ($args)" - global current - global w - - . configure -cursor watch - $w(LeftText) configure -cursor watch - $w(RightText) configure -cursor watch - $w(combo) configure -cursor watch - update idletasks -} - -############################################################################### -# Restore the X cursor for a window and all of its descendants. -############################################################################### -proc restore-cursor {args} { - debug-info "-> restore-cursor ($args)" - global current - global w - - . configure -cursor {} - $w(LeftText) configure -cursor {} - $w(RightText) configure -cursor {} - $w(combo) configure -cursor {} - show-info "" - update idletasks -} - -############################################################################### -# Check if error was thrown by us or unexpected -############################################################################### -proc check-error {result output} { - global g errorInfo - - if {$result && $output != "Fatal"} { - error $result $errorInfo - } -} - - -############################################################################### -# redo the current diff. Attempt to return to the same diff region, -# numerically speaking. -############################################################################### -proc recompute-diff {} { - - debug-info "recompute-diff" - global g - set current $g(pos) - debug-info "current position $g(pos)" - - do-diff - move $current 0 1 - center -} - - -############################################################################### -# Flash the "rediff" button and then kick off a rediff. -############################################################################### -proc do-diff {} { - debug-info "do-diff" - global g finfo map errorInfo - global opts - - wipe-window - update idletasks - set result [catch { - if {$g(mapheight)} { - ## FIXME this could better a catch - catch {$map blank} - } - - #assemble-args - rediff - merge-read-file - merge-add-marks - - # If a map exists, recreate it - if {$opts(showmap)} { - set g(mapheight) -1 - map-resize - } - - } output] - - #debug-info " result: $result outptut: $output" - check-error $result $output - - if {$g(mergefileset)} { - do-show-merge 1 - } -} - -############################################################################### -# Get things going... -############################################################################### -proc main {} { - debug-info "main" - global w - global g errorInfo - global startupError - global opts - global waitvar - - set cmd_empty [commandline] - debug-info " main: commandline returned $cmd_empty" - if {! $cmd_empty} { - assemble-args - } else { - newDiffDialog - # If they cancel the dialog before doing any diffs, exit - if {[assemble-args] != 0} { - if {! [winfo exists .client]} { - do-exit - } - # If the full UI is drawn, don't exit - return - } - set cmd_empty 0 - } - - wm withdraw . - wm protocol . WM_DELETE_WINDOW do-exit - wm title . "$g(name) $g(version)" - - if {![catch {set windowingsystem [tk windowingsystem]}]} { - if {$windowingsystem == "x11"} { - # All this nonsense is necessary to use an icon bitmap that's - # not in a separate file. - toplevel .icw - if {[string first "color" [winfo visual .]] >= 0} { - label .icw.l -image deltaGif - } else { - label .icw.l -image delta48 - } - - pack .icw.l - bind .icw "wm deiconify ." - wm iconwindow . .icw - } - } - - set g(started) 1 - wipe - - if {$g(windowingSystem) == "x11"} { - get_cde_params - } - if {$g(windowingSystem) == "aqua"} { - get_aqua_params - } - - create-display - - update - - do-show-linenumbers - do-show-map - - # evaluate any custom code the user has - if {[info exists opts(customCode)]} { - if {[catch [list uplevel \#0 $opts(customCode)] error]} { - set startupError "Error in custom code: \n\n$error" - } else { - update - } - } - - if {$cmd_empty} { - do-new-diff - } - move first 1 1 - - # this forces all of the various scrolling windows (line numbers, - # change bars, etc) to get in sync. - set yview [$w(RightText) yview] - vscroll-sync [list $w(RightInfo) $w(LeftInfo)] 2 [lindex $yview 0] \ - [lindex $yview 1] - - wm deiconify . - update idletasks - - if {[info exists startupError]} { - tk_messageBox -icon warning -type ok -title "$g(name) - Error in \ - Startup File" -message $startupError - } -} - -############################################################################### -# Erase tmp files (if necessary) and destroy the application. -############################################################################### -proc del-tmp {} { - global g - - foreach f $g(tempfiles) { - file delete $f - } -} - -############################################################################### -# Put up a window with formatted text -############################################################################### -proc do-text-info {w title text} { - global g - - catch "destroy $w" - toplevel $w - - wm group $w . - wm transient $w . - wm title $w "$g(name) Help - $title" - - if {$g(windowingSystem) == "aqua"} { - setAquaDialogStyle $w - } - - set width 64 - set height 32 - - frame $w.f -bd 2 -relief sunken - pack $w.f -side top -fill both -expand y - - text $w.f.title -highlightthickness 0 -bd 0 -height 2 -wrap word \ - -width 50 -background white -foreground black - - text $w.f.text -wrap word -setgrid true -padx 20 -highlightthickness 0 \ - -bd 0 -width $width -height $height -yscroll [list $w.f.vsb set] \ - -background white -foreground black - scrollbar $w.f.vsb -borderwidth 1 -command [list $w.f.text yview] \ - -orient vertical - - pack $w.f.vsb -side right -fill y -expand n - pack $w.f.title -side top -fill x -expand n - pack $w.f.text -side left -fill both -expand y - - focus $w.f.text - - button $w.done -text Dismiss -command "destroy $w" - pack $w.done -side right -fill none -pady 5 -padx 5 - - put-text $w.f.title "$title" - put-text $w.f.text $text - $w.f.text configure -state disabled - - wm geometry $w ${width}x${height} - update idletasks - raise $w -} - -############################################################################### -# centers window w over parent -############################################################################### -proc centerWindow {w {size {}}} { - update - set parent . - - if {[llength $size] > 0} { - set wWidth [lindex $size 0] - set wHeight [lindex $size 1] - } else { - set wWidth [winfo reqwidth $w] - set wHeight [winfo reqheight $w] - } - - set pWidth [winfo reqwidth $parent] - set pHeight [winfo reqheight $parent] - set pX [winfo rootx $parent] - set pY [winfo rooty $parent] - - set centerX [expr {$pX +($pWidth / 2)}] - set centerY [expr {$pY +($pHeight / 2)}] - - set x [expr {$centerX -($wWidth / 2)}] - set y [expr {$centerY -($wHeight / 2)}] - - if {[llength $size] > 0} { - wm geometry $w "=${wWidth}x${wHeight}+${x}+${y}" - } else { - wm geometry $w "=+${x}+${y}" - } - update -} - -############################################################################### -# The "New Diff" dialog -# In order to be able to enter only one filename if it's a revision-controlled -# file, the dialog now collects the arguments and sends them through the -# command line parser. -############################################################################### -proc newDiffDialog {} { - debug-info "newDiffDialog" - global g w - global finfo - - set g(mergefile) "" - set g(mergefileset) 0 - - set waitvar {} - set w(newDiffPopup) .newDiffPopup - - if {[winfo exists $w(newDiffPopup)]} { - debug-info " $w(newDiffPopup) already exists, just centering" - } else { - debug-info " creating $w(newDiffPopup)" - toplevel $w(newDiffPopup) - - wm group $w(newDiffPopup) . - # Won't start as the first window on Windows if it's transient - if {[winfo exists .client]} { - wm transient $w(newDiffPopup) . - } - wm title $w(newDiffPopup) "New Diff" - - if {$g(windowingSystem) == "aqua"} { - setAquaDialogStyle $w(newDiffPopup) - } - - wm protocol $w(newDiffPopup) WM_DELETE_WINDOW {wm withdraw \ - $w(newDiffPopup)} - wm withdraw $w(newDiffPopup) - - set simple [frame $w(newDiffPopup).simple -borderwidth 2 -relief groove] - - label $simple.l1 -text "File 1:" - label $simple.l2 -text "File 2:" - entry $simple.e1 -textvariable finfo(f,1) - entry $simple.e2 -textvariable finfo(f,2) - - label $simple.lr1 -text "-r" - label $simple.lr2 -text "-r" - entry $simple.er1 -textvariable finfo(revs,1) - entry $simple.er2 -textvariable finfo(revs,2) - - set w(newDiffPopup,entry1) $simple.e1 - set w(newDiffPopup,entry2) $simple.e2 - - # we want these buttons to be the same height as - # the entry, so we'll try to force the issue... - button $simple.b1 -borderwidth 1 -highlightthickness 0 \ - -text "Browse..." -command [list newDiffBrowse "File 1" $simple.e1] - button $simple.b2 -borderwidth 1 -highlightthickness 0 \ - -text "Browse..." -command [list newDiffBrowse "File 2" $simple.e2] - - - # we'll use the grid geometry manager to get things lined up right... - grid $simple.l1 -row 0 -column 0 -sticky e - grid $simple.e1 -row 0 -column 1 -columnspan 4 -sticky nsew -pady 4 - grid $simple.b1 -row 0 -column 5 -sticky nsew -padx 4 -pady 4 - - grid $simple.lr1 -row 1 -column 1 - grid $simple.er1 -row 1 -column 2 - grid $simple.lr2 -row 1 -column 3 - grid $simple.er2 -row 1 -column 4 - - grid $simple.l2 -row 2 -column 0 -sticky e - grid $simple.e2 -row 2 -column 1 -columnspan 4 -sticky nsew -pady 4 - grid $simple.b2 -row 2 -column 5 -sticky nsew -padx 4 -pady 4 - - grid columnconfigure $simple 0 -weight 0 - - set options [frame $w(newDiffPopup).options -borderwidth 2 \ - -relief groove] - - button $options.more -text "More" -command open-more-options - - label $options.ml -text "Merge Output" - entry $options.me -textvariable g(mergefile) - label $options.al -text "Ancestor" - entry $options.ae -textvariable g(ancfile) - label $options.l1l -text "Label for File 1" - entry $options.l1e -textvariable finfo(userlbl,1) - label $options.l2l -text "Label for File 2" - entry $options.l2e -textvariable finfo(userlbl,2) - - grid $options.more -column 0 -row 0 -sticky nw - grid columnconfigure $options -0 -weight 0 - - # here are the buttons for this dialog... - set commands [frame $w(newDiffPopup).buttons] - - button $commands.ok -text "Ok" -width 5 -default active -command { - if {$g(mergefile) == ""} { - set g(mergefileset) 0 - } else { - set g(mergefileset) 1 - } - if {$g(ancfile) == ""} { - set g(ancfileset) 0 - } else { - set g(ancfileset) 1 - } - set waitvar 1 - } - button $commands.cancel -text "Cancel" -width 5 -default normal \ - -command { - wm withdraw $w(newDiffPopup); set waitvar 0 - } - - pack $commands.ok $commands.cancel -side left -fill none -expand y \ - -pady 4 - - catch {$commands.ok -default 1} - - # pack this crud in... - pack $commands -side bottom -fill x -expand n - pack $simple -side top -fill both -ipady 20 -ipadx 20 -padx 5 -pady 5 - - pack $options -side top -fill both -ipady 5 -ipadx 5 -padx 5 -pady 5 - - bind $w(newDiffPopup) [list $commands.ok invoke] - bind $w(newDiffPopup) [list $commands.cancel invoke] - - } - if {[winfo exists .client]} { - centerWindow $w(newDiffPopup) - } else { - update - } - wm deiconify $w(newDiffPopup) - raise $w(newDiffPopup) - focus $w(newDiffPopup,entry1) - tkwait variable waitvar - wm withdraw $w(newDiffPopup) -} - -proc open-more-options {} { - global w - - grid $w(newDiffPopup).options.ml -row 0 -column 1 -sticky e - grid $w(newDiffPopup).options.me -row 0 -column 2 -sticky nsew -pady 4 - grid $w(newDiffPopup).options.al -row 1 -column 1 -sticky e - grid $w(newDiffPopup).options.ae -row 1 -column 2 -sticky nsew -pady 4 - grid $w(newDiffPopup).options.l1l -row 2 -column 1 -sticky e - grid $w(newDiffPopup).options.l1e -row 2 -column 2 -sticky nsew -pady 4 - grid $w(newDiffPopup).options.l2l -row 3 -column 1 -sticky e - grid $w(newDiffPopup).options.l2e -row 3 -column 2 -sticky nsew -pady 4 - - $w(newDiffPopup).options.more configure -text "Less" \ - -command close-more-options - set x [winfo width $w(newDiffPopup)] - set y [winfo height $w(newDiffPopup)] - set yi [winfo reqheight $w(newDiffPopup).options] - set newy [expr $y + $yi] - if {[winfo exists .client]} { - centerWindow $w(newDiffPopup) - } else { - update - } -} - -proc close-more-options {} { - global w - global finfo - - grid remove $w(newDiffPopup).options.ml - grid remove $w(newDiffPopup).options.me - grid remove $w(newDiffPopup).options.al - grid remove $w(newDiffPopup).options.ae - grid remove $w(newDiffPopup).options.l1l - grid remove $w(newDiffPopup).options.l1e - grid remove $w(newDiffPopup).options.l2l - grid remove $w(newDiffPopup).options.l2e - - set g(mergefileset) "" - set g(conflictset) "" - set g(ancfileset) "" - set g(ancfile) "" - set finfo(userlbl,1) "" - set finfo(userlbl,2) "" - - $w(newDiffPopup).options.more configure -text "More" \ - -command open-more-options -} - -############################################################################### -# File browser for the "New Diff" dialog -############################################################################### -proc newDiffBrowse {title widget} { - global w - - set foo [$widget get] - set initialdir [file dirname $foo] - set initialfile [file tail $foo] - set filename [tk_getOpenFile -title $title -initialfile $initialfile \ - -initialdir $initialdir] - if {[string length $filename] > 0} { - $widget delete 0 end - $widget insert 0 $filename - $widget selection range 0 end - $widget xview end - focus $widget - return $filename - } else { - after idle {raise $w(newDiffPopup)} - return {} - } -} - -############################################################################### -# all the code to handle the report writing dialog. -############################################################################### -proc write-report {command args} { - global g - global w - global report - global finfo - - set w(reportPopup) .reportPopup - switch -- $command { - popup { - if {![winfo exists $w(reportPopup)]} { - write-report build - } - set report(filename) [file join [pwd] $report(filename)] - write-report update - - centerWindow $w(reportPopup) - wm deiconify $w(reportPopup) - raise $w(reportPopup) - } - cancel { - wm withdraw $w(reportPopup) - } - update { - - set stateLeft "disabled" - set stateRight "disabled" - if {$report(doSideLeft)} { - set stateLeft "normal" - } - if {$report(doSideRight)} { - set stateRight "normal" - } - - $w(reportLinenumLeft) configure -state $stateLeft - $w(reportCMLeft) configure -state $stateLeft - $w(reportTextLeft) configure -state $stateLeft - - $w(reportLinenumRight) configure -state $stateRight - $w(reportCMRight) configure -state $stateRight - $w(reportTextRight) configure -state $stateRight - - } - save { - set leftLines [lindex [split [$w(LeftText) index end-1lines] .] 0] - set rightLines [lindex [split [$w(RightText) index end-1lines] .] 0] - - # number of lines of the largest window... - set maxlines [max $leftLines $rightLines] - - # probably ought to catch this, in case it fails. Maybe later... - set handle [open $report(filename) w] - - puts $handle "$g(name) $g(version) report" - - # write the file names - if {$report(doSideLeft) == 1 && $report(doSideRight) == 1} { - puts $handle "\nFile A: $finfo(lbl,1)\nFile B: $finfo(lbl,2)\n" - } elseif {$report(doSideLeft) == 1} { - puts $handle "\nFile: $finfo(lbl,1)" - } else { - puts $handle "\nFile: $finfo(lbl,2)" - } - - puts $handle "number of diffs: $g(count)" - - set acount [set ccount [set dcount 0]] - for {set i 1} {$i <= $g(count)} {incr i} { - foreach {line s1 e1 s2 e2 type} $g(scrdiff,$i) { } - switch -- $type { - "d" { - incr dcount - } - "a" { - incr acount - } - "c" { - incr ccount - } - } - } - - puts $handle [format " %6d regions were deleted" $dcount] - puts $handle [format " %6d regions were added" $acount] - puts $handle [format " %6d regions were changed" $ccount] - - puts $handle "\n" - for {set i 1} {$i <= $maxlines} {incr i} { - set out(Left) [set out(Right) ""] - foreach side {Left Right} { - - if {$side == "Left" && $i > $leftLines} break - - if {$side == "Right" && $i > $rightLines} break - - - if {$report(doLineNumbers$side)} { - set widget $w(${side}Info) - set number [string trimright [$widget get "$i.0" \ - "$i.0 lineend"]] - - append out($side) [format "%6s " $number] - } - - if {$report(doChangeMarkers$side)} { - set widget $w(${side}CB) - set data [$widget get "$i.0" "$i.1"] - append out($side) "$data " - } - - if {$report(doText$side)} { - set widget $w(${side}Text) - append out($side) [string trimright [$widget get \ - "$i.0" "$i.0 lineend"]] - } - } - - if {$report(doSideLeft) == 1 && $report(doSideRight) == 1} { - set output [format "%-90s%-90s" $out(Left) $out(Right)] - - } elseif {$report(doSideRight) == 1} { - set output $out(Right) - - } elseif {$report(doSideLeft) == 1} { - set output $out(Left) - - } else { - # what a wasted effort! - set output "" - } - puts $handle [string trimright $output] - } - close $handle - - wm withdraw $w(reportPopup) - } - browse { - set types { - {{All Files} {*}} - } - - set path [tk_getSaveFile -defaultextension "" -filetypes $types \ - -initialfile $report(filename)] - - if {[string length $path] > 0} { - set report(filename) $path - } - } - build { - catch {destroy $w(reportPopup)} - toplevel $w(reportPopup) - wm group $w(reportPopup) . - wm transient $w(reportPopup) . - wm title $w(reportPopup) "$g(name) - Generate Report" - wm protocol $w(reportPopup) WM_DELETE_WINDOW [list write-report \ - cancel] - wm withdraw $w(reportPopup) - - if {$g(windowingSystem) == "aqua"} { - setAquaDialogStyle $w(reportPopup) - } - - set cf [frame $w(reportPopup).clientFrame -bd 2 -relief groove] - set bf [frame $w(reportPopup).buttonFrame -bd 0] - pack $cf -side top -fill both -expand y -padx 5 -pady 5 - pack $bf -side bottom -fill x -expand n - - # buttons... - set w(reportSave) $bf.save - set w(reportCancel) $bf.cancel - - button $w(reportSave) -text "Save" -underline 0 -command \ - [list write-report save] -width 6 - button $w(reportCancel) -text "Cancel" -underline 0 \ - -command [list write-report cancel] -width 6 - - pack $w(reportCancel) -side right -pady 5 -padx 5 - pack $w(reportSave) -side right -pady 5 - - # client area. - set col(Left) 0 - set col(Right) 1 - foreach side [list Left Right] { - set choose [checkbutton $cf.choose$side] - set linenum [checkbutton $cf.linenum$side] - set cm [checkbutton $cf.changemarkers$side] - set text [checkbutton $cf.text$side] - - $choose configure -text "$side Side" \ - -variable report(doSide$side) -command [list write-report \ - update] - - $linenum configure -text "Line Numbers" \ - -variable report(doLineNumbers$side) - $cm configure -text "Change Markers" \ - -variable report(doChangeMarkers$side) - $text configure -text "Text" -variable report(doText$side) - - grid $choose -row 0 -column $col($side) -sticky w - grid $linenum -row 1 -column $col($side) -sticky w -padx 10 - grid $cm -row 2 -column $col($side) -sticky w -padx 10 - grid $text -row 3 -column $col($side) -sticky w -padx 10 - - # save the widget paths for later use... - set w(reportChoose$side) $choose - set w(reportLinenum$side) $linenum - set w(reportCM$side) $cm - set w(reportText$side) $text - } - - # the entry, label and button for the filename will get - # stuffed into a frame for convenience... - frame $cf.fileFrame -bd 0 - grid $cf.fileFrame -row 4 -columnspan 2 -sticky ew -padx 5 - - label $cf.fileFrame.l -text "File:" - entry $cf.fileFrame.e -textvariable report(filename) -width 30 - button $cf.fileFrame.b -text "Browse..." -pady 0 \ - -highlightthickness 0 -borderwidth 1 -command \ - [list write-report browse] - - pack $cf.fileFrame.l -side left -pady 4 - pack $cf.fileFrame.b -side right -pady 4 -padx 2 - pack $cf.fileFrame.e -side left -fill x -expand y -pady 4 - - grid rowconfigure $cf 0 -weight 0 - grid rowconfigure $cf 1 -weight 0 - grid rowconfigure $cf 2 -weight 0 - grid rowconfigure $cf 3 -weight 0 - - grid columnconfigure $cf 0 -weight 1 - grid columnconfigure $cf 1 -weight 1 - - # make sure the widgets are in the proper state - write-report update - } - } -} - -############################################################################### -# Throw up an "about" window. -############################################################################### -proc do-about {} { - global g - - set title "About $g(name)" - set text { -$g(name) $g(version) - -$g(name) is a Tcl/Tk front-end to diff for Unix and \ - Windows, and is Copyright (C) 1994-2005 by John M. Klassa. - -Many of the toolbar icons were created by Dean S. Jones and used with his \ - permission. The icons have the following copyright: - -Copyright(C) 1998 by Dean S. Jones -dean@gallant.com -http://www.gallant.com/icons.htm -http://www.javalobby.org/jfa/projects/icons/ - -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; either version 2 of the License, or (at your \ - option) any later version. - -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, write to the Free Software Foundation, Inc., 59 \ - Temple Place, Suite 330, Boston, MA 02111-1307 USA - } - - set text [subst -nobackslashes -nocommands $text] - do-text-info .about $title $text -} - -############################################################################### -# Throw up a "command line usage" window. -############################################################################### -proc do-usage {mode} { - global g - - debug-info "do-usage ($mode)" - set usage { - $g(name) may be started in any of the following ways: - - Interactive selection of files to compare: - tkdiff - - Plain files: - tkdiff FILE1 FILE2 - - Plain file with conflict markers: - tkdiff -conflict FILE - - Source control (AccuRev, BitKeeper, CVS, Subversion, Perforce, PVCS, - RCS, SCCS, ClearCase) - tkdiff FILE - tkdiff -rREV FILE - tkdiff -rREV1 -rREV2 FILE - tkdiff OLD-URL[@OLDREV] NEW-URL[@NEWREV] (Subversion) - - Additional optional parameters: - -a ANCESTORFILE - -o MERGEOUTPUTFILE - -L LEFT_FILE_LABEL [-L RIGHT_FILE_LABEL] - } - - set usage [subst -nobackslashes -nocommands $usage] - - set text { -$g(name) detects and supports RCS, CVS, Subversion and SCCS by looking for a \ - directory with the same name. It detects and supports PVCS by looking \ - for a vcs.cfg file. It detects and supports AccuRev, Perforce and \ - ClearCase by looking for the environment variables named ACCUREV_BIN, \ - P4CLIENT, and CLEARCASE_ROOT respectively. - -In the first form, tkdiff will present a dialog to allow you to choose the \ - files to diff interactively. At present this dialog only supports a \ - diff between two files that already exist. There is no way to do a diff \ - against a file under souce code control (unless the previous versions \ - can be found on disk via a standard file selection dialog). - -In the second form, at least one of the arguments must be the name of a plain \ - text file. Symbolic links are acceptable, but at least one of the \ - filename arguments must point to a real file rather than to a directory. - -In the remaining forms, REV (or REV1 and \ - REV2) must be a valid revision number for FILE. \ - Where AccuRev, RCS, CVS, Subversion, SCCS, PVCS or Perforce is implied \ - but no revision number is specified, FILE is compared with \ - the the revision most recently checked in. - -To merge a file with conflict markers generated by "merge", \ - "cvs", or "vmrg", use \ - "tkdiff -conflict FILE". The file is split into two temporary \ - files which you can merge as usual (see below). - -For "tkdiff FILE" The CVS version has priority, followed by the \ - Subversion version, followed by the SCCS version -- i.e. if a CVS \ - directory is present, CVS; if not and a Subversion directory is \ - present, Subversion; if not and an SCCS directory is present, SCCS is \ - assumed; otherwise, if a CVS.CFG file is found, PVCS is assumed; \ - otherwise RCS is assumed. If none of the above apply and the AccuRev \ - environment variable ACCUREV_BIN is found, AccuRev is used. If P4CLIENT \ - is found, Perforce is used. If CLEARCASE_ROOT is found, ClearCase is used. - -If the merge output filename is not specified, tkdiff will present a dialog \ - to allow you to choose the name of the merge output file. - -Note further that anything with a leading dash that isn\'t recognized as a \ - $g(name) option is passed through to diff. This permits you to \ - temporarily alter the way diff is called, without resorting to a change \ - in your preferences file. -} - - if {$mode == "cline"} { - puts $usage - exit 0 - } - set text [subst -nobackslashes -nocommands $text] - append usage $text - do-text-info .usage "$g(name) Usage" $usage -} - -############################################################################### -# Throw up a help window. -############################################################################### -proc do-help {} { - global g - - set title "How to use the $g(name) GUI" - set text { -Layout - -The top row contains the File, Edit, View, Mark, Merge and Help menus. The \ - second row contains the labels which identify the contents of each text \ - window. Below that is a toolbar which contains\ - navigation and merge selection tools. - -The left-most text widget displays the contents of FILE1, the most \ - recently checked-in revision, REV or REV1, \ - respectively (as per the startup options described in\ - the "On Command Line" help). The right-most widget displays the \ - contents of FILE2, FILE or REV2, \ - respectively. Clicking the right mouse button over either of\ - these windows will give you a context sensitive menu with actions that \ - will act on the window you clicked over. For example, if you click \ - right over the right hand window and select\ - "Edit", the file displayed on the right hand side will be loaded into a \ - text editor. - -At the bottom of the display is a two line window called the \ - "Line Comparison" window. This will show the "current line" from the \ - left and right windows, one on top of the other. The "current line"\ - is defined by the line that has the blinking insertion cursor, which \ - can be set by merely clicking on any line in the display. This window \ - may be hidden if the View menu item\ - Show Line Comparison is deselected. -All difference regions (DRs) are highlighted to set them apart from the \ - surrounding text. The current difference region, or \ - CDR, is further set apart so that it can be\ - correlated to its partner in the other text widget (that is, the CDR on \ - the left matches the CDR on the right). - -Changing the CDR - -The CDR can be changed in a sequential manner by means of the Next \ - and Previous buttons. The First and \ - Last buttons allow you to quickly navigate to the\ - first or last CDR, respectively. For random access to the DRs, use the \ - dropdown listbox in the toolbar or the diff map, described below. - -By clicking right over a window and using the popup menu you can select \ - Find Nearest Diff to find the diff record nearest the point \ - where you clicked. - -You may also select any highlighted diff region as the current diff region by \ - double-clicking on it. - -Operations - -1. From the File menu: - -The New... button displays a dialog where you may choose two files \ - to compare. Selecting "Ok" from the dialog will diff the two files. The \ - Recompute Diffs button recomputes the\ - differences between the two files whose names appear at the top of the \ - $g(name) window. The Write Report... lets you \ - create a report file that contains the information\ - visible in the windows. Lastly, the Exit button terminates \ - $g(name). - -2. From the Edit menu: - -Copy copies the currently selected text to the system clipboard. \ - Find pops up a dialog to let you search either text window \ - for a specified text string. Edit File 1 and Edit File \ - 2 launch an editor on the files displayed in the left- and \ - right-hand panes. Preferences pops up a dialog box from \ - which display (and other) options can be -changed and saved. - -3. From the View menu: - -Show Line Numbers toggles the display of line numbers in the text \ - widgets. If Synchronize Scrollbars is on, the left and right \ - text widgets are synchronized i.e. scrolling one\ - of the windows scrolls the other. If Auto Center is on, \ - pressing the Next or Prev buttons centers the new CDR automatically. \ - Show Diff Map toggles the display of the diff\ - map (see below) on or off. Show Merge Preview shows or hides \ - the merge preview (see below). Show Line Comparison toggles \ - the display of the "line comparison" window at\ - the bottom of the display. - -4. From the Mark menu: - -The Mark Current Diff creates a new toolbar button that will jump \ - to the current diff region. The Clear Current Diff Mark will \ - remove the toolbar mark button associated with\ - the current diff region, if one exists. - -5. From the Merge menu: - -The Show Merge Window button pops up a window with the current \ - merged version of the two files. The Write Merge File button \ - will allow you to save the contents of that window\ - to a file. - -6. From the Help menu: - -The About $g(name) button displays copyright and author \ - information. The On GUI button generates this window. The \ - On Command Line button displays help on the\ - $g(name) command line options. The On Preferences button \ - displays help on the user-settable preferences. - -7. From the toolbar: - -The first tool is a dropdown list of all of the differences in a standard \ - diff-type format. You may use this list to go directly to any diff \ - record. The Next and Previous\ - buttons take you to the "next" and "previous" DR, respectively. The \ - First and Last buttons take you to the \ - "first" and "last" DR. The Center button centers the\ - CDRs in their respective text windows. You can set Auto \ - Center in Preferences to do this automatically for you \ - as you navigate through the diff records. - -Keyboard Navigation - -When a text widget has the focus, you may use the following shortcut keys: - - f First diff - c Center current diff - l Last diff - n Next diff - p Previous diff - 1 Merge Choice 1 - 2 Merge Choice 2 - -The cursor, Home, End, PageUp and PageDown keys work as expected, adjusting \ - the view in whichever text window has the focus. Note that if \ - Synchronize Scrollbars is set in\ - Preferences, both windows will scroll at the same time. - -Scrolling - -To scroll the text widgets independently, make sure Synchronize \ - Scrollbars in Preferences is off. If it is on, \ - scrolling any text widget scrolls all others. Scrolling does not\ - change the current diff record (CDR). - -Diff Marks - -You can set "markers" at specific diff regions for easier navigation. To do \ - this, click on the Set Mark button. It will create a new \ - toolbar button that will jump back to this diff\ - region. To clear a diff mark, go to that diff record and click on the \ - Clear Mark button. - -Diff Map - -The diff map is a map of all the diff regions. It is shown in the middle of \ - the main window if "Diff Map" on the View menu is on. The map is a \ - miniature of the file's diff regions from top to\ - bottom. Each diff region is rendered as a patch of color, Delete as \ - red, Insert as green and Change as blue. In the case of a 3-way merge, \ - overlap regions are marked in yellow. The height of each patch \ - corresponds to the relative size of the diff region. A\ - thumb lets you interact with the map as if it were a scrollbar. -All diff regions are drawn on the map even if too small to be visible. For \ - large files with small diff regions, this may result in patches \ - overwriting each other. - -Merging - -To merge the two files, go through the difference regions (via "Next", \ - "Prev" or whatever other means you prefer) and select "Left" or \ - "Right" (next to the "Merge Choice:" label) for each. Selecting\ - "Left" means that the the left-most file's version of the difference \ - will be used in creating the final result; choosing "Right" means that \ - the right-most file's difference will be used. Each\ - choice is recorded, and can be changed arbitrarily many times. To \ - commit the final, merged result to disk, choose "Write Merge File..." \ - from the Merge menu. - -Merge Preview - -To see a preview of the file that would be written by "Write Merge File...", \ - select "Show Merge Window" in the View menu. A separate window is shown \ - containing the preview. It is updated as you\ - change merge choices. It is synchronized with the other text widgets if \ - "Synchronize Scrollbars" is on. - -Author -John M. Klassa - -Comments -Questions and comments should be sent to the TkDiff mailing list at \ - tkdiff-discuss@lists.sourceforge.net. - } - - set text [subst -nobackslashes -nocommands $text] - do-text-info .help $title $text -} - -###################################################################### -# display help on the preferences -###################################################################### -proc do-help-preferences {} { - global g - global pref - - customize-initLabels - - set title "$g(name) Preferences" - set text { -Overview - -Preferences are stored in a file in your home directory (identified by the \ - environment variable HOME.) If the environment variable \ - HOME is not set the platform-specific variant\ - of "/" will be used. If you are on a Windows platform the file will be \ - named _tkdiff.rc and will have the attribute "hidden". For \ - all other platforms the file will be named\ - ".tkdiffrc". You may override the name and location of this file by \ - setting the environment variable TKDIFFRC to whatever \ - filename you wish. - -Preferences are organized into three categories: General, Display and \ - Appearance. - -General - -$pref(diffcmd) - -This is the command to run to generate a diff of the two files. Typically \ - this will be "diff". When this command is run, the ignore-blanks \ - options and the names of two files to be diffed will be added as the \ - last to arguments on the command line. - -$pref(ignoreblanksopt) - -Arguments to send with the diff command to tell it how to ignore whitespace. \ - If you are using gnu diff, "-b" or "--ignore-space-change" ignores \ - changes in the amount of whitespace, while "-w" or \ - "--ignore-all-space" ignores all white space. - -$pref(tmpdir) - -The name of a directory for files that are temporarily created while $g(name) \ - is running. - -$pref(editor) - -The name of an external editor program to use when editing a file (ie: when \ - you select "Edit" from the popup menu). If this value is blank, a \ - simple editor built in to $g(name) will be used. For\ - windows users you might want to set this to "notepad". Unix users may \ - want to set this to "xterm -e vi" or perhaps "gnuclient". When run, the \ - name of the file to edit will be appened as the\ - last argument on the command line. -If the supplied string contains the string "\$file", it\'s treated as a whole \ - command line, where the following parameters can be used: - \$file: the file of your choice - \$line: the starting line of the current diff -For example, in the case of NEdit or Emacs you can use "nc -line \$line \ - \$file" and "emacs +\$line \$file" respectively. - -$pref(geometry) - -This defines the default size, in characters of the two text windows. The \ - format should be WIDTHxHEIGHT. For example, "80x40". - -$pref(fancyButtons) - -If set, toolbar buttons will mimic the visual behavior of typical Microsoft \ - Windows applications. Buttons will initially be flat until the cursor \ - moves over them, at which time they will be raised. -If unset, toolbar buttons will always appear raised. -This feature is not supported in MacOSX. - -$pref(toolbarIcons) - -If set, the toolbar buttons will use icons instead of text labels. -If unset, the toolbar buttons will use text labels instead of icons. - -$pref(autocenter) - -If set, whenever a new diff record becomes the current diff record (for \ - example, when pressing the next or previous buttons), the diff record \ - will be automatically centered on the screen. -If unset, no automatic scrolling will occur. - -$pref(syncscroll) - -If set, scrolling either text window will result in both windows scrolling. -If not set, the windows will scroll independent of each other. - -$pref(autoselect) - -If set, automatically select the nearest visible diff region when scrolling. -If not set, the current diff region will not change during scrolling. -This only takes effect if $pref(syncscroll) is set. - -Display - -$pref(showln) - -If set, line numbers will be displayed alongside each line of each file. -If not set, no line numbers will appear. - -$pref(tagln) - -If set, line numbers are highlighted with the options defined in the \ - Appearance section of the preferences. -If not set, line numbers won\'t be highlighted. - -$pref(showcbs) - -If set, change bars will be displayed alongside each line of each file. -If not set, no change bars will appear. - -$pref(tagcbs) - -If set, change indicators will be highlighted. If $pref(colorcbs) \ - is set they will appear as solid colored bars that match the colors \ - used in the diff map. If $pref(colorcbs)\ - is not set, the change indicators will be highlighted according to the \ - options defined in the Appearance section of preferences. - -$pref(showmap) - -If set, colorized, graphical "diff map" will be displayed between the two \ - files, showing regions that have changed. Red is used to show deleted \ - lines, green for added lines, blue for changed\ - lines, and yellow for overlapping lines during a 3-way merge. -If not set, the diff map will not be shown. - -$pref(showlineview) - -If set, show a window at the bottom of the display that shows the current \ - line from each file, one on top of the other. This window is most \ - useful to do a byte-by-byte comparison of a line that has\ - changed. -If not set, the window will not be shown. - -$pref(showinline1) - -If set, show inline diffs in the main window. This is useful to see what the \ - actual diffs are within a large diff region. \ -If not set, the inline diffs are neither computed nor shown. This is the \ - simpler approach, where byte-by-byte comparisons \ -are used. - -$pref(showinline2) - -If set, show inline diffs in the main window. This is useful to see what the \ - actual diffs are within a large diff region. \ -If not set, the inline diffs are neither computed nor shown. This approach \ - is more complex, but should give more pleasing \ -results for source code and written text files. This is the \ - Ratcliff/Obershelp pattern matching algorithm which recursively \ -finds the largest common substring, and recursively repeats on the left and \ - right remainders. - -$pref(tagtext) - -If set, the file contents will be highlighted with the options defined in the \ - Appearance section of the preferences. -If not set, the file contents won\'t be highlighted. - -$pref(colorcbs) - -If set, the change bars will display as solid bars of color that match the \ - colors used by the diff map. -If not set, the change bars will display a "+" for lines that exist in only \ - one file, a "-" for lines that are missing from only one file, and \ - "!" for lines that are different between the two files. - -Appearance - -$pref(textopt) - -This is a list of Tk text widget options that are applied to each of the two \ - text windows in the main display. If you have Tk installed on your \ - machine these will be documented in the "Text.n" man\ - page. - -$pref(difftag) - -This is a list of Tk text widget tag options that are applied to all diff \ - regions. Use this option to make diff regions stand out from regular text. - -$pref(deltag) - -This is a list of Tk text widget tag options that are applied to the current \ - diff region. These options have a higher priority than those for all \ - diff regions. So, for example, if you set the\ - forground for all diff regions to be black and set the foreground for \ - the current diff region to be blue, the current diff region foreground \ - color will be used. - -$pref(instag) - -This is a list of Tk text widget tag options that are applied to regions that \ - have been inserted. These options have a higher priority than those for \ - all diff regions. - -$pref(chgtag) - -This is a list of Tk text widget tag options that are applied to regions that \ - have been changed. These options have a higher priority than those for \ - all diff regions. - -$pref(currtag) - -This is a list of Tk text widget tag options that are applied to the current \ - diff region. These tags have a higher priority than those for all diff \ - regions, and a higher priority than the change,\ - inserted and deleted diff regions. - -$pref(inlinetag) - -This is a list of Tk text widget tag options that are applied to differences \ - within lines in a diff region. These tags have a higher priority than \ - those for all diff regions, and a higher priority than the change,\ - inserted and deleted diff regions. - -$pref(bytetag) - -This is a list of Tk text widget tag options that are applied to individual \ - characters in the line view. These options do not affect the main text \ - displays. - -$pref(tabstops) - -This defines the number of characters for each tabstop in the main display \ - windows. The default is 8. - } - - # since we have embedded references to the preference labels in - # the text, we need to perform substitutions. Because of this, if - # you edit the above text, be sure to properly escape any dollar - # signs that are not meant to be treated as a variable reference - - set text [subst -nocommands $text] - do-text-info .help-preferences $title $text -} - -###################################################################### -# -# text formatting routines derived from Klondike -# Reproduced here with permission from their author. -# -# Copyright (C) 1993,1994 by John Heidemann -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions -# are met: -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# 3. The name of John Heidemann may not be used to endorse or promote products -# derived from this software without specific prior written permission. -# -# THIS SOFTWARE IS PROVIDED BY JOHN HEIDEMANN ``AS IS'' AND -# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -# ARE DISCLAIMED. IN NO EVENT SHALL JOHN HEIDEMANN BE LIABLE -# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -# SUCH DAMAGE. -# -###################################################################### -proc put-text {tw txt} { - - $tw configure -font {Fixed 12} - - $tw configure -font -*-Times-Medium-R-Normal-*-14-* - - $tw tag configure bld -font -*-Times-Bold-R-Normal-*-14-* - $tw tag configure cmp -font -*-Courier-Medium-R-Normal-*-12-* - $tw tag configure hdr -font -*-Helvetica-Bold-R-Normal-*-16-* -underline 1 - $tw tag configure itl -font -*-Times-Medium-I-Normal-*-14-* - $tw tag configure ttl -font -*-Helvetica-Bold-R-Normal-*-18-* - #$tw tag configure h3 -font -*-Helvetica-Bold-R-Normal-*-14-* - #$tw tag configure itl -font -*-Times-Medium-I-Normal-*-14-* - #$tw tag configure rev -foreground white -background black - - - $tw mark set insert 0.0 - - set t $txt - - while {[regexp -indices {<([^@>]*)>} $t match inds] == 1} { - - set start [lindex $inds 0] - set end [lindex $inds 1] - set keyword [string range $t $start $end] - - set oldend [$tw index end] - - $tw insert end [string range $t 0 [expr {$start - 2}]] - - purge-all-tags $tw $oldend insert - - if {[string range $keyword 0 0] == "/"} { - set keyword [string trimleft $keyword "/"] - if {[info exists tags($keyword)] == 0} { - error "end tag $keyword without beginning" - } - $tw tag add $keyword $tags($keyword) insert - unset tags($keyword) - } else { - if {[info exists tags($keyword)] == 1} { - error "nesting of begin tag $keyword" - } - set tags($keyword) [$tw index insert] - } - - set t [string range $t [expr {$end + 2}] end] - } - - set oldend [$tw index end] - $tw insert end $t - purge-all-tags $tw $oldend insert -} - -proc purge-all-tags {w start end} { - foreach tag [$w tag names $start] { - $w tag remove $tag $start $end - } -} - -# Open one of the diffed files in an editor if possible -proc do-edit {} { - global g - global opts - global finfo - global w - - if {$g(activeWindow) == $w(LeftText)} { - set fileno 1 - } elseif {$g(activeWindow) == $w(RightText)} { - set fileno 2 - } else { - set fileno 1 - } - - if {$finfo(tmp,$fileno)} { - do-error "This file is not editable" - } else { - if {[string length [string trim $opts(editor)]] == 0} { - simpleEd open $finfo(pth,$fileno) - } elseif {[regexp "\\\$file" "$opts(editor)"] == 1} { - set line [lindex [extract $g(currdiff)] [expr {($fileno-1) *2+1}]] - set file $finfo(pth,$fileno) - eval set commandline \"$opts(editor) &\" - eval exec $commandline - } else { - eval exec $opts(editor) "{$finfo(pth,$fileno)}" & - } - } -} - -########################################################################## -# platform-specific stuff -########################################################################## -proc setAquaDialogStyle {toplevel} { - #tk::unsupported::MacWindowStyle style $toplevel movableDBoxProc -} - -########################################################################## -# A simple editor, from Bryan Oakley. -########################################################################## -proc simpleEd {command args} { - global textfont - - switch -- $command { - open { - set filename [lindex $args 0] - - set w .editor - set count 0 - while {[winfo exists ${w}$count]} { - incr count 1 - } - set w ${w}$count - - toplevel $w -borderwidth 2 -relief sunken - wm title $w "$filename - Simple Editor" - wm group $w . - - menu $w.menubar - $w configure -menu $w.menubar - - $w.menubar add cascade -label "File" -menu $w.menubar.fileMenu - $w.menubar add cascade -label "Edit" -menu $w.menubar.editMenu - - menu $w.menubar.fileMenu - menu $w.menubar.editMenu - - $w.menubar.fileMenu add command -label "Save" -underline 1 \ - -command [list simpleEd save $filename $w] - $w.menubar.fileMenu add command -label "Save As..." -underline 1 \ - -command [list simpleEd saveAs $filename $w] - $w.menubar.fileMenu add separator - $w.menubar.fileMenu add command -label "Exit" -underline 1 \ - -command [list simpleEd exit $w] - - $w.menubar.editMenu add command -label "Cut" -command [list event \ - generate $w.text <>] - $w.menubar.editMenu add command -label "Copy" -command \ - [list event generate $w.text <>] - $w.menubar.editMenu add command -label "Paste" -command \ - [list event generate $w.text <>] - - text $w.text -wrap none -xscrollcommand [list $w.hsb set] \ - -yscrollcommand [list $w.vsb set] -borderwidth 0 -font $textfont - scrollbar $w.vsb -orient vertical -command [list $w.text yview] - scrollbar $w.hsb -orient horizontal -command [list $w.text xview] - - grid $w.text -row 0 -column 0 -sticky nsew - grid $w.vsb -row 0 -column 1 -sticky ns - grid $w.hsb -row 1 -column 0 -sticky ew - - grid columnconfigure $w 0 -weight 1 - grid columnconfigure $w 1 -weight 0 - grid rowconfigure $w 0 -weight 1 - grid rowconfigure $w 1 -weight 0 - - set fd [open $filename] - $w.text insert 1.0 [read $fd] - close $fd - } - save { - set filename [lindex $args 0] - set w [lindex $args 1] - set fd [open $filename w] - puts $fd [$w.text get 1.0 "end-1c"] - close $fd - } - saveAs { - set filename [lindex $args 0] - set w [lindex $args 1] - set filename [tk_getSaveFile -initialfile $filename] - if {$filename != ""} { - simpleEd save $filename $w - } - } - exit { - set w [lindex $args 0] - destroy $w - } - } -} - -# end of simpleEd - -# Copyright (c) 1998-2005, Bryan Oakley -# All Rights Reservered -# -# Bryan Oakley -# oakley@bardo.clearlight.com -# -# combobox v2.2.2 September 22, 2002 -# -# a combobox / dropdown listbox (pick your favorite name) widget -# written in pure tcl -# -# this code is freely distributable without restriction, but is -# provided as-is with no warranty expressed or implied. -# -# thanks to the following people who provided beta test support or -# patches to the code (in no particular order): -# -# Scott Beasley Alexandre Ferrieux Todd Helfter -# Matt Gushee Laurent Duperval John Jackson -# Fred Rapp Christopher Nelson -# Eric Galluzzo Jean-Francois Moine -# -# A special thanks to Martin M. Hunt who provided several good ideas, -# and always with a patch to implement them. Jean-Francois Moine, -# Todd Helfter and John Jackson were also kind enough to send in some -# code patches. -# -# ... and many others over the years. - -package provide combobox 2.2.2 - -namespace eval ::combobox { - - # this is the public interface - namespace export combobox - - # these contain references to available options - variable widgetOptions - - # these contain references to available commands and subcommands - variable widgetCommands - variable scanCommands - variable listCommands -} - -# ::combobox::combobox -- -# -# This is the command that gets exported. It creates a new -# combobox widget. -# -# Arguments: -# -# w path of new widget to create -# args additional option/value pairs (eg: -background white, etc.) -# -# Results: -# -# It creates the widget and sets up all of the default bindings -# -# Returns: -# -# The name of the newly create widget - -proc ::combobox::combobox {w args} { - variable widgetOptions - variable widgetCommands - variable scanCommands - variable listCommands - - # perform a one time initialization - if {![info exists widgetOptions]} { - Init - } - - # build it... - eval Build $w $args - - # set some bindings... - SetBindings $w - - # and we are done! - return $w -} - -# ::combobox::Init -- -# -# Initialize the namespace variables. This should only be called -# once, immediately prior to creating the first instance of the -# widget -# -# Arguments: -# -# none -# -# Results: -# -# All state variables are set to their default values; all of -# the option database entries will exist. -# -# Returns: -# -# empty string - -proc ::combobox::Init {} { - variable widgetOptions - variable widgetCommands - variable scanCommands - variable listCommands - variable defaultEntryCursor - - array set widgetOptions [list -background \ - {background Background} -bd -borderwidth -bg -background \ - -borderwidth {borderWidth BorderWidth} -command \ - {command Command} -commandstate {commandState State} \ - -cursor {cursor Cursor} \ - -disabledbackground {disabledBackground DisabledBackground} \ - -disabledforeground {disabledForeground DisabledForeground} \ - -dropdownwidth {dropdownWidth DropdownWidth} -editable \ - {editable Editable} -fg -foreground -font \ - {font Font} -foreground {foreground Foreground} \ - -height {height Height} \ - -highlightbackground {highlightBackground HighlightBackground} \ - -highlightcolor {highlightColor HighlightColor} \ - -highlightthickness {highlightThickness HighlightThickness} \ - -image {image Image} -maxheight \ - {maxHeight Height} -opencommand {opencommand Command} \ - -relief {relief Relief} \ - -selectbackground {selectBackground Foreground} \ - -selectborderwidth {selectBorderWidth BorderWidth} \ - -selectforeground {selectForeground Background} -state \ - {state State} -takefocus {takeFocus TakeFocus} \ - -textvariable {textVariable Variable} -value \ - {value Value} -width {width Width} \ - -xscrollcommand {xScrollCommand ScrollCommand}] - - - set widgetCommands [list bbox cget configure curselection delete get \ - icursor index insert list scan selection xview select toggle open close] - - set listCommands [list delete get index insert size] - - set scanCommands [list mark dragto] - - # why check for the Tk package? This lets us be sourced into - # an interpreter that doesn't have Tk loaded, such as the slave - # interpreter used by pkg_mkIndex. In theory it should have no - # side effects when run - if {[lsearch -exact [package names] "Tk"] != -1} { - - ################################################################## - #- this initializes the option database. Kinda gross, but it works - #- (I think). - ################################################################## - - # the image used for the button... - if {$::tcl_platform(platform) == "windows"} { - image create bitmap ::combobox::bimage -data { - #define down_arrow_width 12 - #define down_arrow_height 12 - static char down_arrow_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00; - } - } - } else { - image create bitmap ::combobox::bimage -data { - #define down_arrow_width 15 - #define down_arrow_height 15 - static char down_arrow_bits[] = { - 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80, - 0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83, - 0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80, - 0x00,0x80,0x00,0x80,0x00,0x80 - } - } - } - - # compute a widget name we can use to create a temporary widget - set tmpWidget ".__tmp__" - set count 0 - while {[winfo exists $tmpWidget] == 1} { - set tmpWidget ".__tmp__$count" - incr count - } - - # get the scrollbar width. Because we try to be clever and draw our - # own button instead of using a tk widget, we need to know what size - # button to create. This little hack tells us the width of a scroll - # bar. - # - # NB: we need to be sure and pick a window that doesn't already - # exist... - scrollbar $tmpWidget - set sb_width [winfo reqwidth $tmpWidget] - destroy $tmpWidget - - # steal options from the entry widget - # we want darn near all options, so we'll go ahead and do - # them all. No harm done in adding the one or two that we - # don't use. - entry $tmpWidget - foreach foo [$tmpWidget configure] { - # the cursor option is special, so we'll save it in - # a special way - if {[lindex $foo 0] == "-cursor"} { - set defaultEntryCursor [lindex $foo 4] - } - if {[llength $foo] == 5} { - set option [lindex $foo 1] - set value [lindex $foo 4] - option add *Combobox.$option $value widgetDefault - - # these options also apply to the dropdown listbox - if {[string compare $option "foreground"] == 0 || \ - [string compare $option "background"] == 0 || \ - [string compare $option "font"] == 0} { - option add *Combobox*ComboboxListbox.$option $value \ - widgetDefault - } - } - } - destroy $tmpWidget - - # these are unique to us... - option add *Combobox.dropdownWidth {} widgetDefault - option add *Combobox.openCommand {} widgetDefault - option add *Combobox.cursor {} widgetDefault - option add *Combobox.commandState normal widgetDefault - option add *Combobox.editable 1 widgetDefault - option add *Combobox.maxHeight 10 widgetDefault - option add *Combobox.height 0 - } - - # set class bindings - SetClassBindings -} - -# ::combobox::SetClassBindings -- -# -# Sets up the default bindings for the widget class -# -# this proc exists since it's The Right Thing To Do, but -# I haven't had the time to figure out how to do all the -# binding stuff on a class level. The main problem is that -# the entry widget must have focus for the insertion cursor -# to be visible. So, I either have to have the entry widget -# have the Combobox bindtag, or do some fancy juggling of -# events or some such. What a pain. -# -# Arguments: -# -# none -# -# Returns: -# -# empty string - -proc ::combobox::SetClassBindings {} { - - # make sure we clean up after ourselves... - bind Combobox [list ::combobox::DestroyHandler %W] - - # this will (hopefully) close (and lose the grab on) the - # listbox if the user clicks anywhere outside of it. Note - # that on Windows, you can click on some other app and - # the listbox will still be there, because tcl won't see - # that button click - set this {[::combobox::convert %W -W]} - bind Combobox "$this close" - bind Combobox "$this close" - - # this helps (but doesn't fully solve) focus issues. The general - # idea is, whenever the frame gets focus it gets passed on to - # the entry widget - #bind Combobox {::combobox::tkTabToWindow \ - #[::combobox::convert %W -W].entry} - - # this closes the listbox if we get hidden - bind Combobox {[::combobox::convert %W -W] close} - - return "" -} - -# ::combobox::SetBindings -- -# -# here's where we do most of the binding foo. I think there's probably -# a few bindings I ought to add that I just haven't thought -# about... -# -# I'm not convinced these are the proper bindings. Ideally all -# bindings should be on "Combobox", but because of my juggling of -# bindtags I'm not convinced thats what I want to do. But, it all -# seems to work, its just not as robust as it could be. -# -# Arguments: -# -# w widget pathname -# -# Returns: -# -# empty string - -proc ::combobox::SetBindings {w} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - # juggle the bindtags. The basic idea here is to associate the - # widget name with the entry widget, so if a user does a bind - # on the combobox it will get handled properly since it is - # the entry widget that has keyboard focus. - bindtags $widgets(entry) [concat $widgets(this) [bindtags $widgets(entry)]] - - bindtags $widgets(button) [concat $widgets(this) \ - [bindtags $widgets(button)]] - - # override the default bindings for tab and shift-tab. The - # focus procs take a widget as their only parameter and we - # want to make sure the right window gets used (for shift- - # tab we want it to appear as if the event was generated - # on the frame rather than the entry. - #bind $widgets(entry) "::combobox::tkTabToWindow \[tk_focusNext \ - #$widgets(entry)\]; break" - #bind $widgets(entry) \ - #"::combobox::tkTabToWindow \[tk_focusPrev $widgets(this)\]; break" - - # this makes our "button" (which is actually a label) - # do the right thing - bind $widgets(button) [list $widgets(this) toggle] - - # this lets the autoscan of the listbox work, even if they - # move the cursor over the entry widget. - bind $widgets(entry) "break" - - bind $widgets(listbox) "::combobox::Select \ - [list $widgets(this)] \[$widgets(listbox) nearest %y\]; break" - - bind $widgets(vsb) {continue} - bind $widgets(vsb) {continue} - - bind $widgets(listbox) { - %W selection clear 0 end - %W activate @%x,%y - %W selection anchor @%x,%y - %W selection set @%x,%y @%x,%y - # need to do a yview if the cursor goes off the top - # or bottom of the window... (or do we?) - } - - # these events need to be passed from the entry widget - # to the listbox, or otherwise need some sort of special - # handling. - foreach event [list \ - <1> ] { - bind $widgets(entry) $event [list ::combobox::HandleEvent \ - $widgets(this) $event] - } - - # like the other events, needs to be passed from - # the entry widget to the listbox. However, in this case we - # need to add an additional parameter - catch { - bind $widgets(entry) [list ::combobox::HandleEvent \ - $widgets(this) %D] - } -} - -# ::combobox::Build -- -# -# This does all of the work necessary to create the basic -# combobox. -# -# Arguments: -# -# w widget name -# args additional option/value pairs -# -# Results: -# -# Creates a new widget with the given name. Also creates a new -# namespace patterened after the widget name, as a child namespace -# to ::combobox -# -# Returns: -# -# the name of the widget - -proc ::combobox::Build {w args} { - variable widgetOptions - - if {[winfo exists $w]} { - error "window name \"$w\" already exists" - } - - # create the namespace for this instance, and define a few - # variables - namespace eval ::combobox::$w { - - variable ignoreTrace 0 - variable oldFocus {} - variable oldGrab {} - variable oldValue {} - variable options - variable this - variable widgets - - set widgets(foo) foo ;# coerce into an array - set options(foo) foo ;# coerce into an array - - unset widgets(foo) - unset options(foo) - } - - # import the widgets and options arrays into this proc so - # we don't have to use fully qualified names, which is a - # pain. - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - # this is our widget -- a frame of class Combobox. Naturally, - # it will contain other widgets. We create it here because - # we need it in order to set some default options. - set widgets(this) [frame $w -class Combobox -takefocus 0] - set widgets(entry) [entry $w.entry -takefocus 1] - set widgets(button) [label $w.button -takefocus 0] - - # this defines all of the default options. We get the - # values from the option database. Note that if an array - # value is a list of length one it is an alias to another - # option, so we just ignore it - foreach name [array names widgetOptions] { - if {[llength $widgetOptions($name)] == 1} continue - - set optName [lindex $widgetOptions($name) 0] - set optClass [lindex $widgetOptions($name) 1] - - set value [option get $w $optName $optClass] - set options($name) $value - } - - # a couple options aren't available in earlier versions of - # tcl, so we'll set them to sane values. For that matter, if - # they exist but are empty, set them to sane values. - if {[string length $options(-disabledforeground)] == 0} { - set options(-disabledforeground) $options(-foreground) - } - if {[string length $options(-disabledbackground)] == 0} { - set options(-disabledbackground) $options(-background) - } - - # if -value is set to null, we'll remove it from our - # local array. The assumption is, if the user sets it from - # the option database, they will set it to something other - # than null (since it's impossible to determine the difference - # between a null value and no value at all). - if {[info exists options(-value)] && [string length $options(-value)] == \ - 0} { - unset options(-value) - } - - # we will later rename the frame's widget proc to be our - # own custom widget proc. We need to keep track of this - # new name, so we'll define and store it here... - set widgets(frame) ::combobox::${w}::$w - - # gotta do this sooner or later. Might as well do it now - pack $widgets(entry) -side left -fill both -expand yes - pack $widgets(button) -side right -fill y -expand no - - # I should probably do this in a catch, but for now it's - # good enough... What it does, obviously, is put all of - # the option/values pairs into an array. Make them easier - # to handle later on... - array set options $args - - # now, the dropdown list... the same renaming nonsense - # must go on here as well... - set widgets(dropdown) [toplevel $w.top] - set widgets(listbox) [listbox $w.top.list] - set widgets(vsb) [scrollbar $w.top.vsb] - - pack $widgets(listbox) -side left -fill both -expand y - - # fine tune the widgets based on the options (and a few - # arbitrary values...) - - # NB: we are going to use the frame to handle the relief - # of the widget as a whole, so the entry widget will be - # flat. This makes the button which drops down the list - # to appear "inside" the entry widget. - - $widgets(vsb) configure -command "$widgets(listbox) yview" \ - -highlightthickness 0 - - $widgets(button) configure -highlightthickness 0 -borderwidth 1 \ - -relief raised -width [expr {[winfo reqwidth $widgets(vsb)] - 2}] - - $widgets(entry) configure -borderwidth 0 -relief flat -highlightthickness 0 - - $widgets(dropdown) configure -borderwidth 1 -relief sunken - - $widgets(listbox) configure -selectmode browse \ - -background [$widgets(entry) cget -bg] -yscrollcommand \ - "$widgets(vsb) set" -exportselection false -borderwidth 0 - - - # do some window management foo on the dropdown window - # There seems to be some order dependency here on some platforms - wm transient $widgets(dropdown) [winfo toplevel $w] - wm group $widgets(dropdown) [winfo parent $w] - wm resizable $widgets(dropdown) 0 0 - wm overrideredirect $widgets(dropdown) 1 - wm withdraw $widgets(dropdown) - - # this moves the original frame widget proc into our - # namespace and gives it a handy name - rename ::$w $widgets(frame) - - # now, create our widget proc. Obviously (?) it goes in - # the global namespace. All combobox widgets will actually - # share the same widget proc to cut down on the amount of - # bloat. - proc ::$w {command args} "eval ::combobox::WidgetProc $w \$command \$args" - - - # ok, the thing exists... let's do a bit more configuration. - if {[catch "::combobox::Configure [list $widgets(this)] [array get \ - options]" error]} { - catch {destroy $w} - error "internal error: $error" - } - - return "" -} - -# ::combobox::HandleEvent -- -# -# this proc handles events from the entry widget that we want -# handled specially (typically, to allow navigation of the list -# even though the focus is in the entry widget) -# -# Arguments: -# -# w widget pathname -# event a string representing the event (not necessarily an -# actual event) -# args additional arguments required by particular events - -proc ::combobox::HandleEvent {w event args} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - upvar ::combobox::${w}::oldValue oldValue - - # for all of these events, if we have a special action we'll - # do that and do a "return -code break" to keep additional - # bindings from firing. Otherwise we'll let the event fall - # on through. - switch -- $event { - "" { - if {[winfo ismapped $widgets(dropdown)]} { - set D [lindex $args 0] - # the '120' number in the following expression has - # it's genesis in the tk bind manpage, which suggests - # that the smallest value of %D for mousewheel events - # will be 120. The intent is to scroll one line at a time. - $widgets(listbox) yview scroll [expr {-($D/120)}] units - } - } - "" { - # if the widget is editable, clear the selection. - # this makes it more obvious what will happen if the - # user presses (and helps our code know what - # to do if the user presses return) - if {$options(-editable)} { - $widgets(listbox) see 0 - $widgets(listbox) selection clear 0 end - $widgets(listbox) selection anchor 0 - $widgets(listbox) activate 0 - } - } - "" { - set oldValue [$widgets(entry) get] - } - "" { - if {![winfo ismapped $widgets(dropdown)]} { - # did the value change? - set newValue [$widgets(entry) get] - if {$oldValue != $newValue} { - CallCommand $widgets(this) $newValue - } - } - } - "<1>" { - set editable [::combobox::GetBoolean $options(-editable)] - if {!$editable} { - if {[winfo ismapped $widgets(dropdown)]} { - $widgets(this) close - return -code break - } else { - if {$options(-state) != "disabled"} { - $widgets(this) open - return -code break - } - } - } - } - "" { - if {$options(-state) != "disabled"} { - $widgets(this) toggle - return -code break - } - } - "" { - if {[winfo ismapped $widgets(dropdown)]} { - ::combobox::Find $widgets(this) 0 - return -code break - } else { - ::combobox::SetValue $widgets(this) [$widgets(this) get] - } - } - "" { - # $widgets(entry) delete 0 end - # $widgets(entry) insert 0 $oldValue - if {[winfo ismapped $widgets(dropdown)]} { - $widgets(this) close - return -code break - } - } - "" { - # did the value change? - set newValue [$widgets(entry) get] - if {$oldValue != $newValue} { - CallCommand $widgets(this) $newValue - } - - if {[winfo ismapped $widgets(dropdown)]} { - ::combobox::Select $widgets(this) \ - [$widgets(listbox) curselection] - return -code break - } - - } - "" { - $widgets(listbox) yview scroll 1 pages - set index [$widgets(listbox) index @0,0] - $widgets(listbox) see $index - $widgets(listbox) activate $index - $widgets(listbox) selection clear 0 end - $widgets(listbox) selection anchor $index - $widgets(listbox) selection set $index - - } - "" { - $widgets(listbox) yview scroll -1 pages - set index [$widgets(listbox) index @0,0] - $widgets(listbox) activate $index - $widgets(listbox) see $index - $widgets(listbox) selection clear 0 end - $widgets(listbox) selection anchor $index - $widgets(listbox) selection set $index - } - "" { - if {[winfo ismapped $widgets(dropdown)]} { - ::combobox::tkListboxUpDown $widgets(listbox) 1 - return -code break - } else { - if {$options(-state) != "disabled"} { - $widgets(this) open - return -code break - } - } - } - "" { - if {[winfo ismapped $widgets(dropdown)]} { - ::combobox::tkListboxUpDown $widgets(listbox) -1 - return -code break - } else { - if {$options(-state) != "disabled"} { - $widgets(this) open - return -code break - } - } - } - } - - return "" -} - -# ::combobox::DestroyHandler {w} -- -# -# Cleans up after a combobox widget is destroyed -# -# Arguments: -# -# w widget pathname -# -# Results: -# -# The namespace that was created for the widget is deleted, -# and the widget proc is removed. - -proc ::combobox::DestroyHandler {w} { - - # if the widget actually being destroyed is of class Combobox, - # crush the namespace and kill the proc. Get it? Crush. Kill. - # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it - # brings tears to my eyes. - if {[string compare [winfo class $w] "Combobox"] == 0} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - # delete the namespace and the proc which represents - # our widget - namespace delete ::combobox::$w - rename $w {} - } - - return "" -} - -# ::combobox::Find -# -# finds something in the listbox that matches the pattern in the -# entry widget and selects it -# -# N.B. I'm not convinced this is working the way it ought to. It -# works, but is the behavior what is expected? I've also got a gut -# feeling that there's a better way to do this, but I'm too lazy to -# figure it out... -# -# Arguments: -# -# w widget pathname -# exact boolean; if true an exact match is desired -# -# Returns: -# -# Empty string - -proc ::combobox::Find {w {exact 0}} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - ## *sigh* this logic is rather gross and convoluted. Surely - ## there is a more simple, straight-forward way to implement - ## all this. As the saying goes, I lack the time to make it - ## shorter... - - # use what is already in the entry widget as a pattern - set pattern [$widgets(entry) get] - - if {[string length $pattern] == 0} { - # clear the current selection - $widgets(listbox) see 0 - $widgets(listbox) selection clear 0 end - $widgets(listbox) selection anchor 0 - $widgets(listbox) activate 0 - return - } - - # we're going to be searching this list... - set list [$widgets(listbox) get 0 end] - - # if we are doing an exact match, try to find, - # well, an exact match - set exactMatch -1 - if {$exact} { - set exactMatch [lsearch -exact $list $pattern] - } - - # search for it. We'll try to be clever and not only - # search for a match for what they typed, but a match for - # something close to what they typed. We'll keep removing one - # character at a time from the pattern until we find a match - # of some sort. - set index -1 - while {$index == -1 && [string length $pattern]} { - set index [lsearch -glob $list "$pattern*"] - if {$index == -1} { - regsub {.$} $pattern {} pattern - } - } - - # this is the item that most closely matches... - set thisItem [lindex $list $index] - - # did we find a match? If so, do some additional munging... - if {$index != -1} { - - # we need to find the part of the first item that is - # unique WRT the second... I know there's probably a - # simpler way to do this... - - set nextIndex [expr {$index + 1}] - set nextItem [lindex $list $nextIndex] - - # we don't really need to do much if the next - # item doesn't match our pattern... - if {[string match $pattern* $nextItem]} { - # ok, the next item matches our pattern, too - # now the trick is to find the first character - # where they *don't* match... - set marker [string length $pattern] - while {$marker <= [string length $pattern]} { - set a [string index $thisItem $marker] - set b [string index $nextItem $marker] - if {[string compare $a $b] == 0} { - append pattern $a - incr marker - } else { - break - } - } - } else { - set marker [string length $pattern] - } - - } else { - set marker end - set index 0 - } - - # ok, we know the pattern and what part is unique; - # update the entry widget and listbox appropriately - if {$exact && $exactMatch == -1} { - # this means we didn't find an exact match - $widgets(listbox) selection clear 0 end - $widgets(listbox) see $index - - } elseif {!$exact} { - # this means we found something, but it isn't an exact - # match. If we find something that *is* an exact match we - # don't need to do the following, since it would merely - # be replacing the data in the entry widget with itself - set oldstate [$widgets(entry) cget -state] - $widgets(entry) configure -state normal - $widgets(entry) delete 0 end - $widgets(entry) insert end $thisItem - $widgets(entry) selection clear - $widgets(entry) selection range $marker end - $widgets(listbox) activate $index - $widgets(listbox) selection clear 0 end - $widgets(listbox) selection anchor $index - $widgets(listbox) selection set $index - $widgets(listbox) see $index - $widgets(entry) configure -state $oldstate - } -} - -# ::combobox::Select -- -# -# selects an item from the list and sets the value of the combobox -# to that value -# -# Arguments: -# -# w widget pathname -# index listbox index of item to be selected -# -# Returns: -# -# empty string - -proc ::combobox::Select {w index} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - # the catch is because I'm sloppy -- presumably, the only time - # an error will be caught is if there is no selection. - if {![catch {set data [$widgets(listbox) get [lindex $index 0]]}]} { - ::combobox::SetValue $widgets(this) $data - - $widgets(listbox) selection clear 0 end - $widgets(listbox) selection anchor $index - $widgets(listbox) selection set $index - - } - $widgets(entry) selection range 0 end - - $widgets(this) close - - return "" -} - -# ::combobox::HandleScrollbar -- -# -# causes the scrollbar of the dropdown list to appear or disappear -# based on the contents of the dropdown listbox -# -# Arguments: -# -# w widget pathname -# action the action to perform on the scrollbar -# -# Returns: -# -# an empty string - -proc ::combobox::HandleScrollbar {w {action "unknown"}} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - if {$options(-height) == 0} { - set hlimit $options(-maxheight) - } else { - set hlimit $options(-height) - } - - switch -- $action { - "grow" { - if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { - pack $widgets(vsb) -side right -fill y -expand n - } - } - "shrink" { - if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} { - pack forget $widgets(vsb) - } - } - "crop" { - # this means the window was cropped and we definitely - # need a scrollbar no matter what the user wants - pack $widgets(vsb) -side right -fill y -expand n - } - default { - if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { - pack $widgets(vsb) -side right -fill y -expand n - } else { - pack forget $widgets(vsb) - } - } - } - - return "" -} - -# ::combobox::ComputeGeometry -- -# -# computes the geometry of the dropdown list based on the size of the -# combobox... -# -# Arguments: -# -# w widget pathname -# -# Returns: -# -# the desired geometry of the listbox - -proc ::combobox::ComputeGeometry {w} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - if {$options(-height) == 0 && $options(-maxheight) != "0"} { - # if this is the case, count the items and see if - # it exceeds our maxheight. If so, set the listbox - # size to maxheight... - set nitems [$widgets(listbox) size] - if {$nitems > $options(-maxheight)} { - # tweak the height of the listbox - $widgets(listbox) configure -height $options(-maxheight) - } else { - # un-tweak the height of the listbox - $widgets(listbox) configure -height 0 - } - update idletasks - } - - # compute height and width of the dropdown list - set bd [$widgets(dropdown) cget -borderwidth] - set height [expr {[winfo reqheight $widgets(dropdown)] + $bd + $bd}] - if {[string length $options(-dropdownwidth)] == 0 || \ - $options(-dropdownwidth) == 0} { - set width [winfo width $widgets(this)] - } else { - set m [font measure [$widgets(listbox) cget -font] "m"] - set width [expr {$options(-dropdownwidth) * $m}] - } - - # figure out where to place it on the screen, trying to take into - # account we may be running under some virtual window manager - set screenWidth [winfo screenwidth $widgets(this)] - set screenHeight [winfo screenheight $widgets(this)] - set rootx [winfo rootx $widgets(this)] - set rooty [winfo rooty $widgets(this)] - set vrootx [winfo vrootx $widgets(this)] - set vrooty [winfo vrooty $widgets(this)] - - # the x coordinate is simply the rootx of our widget, adjusted for - # the virtual window. We won't worry about whether the window will - # be offscreen to the left or right -- we want the illusion that it - # is part of the entry widget, so if part of the entry widget is off- - # screen, so will the list. If you want to change the behavior, - # simply change the if statement... (and be sure to update this - # comment!) - set x [expr {$rootx + $vrootx}] - if {0} { - set rightEdge [expr {$x + $width}] - if {$rightEdge > $screenWidth} { - set x [expr {$screenWidth - $width}] - } - if {$x < 0} { - set x 0 - } - } - - # the y coordinate is the rooty plus vrooty offset plus - # the height of the static part of the widget plus 1 for a - # tiny bit of visual separation... - set y [expr {$rooty + $vrooty + [winfo reqheight $widgets(this)] + 1}] - set bottomEdge [expr {$y + $height}] - - if {$bottomEdge >= $screenHeight} { - # ok. Fine. Pop it up above the entry widget isntead of - # below. - set y [expr {($rooty - $height - 1) + $vrooty}] - - if {$y < 0} { - # this means it extends beyond our screen. How annoying. - # Now we'll try to be real clever and either pop it up or - # down, depending on which way gives us the biggest list. - # then, we'll trim the list to fit and force the use of - # a scrollbar - - # (sadly, for windows users this measurement doesn't - # take into consideration the height of the taskbar, - # but don't blame me -- there isn't any way to detect - # it or figure out its dimensions. The same probably - # applies to any window manager with some magic windows - # glued to the top or bottom of the screen) - - if {$rooty > [expr {$screenHeight / 2}]} { - # we are in the lower half of the screen -- - # pop it up. Y is zero; that parts easy. The height - # is simply the y coordinate of our widget, minus - # a pixel for some visual separation. The y coordinate - # will be the topof the screen. - set y 1 - set height [expr {$rooty - 1 - $y}] - - } else { - # we are in the upper half of the screen -- - # pop it down - set y [expr {$rooty + $vrooty + [winfo reqheight \ - $widgets(this)] + 1}] - set height [expr {$screenHeight - $y}] - - } - - # force a scrollbar - HandleScrollbar $widgets(this) crop - } - } - - if {$y < 0} { - # hmmm. Bummer. - set y 0 - set height $screenheight - } - - set geometry [format "=%dx%d+%d+%d" $width $height $x $y] - - return $geometry -} - -# ::combobox::DoInternalWidgetCommand -- -# -# perform an internal widget command, then mung any error results -# to look like it came from our megawidget. A lot of work just to -# give the illusion that our megawidget is an atomic widget -# -# Arguments: -# -# w widget pathname -# subwidget pathname of the subwidget -# command subwidget command to be executed -# args arguments to the command -# -# Returns: -# -# The result of the subwidget command, or an error - -proc ::combobox::DoInternalWidgetCommand {w subwidget command args} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - set subcommand $command - set command [concat $widgets($subwidget) $command $args] - if {[catch $command result]} { - # replace the subwidget name with the megawidget name - regsub $widgets($subwidget) $result $widgets(this) result - - # replace specific instances of the subwidget command - # with our megawidget command - switch -- $subwidget,$subcommand { - listbox,index { - regsub "index" $result "list index" result - } - listbox,insert { - regsub "insert" $result "list insert" result - } - listbox,delete { - regsub "delete" $result "list delete" result - } - listbox,get { - regsub "get" $result "list get" result - } - listbox,size { - regsub "size" $result "list size" result - } - } - error $result - - } else { - return $result - } -} - - -# ::combobox::WidgetProc -- -# -# This gets uses as the widgetproc for an combobox widget. -# Notice where the widget is created and you'll see that the -# actual widget proc merely evals this proc with all of the -# arguments intact. -# -# Note that some widget commands are defined "inline" (ie: -# within this proc), and some do most of their work in -# separate procs. This is merely because sometimes it was -# easier to do it one way or the other. -# -# Arguments: -# -# w widget pathname -# command widget subcommand -# args additional arguments; varies with the subcommand -# -# Results: -# -# Performs the requested widget command - -proc ::combobox::WidgetProc {w command args} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - upvar ::combobox::${w}::oldFocus oldFocus - upvar ::combobox::${w}::oldFocus oldGrab - - set command [::combobox::Canonize $w command $command] - - # this is just shorthand notation... - set doWidgetCommand [list ::combobox::DoInternalWidgetCommand \ - $widgets(this)] - - if {$command == "list"} { - # ok, the next argument is a list command; we'll - # rip it from args and append it to command to - # create a unique internal command - # - # NB: because of the sloppy way we are doing this, - # we'll also let the user enter our secret command - # directly (eg: listinsert, listdelete), but we - # won't document that fact - set command "list-[lindex $args 0]" - set args [lrange $args 1 end] - } - - set result "" - - # many of these commands are just synonyms for specific - # commands in one of the subwidgets. We'll get them out - # of the way first, then do the custom commands. - switch -- $command { - bbox - - delete - - get - - icursor - - index - - insert - - scan - - selection - - xview { - set result [eval $doWidgetCommand entry $command $args] - } - list-get { - set result [eval $doWidgetCommand listbox get $args] - } - list-index { - set result [eval $doWidgetCommand listbox index $args] - } - list-size { - set result [eval $doWidgetCommand listbox size $args] - } - select { - if {[llength $args] == 1} { - set index [lindex $args 0] - set result [Select $widgets(this) $index] - } else { - error "usage: $w select index" - } - } - subwidget { - set knownWidgets [list button entry listbox dropdown vsb] - if {[llength $args] == 0} { - return $knownWidgets - } - - set name [lindex $args 0] - if {[lsearch $knownWidgets $name] != -1} { - set result $widgets($name) - } else { - error "unknown subwidget $name" - } - } - curselection { - set result [eval $doWidgetCommand listbox curselection] - } - list-insert { - eval $doWidgetCommand listbox insert $args - set result [HandleScrollbar $w "grow"] - } - list-delete { - eval $doWidgetCommand listbox delete $args - set result [HandleScrollbar $w "shrink"] - } - toggle { - # ignore this command if the widget is disabled... - if {$options(-state) == "disabled"} return - - # pops down the list if it is not, hides it - # if it is... - if {[winfo ismapped $widgets(dropdown)]} { - set result [$widgets(this) close] - } else { - set result [$widgets(this) open] - } - } - open { - - # if this is an editable combobox, the focus should - # be set to the entry widget - if {$options(-editable)} { - focus $widgets(entry) - $widgets(entry) select range 0 end - $widgets(entry) icur end - } - - # if we are disabled, we won't allow this to happen - if {$options(-state) == "disabled"} { - return 0 - } - - # if there is a -opencommand, execute it now - if {[string length $options(-opencommand)] > 0} { - # hmmm... should I do a catch, or just let the normal - # error handling handle any errors? For now, the latter... - uplevel \#0 $options(-opencommand) - } - - # compute the geometry of the window to pop up, and set - # it, and force the window manager to take notice - # (even if it is not presently visible). - # - # this isn't strictly necessary if the window is already - # mapped, but we'll go ahead and set the geometry here - # since its harmless and *may* actually reset the geometry - # to something better in some weird case. - set geometry [::combobox::ComputeGeometry $widgets(this)] - wm geometry $widgets(dropdown) $geometry - update idletasks - - # if we are already open, there's nothing else to do - if {[winfo ismapped $widgets(dropdown)]} { - return 0 - } - - # save the widget that currently has the focus; we'll restore - # the focus there when we're done - set oldFocus [focus] - - # ok, tweak the visual appearance of things and - # make the list pop up - $widgets(button) configure -relief sunken - raise $widgets(dropdown) - wm deiconify $widgets(dropdown) - tkwait visibility $widgets(dropdown) - focus -force $widgets(dropdown) - - # force focus to the entry widget so we can handle keypress - # events for traversal - focus -force $widgets(entry) - - # select something by default, but only if its an - # exact match... - ::combobox::Find $widgets(this) 1 - - # save the current grab state for the display containing - # this widget. We'll restore it when we close the dropdown - # list - set status "none" - set grab [grab current $widgets(this)] - if {$grab != ""} { - set status [grab status $grab] - } - set oldGrab [list $grab $status] - unset grab status - - # *gasp* do a global grab!!! Mom always told me not to - # do things like this, but sometimes a man's gotta do - # what a man's gotta do. - raise $widgets(dropdown) - grab -global $widgets(this) - - # fake the listbox into thinking it has focus. This is - # necessary to get scanning initialized properly in the - # listbox. - event generate $widgets(listbox) - - return 1 - } - close { - # if we are already closed, don't do anything... - if {![winfo ismapped $widgets(dropdown)]} { - return 0 - } - - # restore the focus and grab, but ignore any errors... - # we're going to be paranoid and release the grab before - # trying to set any other grab because we really really - # really want to make sure the grab is released. - catch {focus $oldFocus} result - catch {grab release $widgets(this)} - catch { - set status [lindex $oldGrab 1] - if {$status == "global"} { - grab -global [lindex $oldGrab 0] - } elseif {$status == "local"} { - grab [lindex $oldGrab 0] - } - unset status - } - - # hides the listbox - $widgets(button) configure -relief raised - wm withdraw $widgets(dropdown) - - # select the data in the entry widget. Not sure - # why, other than observation seems to suggest that's - # what windows widgets do. - set editable [::combobox::GetBoolean $options(-editable)] - if {$editable} { - $widgets(entry) selection range 0 end - $widgets(button) configure -relief raised - } - - - # magic tcl stuff (see tk.tcl in the distribution - # lib directory) - ::combobox::tkCancelRepeat - - return 1 - } - cget { - if {[llength $args] != 1} { - error "wrong # args: should be $w cget option" - } - set opt [::combobox::Canonize $w option [lindex $args 0]] - - if {$opt == "-value"} { - set result [$widgets(entry) get] - } else { - set result $options($opt) - } - } - configure { - set result [eval ::combobox::Configure {$w} $args] - } - default { - error "bad option \"$command\"" - } - } - - return $result -} - -# ::combobox::Configure -- -# -# Implements the "configure" widget subcommand -# -# Arguments: -# -# w widget pathname -# args zero or more option/value pairs (or a single option) -# -# Results: -# -# Performs typcial "configure" type requests on the widget - -proc ::combobox::Configure {w args} { - variable widgetOptions - variable defaultEntryCursor - - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - if {[llength $args] == 0} { - # hmmm. User must be wanting all configuration information - # note that if the value of an array element is of length - # one it is an alias, which needs to be handled slightly - # differently - set results {} - foreach opt [lsort [array names widgetOptions]] { - if {[llength $widgetOptions($opt)] == 1} { - set alias $widgetOptions($opt) - set optName $widgetOptions($alias) - lappend results [list $opt $optName] - } else { - set optName [lindex $widgetOptions($opt) 0] - set optClass [lindex $widgetOptions($opt) 1] - set default [option get $w $optName $optClass] - if {[info exists options($opt)]} { - lappend results [list $opt $optName $optClass $default \ - $options($opt)] - } else { - lappend results [list $opt $optName $optClass $default ""] - } - } - } - - return $results - } - - # one argument means we are looking for configuration - # information on a single option - if {[llength $args] == 1} { - set opt [::combobox::Canonize $w option [lindex $args 0]] - - set optName [lindex $widgetOptions($opt) 0] - set optClass [lindex $widgetOptions($opt) 1] - set default [option get $w $optName $optClass] - set results [list $opt $optName $optClass $default $options($opt)] - return $results - } - - # if we have an odd number of values, bail. - if {[expr {[llength $args]%2}] == 1} { - # hmmm. An odd number of elements in args - error "value for \"[lindex $args end]\" missing" - } - - # Great. An even number of options. Let's make sure they - # are all valid before we do anything. Note that Canonize - # will generate an error if it finds a bogus option; otherwise - # it returns the canonical option name - foreach {name value} $args { - set name [::combobox::Canonize $w option $name] - set opts($name) $value - } - - # process all of the configuration options - # some (actually, most) options require us to - # do something, like change the attributes of - # a widget or two. Here's where we do that... - # - # note that the handling of disabledforeground and - # disabledbackground is a little wonky. First, we have - # to deal with backwards compatibility (ie: tk 8.3 and below - # didn't have such options for the entry widget), and - # we have to deal with the fact we might want to disable - # the entry widget but use the normal foreground/background - # for when the combobox is not disabled, but not editable either. - - set updateVisual 0 - foreach option [array names opts] { - set newValue $opts($option) - if {[info exists options($option)]} { - set oldValue $options($option) - } - - switch -- $option { - -background { - set updateVisual 1 - set options($option) $newValue - } - -borderwidth { - $widgets(frame) configure -borderwidth $newValue - set options($option) $newValue - } - -command { - # nothing else to do... - set options($option) $newValue - } - -commandstate { - # do some value checking... - if {$newValue != "normal" && $newValue != "disabled"} { - set options($option) $oldValue - set message "bad state value \"$newValue\";" - append message " must be normal or disabled" - error $message - } - set options($option) $newValue - } - -cursor { - $widgets(frame) configure -cursor $newValue - $widgets(entry) configure -cursor $newValue - $widgets(listbox) configure -cursor $newValue - set options($option) $newValue - } - -disabledforeground { - set updateVisual 1 - set options($option) $newValue - } - -disabledbackground { - set updateVisual 1 - set options($option) $newValue - } - -dropdownwidth { - set options($option) $newValue - } - -editable { - set updateVisual 1 - if {$newValue} { - # it's editable... - $widgets(entry) configure -state normal \ - -cursor $defaultEntryCursor - } else { - $widgets(entry) configure -state disabled \ - -cursor $options(-cursor) - } - set options($option) $newValue - } - -font { - $widgets(entry) configure -font $newValue - $widgets(listbox) configure -font $newValue - set options($option) $newValue - } - -foreground { - set updateVisual 1 - set options($option) $newValue - } - -height { - $widgets(listbox) configure -height $newValue - HandleScrollbar $w - set options($option) $newValue - } - -highlightbackground { - $widgets(frame) configure -highlightbackground $newValue - set options($option) $newValue - } - -highlightcolor { - $widgets(frame) configure -highlightcolor $newValue - set options($option) $newValue - } - -highlightthickness { - $widgets(frame) configure -highlightthickness $newValue - set options($option) $newValue - } - -image { - if {[string length $newValue] > 0} { - $widgets(button) configure -image $newValue - } else { - $widgets(button) configure -image ::combobox::bimage - } - set options($option) $newValue - } - -maxheight { - # ComputeGeometry may dork with the actual height - # of the listbox, so let's undork it - $widgets(listbox) configure -height $options(-height) - HandleScrollbar $w - set options($option) $newValue - } - -opencommand { - # nothing else to do... - set options($option) $newValue - } - -relief { - $widgets(frame) configure -relief $newValue - set options($option) $newValue - } - -selectbackground { - $widgets(entry) configure -selectbackground $newValue - $widgets(listbox) configure -selectbackground $newValue - set options($option) $newValue - } - -selectborderwidth { - $widgets(entry) configure -selectborderwidth $newValue - $widgets(listbox) configure -selectborderwidth $newValue - set options($option) $newValue - } - -selectforeground { - $widgets(entry) configure -selectforeground $newValue - $widgets(listbox) configure -selectforeground $newValue - set options($option) $newValue - } - -state { - if {$newValue == "normal"} { - set updateVisual 1 - # it's enabled - - set editable [::combobox::GetBoolean $options(-editable)] - if {$editable} { - $widgets(entry) configure -state normal - $widgets(entry) configure -takefocus 1 - } - - # note that $widgets(button) is actually a label, - # not a button. And being able to disable labels - # wasn't possible until tk 8.3. (makes me wonder - # why I chose to use a label, but that answer is - # lost to antiquity) - if {[info patchlevel] >= 8.3} { - $widgets(button) configure -state normal - } - - } elseif {$newValue == "disabled"} { - set updateVisual 1 - # it's disabled - $widgets(entry) configure -state disabled - $widgets(entry) configure -takefocus 0 - # note that $widgets(button) is actually a label, - # not a button. And being able to disable labels - # wasn't possible until tk 8.3. (makes me wonder - # why I chose to use a label, but that answer is - # lost to antiquity) - if {$::tcl_version >= 8.3} { - $widgets(button) configure -state disabled - } - - } else { - set options($option) $oldValue - set message "bad state value \"$newValue\";" - append message " must be normal or disabled" - error $message - } - - set options($option) $newValue - } - -takefocus { - $widgets(entry) configure -takefocus $newValue - set options($option) $newValue - } - -textvariable { - $widgets(entry) configure -textvariable $newValue - set options($option) $newValue - } - -value { - ::combobox::SetValue $widgets(this) $newValue - set options($option) $newValue - } - -width { - $widgets(entry) configure -width $newValue - $widgets(listbox) configure -width $newValue - set options($option) $newValue - } - -xscrollcommand { - $widgets(entry) configure -xscrollcommand $newValue - set options($option) $newValue - } - } - - if {$updateVisual} { - UpdateVisualAttributes $w - } - } -} - -# ::combobox::UpdateVisualAttributes -- -# -# sets the visual attributes (foreground, background mostly) -# based on the current state of the widget (normal/disabled, -# editable/non-editable) -# -# why a proc for such a simple thing? Well, in addition to the -# various states of the widget, we also have to consider the -# version of tk being used -- versions from 8.4 and beyond have -# the notion of disabled foreground/background options for various -# widgets. All of the permutations can get nasty, so we encapsulate -# it all in one spot. -# -# note also that we don't handle all visual attributes here; just -# the ones that depend on the state of the widget. The rest are -# handled on a case by case basis -# -# Arguments: -# w widget pathname -# -# Returns: -# empty string - -proc ::combobox::UpdateVisualAttributes {w} { - - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - if {$options(-state) == "normal"} { - - set foreground $options(-foreground) - set background $options(-background) - - } elseif {$options(-state) == "disabled"} { - - set foreground $options(-disabledforeground) - set background $options(-disabledbackground) - } - - $widgets(entry) configure -foreground $foreground -background $background - $widgets(listbox) configure -foreground $foreground -background $background - $widgets(button) configure -foreground $foreground - $widgets(vsb) configure -background $background -troughcolor $background - $widgets(frame) configure -background $background - - # we need to set the disabled colors in case our widget is disabled. - # We could actually check for disabled-ness, but we also need to - # check whether we're enabled but not editable, in which case the - # entry widget is disabled but we still want the enabled colors. It's - # easier just to set everything and be done with it. - - if {$::tcl_version >= 8.4} { - $widgets(entry) configure -disabledforeground $foreground \ - -disabledbackground $background - $widgets(button) configure -disabledforeground $foreground - $widgets(listbox) configure -disabledforeground $foreground - } -} - -# ::combobox::SetValue -- -# -# sets the value of the combobox and calls the -command, -# if defined -# -# Arguments: -# -# w widget pathname -# newValue the new value of the combobox -# -# Returns -# -# Empty string - -proc ::combobox::SetValue {w newValue} { - - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - upvar ::combobox::${w}::ignoreTrace ignoreTrace - upvar ::combobox::${w}::oldValue oldValue - - if {[info exists options(-textvariable)] && [string length \ - $options(-textvariable)] > 0} { - set variable ::$options(-textvariable) - set $variable $newValue - } else { - set oldstate [$widgets(entry) cget -state] - $widgets(entry) configure -state normal - $widgets(entry) delete 0 end - $widgets(entry) insert 0 $newValue - $widgets(entry) configure -state $oldstate - } - - # set our internal textvariable; this will cause any public - # textvariable (ie: defined by the user) to be updated as - # well - # set ::combobox::${w}::entryTextVariable $newValue - - # redefine our concept of the "old value". Do it before running - # any associated command so we can be sure it happens even - # if the command somehow fails. - set oldValue $newValue - - - # call the associated command. The proc will handle whether or - # not to actually call it, and with what args - CallCommand $w $newValue - - return "" -} - -# ::combobox::CallCommand -- -# -# calls the associated command, if any, appending the new -# value to the command to be called. -# -# Arguments: -# -# w widget pathname -# newValue the new value of the combobox -# -# Returns -# -# empty string - -proc ::combobox::CallCommand {w newValue} { - upvar ::combobox::${w}::widgets widgets - upvar ::combobox::${w}::options options - - # call the associated command, if defined and -commandstate is - # set to "normal" - if {$options(-commandstate) == "normal" && [string length \ - $options(-command)] > 0} { - set args [list $widgets(this) $newValue] - uplevel \#0 $options(-command) $args - } -} - - -# ::combobox::GetBoolean -- -# -# returns the value of a (presumably) boolean string (ie: it should -# do the right thing if the string is "yes", "no", "true", 1, etc -# -# Arguments: -# -# value value to be converted -# errorValue a default value to be returned in case of an error -# -# Returns: -# -# a 1 or zero, or the value of errorValue if the string isn't -# a proper boolean value - -proc ::combobox::GetBoolean {value {errorValue 1}} { - if {[catch {expr {([string trim $value]) ?1:0}} res]} { - return $errorValue - } else { - return $res - } -} - -# ::combobox::convert -- -# -# public routine to convert %x, %y and %W binding substitutions. -# Given an x, y and or %W value relative to a given widget, this -# routine will convert the values to be relative to the combobox -# widget. For example, it could be used in a binding like this: -# -# bind .combobox {doSomething [::combobox::convert %W -x %x]} -# -# Note that this procedure is *not* exported, but is intended for -# public use. It is not exported because the name could easily -# clash with existing commands. -# -# Arguments: -# -# w a widget path; typically the actual result of a %W -# substitution in a binding. It should be either a -# combobox widget or one of its subwidgets -# -# args should one or more of the following arguments or -# pairs of arguments: -# -# -x will convert the value ; typically will -# be the result of a %x substitution -# -y will convert the value ; typically will -# be the result of a %y substitution -# -W (or -w) will return the name of the combobox widget -# which is the parent of $w -# -# Returns: -# -# a list of the requested values. For example, a single -w will -# result in a list of one items, the name of the combobox widget. -# Supplying "-x 10 -y 20 -W" (in any order) will return a list of -# three values: the converted x and y values, and the name of -# the combobox widget. - -proc ::combobox::convert {w args} { - set result {} - if {![winfo exists $w]} { - error "window \"$w\" doesn't exist" - } - - while {[llength $args] > 0} { - set option [lindex $args 0] - set args [lrange $args 1 end] - - switch -exact -- $option { - -x { - set value [lindex $args 0] - set args [lrange $args 1 end] - set win $w - while {[winfo class $win] != "Combobox"} { - incr value [winfo x $win] - set win [winfo parent $win] - if {$win == "."} break - } - lappend result $value - } - -y { - set value [lindex $args 0] - set args [lrange $args 1 end] - set win $w - while {[winfo class $win] != "Combobox"} { - incr value [winfo y $win] - set win [winfo parent $win] - if {$win == "."} break - } - lappend result $value - } - -w - - -W { - set win $w - while {[winfo class $win] != "Combobox"} { - set win [winfo parent $win] - if {$win == "."} break - - } - lappend result $win - } - } - } - return $result -} - -# ::combobox::Canonize -- -# -# takes a (possibly abbreviated) option or command name and either -# returns the canonical name or an error -# -# Arguments: -# -# w widget pathname -# object type of object to canonize; must be one of "command", -# "option", "scan command" or "list command" -# opt the option (or command) to be canonized -# -# Returns: -# -# Returns either the canonical form of an option or command, -# or raises an error if the option or command is unknown or -# ambiguous. - -proc ::combobox::Canonize {w object opt} { - variable widgetOptions - variable columnOptions - variable widgetCommands - variable listCommands - variable scanCommands - - switch -- $object { - command { - if {[lsearch -exact $widgetCommands $opt] >= 0} { - return $opt - } - - # command names aren't stored in an array, and there - # isn't a way to get all the matches in a list, so - # we'll stuff the commands in a temporary array so - # we can use [array names] - set list $widgetCommands - foreach element $list { - set tmp($element) "" - } - set matches [array names tmp ${opt}*] - } - {list command} { - if {[lsearch -exact $listCommands $opt] >= 0} { - return $opt - } - - # command names aren't stored in an array, and there - # isn't a way to get all the matches in a list, so - # we'll stuff the commands in a temporary array so - # we can use [array names] - set list $listCommands - foreach element $list { - set tmp($element) "" - } - set matches [array names tmp ${opt}*] - } - {scan command} { - if {[lsearch -exact $scanCommands $opt] >= 0} { - return $opt - } - - # command names aren't stored in an array, and there - # isn't a way to get all the matches in a list, so - # we'll stuff the commands in a temporary array so - # we can use [array names] - set list $scanCommands - foreach element $list { - set tmp($element) "" - } - set matches [array names tmp ${opt}*] - } - option { - if {[info exists widgetOptions($opt)] && \ - [llength $widgetOptions($opt)] == 2} { - return $opt - } - set list [array names widgetOptions] - set matches [array names widgetOptions ${opt}*] - } - } - - if {[llength $matches] == 0} { - set choices [HumanizeList $list] - error "unknown $object \"$opt\"; must be one of $choices" - - } elseif {[llength $matches] == 1} { - set opt [lindex $matches 0] - - # deal with option aliases - switch -- $object { - option { - set opt [lindex $matches 0] - if {[llength $widgetOptions($opt)] == 1} { - set opt $widgetOptions($opt) - } - } - } - - return $opt - - } else { - set choices [HumanizeList $list] - error "ambiguous $object \"$opt\"; must be one of $choices" - } -} - -# ::combobox::HumanizeList -- -# -# Returns a human-readable form of a list by separating items -# by columns, but separating the last two elements with "or" -# (eg: foo, bar or baz) -# -# Arguments: -# -# list a valid tcl list -# -# Results: -# -# A string which as all of the elements joined with ", " or -# the word " or " - -proc ::combobox::HumanizeList {list} { - - if {[llength $list] == 1} { - return [lindex $list 0] - } else { - set list [lsort $list] - set secondToLast [expr {[llength $list] -2}] - set most [lrange $list 0 $secondToLast] - set last [lindex $list end] - - return "[join $most {, }] or $last" - } -} - -# This is some backwards-compatibility code to handle TIP 44 -# (http://purl.org/tcl/tip/44.html). For all private tk commands -# used by this widget, we'll make duplicates of the procs in the -# combobox namespace. -# -# I'm not entirely convinced this is the right thing to do. I probably -# shouldn't even be using the private commands. Then again, maybe the -# private commands really should be public. Oh well; it works so it -# must be OK... -foreach command {TabToWindow CancelRepeat ListboxUpDown} { - if {[llength [info commands ::combobox::tk$command]] == 1} break - - - set tmp [info commands tk$command] - set proc ::combobox::tk$command - if {[llength [info commands tk$command]] == 1} { - set command [namespace which [lindex $tmp 0]] - proc $proc {args} "uplevel $command \$args" - } else { - if {[llength [info commands ::tk::$command]] == 1} { - proc $proc {args} "uplevel ::tk::$command \$args" - } - } -} - -# end of combobox.tcl - - -###################################################################### -# icon image data. -###################################################################### -image create bitmap delta48 -data { - #define delta48_width 48 - #define delta48_height 48 - static char delta48_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x80, 0x13, 0x00, 0x00, - 0x00, 0x00, 0xc0, 0x10, 0x00, 0x00, 0x00, 0x00, 0x40, 0x08, 0x00, 0x00, - 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x00, 0x00, 0x30, 0x0c, 0x00, 0x00, - 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x00, 0x00, 0x0c, 0x0e, 0x00, 0x00, - 0x00, 0x00, 0x04, 0x1b, 0x00, 0x00, 0x00, 0x00, 0x06, 0x1b, 0x00, 0x00, - 0x00, 0x00, 0x02, 0x33, 0x00, 0x00, 0x00, 0x00, 0x03, 0x2e, 0x00, 0x00, - 0x00, 0x00, 0x11, 0x6c, 0x00, 0x00, 0x00, 0x00, 0x11, 0x68, 0x00, 0x00, - 0x00, 0x80, 0x10, 0xc8, 0x00, 0x00, 0x00, 0x80, 0x10, 0xa8, 0x01, 0x00, - 0x00, 0x80, 0x08, 0x08, 0x01, 0x00, 0x00, 0x80, 0x08, 0xac, 0x03, 0x00, - 0x00, 0x80, 0x09, 0x06, 0x02, 0x00, 0x00, 0xc0, 0x09, 0xaa, 0x06, 0x00, - 0x00, 0x40, 0x09, 0x01, 0x04, 0x00, 0x00, 0xe0, 0x93, 0xae, 0x0a, 0x00, - 0x00, 0x30, 0x92, 0x06, 0x18, 0x00, 0x00, 0xb0, 0x92, 0xad, 0x1a, 0x00, - 0x00, 0x18, 0x53, 0x04, 0x30, 0x00, 0x00, 0xa8, 0x11, 0xac, 0x2a, 0x00, - 0x00, 0x0c, 0x12, 0x04, 0x60, 0x00, 0x00, 0xac, 0x12, 0xac, 0x6a, 0x00, - 0x00, 0x02, 0x14, 0x04, 0x80, 0x00, 0x00, 0xab, 0x0a, 0xae, 0xaa, 0x01, - 0x00, 0x01, 0x28, 0x02, 0x00, 0x01, 0x80, 0xab, 0x3a, 0xaf, 0xaa, 0x03, - 0x80, 0x00, 0x70, 0x0c, 0x00, 0x02, 0xc0, 0xaa, 0x5a, 0xa8, 0xaa, 0x06, - 0x40, 0x00, 0xa0, 0x08, 0x00, 0x0c, 0xa0, 0xaa, 0xea, 0xac, 0xaa, 0x0a, - 0x30, 0x00, 0x80, 0x05, 0x00, 0x18, 0xb0, 0xaa, 0xaa, 0xab, 0xaa, 0x1a, - 0x08, 0x00, 0x00, 0x04, 0x00, 0x30, 0xfc, 0xff, 0xff, 0xbe, 0xff, 0x7f, - 0xfc, 0xff, 0xff, 0xbd, 0xff, 0x7f, 0x00, 0x00, 0x00, 0x70, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - } -} - -image create photo deltaGif -format gif -data { -R0lGODlhMAAwAOcAAAIyRsQWGJ4eIIYrK0aK4jZ2yXIkKOJ2hhpKgqZ+isJW -Y1IuNpBebKJifi5qumpKUsQ0OE4ySkJiip5SXoZWXnpWahZGfp5GUideptrG -yopSWtpOVnp+kiY6XiVaoIJGTphKVjxMcJ45Pso6PiFWmgYyZt5SWroeHrau -tmaClu4eJsoeHlJmhts+Q3JCSi5Kepo2PpKGkiBSlqIiIuaWllY6QrQmJmJy -kjp6zk6W9h5Ojx4yPh1Cc5YeIspaatoiJvJcaE5eekpihpR2gMIiItteZz6C -2nZqfuY2Pu9MVG5aYq4iIutGTqJOXkY+SuKKkgc6c4YyMkqO6cZCUgI2Vipi -rV4iInI2Pq5yepIiIsIrK6ErLBpKhrY+RsozM052uhIuTsJqhrJebu5UWLRM -WopWbr4iIl5mjtpCRE6G2u5eatVibqwcHjZGVoAoKr52ftoSEmo2SsYmKlaS -5pYiItZWbrpucppialKO3m5GUscqKyBGfudKUc8yMyZKeh46YiZGag42Ts46 -PjZyxKcqK+JCSMpCSu7Gxh5Skp5CRtU+Px9OiUI+YropKUSC2ppOWm4eHpIp -KbV/h85qcsYuLnZOYospKoZmcqlaY5ZWWnZiZuYoLl5Scm4qLlSW8jZCXpgm -KIJCStpibAI2TrYuMK4pKp4yNtpaZr58hk6O5t1GSNE2N85CRopSciJKfuY+ -Rgo2UuJOWj5+1CpmsLJkcn4uNi5QgEWG4ZI+RBpGgNU6PEZOcpAyNL5OWoBQ -ZJJKZqpSYi5eovKWnmpaflea+CZSjjFuvU2K3couMLpkcnIqLuJaXnpyhupa -Zj5Gar4uLpIuMo4uLuFLT84qKk6S7JZZZ6klJ/ZKUuJmdjZGah5WorUqKqY2 -QudOUpkqK4ZabnJaegI2XiNGdspqguJGS7IaHuJeZuJaYlKS7SpGbkyK5Op0 -fN5CRY5mctZESDZShtZmbhpKir4qKi5mtAIyUtpGUuBYbh5KgIJ6im5+ltIe -IlpmgnpCSuIiJgY4Tv///yH5BAEKAP8ALAAAAAAwADAAAAj+AP8JHEiwoMGD -CBMqXJgwFMOHEA0usIJpSMSLC10oMzCAFsaPBx/0yOJmwBuQKAXmccNmgBte -WFKCrFFLgIABlkRckvmRwoByloJO4PmxUxY2lgww+kI04hVILGdAiyPDGLWm -DD8M2FoOFLcLw4LJIoZVIS6c0U54AwWjQrFZUsoi1MDLUqQlS7ZYYxDiHQkc -6OQafBQtkrcA1rZ0wQQi2b0q6gQXTBTJMBxr1kpZs1FHCIlBniQLZCDCmzdr -AQiV2rbtmah8izDcCiwZk6ktW2ysWL1NHqU1N7ggchBXMjDchIiY2dZIXiNk -ayRwiecBB1m5+MhsUa2vUXM9lFb+jVuEQDhkwczIqN72Q54WLZT0CEJ1LxeC -eCQK0MZ6ptfqRv3IAx4llLByBAL2caGDbGVRw4ICpDQihwrwUYIMBJeIg8CG -uXBRVQ5YGWELLRA0oscmyCDjBSXV8MAhhzp4YAQeRKEzzyKVGKLFNJtYiEwy -QQCSzYZECjfPVTJ5IgsJ8YSggBd9IOGFF2vEkIIkkyBo34b4yZKKTARUoUMu -PHyzQR+veLGKKKjYMQI2RCJYng5V3JKSFIOQwEUuEfCjSB98rLKKIl4go0sR -RNqX4GfFfeQIBotwcQ8IpOixyhiCrqKLLoogumWiCzoCEjUOILInAmW404cX -mG7KqS7+9myp6IbCOfDlRcfI4kGkG3JyiqBJbKpICy3oYk6csk7ngSzHXCTF -LDqcmosrDUjThzRocKoIGvU88WKcc84SGUTEFMDkt9mEUY8qfCiyLTvL7APu -rPfldx1Dt2Aw5ry7iMJOEu/qQoO89M6qIIMMoWOMDNK+mAs4zSTBDhrsrLOP -OOJ8imx5Ve2XkBEeRJtoos6okQQ57MQiTDoJSJKOnDDTGqMRzSZEzTymahyn -M+e4wwTK6xQRywEvjCxngjrMM+5BqSwZj6ww27eHL7FcQw450rRQCCp7OLxx -l0gadAu0XHzrtTitAMGENFgXMoTZZis4i50GEZNn2RrrjMCzHmXwwUc30sBj -y8h50yrDIHMUlEa+vG589NG/MKGKCRzo/TiCXMR2SxoESWEMIhaELvropIf+ -BzdqNMFD6ayLPlyjnuCACBQl1F57OLbnrnsHU/gAhu7A6w4FIjjULIs2UNAz -CgCjNN8888s7Lz0ATtijhD/RQy/9883TA4U2svzjCPLhUGH++einnz4sl4ji -yw6B+KP+/OF8LypRbWgiBjwKVPOJaA+5Ay4yAcACGhAiAQEAOw== -} - -image create photo findImage -format gif -data { -R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAjUAAMIHEiwoEF3 -AOQpXMiQIQB3ARC6a6fO3buHAiVWfAcPYwB1AN6pa/fQnUkAIy+qEwiy3bp07DqaPPmS3TqS -Kz/SA8ATQDyB8XoCoJczI4B2F+VBjCjvocyBCNOVS9cxAE+rUqliRHhznbunEY96dbl15kyC -Zs8OrDgzJ1uTRVnSYzcO5M8AQeu6I0oQ5DukAOAJlglPJVR5gBMifNjUqTyoAM6NK1f1auTJ -YDuuOxdTKM/NneGFHVkRLEKKE0GeFGzRdODWMhd7Xipb6FKDuAsGBAA7 -} - -image create photo centerDiffsImage -format gif -data { -R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiUAAMIHBjAHYCD -ANwRHHjOncOHBgkRSgjRYUOEGAEYMpQRoUMA/8SJFGdwY0JyKFFSBGCuZcuSHN25bLmyo0aO -Nj+GJAkg0caNiU6q/DjToE9DQWW6rNkxUdCcBneONHhy5FCDM106zErzo82vB3XuTEm27Equ -aJd6BQsVpFSRZcmeTYuWKduM7hpW3Lv33MK/gAUGBAA7 -} - -image create photo firstDiffImage -format gif -data { -R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiUAAMIdFevoMGD -Bd0JXBig3j9ChAxJnDixHkOBDilqlGjxIkGEIBVevHjOnbtzI1MKLAkAwEmVJN0BIKTIJUqY -AVgS+neo5kuVOv9J7Gkzpc5BFIn+XHg06SGlN1fKbDlTYiKqRRmWNFnV0FWTS7XqtGoz6six -XrMClRkxbdizbMm+jQngUKK7ao1OxTo3JliTZgUGBAA7 -} - -image create photo prevDiffImage -format gif -data { -R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAiGAAMIHCjwnDt3 -5wgqLHjQHQBChgwlAtAw4cIABh9GnIjwIsOH/yIeUkTR4sWMECWW9DgQJcmOJx0SGhRR5KGR -Kxei3JjT406VMH06BECUaFCWGXsilfkP51GCKGnWdGryY9GUE4s+xfiT47mqCrsq1SmT51ao -ZYGCDevwUKK3Y8k2PLg2IAA7 -} - -image create photo nextDiffImage -format gif -data { -R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAiGAAMIHHjOncGD -5wYqVFgQACFDhhIBcJdwIUN3DgsdUjSxokWBDR9G7PixIYCTIiWeJGmx4T9ChA6x/BggJESJ -FGnWtDmSoseLGSFC3DizJMaiNE2uRLrQ5U2mQFNCJYhRak6dPHH+vGjQ4VOETasWEmrokFmO -V6OOLYt2a1iHbXWGTbswIAA7 -} - -image create photo lastDiffImage -format gif -data { -R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiTAAMIHHjOncGD -5wYqVFgQgMOH7hIuZOgOwD9ChA4BiDiRokVDhhJtlNgxQENCIEVyLGmyIsqQI1meO5lyJEmK -BgG8VGnwZsuHOmtCvHmyEEiQh5IqiumRkNGjh5auXFgUqVSfTQtFZSrT5VWWHrmCFVhwakl3 -9dKqXZvW3cR6F18enVvv7b+5eEHWXYiWrV+3AgMCADs= -} - -image create photo rediffImage -format gif -data { -R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQCrPQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAicAAMIHEiwoMF0 -7AD0euVKl8OHrhjqAgDvnDsAGDOmG2jR3TmDIAVaxFiRoMJXKF/1ypgR5UqPIWOCTIfQnc2b -ABpS/Bgg3cmUQIOqBHBxIUpYADYKLEqUp8ynUKMatFgy5LmrWEdOrDoQIcuvrnSWPJfQqFCg -YhPCAtqrrduUL8/9fIWUJs2LQ2EGmFt34MWmBNPdvKlUquEAAQEAOw== -} - -image create photo markSetImage -format gif -data { -R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1Pjisd/UjtHJ -a8O4SL2qJcWqAK+SAJN6AGJiAEpKADIyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiZAAMIHEhQoLqD -CAsqFAigIQB3Dd0tNKjOXSxXrmABWBABgLqCByECuAir5EYJHimKvOgqFqxXrzZ2lBhgJUaY -LV/GOpkSIqybOF3ClPlQIEShMF/lfLVzAcqPRhsKXRqTY1GCFaUy1ckTKkiRGhtapTkxa82u -ExUSJZs2qtOUbQ2ujTsQ4luvbdXNpRtA712+UeEC7ou3YEAAADt= -} - -image create photo markClearImage -format gif -data { -R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1Pjisd/UjtHJ -a8O4SL2qJcWqAK+SAJN6AGJiAEpKADIyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiwAAMIHEhQoLqD -CAsCWKhwIbyFANwNXBiD4UF3sVw9rLhQXQCKNTguzLgxZMePMWqo5OgqVkmVNwAIXHhDpUl3 -7gCkhMkwJ02bHHfWiCkzQM5YP1cKJepRoM+kNoculEhQXc6cNW3GzNm0oFWdUSviLDgRbFST -RRsuzYpWrVaoHMsujYgVKMOPUYkCWPCQbY2iP/UuiACgr9S0NDvulQBAXd+7ZYv6bPowLdmB -By8LDAgAOw== -} - -image create photo mergeChoice1Image -format gif -data { -R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAiIAAMIHEiwYMFz -7gAQ+meoIaGHECEeAuDuoDt35wxqFIgQAMWMGzkmVHRooseTKD1WPAgy5MCOhAZRvEizJsaR -hxrq3LkzEcWXIz+eG0qUqMujSJMixJg0AEyhRYuKVDjIUMqrMxUy5MnVkM+bAEgaOpSorNmz -X6eSnGmzZkunCT825fh2btKAADt= -} - -image create photo mergeChoice2Image -format gif -data { -R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G -a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx -AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r -j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA -YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr -/7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA -liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP -/0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi -lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ -xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW -MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// -a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW -AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O -zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg -pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAiNAAMIHEiwYEF3 -AP79GzSIkMOHhAwZKkQIgLtzBguec3cxo8eNACxiHIgwpMmTIQ8dUiTSo8aRBDdynEkTIcWW -ARBGlMizJ8+VFgOcG0q0KEKWHV0qXcp0qUyYA4tKBVkxaU6UWAFMrIoR4SCfYCXe5AjgUKKz -aNMeMgT0osyaNMsihfqxpNWmQ5s2DQgAOw== -} - -image create photo mergeChoice12Image -format gif -data { -R0lGODlhFAAUAPMHAAAAAAB6uQCS3CWq/0i4/47U/7Hi/////729vQAAAAAAAAAAAAAAAAAAAAAA -AAAAACH5BAEAAAgALAAAAAAUABQAAAT+ECGEECgAIYQQggghhBBCCIFiAEQIIYQQQgghhCACxRAA -AAAAAAABAAghUA4hpBRYSimllAEQAuVAQgghhBBCCCECAoRAGIQQQgghkBBCiAAIIRAGgUMIIYQQ -QggBEEQIgTAGAAAAACAAAACEEEIgDAARQgghhBBCCCGIEAIBIIQQQghBhBBCCCGEEEIIIgQKQAgh -hBBCECGEEEIImAIQggghAAAAAAAAAATEFIAQQmCUUmAppZRCCDkFIAQREIQQQgghhBBIyCkAISAI -IYRAQgghhJARAEIACiGEEEIIIQYZMACEEAAAAAAAgACAMQJACCGEEEQIIYQQAiMAhCAPQgghhBBC -CCEEQQAIIYQiADs= -} - -image create photo mergeChoice21Image -format gif -data { -R0lGODlhFAAUAPMHAAAAAAB6uQCS3CWq/0i4/47U/7Hi/////729vQAAAAAAAAAAAAAAAAAAAAAA -AAAAACH5BAEAAAgALAAAAAAUABQAAAT+ECGEEEIIIYRAgQAhhBBCCCGEEEQIIWAKQAghBCAAAAAA -AACAmAIBQgiBUUoppRRYCiHkFIAQAoJAQgghhBBCCDkFAoSAIIQQQgghkBBCRgAIASGEgEIIIYQY -ZASAEEQAAAAAAAAAMOAIACGEEEIIIQQRQgiMABBCCCGIEEIIIYQQCABBhBBCCCEECkAIIoQQQggh -hBBCEBQDEEIIIYQQggghhEAxBAAAAAQAAAAAQgiUQyAhpZRSSillAAQRKIcQQgghhBBICBEAIRAG -IYRAQgghhBAiAEIIgjDIEEIIIYQQUAiAEEIgjAEAgAAAAAAAACGEEARhAIQQQgghhCAPQgghhEAA -CCEEEUIIIYQiADs= -} - -image create photo nullImage - -image create bitmap resize -data { - #define resize_width 14 - #define resize_height 11 - static char resize_bits[] = { - 0x20, 0x01, 0x30, 0x03, 0x38, 0x07, 0x3c, 0x0f, 0x3e, 0x1f, 0x3f, 0x3f, - 0x3e, 0x1f, 0x3c, 0x0f, 0x38, 0x07, 0x30, 0x03, 0x20, 0x01 - } -} - -# Tooltip popups - -# -# tooltips version 0.1 -# Paul Boyer -# Science Applications International Corp. -# - -############################## -# set_tooltips gets a button's name and the tooltip string as -# arguments and creates the proper bindings for entering -# and leaving the button -############################## -proc set_tooltips {widget name} { - global g - - bind $widget " - catch { after 500 { internal_tooltips_PopUp %W $name } } g(tooltip_id) - " - bind $widget "internal_tooltips_PopDown" - bind $widget "internal_tooltips_PopDown" -} - -############################## -# internal_tooltips_PopUp is used to activate the tooltip window -############################## -proc internal_tooltips_PopUp {wid name} { - global g - - # get rid of other existing tooltips - catch {destroy .tooltips_wind} - - toplevel .tooltips_wind -class ToolTip - set size_changed 0 - set bg [option get .tooltips_wind background background] - set fg [option get .tooltips_wind foreground foreground] - - # get the cursor position - set X [winfo pointerx $wid] - set Y [winfo pointery $wid] - - # add a slight offset to make tooltips fall below cursor - set Y [expr {$Y + 20}] - - # Now pop up the new widgetLabel - wm overrideredirect .tooltips_wind 1 - wm geometry .tooltips_wind +$X+$Y - label .tooltips_wind.l -text $name -border 2 -relief raised \ - -background $bg -foreground $fg - pack .tooltips_wind.l - - # make invisible - wm withdraw .tooltips_wind - update idletasks - - # adjust for bottom of screen - if {($Y + [winfo reqheight .tooltips_wind]) > [winfo screenheight .]} { - set Y [expr {$Y - [winfo reqheight .tooltips_wind] - 25}] - set size_changed 1 - } - # adjust for right border of screen - if {($X + [winfo reqwidth .tooltips_wind]) > [winfo screenwidth .]} { - set X [expr {[winfo screenwidth .] - [winfo reqwidth .tooltips_wind]}] - set size_changed 1 - } - # reset position - if {$size_changed == 1} { - wm geometry .tooltips_wind +$X+$Y - } - # make visible - wm deiconify .tooltips_wind - - # make tooltip dissappear after 5 sec - set g(tooltip_id) [after 5000 { internal_tooltips_PopDown }] -} - -proc internal_tooltips_PopDown {} { - global g - - after cancel $g(tooltip_id) - catch {destroy .tooltips_wind} -} - -# Most of this was stolen from the "CDE" package by D. J. Hagberg. -# I dig a couple more things out of the palette. -dar -proc get_cde_params {} { - global w - - # Set defaults for all the necessary things - set bg [option get . background background] - set fg [option get . foreground foreground] - set guifont [option get . buttonFontList buttonFontList] - set txtfont [option get . FontSet FontSet] - set listfont [option get . textFontList textFontList] - set textbg $bg - set textfg $fg - - # If any of these aren't set, I don't think we're in CDE after all - if {![string length $fg]} { - return 0 - } - if {![string length $bg]} { - return 0 - } - if {![string length $guifont]} { - return 0 - } - if {![string length $txtfont]} { - return 0 - } - - set guifont [string trimright $guifont ":"] - set txtfont [string trimright $txtfont ":"] - set listfont [string trimright $txtfont ":"] - regsub {medium} $txtfont "bold" dlgfont - - # They don't tell us the slightly darker color they use for the - # scrollbar backgrounds and graphics backgrounds, so we'll make - # one up. - set rgb_bg [winfo rgb . $bg] - set shadow [format #%02x%02x%02x [expr {(9*[lindex $rgb_bg 0]) /2560}] \ - [expr {(9*[lindex $rgb_bg 1]) /2560}] [expr {(9*[lindex $rgb_bg 2]) \ - /2560}]] - - # If we can find the user's dt.resources file, we can find out the - # palette and background/foreground colors - set fh "" - set palette "" - set cur_rsrc ~/.dt/sessions/current/dt.resources - set hom_rsrc ~/.dt/sessions/home/dt.resources - if {[file readable $cur_rsrc] && [file readable $hom_rsrc]} { - if {[file mtime $cur_rsrc] > [file mtime $hom_rsrc]} { - if {[catch {open $cur_rsrc r} fh]} { - set fh "" - } - } else { - if {[catch {open $hom_rsrc r} fh]} { - set fh "" - } - } - } elseif {[file readable $cur_rsrc]} { - if {[catch {open $cur_rsrc r} fh]} { - set fh "" - } - } elseif {[file readable $hom_rsrc]} { - if {[catch {open $hom_rsrc r} fh]} { - set fh "" - } - } - if {[string length $fh]} { - set palf "" - while {[gets $fh ln] != -1} { - regexp "^\\*background:\[ \t]*(.*)\$" $ln nil textbg - regexp "^\\*foreground:\[ \t]*(.*)\$" $ln nil textbg - regexp "^\\*0\\*ColorPalette:\[ \t]*(.*)\$" $ln nil palette - regexp "^Window.Color.Background:\[ \t]*(.*)\$" $ln nil textbg - regexp "^Window.Color.Foreground:\[ \t]*(.*)\$" $ln nil textfg - } - catch {close $fh} - # - # If the *0*ColorPalette setting was found above, try to find the - # indicated file in ~/.dt, $DTHOME, or /usr/dt. - # - if {[string length $palette]} { - foreach dtdir {/usr/dt /etc/dt ~/.dt} { - # This uses the last palette that we find - if {[file readable [file join $dtdir palettes $palette]]} { - set palf [file join $dtdir palettes $palette] - } - } - # debug-info "Using palette $palf" - if {[string length $palf]} { - if {![catch {open $palf r} fh]} { - gets $fh activetitle - gets $fh inactivetitle - gets $fh wkspc1 - gets $fh textbg - gets $fh guibg ;#(*.background) - default for tk under cde - gets $fh menubg - gets $fh wkspc4 - gets $fh iconbg ;#control panel bg too - close $fh - - option add *Entry.highlightColor $activetitle userDefault - option add *selectColor $activetitle userDefault - option add *Text.highlightColor $wkspc4 userDefault - option add *Dialog.Background $menubg userDefault - option add *Menu.Background $menubg userDefault - option add *Menubutton.Background $menubg userDefault - option add *Menu.activeBackground $menubg userDefault - option add *Menubutton.activeBackground $menubg userDefault - set w(selcolor) $activetitle - } - } - } - } else { - puts stderr "Neither ~/.dt/sessions/current/dt.resources nor" - puts stderr " ~/.dt/sessions/home/dt.resources was readable" - puts stderr " Falling back to plain X" - return 0 - } - - #option add *Button.font $guifont userDefault - #option add *Label.font $guifont userDefault - #option add *Menu.font $guifont userDefault - #option add *Menubutton.font $guifont userDefault - #option add *Dialog.msg.font $dlgfont userDefault - - option add *Text.Background $textbg userDefault - option add *Entry.Background $textbg userDefault - option add *Text.Foreground $textfg userDefault - option add *Entry.Foreground $textfg userDefault - option add *Button.activeBackground $bg userDefault - option add *Button.activeForeground $fg userDefault - option add *Scrollbar.activeBackground $bg userDefault - option add *Scrollbar.troughColor $shadow userDefault - option add *Canvas.Background $shadow userDefault - - # These menu configs work if you use native menus. - option add *Menu.borderWidth 1 userDefault - option add *Menu.activeForeground $fg userDefault - option add *Menubutton.activeForeground $fg userDefault - - # This draws a thin border around buttons - #option add *highlightBackground $bg userDefault - # Suppress the border - option add *HighlightThickness 0 userDefault - # Add it back for text and entry widgets - option add *Text.highlightBackground $bg userDefault - option add *Entry.highlightBackground $bg userDefault - option add *Text.HighlightThickness 2 userDefault - option add *Entry.HighlightThickness 1 userDefault - - return 1 -} - -# Maybe this could be enhanced to get configs from themes and so on? -# Right now it just sets colors so everything isn't blinding white. -proc get_aqua_params {} { - global w - - # This doesn't seem to do anything? - set w(selcolor) lightsteelblue - - # button highlightbackground has to be the same as background - # or else there are little white boxes around the button "pill" - option add *background #ebebeb userDefault - option add *Button.highlightBackground #ebebeb userDefault - - option add *Entry.HighlightThickness 2 userDefault - option add *Entry.highlightBackground $w(selcolor) userDefault - #option add *Canvas.background #eeeeee userDefault - option add *Entry.background #ffffff userDefault - option add *Text.background white userDefault -} - -############################################################################### - -# run the main proc -main - DELETED scripts/upgrade.tcl Index: scripts/upgrade.tcl ================================================================== --- scripts/upgrade.tcl +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh -# \ -exec tclsh "$0" ${1+"$@"} DELETED scripts/upload.tcl Index: scripts/upload.tcl ================================================================== --- scripts/upload.tcl +++ /dev/null @@ -1,77 +0,0 @@ -### -# Special script to upload the binaries produced by this odie -# environment for use by others -### -set server www.etoyoc.com - -proc dewinify fname { - if {[string index $fname 1] ne ":"} { - return $fname - } - return "/[string index $fname 0][string range $fname 2 end]" -} - -proc scp args { - puts "scp $args" - exec scp {*}${args} >@ stdout 2>@ stderr -} - -proc ssh {args} { - puts "ssh $args" - exec ssh {*}${args} >@ stdout 2>@ stderr -} - -proc doexec {args} { - puts "$args" - exec {*}${args} >@ stdout 2>@ stderr -} - -proc upload {fout fname server path desc} { - scp [dewinify $fname] ${server}:$path - puts $fout "[file tail $fname]$desc[expr [file size $fname]/1024]kb" -} - -set here [file dirname [file normalize [info script]]] -source [file join $here .. odieConfig.tcl] - -cd [file join $here ..] - -#if {![file exists $::odie(tcl_kit)]} { -# doexec make basekit -#} -#if {![file exists $::odie(toad_kit)]} { -# doexec make toadkit -#} -#if {![file exists $here/../src/toadkit/bipkgs.zip]} { -# doexec make basekit -#} - - -set fout [open index.html w] -puts $fout "" -puts $fout "Back to the top

" -puts $fout "Binaries tailored to $::odie(teacup_profile)" -puts $fout "

Built and uploaded on [clock format [clock seconds]]

" - -set path /var/www/download/$::odie(platform)/$::odie(odie_binary_platform) -ssh ${server} mkdir -p $path -puts $fout "" -puts $fout "" -if {[file exists $::odie(wish_kit)]} { - upload $fout $::odie(wish_kit) ${server} $path "Base kit with tk" -} -upload $fout $::odie(tcl_kit) ${server} $path "Base kit with no tk" -upload $fout $::odie(zip_kit) ${server} $path "Sourceable Zipfile" -upload $fout $::odie(gort) ${server} $path "The Gort package manager" -puts $fout "" -upload $fout $here/../odieConfig.sh ${server} $path "Odie Configuration Paramters (sh readable)" -upload $fout $here/../odieConfig.tcl ${server} $path "Odie Configuration Paramters (tcl readable)" -upload $fout ${exec_prefix}/lib/tclConfig.sh ${server} $path "Tcl Configuration Paramters (sh readable)" -upload $fout ${exec_prefix}/lib/tkConfig.sh ${server} $path "Tk Configuration Paramters (sh readable)" -puts $fout "" -upload $fout $::odie(toad_kit) ${server} $path "Batteries included binary" -upload $fout $here/../src/toadkit/bipkgs.zip ${server} $path "Batteries included packages (zipvfs without binary)" -upload $fout $here/../src/toadkit/toadkit.vfs/manifest.txt ${server} $path "Package List" -puts $fout "
Self contained executables
Config Files
Packages
" -close $fout -scp index.html ${server}:$path DELETED scripts/url-get.tcl Index: scripts/url-get.tcl ================================================================== --- scripts/url-get.tcl +++ /dev/null @@ -1,47 +0,0 @@ -### -# Package to download a file -### -if {[llength $argv] != 2} { - puts "Usage: url-get URL FILE" - exit 1 -} -package require http -set url [lindex $argv 0] -set tarfile [lindex $argv 1] -set tmpchan [open $tarfile w] -fconfigure $tmpchan -translation binary -puts [list GETTING [file tail $tarfile] from $url] - -# this proc contributed by Donal Fellows -proc geturl_followRedirects {url args} { - while 1 { - set token [http::geturl $url -validate 1] - set ncode [http::ncode $token] - if { $ncode eq "404" } { - puts stderr "URL Not found" - exit 1 - } - switch -glob $ncode { - 30[1237] {### redirect - see below ###} - default {http::cleanup $token ; return $url} - } - upvar #0 $token state - array set meta [set ${token}(meta)] - http::cleanup $token - if {![info exists meta(Location)]} { - return $url - } - set url $meta(Location) - unset meta - } -} - -set real_url [geturl_followRedirects $url] -set token [::http::geturl $real_url -channel $tmpchan -binary yes] -if {[::http::ncode $token] != "200"} { - puts stderr "DOWNLOAD FAILED" - exit 1 -} -http::cleanup $token -close $tmpchan -exit 0 DELETED scripts/walk_changes.tcl Index: scripts/walk_changes.tcl ================================================================== --- scripts/walk_changes.tcl +++ /dev/null @@ -1,50 +0,0 @@ -### -# SBIR DATA RIGHTS -# Contract No.: N00024-11-C-4120 -# Contractor Name: Test & Evaluation Solutions, LLC -# Contractor Address: 400 Holiday CT, STE 204, Warrenton, VA 20186 -# -# Expiration of SBIR Data Rights Period: 22 May 2017 -# The Government's rights to use, modify, reproduce, release, perform, -# display, or disclose technical data or computer software marked with -# this legend are restricted during the period shown as provided in -# paragraph (b)(4) of the Rights in Noncommercial Technical Data and -# Computer Software--Small Business Innovative Research (SBIR) Program -# clause contained in the above identified contract. No restrictions -# apply after the expiration date shown above. Any reproduction of -# technical data, computer software, or portions thereof marked with -# this legend must also reproduce the markings. -# -# Distribution Statement B: Distribution authorized to U.S. Government -# agencies only; (DFARS - SBIR Data Rights); 22 November 2010. Other -# requests for this document shall be referred to Naval Sea Systems -# Command ATTN: Small Business Innovation Research Program Office -# SEA05T1R, 1333 Isaac Hull Ave SE, Washington Navy Yard, DC 20376. -### - -set scriptpath [file dirname [file normalize [info script]]] -set tclsh [info nameofexecutable] -set list [exec find . -iname *.tcl.new] - - button .keep -text "Keep Change" -command {set action keep} - button .trash -text "Trash Change" -command {set action trash} - button .skip -text "Skip" -command {set action skip} - grid .keep .trash .skip - -foreach item $list { - set oldfile [file rootname $item] - set newfile $item - catch {exec $tclsh $scriptpath/tkdiff.tcl [file rootname $item] $item &} pid - vwait action - exec kill $pid - switch $action { - keep { - file rename -force $newfile $oldfile - } - trash { - file delete $newfile - } - skip {} - } -} -exit 0 DELETED tcl.m4 Index: tcl.m4 ================================================================== --- tcl.m4 +++ /dev/null @@ -1,3141 +0,0 @@ -#------------------------------------------------------------------------ -# SC_PATH_TCLCONFIG -- -# -# Locate the tclConfig.sh file and perform a sanity check on -# the Tcl compile flags -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tcl=... -# -# Defines the following vars: -# TCL_BIN_DIR Full path to the directory containing -# the tclConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN([SC_PATH_TCLCONFIG], [ - # - # Ok, lets find the tcl configuration - # First, look for one uninstalled. - # the alternative search directory is invoked by --with-tcl - # - - if test x"${no_tcl}" = x ; then - # we reset no_tcl in case something fails here - no_tcl=true - AC_ARG_WITH(tcl, - AC_HELP_STRING([--with-tcl], - [directory containing tcl configuration (tclConfig.sh)]), - with_tclconfig="${withval}") - AC_MSG_CHECKING([for Tcl configuration]) - AC_CACHE_VAL(ac_cv_c_tclconfig,[ - - # First check to see if --with-tcl was specified. - if test x"${with_tclconfig}" != x ; then - case "${with_tclconfig}" in - */tclConfig.sh ) - if test -f "${with_tclconfig}"; then - AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself]) - with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`" - fi ;; - esac - if test -f "${with_tclconfig}/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`" - else - AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) - fi - fi - - # then check for a private Tcl installation - if test x"${ac_cv_c_tclconfig}" = x ; then - for i in \ - ../tcl \ - `ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../tcl \ - `ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../../tcl \ - `ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" - break - fi - done - fi - - # on Darwin, check in Framework installation locations - if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then - for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ - `ls -d /Library/Frameworks 2>/dev/null` \ - `ls -d /Network/Library/Frameworks 2>/dev/null` \ - `ls -d /System/Library/Frameworks 2>/dev/null` \ - ; do - if test -f "$i/Tcl.framework/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd $i/Tcl.framework; pwd)`" - break - fi - done - fi - - # check in a few common install locations - if test x"${ac_cv_c_tclconfig}" = x ; then - for i in `ls -d ${libdir} 2>/dev/null` \ - `ls -d ${exec_prefix}/lib 2>/dev/null` \ - `ls -d ${prefix}/lib 2>/dev/null` \ - `ls -d /usr/local/lib 2>/dev/null` \ - `ls -d /usr/contrib/lib 2>/dev/null` \ - `ls -d /usr/lib 2>/dev/null` \ - `ls -d /usr/lib64 2>/dev/null` \ - ; do - if test -f "$i/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd $i; pwd)`" - break - fi - done - fi - - # check in a few other private locations - if test x"${ac_cv_c_tclconfig}" = x ; then - for i in \ - ${srcdir}/../tcl \ - `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" - break - fi - done - fi - ]) - - if test x"${ac_cv_c_tclconfig}" = x ; then - TCL_BIN_DIR="# no Tcl configs found" - AC_MSG_ERROR([Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh]) - else - no_tcl= - TCL_BIN_DIR="${ac_cv_c_tclconfig}" - AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh]) - fi - fi -]) - -#------------------------------------------------------------------------ -# SC_PATH_TKCONFIG -- -# -# Locate the tkConfig.sh file -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --with-tk=... -# -# Defines the following vars: -# TK_BIN_DIR Full path to the directory containing -# the tkConfig.sh file -#------------------------------------------------------------------------ - -AC_DEFUN([SC_PATH_TKCONFIG], [ - # - # Ok, lets find the tk configuration - # First, look for one uninstalled. - # the alternative search directory is invoked by --with-tk - # - - if test x"${no_tk}" = x ; then - # we reset no_tk in case something fails here - no_tk=true - AC_ARG_WITH(tk, - AC_HELP_STRING([--with-tk], - [directory containing tk configuration (tkConfig.sh)]), - with_tkconfig="${withval}") - AC_MSG_CHECKING([for Tk configuration]) - AC_CACHE_VAL(ac_cv_c_tkconfig,[ - - # First check to see if --with-tkconfig was specified. - if test x"${with_tkconfig}" != x ; then - case "${with_tkconfig}" in - */tkConfig.sh ) - if test -f "${with_tkconfig}"; then - AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself]) - with_tkconfig="`echo "${with_tkconfig}" | sed 's!/tkConfig\.sh$!!'`" - fi ;; - esac - if test -f "${with_tkconfig}/tkConfig.sh" ; then - ac_cv_c_tkconfig="`(cd "${with_tkconfig}"; pwd)`" - else - AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) - fi - fi - - # then check for a private Tk library - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in \ - ../tk \ - `ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../tk \ - `ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ - ../../../tk \ - `ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tkConfig.sh" ; then - ac_cv_c_tkconfig="`(cd $i/unix; pwd)`" - break - fi - done - fi - - # on Darwin, check in Framework installation locations - if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tkconfig}" = x ; then - for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ - `ls -d /Library/Frameworks 2>/dev/null` \ - `ls -d /Network/Library/Frameworks 2>/dev/null` \ - `ls -d /System/Library/Frameworks 2>/dev/null` \ - ; do - if test -f "$i/Tk.framework/tkConfig.sh" ; then - ac_cv_c_tkconfig="`(cd $i/Tk.framework; pwd)`" - break - fi - done - fi - - # check in a few common install locations - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in `ls -d ${libdir} 2>/dev/null` \ - `ls -d ${exec_prefix}/lib 2>/dev/null` \ - `ls -d ${prefix}/lib 2>/dev/null` \ - `ls -d /usr/local/lib 2>/dev/null` \ - `ls -d /usr/contrib/lib 2>/dev/null` \ - `ls -d /usr/lib 2>/dev/null` \ - `ls -d /usr/lib64 2>/dev/null` \ - ; do - if test -f "$i/tkConfig.sh" ; then - ac_cv_c_tkconfig="`(cd $i; pwd)`" - break - fi - done - fi - - # check in a few other private locations - if test x"${ac_cv_c_tkconfig}" = x ; then - for i in \ - ${srcdir}/../tk \ - `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ - `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \ - `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do - if test -f "$i/unix/tkConfig.sh" ; then - ac_cv_c_tkconfig="`(cd $i/unix; pwd)`" - break - fi - done - fi - ]) - - if test x"${ac_cv_c_tkconfig}" = x ; then - TK_BIN_DIR="# no Tk configs found" - AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh]) - else - no_tk= - TK_BIN_DIR="${ac_cv_c_tkconfig}" - AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh]) - fi - fi -]) - -#------------------------------------------------------------------------ -# SC_LOAD_TCLCONFIG -- -# -# Load the tclConfig.sh file -# -# Arguments: -# -# Requires the following vars to be set: -# TCL_BIN_DIR -# -# Results: -# -# Substitutes the following vars: -# TCL_BIN_DIR -# TCL_SRC_DIR -# TCL_LIB_FILE -#------------------------------------------------------------------------ - -AC_DEFUN([SC_LOAD_TCLCONFIG], [ - AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) - - if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then - AC_MSG_RESULT([loading]) - . "${TCL_BIN_DIR}/tclConfig.sh" - else - AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) - fi - - # eval is required to do the TCL_DBGX substitution - eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" - eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" - - # If the TCL_BIN_DIR is the build directory (not the install directory), - # then set the common variable name to the value of the build variables. - # For example, the variable TCL_LIB_SPEC will be set to the value - # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC - # instead of TCL_BUILD_LIB_SPEC since it will work with both an - # installed and uninstalled version of Tcl. - if test -f "${TCL_BIN_DIR}/Makefile" ; then - TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}" - TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}" - TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}" - elif test "`uname -s`" = "Darwin"; then - # If Tcl was built as a framework, attempt to use the libraries - # from the framework at the given location so that linking works - # against Tcl.framework installed in an arbitrary location. - case ${TCL_DEFS} in - *TCL_FRAMEWORK*) - if test -f "${TCL_BIN_DIR}/${TCL_LIB_FILE}"; then - for i in "`cd "${TCL_BIN_DIR}"; pwd`" \ - "`cd "${TCL_BIN_DIR}"/../..; pwd`"; do - if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then - TCL_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TCL_LIB_FILE}" - break - fi - done - fi - if test -f "${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}"; then - TCL_STUB_LIB_SPEC="-L`echo "${TCL_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" - TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}" - fi - ;; - esac - fi - - # eval is required to do the TCL_DBGX substitution - eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" - eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" - eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\"" - eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\"" - - AC_SUBST(TCL_VERSION) - AC_SUBST(TCL_PATCH_LEVEL) - AC_SUBST(TCL_BIN_DIR) - AC_SUBST(TCL_SRC_DIR) - - AC_SUBST(TCL_LIB_FILE) - AC_SUBST(TCL_LIB_FLAG) - AC_SUBST(TCL_LIB_SPEC) - - AC_SUBST(TCL_STUB_LIB_FILE) - AC_SUBST(TCL_STUB_LIB_FLAG) - AC_SUBST(TCL_STUB_LIB_SPEC) -]) - -#------------------------------------------------------------------------ -# SC_LOAD_TKCONFIG -- -# -# Load the tkConfig.sh file -# -# Arguments: -# -# Requires the following vars to be set: -# TK_BIN_DIR -# -# Results: -# -# Sets the following vars that should be in tkConfig.sh: -# TK_BIN_DIR -#------------------------------------------------------------------------ - -AC_DEFUN([SC_LOAD_TKCONFIG], [ - AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh]) - - if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then - AC_MSG_RESULT([loading]) - . "${TK_BIN_DIR}/tkConfig.sh" - else - AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh]) - fi - - # eval is required to do the TK_DBGX substitution - eval "TK_LIB_FILE=\"${TK_LIB_FILE}\"" - eval "TK_STUB_LIB_FILE=\"${TK_STUB_LIB_FILE}\"" - - # If the TK_BIN_DIR is the build directory (not the install directory), - # then set the common variable name to the value of the build variables. - # For example, the variable TK_LIB_SPEC will be set to the value - # of TK_BUILD_LIB_SPEC. An extension should make use of TK_LIB_SPEC - # instead of TK_BUILD_LIB_SPEC since it will work with both an - # installed and uninstalled version of Tcl. - if test -f "${TK_BIN_DIR}/Makefile" ; then - TK_LIB_SPEC="${TK_BUILD_LIB_SPEC}" - TK_STUB_LIB_SPEC="${TK_BUILD_STUB_LIB_SPEC}" - TK_STUB_LIB_PATH="${TK_BUILD_STUB_LIB_PATH}" - elif test "`uname -s`" = "Darwin"; then - # If Tk was built as a framework, attempt to use the libraries - # from the framework at the given location so that linking works - # against Tk.framework installed in an arbitrary location. - case ${TK_DEFS} in - *TK_FRAMEWORK*) - if test -f "${TK_BIN_DIR}/${TK_LIB_FILE}"; then - for i in "`cd "${TK_BIN_DIR}"; pwd`" \ - "`cd "${TK_BIN_DIR}"/../..; pwd`"; do - if test "`basename "$i"`" = "${TK_LIB_FILE}.framework"; then - TK_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TK_LIB_FILE}" - break - fi - done - fi - if test -f "${TK_BIN_DIR}/${TK_STUB_LIB_FILE}"; then - TK_STUB_LIB_SPEC="-L` echo "${TK_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TK_STUB_LIB_FLAG}" - TK_STUB_LIB_PATH="${TK_BIN_DIR}/${TK_STUB_LIB_FILE}" - fi - ;; - esac - fi - - # eval is required to do the TK_DBGX substitution - eval "TK_LIB_FLAG=\"${TK_LIB_FLAG}\"" - eval "TK_LIB_SPEC=\"${TK_LIB_SPEC}\"" - eval "TK_STUB_LIB_FLAG=\"${TK_STUB_LIB_FLAG}\"" - eval "TK_STUB_LIB_SPEC=\"${TK_STUB_LIB_SPEC}\"" - - AC_SUBST(TK_VERSION) - AC_SUBST(TK_BIN_DIR) - AC_SUBST(TK_SRC_DIR) - - AC_SUBST(TK_LIB_FILE) - AC_SUBST(TK_LIB_FLAG) - AC_SUBST(TK_LIB_SPEC) - - AC_SUBST(TK_STUB_LIB_FILE) - AC_SUBST(TK_STUB_LIB_FLAG) - AC_SUBST(TK_STUB_LIB_SPEC) -]) - -#------------------------------------------------------------------------ -# SC_PROG_TCLSH -# Locate a tclsh shell installed on the system path. This macro -# will only find a Tcl shell that already exists on the system. -# It will not find a Tcl shell in the Tcl build directory or -# a Tcl shell that has been installed from the Tcl build directory. -# If a Tcl shell can't be located on the PATH, then TCLSH_PROG will -# be set to "". Extensions should take care not to create Makefile -# rules that are run by default and depend on TCLSH_PROG. An -# extension can't assume that an executable Tcl shell exists at -# build time. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# TCLSH_PROG -#------------------------------------------------------------------------ - -AC_DEFUN([SC_PROG_TCLSH], [ - AC_MSG_CHECKING([for tclsh]) - AC_CACHE_VAL(ac_cv_path_tclsh, [ - search_path=`echo ${prefix}/bin /opt/local/bin ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/tclsh[[8-9]][6-9]* 2> /dev/null` \ - `ls -r $dir/tclsh* 2> /dev/null` ; do - if test x"$ac_cv_path_tclsh" = x ; then - if test -f "$j" ; then - ac_cv_path_tclsh=$j - break - fi - fi - done - done - ]) - - if test -f "$ac_cv_path_tclsh" ; then - TCLSH_PROG="$ac_cv_path_tclsh" - AC_MSG_RESULT([$TCLSH_PROG]) - else - # It is not an error if an installed version of Tcl can't be located. - TCLSH_PROG="" - AC_MSG_RESULT([No tclsh found on PATH]) - fi - AC_SUBST(TCLSH_PROG) -]) - -#------------------------------------------------------------------------ -# SC_BUILD_TCLSH -# Determine the fully qualified path name of the tclsh executable -# in the Tcl build directory. This macro will correctly determine -# the name of the tclsh executable even if tclsh has not yet -# been built in the build directory. The build tclsh must be used -# when running tests from an extension build directory. It is not -# correct to use the TCLSH_PROG in cases like this. -# -# Arguments: -# none -# -# Results: -# Substitutes the following values: -# BUILD_TCLSH -#------------------------------------------------------------------------ - -AC_DEFUN([SC_BUILD_TCLSH], [ - AC_MSG_CHECKING([for tclsh in Tcl build directory]) - BUILD_TCLSH="${TCL_BIN_DIR}"/tclsh - AC_MSG_RESULT([$BUILD_TCLSH]) - AC_SUBST(BUILD_TCLSH) -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_SHARED -- -# -# Allows the building of shared libraries -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-shared=yes|no -# -# Defines the following vars: -# STATIC_BUILD Used for building import/export libraries -# on Windows. -# -# Sets the following vars: -# SHARED_BUILD Value of 1 or 0 -#------------------------------------------------------------------------ - -AC_DEFUN([SC_ENABLE_SHARED], [ - AC_MSG_CHECKING([how to build libraries]) - AC_ARG_ENABLE(shared, - AC_HELP_STRING([--enable-shared], - [build and link with shared libraries (default: on)]), - [tcl_ok=$enableval], [tcl_ok=yes]) - - if test "${enable_shared+set}" = set; then - enableval="$enable_shared" - tcl_ok=$enableval - else - tcl_ok=yes - fi - - if test "$tcl_ok" = "yes" ; then - AC_MSG_RESULT([shared]) - SHARED_BUILD=1 - else - AC_MSG_RESULT([static]) - SHARED_BUILD=0 - AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_FRAMEWORK -- -# -# Allows the building of shared libraries into frameworks -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-framework=yes|no -# -# Sets the following vars: -# FRAMEWORK_BUILD Value of 1 or 0 -#------------------------------------------------------------------------ - -AC_DEFUN([SC_ENABLE_FRAMEWORK], [ - if test "`uname -s`" = "Darwin" ; then - AC_MSG_CHECKING([how to package libraries]) - AC_ARG_ENABLE(framework, - AC_HELP_STRING([--enable-framework], - [package shared libraries in MacOSX frameworks (default: off)]), - [enable_framework=$enableval], [enable_framework=no]) - if test $enable_framework = yes; then - if test $SHARED_BUILD = 0; then - AC_MSG_WARN([Frameworks can only be built if --enable-shared is yes]) - enable_framework=no - fi - if test $tcl_corefoundation = no; then - AC_MSG_WARN([Frameworks can only be used when CoreFoundation is available]) - enable_framework=no - fi - fi - if test $enable_framework = yes; then - AC_MSG_RESULT([framework]) - FRAMEWORK_BUILD=1 - else - if test $SHARED_BUILD = 1; then - AC_MSG_RESULT([shared library]) - else - AC_MSG_RESULT([static library]) - fi - FRAMEWORK_BUILD=0 - fi - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_THREADS -- -# -# Specify if thread support should be enabled -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-threads -# -# Sets the following vars: -# THREADS_LIBS Thread library(s) -# -# Defines the following vars: -# TCL_THREADS -# _REENTRANT -# _THREAD_SAFE -# -#------------------------------------------------------------------------ - -AC_DEFUN([SC_ENABLE_THREADS], [ - AC_ARG_ENABLE(threads, - AC_HELP_STRING([--enable-threads], - [build with threads (default: on)]), - [tcl_ok=$enableval], [tcl_ok=yes]) - - if test "${TCL_THREADS}" = 1; then - tcl_threaded_core=1; - fi - - if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then - TCL_THREADS=1 - # USE_THREAD_ALLOC tells us to try the special thread-based - # allocator that significantly reduces lock contention - AC_DEFINE(USE_THREAD_ALLOC, 1, - [Do we want to use the threaded memory allocator?]) - AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) - if test "`uname -s`" = "SunOS" ; then - AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, - [Do we really want to follow the standard? Yes we do!]) - fi - AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) - AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) - if test "$tcl_ok" = "no"; then - # Check a little harder for __pthread_mutex_init in the same - # library, as some systems hide it there until pthread.h is - # defined. We could alternatively do an AC_TRY_COMPILE with - # pthread.h, but that will work with libpthread really doesn't - # exist, like AIX 4.2. [Bug: 4359] - AC_CHECK_LIB(pthread, __pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - fi - - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthread" - else - AC_CHECK_LIB(pthreads, pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthreads" - else - AC_CHECK_LIB(c, pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = "no"; then - AC_CHECK_LIB(c_r, pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -pthread" - else - TCL_THREADS=0 - AC_MSG_WARN([Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...]) - fi - fi - fi - fi - - # Does the pthread-implementation provide - # 'pthread_attr_setstacksize' ? - - ac_saved_libs=$LIBS - LIBS="$LIBS $THREADS_LIBS" - AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) - LIBS=$ac_saved_libs - else - TCL_THREADS=0 - fi - # Do checking message here to not mess up interleaved configure output - AC_MSG_CHECKING([for building with threads]) - if test "${TCL_THREADS}" = 1; then - AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) - if test "${tcl_threaded_core}" = 1; then - AC_MSG_RESULT([yes (threaded core)]) - else - AC_MSG_RESULT([yes]) - fi - else - AC_MSG_RESULT([no]) - fi - - AC_SUBST(TCL_THREADS) -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_SYMBOLS -- -# -# Specify if debugging symbols should be used. -# Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging -# can also be enabled. -# -# Arguments: -# none -# -# Requires the following vars to be set in the Makefile: -# CFLAGS_DEBUG -# CFLAGS_OPTIMIZE -# LDFLAGS_DEBUG -# LDFLAGS_OPTIMIZE -# -# Results: -# -# Adds the following arguments to configure: -# --enable-symbols -# -# Defines the following vars: -# CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true -# Sets to $(CFLAGS_OPTIMIZE) if false -# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true -# Sets to $(LDFLAGS_OPTIMIZE) if false -# DBGX Formerly used as debug library extension; -# always blank now. -# -#------------------------------------------------------------------------ - -AC_DEFUN([SC_ENABLE_SYMBOLS], [ - AC_MSG_CHECKING([for build with symbols]) - AC_ARG_ENABLE(symbols, - AC_HELP_STRING([--enable-symbols], - [build with debugging symbols (default: off)]), - [tcl_ok=$enableval], [tcl_ok=no]) -# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. - DBGX="" - if test "$tcl_ok" = "no"; then - CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' - LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' - AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?]) - AC_MSG_RESULT([no]) - AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?]) - else - CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' - LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' - if test "$tcl_ok" = "yes"; then - AC_MSG_RESULT([yes (standard debugging)]) - fi - fi - AC_SUBST(CFLAGS_DEFAULT) - AC_SUBST(LDFLAGS_DEFAULT) - - if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then - AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) - fi - - ifelse($1,bccdebug,dnl Only enable 'compile' for the Tcl core itself - if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then - AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?]) - AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?]) - fi) - - if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then - if test "$tcl_ok" = "all"; then - AC_MSG_RESULT([enabled symbols mem ]ifelse($1,bccdebug,[compile ])[debugging]) - else - AC_MSG_RESULT([enabled $tcl_ok debugging]) - fi - fi -]) - -#------------------------------------------------------------------------ -# SC_ENABLE_LANGINFO -- -# -# Allows use of modern nl_langinfo check for better l10n. -# This is only relevant for Unix. -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-langinfo=yes|no (default is yes) -# -# Defines the following vars: -# HAVE_LANGINFO Triggers use of nl_langinfo if defined. -#------------------------------------------------------------------------ - -AC_DEFUN([SC_ENABLE_LANGINFO], [ - AC_ARG_ENABLE(langinfo, - AC_HELP_STRING([--enable-langinfo], - [use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on)]), - [langinfo_ok=$enableval], [langinfo_ok=yes]) - - HAVE_LANGINFO=0 - if test "$langinfo_ok" = "yes"; then - AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no]) - fi - AC_MSG_CHECKING([whether to use nl_langinfo]) - if test "$langinfo_ok" = "yes"; then - AC_CACHE_VAL(tcl_cv_langinfo_h, [ - AC_TRY_COMPILE([#include ], [nl_langinfo(CODESET);], - [tcl_cv_langinfo_h=yes],[tcl_cv_langinfo_h=no])]) - AC_MSG_RESULT([$tcl_cv_langinfo_h]) - if test $tcl_cv_langinfo_h = yes; then - AC_DEFINE(HAVE_LANGINFO, 1, [Do we have nl_langinfo()?]) - fi - else - AC_MSG_RESULT([$langinfo_ok]) - fi -]) - -#-------------------------------------------------------------------- -# SC_CONFIG_MANPAGES -# -# Decide whether to use symlinks for linking the manpages, -# whether to compress the manpages after installation, and -# whether to add a package name suffix to the installed -# manpages to avoidfile name clashes. -# If compression is enabled also find out what file name suffix -# the given compression program is using. -# -# Arguments: -# none -# -# Results: -# -# Adds the following arguments to configure: -# --enable-man-symlinks -# --enable-man-compression=PROG -# --enable-man-suffix[=STRING] -# -# Defines the following variable: -# -# MAN_FLAGS - The apropriate flags for installManPage -# according to the user's selection. -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_CONFIG_MANPAGES], [ - AC_MSG_CHECKING([whether to use symlinks for manpages]) - AC_ARG_ENABLE(man-symlinks, - AC_HELP_STRING([--enable-man-symlinks], - [use symlinks for the manpages (default: off)]), - test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks", - enableval="no") - AC_MSG_RESULT([$enableval]) - - AC_MSG_CHECKING([whether to compress the manpages]) - AC_ARG_ENABLE(man-compression, - AC_HELP_STRING([--enable-man-compression=PROG], - [compress the manpages with PROG (default: off)]), - [case $enableval in - yes) AC_MSG_ERROR([missing argument to --enable-man-compression]);; - no) ;; - *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";; - esac], - enableval="no") - AC_MSG_RESULT([$enableval]) - if test "$enableval" != "no"; then - AC_MSG_CHECKING([for compressed file suffix]) - touch TeST - $enableval TeST - Z=`ls TeST* | sed 's/^....//'` - rm -f TeST* - MAN_FLAGS="$MAN_FLAGS --extension $Z" - AC_MSG_RESULT([$Z]) - fi - - AC_MSG_CHECKING([whether to add a package name suffix for the manpages]) - AC_ARG_ENABLE(man-suffix, - AC_HELP_STRING([--enable-man-suffix=STRING], - [use STRING as a suffix to manpage file names (default: no, AC_PACKAGE_NAME if enabled without specifying STRING)]), - [case $enableval in - yes) enableval="AC_PACKAGE_NAME" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; - no) ;; - *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; - esac], - enableval="no") - AC_MSG_RESULT([$enableval]) - - AC_SUBST(MAN_FLAGS) -]) - -#-------------------------------------------------------------------- -# SC_CONFIG_SYSTEM -# -# Determine what the system is (some things cannot be easily checked -# on a feature-driven basis, alas). This can usually be done via the -# "uname" command, but there are a few systems, like Next, where -# this doesn't work. -# -# Arguments: -# none -# -# Results: -# Defines the following var: -# -# system - System/platform/version identification code. -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_CONFIG_SYSTEM], [ - AC_CACHE_CHECK([system version], tcl_cv_sys_version, [ - if test -f /usr/lib/NextStep/software_version; then - tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` - else - tcl_cv_sys_version=`uname -s`-`uname -r` - if test "$?" -ne 0 ; then - AC_MSG_WARN([can't find uname command]) - tcl_cv_sys_version=unknown - else - # Special check for weird MP-RAS system (uname returns weird - # results, and the version is kept in special file). - - if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then - tcl_cv_sys_version=MP-RAS-`awk '{print $[3]}' /etc/.relid` - fi - if test "`uname -s`" = "AIX" ; then - tcl_cv_sys_version=AIX-`uname -v`.`uname -r` - fi - fi - fi - ]) - system=$tcl_cv_sys_version -]) - -#-------------------------------------------------------------------- -# SC_CONFIG_CFLAGS -# -# Try to determine the proper flags to pass to the compiler -# for building shared libraries and other such nonsense. -# -# Arguments: -# none -# -# Results: -# -# Defines and substitutes the following vars: -# -# DL_OBJS - Name of the object file that implements dynamic -# loading for Tcl on this system. -# DL_LIBS - Library file(s) to include in tclsh and other base -# applications in order for the "load" command to work. -# LDFLAGS - Flags to pass to the compiler when linking object -# files into an executable application binary such -# as tclsh. -# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", -# that tell the run-time dynamic linker where to look -# for shared libraries such as libtcl.so. Depends on -# the variable LIB_RUNTIME_DIR in the Makefile. Could -# be the same as CC_SEARCH_FLAGS if ${CC} is used to link. -# CC_SEARCH_FLAGS-Flags to pass to ${CC}, such as "-Wl,-rpath,/usr/local/tcl/lib", -# that tell the run-time dynamic linker where to look -# for shared libraries such as libtcl.so. Depends on -# the variable LIB_RUNTIME_DIR in the Makefile. -# MAKE_LIB - Command to execute to build the a library; -# differs when building shared or static. -# MAKE_STUB_LIB - -# Command to execute to build a stub library. -# INSTALL_LIB - Command to execute to install a library; -# differs when building shared or static. -# INSTALL_STUB_LIB - -# Command to execute to install a stub library. -# STLIB_LD - Base command to use for combining object files -# into a static library. -# SHLIB_CFLAGS - Flags to pass to cc when compiling the components -# of a shared library (may request position-independent -# code, among other things). -# SHLIB_LD - Base command to use for combining object files -# into a shared library. -# SHLIB_LD_LIBS - Dependent libraries for the linker to scan when -# creating shared libraries. This symbol typically -# goes at the end of the "ld" commands that build -# shared libraries. The value of the symbol is -# "${LIBS}" if all of the dependent libraries should -# be specified when creating a shared library. If -# dependent libraries should not be specified (as on -# SunOS 4.x, where they cause the link to fail, or in -# general if Tcl and Tk aren't themselves shared -# libraries), then this symbol has an empty string -# as its value. -# SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable -# extensions. An empty string means we don't know how -# to use shared libraries on this platform. -# TCL_SHLIB_LD_EXTRAS - Additional element which are added to SHLIB_LD_LIBS -# TK_SHLIB_LD_EXTRAS for the build of Tcl and Tk, but not recorded in the -# tclConfig.sh, since they are only used for the build -# of Tcl and Tk. -# Examples: MacOS X records the library version and -# compatibility version in the shared library. But -# of course the Tcl version of this is only used for Tcl. -# LIB_SUFFIX - Specifies everything that comes after the "libfoo" -# in a static or shared library name, using the $VERSION variable -# to put the version in the right place. This is used -# by platforms that need non-standard library names. -# Examples: ${VERSION}.so.1.1 on NetBSD, since it needs -# to have a version after the .so, and ${VERSION}.a -# on AIX, since a shared library needs to have -# a .a extension whereas shared objects for loadable -# extensions have a .so extension. Defaults to -# ${VERSION}${SHLIB_SUFFIX}. -# TCL_LIBS - -# Libs to use when linking Tcl shell or some other -# shell that includes Tcl libs. -# CFLAGS_DEBUG - -# Flags used when running the compiler in debug mode -# CFLAGS_OPTIMIZE - -# Flags used when running the compiler in optimize mode -# CFLAGS - Additional CFLAGS added as necessary (usually 64-bit) -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_CONFIG_CFLAGS], [ - - # Step 0.a: Enable 64 bit support? - - AC_MSG_CHECKING([if 64bit support is requested]) - AC_ARG_ENABLE(64bit, - AC_HELP_STRING([--enable-64bit], - [enable 64bit support (default: off)]), - [do64bit=$enableval], [do64bit=no]) - AC_MSG_RESULT([$do64bit]) - - # Step 0.b: Enable Solaris 64 bit VIS support? - - AC_MSG_CHECKING([if 64bit Sparc VIS support is requested]) - AC_ARG_ENABLE(64bit-vis, - AC_HELP_STRING([--enable-64bit-vis], - [enable 64bit Sparc VIS support (default: off)]), - [do64bitVIS=$enableval], [do64bitVIS=no]) - AC_MSG_RESULT([$do64bitVIS]) - # Force 64bit on with VIS - AS_IF([test "$do64bitVIS" = "yes"], [do64bit=yes]) - - # Step 0.c: Check if visibility support is available. Do this here so - # that platform specific alternatives can be used below if this fails. - - AC_CACHE_CHECK([if compiler supports visibility "hidden"], - tcl_cv_cc_visibility_hidden, [ - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" - AC_TRY_LINK([ - extern __attribute__((__visibility__("hidden"))) void f(void); - void f(void) {}], [f();], tcl_cv_cc_visibility_hidden=yes, - tcl_cv_cc_visibility_hidden=no) - CFLAGS=$hold_cflags]) - AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ - AC_DEFINE(MODULE_SCOPE, - [extern __attribute__((__visibility__("hidden")))], - [Compiler support for module scope symbols]) - AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols]) - ]) - - # Step 0.d: Disable -rpath support? - - AC_MSG_CHECKING([if rpath support is requested]) - AC_ARG_ENABLE(rpath, - AC_HELP_STRING([--disable-rpath], - [disable rpath support (default: on)]), - [doRpath=$enableval], [doRpath=yes]) - AC_MSG_RESULT([$doRpath]) - - # Step 1: set the variable "system" to hold the name and version number - # for the system. - - SC_CONFIG_SYSTEM - - # Step 2: check for existence of -ldl library. This is needed because - # Linux can use either -ldl or -ldld for dynamic loading. - - AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) - - # Require ranlib early so we can override it in special cases below. - - AC_REQUIRE([AC_PROG_RANLIB]) - - # Step 3: set configuration options based on system name and version. - - do64bit_ok=no - # default to '{$LIBS}' and set to "" on per-platform necessary basis - SHLIB_LD_LIBS='${LIBS}' - LDFLAGS_ORIG="$LDFLAGS" - # When ld needs options to work in 64-bit mode, put them in - # LDFLAGS_ARCH so they eventually end up in LDFLAGS even if [load] - # is disabled by the user. [Bug 1016796] - LDFLAGS_ARCH="" - UNSHARED_LIB_SUFFIX="" - TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`' - ECHO_VERSION='`echo ${VERSION}`' - TCL_LIB_VERSIONS_OK=ok - CFLAGS_DEBUG=-g - AS_IF([test "$GCC" = yes], [ - CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall" - ], [ - CFLAGS_OPTIMIZE=-O - CFLAGS_WARNING="" - ]) - AC_CHECK_TOOL(AR, ar) - STLIB_LD='${AR} cr' - LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" - PLAT_OBJS="" - PLAT_SRCS="" - LDAIX_SRC="" - AS_IF([test x"${SHLIB_VERSION}" = x], [SHLIB_VERSION="1.0"]) - case $system in - AIX-*) - AS_IF([test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"], [ - # AIX requires the _r compiler when gcc isn't being used - case "${CC}" in - *_r|*_r\ *) - # ok ... - ;; - *) - # Make sure only first arg gets _r - CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'` - ;; - esac - AC_MSG_RESULT([Using $CC for compiling with threads]) - ]) - LIBS="$LIBS -lc" - SHLIB_CFLAGS="" - SHLIB_SUFFIX=".so" - - DL_OBJS="tclLoadDl.o" - LD_LIBRARY_PATH_VAR="LIBPATH" - - # ldAix No longer needed with use of -bexpall/-brtl - # but some extensions may still reference it - LDAIX_SRC='$(UNIX_DIR)/ldAix' - - # Check to enable 64-bit flags for compiler/linker - AS_IF([test "$do64bit" = yes], [ - AS_IF([test "$GCC" = yes], [ - AC_MSG_WARN([64bit mode not supported with GCC on $system]) - ], [ - do64bit_ok=yes - CFLAGS="$CFLAGS -q64" - LDFLAGS_ARCH="-q64" - RANLIB="${RANLIB} -X64" - AR="${AR} -X64" - SHLIB_LD_FLAGS="-b64" - ]) - ]) - - AS_IF([test "`uname -m`" = ia64], [ - # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC - SHLIB_LD="/usr/ccs/bin/ld -G -z text" - # AIX-5 has dl* in libc.so - DL_LIBS="" - AS_IF([test "$GCC" = yes], [ - CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - ], [ - CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' - ]) - LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - ], [ - AS_IF([test "$GCC" = yes], [ - SHLIB_LD='${CC} -shared -Wl,-bexpall' - ], [ - SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry" - LDFLAGS="$LDFLAGS -brtl" - ]) - SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - ]) - ;; - BeOS*) - SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -nostart' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - - #----------------------------------------------------------- - # Check for inet_ntoa in -lbind, for BeOS (which also needs - # -lsocket, even if the network functions are in -lnet which - # is always linked to, for compatibility. - #----------------------------------------------------------- - AC_CHECK_LIB(bind, inet_ntoa, [LIBS="$LIBS -lbind -lsocket"]) - ;; - BSD/OS-2.1*|BSD/OS-3*) - SHLIB_CFLAGS="" - SHLIB_LD="shlicc -r" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - BSD/OS-4.*) - SHLIB_CFLAGS="-export-dynamic -fPIC" - SHLIB_LD='${CC} -shared' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="$LDFLAGS -export-dynamic" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - CYGWIN_*) - SHLIB_CFLAGS="" - SHLIB_LD='${CC} -shared' - SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o" - PLAT_OBJS='${CYGWIN_OBJS}' - PLAT_SRCS='${CYGWIN_SRCS}' - DL_LIBS="-ldl" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' - TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' - TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' - AC_CACHE_CHECK(for Cygwin version of gcc, - ac_cv_cygwin, - AC_TRY_COMPILE([ - #ifdef __CYGWIN__ - #error cygwin - #endif - ], [], - ac_cv_cygwin=no, - ac_cv_cygwin=yes) - ) - if test "$ac_cv_cygwin" = "no"; then - AC_MSG_ERROR([${CC} is not a cygwin compiler.]) - fi - if test "x${TCL_THREADS}" = "x0"; then - AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads]) - fi - ;; - MINGW32*) - SHLIB_CFLAGS="" - SHLIB_LD='${CC} -shared' - SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o" - PLAT_OBJS='${CYGWIN_OBJS}' - PLAT_SRCS='${CYGWIN_SRCS}' - DL_LIBS="-ldl" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' - TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' - TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' - do64bit_ok=yes - ;; - dgux*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD='${CC} -G' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - Haiku*) - LDFLAGS="$LDFLAGS -Wl,--export-dynamic" - SHLIB_CFLAGS="-fPIC" - SHLIB_SUFFIX=".so" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' - DL_OBJS="tclLoadDl.o" - DL_LIBS="-lroot" - AC_CHECK_LIB(network, inet_ntoa, [LIBS="$LIBS -lnetwork"]) - ;; - HP-UX-*.11.*) - # Use updated header definitions where possible - AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Do we want to use the XOPEN network library?]) - AC_DEFINE(_XOPEN_SOURCE, 1, [Do we want to use the XOPEN network library?]) - LIBS="$LIBS -lxnet" # Use the XOPEN network library - - AS_IF([test "`uname -m`" = ia64], [ - SHLIB_SUFFIX=".so" - ], [ - SHLIB_SUFFIX=".sl" - ]) - AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) - AS_IF([test "$tcl_ok" = yes], [ - SHLIB_CFLAGS="+z" - SHLIB_LD="ld -b" - DL_OBJS="tclLoadShl.o" - DL_LIBS="-ldld" - LDFLAGS="$LDFLAGS -Wl,-E" - CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' - LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' - LD_LIBRARY_PATH_VAR="SHLIB_PATH" - ]) - AS_IF([test "$GCC" = yes], [ - SHLIB_LD='${CC} -shared' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - ], [ - CFLAGS="$CFLAGS -z" - ]) - - # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc - #CFLAGS="$CFLAGS +DAportable" - - # Check to enable 64-bit flags for compiler/linker - AS_IF([test "$do64bit" = "yes"], [ - AS_IF([test "$GCC" = yes], [ - case `${CC} -dumpmachine` in - hppa64*) - # 64-bit gcc in use. Fix flags for GNU ld. - do64bit_ok=yes - SHLIB_LD='${CC} -shared' - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - ;; - *) - AC_MSG_WARN([64bit mode not supported with GCC on $system]) - ;; - esac - ], [ - do64bit_ok=yes - CFLAGS="$CFLAGS +DD64" - LDFLAGS_ARCH="+DD64" - ]) - ]) ;; - HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) - SHLIB_SUFFIX=".sl" - AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) - AS_IF([test "$tcl_ok" = yes], [ - SHLIB_CFLAGS="+z" - SHLIB_LD="ld -b" - SHLIB_LD_LIBS="" - DL_OBJS="tclLoadShl.o" - DL_LIBS="-ldld" - LDFLAGS="$LDFLAGS -Wl,-E" - CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' - LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' - LD_LIBRARY_PATH_VAR="SHLIB_PATH" - ]) ;; - IRIX-5.*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -shared -rdata_shared" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - AC_LIBOBJ(mkstemp) - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) - ;; - IRIX-6.*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -n32 -shared -rdata_shared" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - AC_LIBOBJ(mkstemp) - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) - AS_IF([test "$GCC" = yes], [ - CFLAGS="$CFLAGS -mabi=n32" - LDFLAGS="$LDFLAGS -mabi=n32" - ], [ - case $system in - IRIX-6.3) - # Use to build 6.2 compatible binaries on 6.3. - CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS" - ;; - *) - CFLAGS="$CFLAGS -n32" - ;; - esac - LDFLAGS="$LDFLAGS -n32" - ]) - ;; - IRIX64-6.*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -n32 -shared -rdata_shared" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - AC_LIBOBJ(mkstemp) - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) - - # Check to enable 64-bit flags for compiler/linker - - AS_IF([test "$do64bit" = yes], [ - AS_IF([test "$GCC" = yes], [ - AC_MSG_WARN([64bit mode not supported by gcc]) - ], [ - do64bit_ok=yes - SHLIB_LD="ld -64 -shared -rdata_shared" - CFLAGS="$CFLAGS -64" - LDFLAGS_ARCH="-64" - ]) - ]) - ;; - Linux*|GNU*|NetBSD-Debian) - SHLIB_CFLAGS="-fPIC" - SHLIB_SUFFIX=".so" - - CFLAGS_OPTIMIZE="-O2" - # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings - # when you inline the string and math operations. Turn this off to - # get rid of the warnings. - #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="$LDFLAGS -Wl,--export-dynamic" - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"]) - AS_IF([test $do64bit = yes], [ - AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [ - hold_cflags=$CFLAGS - CFLAGS="$CFLAGS -m64" - AC_TRY_LINK(,, tcl_cv_cc_m64=yes, tcl_cv_cc_m64=no) - CFLAGS=$hold_cflags]) - AS_IF([test $tcl_cv_cc_m64 = yes], [ - CFLAGS="$CFLAGS -m64" - do64bit_ok=yes - ]) - ]) - - # The combo of gcc + glibc has a bug related to inlining of - # functions like strtod(). The -fno-builtin flag should address - # this problem but it does not work. The -fno-inline flag is kind - # of overkill but it works. Disable inlining only when one of the - # files in compat/*.c is being linked in. - - AS_IF([test x"${USE_COMPAT}" != x],[CFLAGS="$CFLAGS -fno-inline"]) - ;; - Lynx*) - SHLIB_CFLAGS="-fPIC" - SHLIB_SUFFIX=".so" - CFLAGS_OPTIMIZE=-02 - SHLIB_LD='${CC} -shared' - DL_OBJS="tclLoadDl.o" - DL_LIBS="-mshared -ldl" - LD_FLAGS="-Wl,--export-dynamic" - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) - ;; - MP-RAS-02*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD='${CC} -G' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - MP-RAS-*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD='${CC} -G' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LDFLAGS="$LDFLAGS -Wl,-Bexport" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - OpenBSD-*) - arch=`arch -s` - case "$arch" in - vax) - # Equivalent using configure option --disable-load - # Step 4 will set the necessary variables - DL_OBJS="" - SHLIB_LD_LIBS="" - LDFLAGS="" - ;; - *) - SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' - LDFLAGS="-Wl,-export-dynamic" - ;; - esac - case "$arch" in - vax) - CFLAGS_OPTIMIZE="-O1" - ;; - sh) - CFLAGS_OPTIMIZE="-O0" - ;; - *) - CFLAGS_OPTIMIZE="-O2" - ;; - esac - AS_IF([test "${TCL_THREADS}" = "1"], [ - # On OpenBSD: Compile with -pthread - # Don't link with -lpthread - LIBS=`echo $LIBS | sed s/-lpthread//` - CFLAGS="$CFLAGS -pthread" - ]) - # OpenBSD doesn't do version numbers with dots. - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; - NetBSD-*) - # NetBSD has ELF and can use 'cc -shared' to build shared libs - SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="$LDFLAGS -export-dynamic" - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - AS_IF([test "${TCL_THREADS}" = "1"], [ - # The -pthread needs to go in the CFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" - ]) - ;; - FreeBSD-*) - # This configuration from FreeBSD Ports. - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$[@]" - TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LDFLAGS="" - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) - AS_IF([test "${TCL_THREADS}" = "1"], [ - # The -pthread needs to go in the LDFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS $PTHREAD_CFLAGS" - LDFLAGS="$LDFLAGS $PTHREAD_LIBS"]) - # Version numbers are dot-stripped by system policy. - TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1' - TCL_LIB_VERSIONS_OK=nodots - ;; - Darwin-*) - CFLAGS_OPTIMIZE="-Os" - SHLIB_CFLAGS="-fno-common" - # To avoid discrepancies between what headers configure sees during - # preprocessing tests and compiling tests, move any -isysroot and - # -mmacosx-version-min flags from CFLAGS to CPPFLAGS: - CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \ - awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ - if ([$]i~/^(isysroot|mmacosx-version-min)/) print "-"[$]i}'`" - CFLAGS="`echo " ${CFLAGS}" | \ - awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ - if (!([$]i~/^(isysroot|mmacosx-version-min)/)) print "-"[$]i}'`" - AS_IF([test $do64bit = yes], [ - case `arch` in - ppc) - AC_CACHE_CHECK([if compiler accepts -arch ppc64 flag], - tcl_cv_cc_arch_ppc64, [ - hold_cflags=$CFLAGS - CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" - AC_TRY_LINK(,, tcl_cv_cc_arch_ppc64=yes, - tcl_cv_cc_arch_ppc64=no) - CFLAGS=$hold_cflags]) - AS_IF([test $tcl_cv_cc_arch_ppc64 = yes], [ - CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" - do64bit_ok=yes - ]);; - i386) - AC_CACHE_CHECK([if compiler accepts -arch x86_64 flag], - tcl_cv_cc_arch_x86_64, [ - hold_cflags=$CFLAGS - CFLAGS="$CFLAGS -arch x86_64" - AC_TRY_LINK(,, tcl_cv_cc_arch_x86_64=yes, - tcl_cv_cc_arch_x86_64=no) - CFLAGS=$hold_cflags]) - AS_IF([test $tcl_cv_cc_arch_x86_64 = yes], [ - CFLAGS="$CFLAGS -arch x86_64" - do64bit_ok=yes - ]);; - *) - AC_MSG_WARN([Don't know how enable 64-bit on architecture `arch`]);; - esac - ], [ - # Check for combined 32-bit and 64-bit fat build - AS_IF([echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \ - && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '], [ - fat_32_64=yes]) - ]) - SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}' - AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [ - hold_ldflags=$LDFLAGS - LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" - AC_TRY_LINK(, [int i;], tcl_cv_ld_single_module=yes, tcl_cv_ld_single_module=no) - LDFLAGS=$hold_ldflags]) - AS_IF([test $tcl_cv_ld_single_module = yes], [ - SHLIB_LD="${SHLIB_LD} -Wl,-single_module" - ]) - SHLIB_SUFFIX=".dylib" - DL_OBJS="tclLoadDyld.o" - DL_LIBS="" - # Don't use -prebind when building for Mac OS X 10.4 or later only: - AS_IF([test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int([$]2)}'`" -lt 4 -a \ - "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int([$]2)}'`" -lt 4], [ - LDFLAGS="$LDFLAGS -prebind"]) - LDFLAGS="$LDFLAGS -headerpad_max_install_names" - AC_CACHE_CHECK([if ld accepts -search_paths_first flag], - tcl_cv_ld_search_paths_first, [ - hold_ldflags=$LDFLAGS - LDFLAGS="$LDFLAGS -Wl,-search_paths_first" - AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, - tcl_cv_ld_search_paths_first=no) - LDFLAGS=$hold_ldflags]) - AS_IF([test $tcl_cv_ld_search_paths_first = yes], [ - LDFLAGS="$LDFLAGS -Wl,-search_paths_first" - ]) - AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ - AC_DEFINE(MODULE_SCOPE, [__private_extern__], - [Compiler support for module scope symbols]) - ]) - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" - AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?]) - PLAT_OBJS='${MAC_OSX_OBJS}' - PLAT_SRCS='${MAC_OSX_SRCS}' - AC_MSG_CHECKING([whether to use CoreFoundation]) - AC_ARG_ENABLE(corefoundation, - AC_HELP_STRING([--enable-corefoundation], - [use CoreFoundation API on MacOSX (default: on)]), - [tcl_corefoundation=$enableval], [tcl_corefoundation=yes]) - AC_MSG_RESULT([$tcl_corefoundation]) - AS_IF([test $tcl_corefoundation = yes], [ - AC_CACHE_CHECK([for CoreFoundation.framework], - tcl_cv_lib_corefoundation, [ - hold_libs=$LIBS - AS_IF([test "$fat_32_64" = yes], [ - for v in CFLAGS CPPFLAGS LDFLAGS; do - # On Tiger there is no 64-bit CF, so remove 64-bit - # archs from CFLAGS et al. while testing for - # presence of CF. 64-bit CF is disabled in - # tclUnixPort.h if necessary. - eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' - done]) - LIBS="$LIBS -framework CoreFoundation" - AC_TRY_LINK([#include ], - [CFBundleRef b = CFBundleGetMainBundle();], - tcl_cv_lib_corefoundation=yes, - tcl_cv_lib_corefoundation=no) - AS_IF([test "$fat_32_64" = yes], [ - for v in CFLAGS CPPFLAGS LDFLAGS; do - eval $v'="$hold_'$v'"' - done]) - LIBS=$hold_libs]) - AS_IF([test $tcl_cv_lib_corefoundation = yes], [ - LIBS="$LIBS -framework CoreFoundation" - AC_DEFINE(HAVE_COREFOUNDATION, 1, - [Do we have access to Darwin CoreFoundation.framework?]) - ], [tcl_corefoundation=no]) - AS_IF([test "$fat_32_64" = yes -a $tcl_corefoundation = yes],[ - AC_CACHE_CHECK([for 64-bit CoreFoundation], - tcl_cv_lib_corefoundation_64, [ - for v in CFLAGS CPPFLAGS LDFLAGS; do - eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' - done - AC_TRY_LINK([#include ], - [CFBundleRef b = CFBundleGetMainBundle();], - tcl_cv_lib_corefoundation_64=yes, - tcl_cv_lib_corefoundation_64=no) - for v in CFLAGS CPPFLAGS LDFLAGS; do - eval $v'="$hold_'$v'"' - done]) - AS_IF([test $tcl_cv_lib_corefoundation_64 = no], [ - AC_DEFINE(NO_COREFOUNDATION_64, 1, - [Is Darwin CoreFoundation unavailable for 64-bit?]) - LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings" - ]) - ]) - ]) - ;; - NEXTSTEP-*) - SHLIB_CFLAGS="" - SHLIB_LD='${CC} -nostdlib -r' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadNext.o" - DL_LIBS="" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - OS/390-*) - SHLIB_LD_LIBS="" - CFLAGS_OPTIMIZE="" # Optimizer is buggy - AC_DEFINE(_OE_SOCKETS, 1, # needed in sys/socket.h - [Should OS/390 do the right thing with sockets?]) - ;; - OSF1-1.0|OSF1-1.1|OSF1-1.2) - # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 - SHLIB_CFLAGS="" - # Hack: make package name same as library name - SHLIB_LD='ld -R -export $@:' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadOSF.o" - DL_LIBS="" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - OSF1-1.*) - # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 - SHLIB_CFLAGS="-fPIC" - AS_IF([test "$SHARED_BUILD" = 1], [SHLIB_LD="ld -shared"], [ - SHLIB_LD="ld -non_shared" - ]) - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - OSF1-V*) - # Digital OSF/1 - SHLIB_CFLAGS="" - AS_IF([test "$SHARED_BUILD" = 1], [ - SHLIB_LD='ld -shared -expect_unresolved "*"' - ], [ - SHLIB_LD='ld -non_shared -expect_unresolved "*"' - ]) - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) - AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [ - CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"]) - # see pthread_intro(3) for pthread support on osf1, k.furukawa - AS_IF([test "${TCL_THREADS}" = 1], [ - CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" - CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" - LIBS=`echo $LIBS | sed s/-lpthreads//` - AS_IF([test "$GCC" = yes], [ - LIBS="$LIBS -lpthread -lmach -lexc" - ], [ - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" - ]) - ]) - ;; - QNX-6*) - # QNX RTP - # This may work for all QNX, but it was only reported for v6. - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="ld -Bshareable -x" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - # dlopen is in -lc on QNX - DL_LIBS="" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - SCO_SV-3.2*) - # Note, dlopen is available only on SCO 3.2.5 and greater. However, - # this test works, since "uname -s" was non-standard in 3.2.4 and - # below. - AS_IF([test "$GCC" = yes], [ - SHLIB_CFLAGS="-fPIC -melf" - LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" - ], [ - SHLIB_CFLAGS="-Kpic -belf" - LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" - ]) - SHLIB_LD="ld -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - SINIX*5.4*) - SHLIB_CFLAGS="-K PIC" - SHLIB_LD='${CC} -G' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - SunOS-4*) - SHLIB_CFLAGS="-PIC" - SHLIB_LD="ld" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - - # SunOS can't handle version numbers with dots in them in library - # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it - # requires an extra version number at the end of .so file names. - # So, the library has to have a name like libtcl75.so.1.0 - - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; - SunOS-5.[[0-6]]) - # Careful to not let 5.10+ fall into this case - - # Note: If _REENTRANT isn't defined, then Solaris - # won't define thread-safe library routines. - - AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) - AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, - [Do we really want to follow the standard? Yes we do!]) - - SHLIB_CFLAGS="-KPIC" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - AS_IF([test "$GCC" = yes], [ - SHLIB_LD='${CC} -shared' - CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - ], [ - SHLIB_LD="/usr/ccs/bin/ld -G -z text" - CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - ]) - ;; - SunOS-5*) - # Note: If _REENTRANT isn't defined, then Solaris - # won't define thread-safe library routines. - - AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) - AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, - [Do we really want to follow the standard? Yes we do!]) - - SHLIB_CFLAGS="-KPIC" - - # Check to enable 64-bit flags for compiler/linker - AS_IF([test "$do64bit" = yes], [ - arch=`isainfo` - AS_IF([test "$arch" = "sparcv9 sparc"], [ - AS_IF([test "$GCC" = yes], [ - AS_IF([test "`${CC} -dumpversion | awk -F. '{print [$]1}'`" -lt 3], [ - AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system]) - ], [ - do64bit_ok=yes - CFLAGS="$CFLAGS -m64 -mcpu=v9" - LDFLAGS="$LDFLAGS -m64 -mcpu=v9" - SHLIB_CFLAGS="-fPIC" - ]) - ], [ - do64bit_ok=yes - AS_IF([test "$do64bitVIS" = yes], [ - CFLAGS="$CFLAGS -xarch=v9a" - LDFLAGS_ARCH="-xarch=v9a" - ], [ - CFLAGS="$CFLAGS -xarch=v9" - LDFLAGS_ARCH="-xarch=v9" - ]) - # Solaris 64 uses this as well - #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" - ]) - ], [AS_IF([test "$arch" = "amd64 i386"], [ - AS_IF([test "$GCC" = yes], [ - case $system in - SunOS-5.1[[1-9]]*|SunOS-5.[[2-9]][[0-9]]*) - do64bit_ok=yes - CFLAGS="$CFLAGS -m64" - LDFLAGS="$LDFLAGS -m64";; - *) - AC_MSG_WARN([64bit mode not supported with GCC on $system]);; - esac - ], [ - do64bit_ok=yes - case $system in - SunOS-5.1[[1-9]]*|SunOS-5.[[2-9]][[0-9]]*) - CFLAGS="$CFLAGS -m64" - LDFLAGS="$LDFLAGS -m64";; - *) - CFLAGS="$CFLAGS -xarch=amd64" - LDFLAGS="$LDFLAGS -xarch=amd64";; - esac - ]) - ], [AC_MSG_WARN([64bit mode not supported for $arch])])]) - ]) - - #-------------------------------------------------------------------- - # On Solaris 5.x i386 with the sunpro compiler we need to link - # with sunmath to get floating point rounding control - #-------------------------------------------------------------------- - AS_IF([test "$GCC" = yes],[use_sunmath=no],[ - arch=`isainfo` - AC_MSG_CHECKING([whether to use -lsunmath for fp rounding control]) - AS_IF([test "$arch" = "amd64 i386" -o "$arch" = "i386"], [ - AC_MSG_RESULT([yes]) - MATH_LIBS="-lsunmath $MATH_LIBS" - AC_CHECK_HEADER(sunmath.h) - use_sunmath=yes - ], [ - AC_MSG_RESULT([no]) - use_sunmath=no - ]) - ]) - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - AS_IF([test "$GCC" = yes], [ - SHLIB_LD='${CC} -shared' - CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - AS_IF([test "$do64bit_ok" = yes], [ - AS_IF([test "$arch" = "sparcv9 sparc"], [ - # We need to specify -static-libgcc or we need to - # add the path to the sparv9 libgcc. - SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" - # for finding sparcv9 libgcc, get the regular libgcc - # path, remove so name and append 'sparcv9' - #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." - #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" - ], [AS_IF([test "$arch" = "amd64 i386"], [ - SHLIB_LD="$SHLIB_LD -m64 -static-libgcc" - ])]) - ]) - ], [ - AS_IF([test "$use_sunmath" = yes], [textmode=textoff],[textmode=text]) - case $system in - SunOS-5.[[1-9]][[0-9]]*|SunOS-5.[[7-9]]) - SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";; - *) - SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";; - esac - CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - ]) - ;; - UNIX_SV* | UnixWare-5*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD='${CC} -G' - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers - # that don't grok the -Bexport option. Test that it does. - AC_CACHE_CHECK([for ld accepts -Bexport flag], tcl_cv_ld_Bexport, [ - hold_ldflags=$LDFLAGS - LDFLAGS="$LDFLAGS -Wl,-Bexport" - AC_TRY_LINK(, [int i;], tcl_cv_ld_Bexport=yes, tcl_cv_ld_Bexport=no) - LDFLAGS=$hold_ldflags]) - AS_IF([test $tcl_cv_ld_Bexport = yes], [ - LDFLAGS="$LDFLAGS -Wl,-Bexport" - ]) - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - esac - - AS_IF([test "$do64bit" = yes -a "$do64bit_ok" = no], [ - AC_MSG_WARN([64bit support being disabled -- don't know magic for this platform]) - ]) - - AS_IF([test "$do64bit" = yes -a "$do64bit_ok" = yes], [ - AC_DEFINE(TCL_CFG_DO64BIT, 1, [Is this a 64-bit build?]) - ]) - -dnl # Add any CPPFLAGS set in the environment to our CFLAGS, but delay doing so -dnl # until the end of configure, as configure's compile and link tests use -dnl # both CPPFLAGS and CFLAGS (unlike our compile and link) but configure's -dnl # preprocessing tests use only CPPFLAGS. - AC_CONFIG_COMMANDS_PRE([CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""]) - - # Step 4: disable dynamic loading if requested via a command-line switch. - - AC_ARG_ENABLE(load, - AC_HELP_STRING([--enable-load], - [allow dynamic loading and "load" command (default: on)]), - [tcl_ok=$enableval], [tcl_ok=yes]) - AS_IF([test "$tcl_ok" = no], [DL_OBJS=""]) - - AS_IF([test "x$DL_OBJS" != x], [BUILD_DLTEST="\$(DLTEST_TARGETS)"], [ - AC_MSG_WARN([Can't figure out how to do dynamic loading or shared libraries on this system.]) - SHLIB_CFLAGS="" - SHLIB_LD="" - SHLIB_SUFFIX="" - DL_OBJS="tclLoadNone.o" - DL_LIBS="" - LDFLAGS="$LDFLAGS_ORIG" - CC_SEARCH_FLAGS="" - LD_SEARCH_FLAGS="" - BUILD_DLTEST="" - ]) - LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" - - # If we're running gcc, then change the C flags for compiling shared - # libraries to the right flags for gcc, instead of those for the - # standard manufacturer compiler. - - AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [ - case $system in - AIX-*) ;; - BSD/OS*) ;; - CYGWIN_*|MINGW32_*) ;; - IRIX*) ;; - NetBSD-*|FreeBSD-*|OpenBSD-*) ;; - Darwin-*) ;; - SCO_SV-3.2*) ;; - *) SHLIB_CFLAGS="-fPIC" ;; - esac]) - - AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ - AC_DEFINE(MODULE_SCOPE, [extern], - [No Compiler support for module scope symbols]) - ]) - - AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [ - SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}']) - AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [ - UNSHARED_LIB_SUFFIX='${VERSION}.a']) - DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)" - - AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ - LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${TCL_SHLIB_LD_EXTRAS} ${SHLIB_LD_LIBS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' - AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ - INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)"' - DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" - ], [ - INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' - ]) - ], [ - LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} - - AS_IF([test "$RANLIB" = ""], [ - MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}' - INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' - ], [ - MAKE_LIB='${STLIB_LD} [$]@ ${OBJS} ; ${RANLIB} [$]@' - INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)" ; (cd "$(LIB_INSTALL_DIR)" ; $(RANLIB) $(LIB_FILE))' - ]) - ]) - - # Stub lib does not depend on shared/static configuration - AS_IF([test "$RANLIB" = ""], [ - MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS}' - INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"' - ], [ - MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS} ; ${RANLIB} [$]@' - INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)" ; (cd "$(LIB_INSTALL_DIR)" ; $(RANLIB) $(STUB_LIB_FILE))' - ]) - - # Define TCL_LIBS now that we know what DL_LIBS is. - # The trick here is that we don't want to change the value of TCL_LIBS if - # it is already set when tclConfig.sh had been loaded by Tk. - AS_IF([test "x${TCL_LIBS}" = x], [ - TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"]) - AC_SUBST(TCL_LIBS) - - # See if the compiler supports casting to a union type. - # This is used to stop gcc from printing a compiler - # warning when initializing a union member. - - AC_CACHE_CHECK(for cast to union support, - tcl_cv_cast_to_union, - AC_TRY_COMPILE([], - [ - union foo { int i; double d; }; - union foo f = (union foo) (int) 0; - ], - tcl_cv_cast_to_union=yes, - tcl_cv_cast_to_union=no) - ) - if test "$tcl_cv_cast_to_union" = "yes"; then - AC_DEFINE(HAVE_CAST_TO_UNION, 1, - [Defined when compiler supports casting to union type.]) - fi - - # FIXME: This subst was left in only because the TCL_DL_LIBS - # entry in tclConfig.sh uses it. It is not clear why someone - # would use TCL_DL_LIBS instead of TCL_LIBS. - AC_SUBST(DL_LIBS) - - AC_SUBST(DL_OBJS) - AC_SUBST(PLAT_OBJS) - AC_SUBST(PLAT_SRCS) - AC_SUBST(LDAIX_SRC) - AC_SUBST(CFLAGS) - AC_SUBST(CFLAGS_DEBUG) - AC_SUBST(CFLAGS_OPTIMIZE) - AC_SUBST(CFLAGS_WARNING) - - AC_SUBST(LDFLAGS) - AC_SUBST(LDFLAGS_DEBUG) - AC_SUBST(LDFLAGS_OPTIMIZE) - AC_SUBST(CC_SEARCH_FLAGS) - AC_SUBST(LD_SEARCH_FLAGS) - - AC_SUBST(STLIB_LD) - AC_SUBST(SHLIB_LD) - AC_SUBST(TCL_SHLIB_LD_EXTRAS) - AC_SUBST(TK_SHLIB_LD_EXTRAS) - AC_SUBST(SHLIB_LD_LIBS) - AC_SUBST(SHLIB_CFLAGS) - AC_SUBST(SHLIB_SUFFIX) - AC_DEFINE_UNQUOTED(TCL_SHLIB_EXT,"${SHLIB_SUFFIX}", - [What is the default extension for shared libraries?]) - - AC_SUBST(MAKE_LIB) - AC_SUBST(MAKE_STUB_LIB) - AC_SUBST(INSTALL_LIB) - AC_SUBST(DLL_INSTALL_DIR) - AC_SUBST(INSTALL_STUB_LIB) - AC_SUBST(RANLIB) -]) - -#-------------------------------------------------------------------- -# SC_MISSING_POSIX_HEADERS -# -# Supply substitutes for missing POSIX header files. Special -# notes: -# - stdlib.h doesn't define strtol, strtoul, or -# strtod insome versions of SunOS -# - some versions of string.h don't declare procedures such -# as strstr -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# NO_DIRENT_H -# NO_VALUES_H -# HAVE_LIMITS_H or NO_LIMITS_H -# NO_STDLIB_H -# NO_STRING_H -# NO_SYS_WAIT_H -# NO_DLFCN_H -# HAVE_SYS_PARAM_H -# -# HAVE_STRING_H ? -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_MISSING_POSIX_HEADERS], [ - AC_CACHE_CHECK([dirent.h], tcl_cv_dirent_h, [ - AC_TRY_LINK([#include -#include ], [ -#ifndef _POSIX_SOURCE -# ifdef __Lynx__ - /* - * Generate compilation error to make the test fail: Lynx headers - * are only valid if really in the POSIX environment. - */ - - missing_procedure(); -# endif -#endif -DIR *d; -struct dirent *entryPtr; -char *p; -d = opendir("foobar"); -entryPtr = readdir(d); -p = entryPtr->d_name; -closedir(d); -], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no)]) - - if test $tcl_cv_dirent_h = no; then - AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) - fi - - AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])]) - AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) - AC_CHECK_HEADER(limits.h, - [AC_DEFINE(HAVE_LIMITS_H, 1, [Do we have ?])], - [AC_DEFINE(NO_LIMITS_H, 1, [Do we have ?])]) - AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) - AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) - AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) - AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) - if test $tcl_ok = 0; then - AC_DEFINE(NO_STDLIB_H, 1, [Do we have ?]) - fi - AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) - AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) - AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) - - # See also memmove check below for a place where NO_STRING_H can be - # set and why. - - if test $tcl_ok = 0; then - AC_DEFINE(NO_STRING_H, 1, [Do we have ?]) - fi - - AC_CHECK_HEADER(sys/wait.h, , [AC_DEFINE(NO_SYS_WAIT_H, 1, [Do we have ?])]) - AC_CHECK_HEADER(dlfcn.h, , [AC_DEFINE(NO_DLFCN_H, 1, [Do we have ?])]) - - # OS/390 lacks sys/param.h (and doesn't need it, by chance). - AC_HAVE_HEADERS(sys/param.h) -]) - -#-------------------------------------------------------------------- -# SC_PATH_X -# -# Locate the X11 header files and the X11 library archive. Try -# the ac_path_x macro first, but if it doesn't find the X stuff -# (e.g. because there's no xmkmf program) then check through -# a list of possible directories. Under some conditions the -# autoconf macro will return an include directory that contains -# no include files, so double-check its result just to be safe. -# -# Arguments: -# none -# -# Results: -# -# Sets the following vars: -# XINCLUDES -# XLIBSW -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_PATH_X], [ - AC_PATH_X - not_really_there="" - if test "$no_x" = ""; then - if test "$x_includes" = ""; then - AC_TRY_CPP([#include ], , not_really_there="yes") - else - if test ! -r $x_includes/X11/Xlib.h; then - not_really_there="yes" - fi - fi - fi - if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then - AC_MSG_CHECKING([for X11 header files]) - found_xincludes="no" - AC_TRY_CPP([#include ], found_xincludes="yes", found_xincludes="no") - if test "$found_xincludes" = "no"; then - dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include" - for i in $dirs ; do - if test -r $i/X11/Xlib.h; then - AC_MSG_RESULT([$i]) - XINCLUDES=" -I$i" - found_xincludes="yes" - break - fi - done - fi - else - if test "$x_includes" != ""; then - XINCLUDES="-I$x_includes" - found_xincludes="yes" - fi - fi - if test "$found_xincludes" = "no"; then - AC_MSG_RESULT([couldn't find any!]) - fi - - if test "$no_x" = yes; then - AC_MSG_CHECKING([for X11 libraries]) - XLIBSW=nope - dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib" - for i in $dirs ; do - if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl -o -r $i/libX11.dylib; then - AC_MSG_RESULT([$i]) - XLIBSW="-L$i -lX11" - x_libraries="$i" - break - fi - done - else - if test "$x_libraries" = ""; then - XLIBSW=-lX11 - else - XLIBSW="-L$x_libraries -lX11" - fi - fi - if test "$XLIBSW" = nope ; then - AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow) - fi - if test "$XLIBSW" = nope ; then - AC_MSG_RESULT([could not find any! Using -lX11.]) - XLIBSW=-lX11 - fi -]) - -#-------------------------------------------------------------------- -# SC_BLOCKING_STYLE -# -# The statements below check for systems where POSIX-style -# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. -# On these systems (mostly older ones), use the old BSD-style -# FIONBIO approach instead. -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# HAVE_SYS_IOCTL_H -# HAVE_SYS_FILIO_H -# USE_FIONBIO -# O_NONBLOCK -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_BLOCKING_STYLE], [ - AC_CHECK_HEADERS(sys/ioctl.h) - AC_CHECK_HEADERS(sys/filio.h) - SC_CONFIG_SYSTEM - AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) - case $system in - OSF*) - AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) - AC_MSG_RESULT([FIONBIO]) - ;; - SunOS-4*) - AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) - AC_MSG_RESULT([FIONBIO]) - ;; - *) - AC_MSG_RESULT([O_NONBLOCK]) - ;; - esac -]) - -#-------------------------------------------------------------------- -# SC_TIME_HANLDER -# -# Checks how the system deals with time.h, what time structures -# are used on the system, and what fields the structures have. -# -# Arguments: -# none -# -# Results: -# -# Defines some of the following vars: -# USE_DELTA_FOR_TZ -# HAVE_TM_GMTOFF -# HAVE_TM_TZADJ -# HAVE_TIMEZONE_VAR -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TIME_HANDLER], [ - AC_CHECK_HEADERS(sys/time.h) - AC_HEADER_TIME - - AC_CHECK_FUNCS(gmtime_r localtime_r mktime) - - AC_CACHE_CHECK([tm_tzadj in struct tm], tcl_cv_member_tm_tzadj, [ - AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_tzadj;], - tcl_cv_member_tm_tzadj=yes, tcl_cv_member_tm_tzadj=no)]) - if test $tcl_cv_member_tm_tzadj = yes ; then - AC_DEFINE(HAVE_TM_TZADJ, 1, [Should we use the tm_tzadj field of struct tm?]) - fi - - AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, [ - AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_gmtoff;], - tcl_cv_member_tm_gmtoff=yes, tcl_cv_member_tm_gmtoff=no)]) - if test $tcl_cv_member_tm_gmtoff = yes ; then - AC_DEFINE(HAVE_TM_GMTOFF, 1, [Should we use the tm_gmtoff field of struct tm?]) - fi - - # - # Its important to include time.h in this check, as some systems - # (like convex) have timezone functions, etc. - # - AC_CACHE_CHECK([long timezone variable], tcl_cv_timezone_long, [ - AC_TRY_COMPILE([#include ], - [extern long timezone; - timezone += 1; - exit (0);], - tcl_cv_timezone_long=yes, tcl_cv_timezone_long=no)]) - if test $tcl_cv_timezone_long = yes ; then - AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?]) - else - # - # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. - # - AC_CACHE_CHECK([time_t timezone variable], tcl_cv_timezone_time, [ - AC_TRY_COMPILE([#include ], - [extern time_t timezone; - timezone += 1; - exit (0);], - tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no)]) - if test $tcl_cv_timezone_time = yes ; then - AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?]) - fi - fi -]) - -#-------------------------------------------------------------------- -# SC_BUGGY_STRTOD -# -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" (provided by Tcl) that corrects the error. -# Also, on Compaq's Tru64 Unix 5.0, -# strtod(" ") returns 0.0 instead of a failure to convert. -# -# Arguments: -# none -# -# Results: -# -# Might defines some of the following vars: -# strtod (=fixstrtod) -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_BUGGY_STRTOD], [ - AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) - if test "$tcl_strtod" = 1; then - AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[ - AC_TRY_RUN([ - extern double strtod(); - int main() { - char *infString="Inf", *nanString="NaN", *spaceString=" "; - char *term; - double value; - value = strtod(infString, &term); - if ((term != infString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(nanString, &term); - if ((term != nanString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(spaceString, &term); - if (term == (spaceString+1)) { - exit(1); - } - exit(0); - }], tcl_cv_strtod_buggy=ok, tcl_cv_strtod_buggy=buggy, - tcl_cv_strtod_buggy=buggy)]) - if test "$tcl_cv_strtod_buggy" = buggy; then - AC_LIBOBJ([fixstrtod]) - USE_COMPAT=1 - AC_DEFINE(strtod, fixstrtod, [Do we want to use the strtod() in compat?]) - fi - fi -]) - -#-------------------------------------------------------------------- -# SC_TCL_LINK_LIBS -# -# Search for the libraries needed to link the Tcl shell. -# Things like the math library (-lm) and socket stuff (-lsocket vs. -# -lnsl) are dealt with here. -# -# Arguments: -# None. -# -# Results: -# -# Might append to the following vars: -# LIBS -# MATH_LIBS -# -# Might define the following vars: -# HAVE_NET_ERRNO_H -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_LINK_LIBS], [ - #-------------------------------------------------------------------- - # On a few very rare systems, all of the libm.a stuff is - # already in libc.a. Set compiler flags accordingly. - # Also, Linux requires the "ieee" library for math to work - # right (and it must appear before "-lm"). - #-------------------------------------------------------------------- - - AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") - AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) - - #-------------------------------------------------------------------- - # Interactive UNIX requires -linet instead of -lsocket, plus it - # needs net/errno.h to define the socket-related error codes. - #-------------------------------------------------------------------- - - AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) - AC_CHECK_HEADER(net/errno.h, [ - AC_DEFINE(HAVE_NET_ERRNO_H, 1, [Do we have ?])]) - - #-------------------------------------------------------------------- - # Check for the existence of the -lsocket and -lnsl libraries. - # The order here is important, so that they end up in the right - # order in the command line generated by make. Here are some - # special considerations: - # 1. Use "connect" and "accept" to check for -lsocket, and - # "gethostbyname" to check for -lnsl. - # 2. Use each function name only once: can't redo a check because - # autoconf caches the results of the last check and won't redo it. - # 3. Use -lnsl and -lsocket only if they supply procedures that - # aren't already present in the normal libraries. This is because - # IRIX 5.2 has libraries, but they aren't needed and they're - # bogus: they goof up name resolution if used. - # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. - # To get around this problem, check for both libraries together - # if -lsocket doesn't work by itself. - #-------------------------------------------------------------------- - - tcl_checkBoth=0 - AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) - if test "$tcl_checkSocket" = 1; then - AC_CHECK_FUNC(setsockopt, , [AC_CHECK_LIB(socket, setsockopt, - LIBS="$LIBS -lsocket", tcl_checkBoth=1)]) - fi - if test "$tcl_checkBoth" = 1; then - tk_oldLibs=$LIBS - LIBS="$LIBS -lsocket -lnsl" - AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) - fi - AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname, - [LIBS="$LIBS -lnsl"])]) -]) - -#-------------------------------------------------------------------- -# SC_TCL_EARLY_FLAGS -# -# Check for what flags are needed to be passed so the correct OS -# features are available. -# -# Arguments: -# None -# -# Results: -# -# Might define the following vars: -# _ISOC99_SOURCE -# _LARGEFILE64_SOURCE -# _LARGEFILE_SOURCE64 -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_EARLY_FLAG],[ - AC_CACHE_VAL([tcl_cv_flag_]translit($1,[A-Z],[a-z]), - AC_TRY_COMPILE([$2], $3, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no, - AC_TRY_COMPILE([[#define ]$1[ 1 -]$2], $3, - [tcl_cv_flag_]translit($1,[A-Z],[a-z])=yes, - [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no))) - if test ["x${tcl_cv_flag_]translit($1,[A-Z],[a-z])[}" = "xyes"] ; then - AC_DEFINE($1, 1, [Add the ]$1[ flag when building]) - tcl_flags="$tcl_flags $1" - fi -]) - -AC_DEFUN([SC_TCL_EARLY_FLAGS],[ - AC_MSG_CHECKING([for required early compiler flags]) - tcl_flags="" - SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include ], - [char *p = (char *)strtoll; char *q = (char *)strtoull;]) - SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include ], - [struct stat64 buf; int i = stat64("/", &buf);]) - SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include ], - [char *p = (char *)open64;]) - if test "x${tcl_flags}" = "x" ; then - AC_MSG_RESULT([none]) - else - AC_MSG_RESULT([${tcl_flags}]) - fi -]) - -#-------------------------------------------------------------------- -# SC_TCL_64BIT_FLAGS -# -# Check for what is defined in the way of 64-bit features. -# -# Arguments: -# None -# -# Results: -# -# Might define the following vars: -# TCL_WIDE_INT_IS_LONG -# TCL_WIDE_INT_TYPE -# HAVE_STRUCT_DIRENT64 -# HAVE_STRUCT_STAT64 -# HAVE_TYPE_OFF64_T -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_64BIT_FLAGS], [ - AC_MSG_CHECKING([for 64-bit integer type]) - AC_CACHE_VAL(tcl_cv_type_64bit,[ - tcl_cv_type_64bit=none - # See if the compiler knows natively about __int64 - AC_TRY_COMPILE(,[__int64 value = (__int64) 0;], - tcl_type_64bit=__int64, tcl_type_64bit="long long") - # See if we should use long anyway Note that we substitute in the - # type that is our current guess for a 64-bit type inside this check - # program, so it should be modified only carefully... - AC_TRY_COMPILE(,[switch (0) { - case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ; - }],tcl_cv_type_64bit=${tcl_type_64bit})]) - if test "${tcl_cv_type_64bit}" = none ; then - AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Are wide integers to be implemented with C 'long's?]) - AC_MSG_RESULT([using long]) - else - AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit}, - [What type should be used to define wide integers?]) - AC_MSG_RESULT([${tcl_cv_type_64bit}]) - - # Now check for auxiliary declarations - AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[ - AC_TRY_COMPILE([#include -#include ],[struct dirent64 p;], - tcl_cv_struct_dirent64=yes,tcl_cv_struct_dirent64=no)]) - if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then - AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in ?]) - fi - - AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[ - AC_TRY_COMPILE([#include ],[struct stat64 p; -], - tcl_cv_struct_stat64=yes,tcl_cv_struct_stat64=no)]) - if test "x${tcl_cv_struct_stat64}" = "xyes" ; then - AC_DEFINE(HAVE_STRUCT_STAT64, 1, [Is 'struct stat64' in ?]) - fi - - AC_CHECK_FUNCS(open64 lseek64) - AC_MSG_CHECKING([for off64_t]) - AC_CACHE_VAL(tcl_cv_type_off64_t,[ - AC_TRY_COMPILE([#include ],[off64_t offset; -], - tcl_cv_type_off64_t=yes,tcl_cv_type_off64_t=no)]) - dnl Define HAVE_TYPE_OFF64_T only when the off64_t type and the - dnl functions lseek64 and open64 are defined. - if test "x${tcl_cv_type_off64_t}" = "xyes" && \ - test "x${ac_cv_func_lseek64}" = "xyes" && \ - test "x${ac_cv_func_open64}" = "xyes" ; then - AC_DEFINE(HAVE_TYPE_OFF64_T, 1, [Is off64_t in ?]) - AC_MSG_RESULT([yes]) - else - AC_MSG_RESULT([no]) - fi - fi -]) - -#-------------------------------------------------------------------- -# SC_TCL_CFG_ENCODING TIP #59 -# -# Declare the encoding to use for embedded configuration information. -# -# Arguments: -# None. -# -# Results: -# Might append to the following vars: -# DEFS (implicit) -# -# Will define the following vars: -# TCL_CFGVAL_ENCODING -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_CFG_ENCODING], [ - AC_ARG_WITH(encoding, - AC_HELP_STRING([--with-encoding], - [encoding for configuration values (default: iso8859-1)]), - with_tcencoding=${withval}) - - if test x"${with_tcencoding}" != x ; then - AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}", - [What encoding should be used for embedded configuration info?]) - else - AC_DEFINE(TCL_CFGVAL_ENCODING,"iso8859-1", - [What encoding should be used for embedded configuration info?]) - fi -]) - -#-------------------------------------------------------------------- -# SC_TCL_CHECK_BROKEN_FUNC -# -# Check for broken function. -# -# Arguments: -# funcName - function to test for -# advancedTest - the advanced test to run if the function is present -# -# Results: -# Might cause compatability versions of the function to be used. -# Might affect the following vars: -# USE_COMPAT (implicit) -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_CHECK_BROKEN_FUNC],[ - AC_CHECK_FUNC($1, tcl_ok=1, tcl_ok=0) - if test ["$tcl_ok"] = 1; then - AC_CACHE_CHECK([proper ]$1[ implementation], [tcl_cv_]$1[_unbroken], - AC_TRY_RUN([[int main() {]$2[}]],[tcl_cv_]$1[_unbroken]=ok, - [tcl_cv_]$1[_unbroken]=broken,[tcl_cv_]$1[_unbroken]=unknown)) - if test ["$tcl_cv_]$1[_unbroken"] = "ok"; then - tcl_ok=1 - else - tcl_ok=0 - fi - fi - if test ["$tcl_ok"] = 0; then - AC_LIBOBJ($1) - USE_COMPAT=1 - fi -]) - -#-------------------------------------------------------------------- -# SC_TCL_GETHOSTBYADDR_R -# -# Check if we have MT-safe variant of gethostbyaddr(). -# -# Arguments: -# None -# -# Results: -# -# Might define the following vars: -# HAVE_GETHOSTBYADDR_R -# HAVE_GETHOSTBYADDR_R_7 -# HAVE_GETHOSTBYADDR_R_8 -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_GETHOSTBYADDR_R], [AC_CHECK_FUNC(gethostbyaddr_r, [ - AC_CACHE_CHECK([for gethostbyaddr_r with 7 args], tcl_cv_api_gethostbyaddr_r_7, [ - AC_TRY_COMPILE([ - #include - ], [ - char *addr; - int length; - int type; - struct hostent *result; - char buffer[2048]; - int buflen = 2048; - int h_errnop; - - (void) gethostbyaddr_r(addr, length, type, result, buffer, buflen, - &h_errnop); - ], tcl_cv_api_gethostbyaddr_r_7=yes, tcl_cv_api_gethostbyaddr_r_7=no)]) - tcl_ok=$tcl_cv_api_gethostbyaddr_r_7 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETHOSTBYADDR_R_7, 1, - [Define to 1 if gethostbyaddr_r takes 7 args.]) - else - AC_CACHE_CHECK([for gethostbyaddr_r with 8 args], tcl_cv_api_gethostbyaddr_r_8, [ - AC_TRY_COMPILE([ - #include - ], [ - char *addr; - int length; - int type; - struct hostent *result, *resultp; - char buffer[2048]; - int buflen = 2048; - int h_errnop; - - (void) gethostbyaddr_r(addr, length, type, result, buffer, buflen, - &resultp, &h_errnop); - ], tcl_cv_api_gethostbyaddr_r_8=yes, tcl_cv_api_gethostbyaddr_r_8=no)]) - tcl_ok=$tcl_cv_api_gethostbyaddr_r_8 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETHOSTBYADDR_R_8, 1, - [Define to 1 if gethostbyaddr_r takes 8 args.]) - fi - fi - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETHOSTBYADDR_R, 1, - [Define to 1 if gethostbyaddr_r is available.]) - fi -])]) - -#-------------------------------------------------------------------- -# SC_TCL_GETHOSTBYNAME_R -# -# Check to see what variant of gethostbyname_r() we have. -# Based on David Arnold's example from the comp.programming.threads -# FAQ Q213 -# -# Arguments: -# None -# -# Results: -# -# Might define the following vars: -# HAVE_GETHOSTBYADDR_R -# HAVE_GETHOSTBYADDR_R_3 -# HAVE_GETHOSTBYADDR_R_5 -# HAVE_GETHOSTBYADDR_R_6 -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_GETHOSTBYNAME_R], [AC_CHECK_FUNC(gethostbyname_r, [ - AC_CACHE_CHECK([for gethostbyname_r with 6 args], tcl_cv_api_gethostbyname_r_6, [ - AC_TRY_COMPILE([ - #include - ], [ - char *name; - struct hostent *he, *res; - char buffer[2048]; - int buflen = 2048; - int h_errnop; - - (void) gethostbyname_r(name, he, buffer, buflen, &res, &h_errnop); - ], tcl_cv_api_gethostbyname_r_6=yes, tcl_cv_api_gethostbyname_r_6=no)]) - tcl_ok=$tcl_cv_api_gethostbyname_r_6 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETHOSTBYNAME_R_6, 1, - [Define to 1 if gethostbyname_r takes 6 args.]) - else - AC_CACHE_CHECK([for gethostbyname_r with 5 args], tcl_cv_api_gethostbyname_r_5, [ - AC_TRY_COMPILE([ - #include - ], [ - char *name; - struct hostent *he; - char buffer[2048]; - int buflen = 2048; - int h_errnop; - - (void) gethostbyname_r(name, he, buffer, buflen, &h_errnop); - ], tcl_cv_api_gethostbyname_r_5=yes, tcl_cv_api_gethostbyname_r_5=no)]) - tcl_ok=$tcl_cv_api_gethostbyname_r_5 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETHOSTBYNAME_R_5, 1, - [Define to 1 if gethostbyname_r takes 5 args.]) - else - AC_CACHE_CHECK([for gethostbyname_r with 3 args], tcl_cv_api_gethostbyname_r_3, [ - AC_TRY_COMPILE([ - #include - ], [ - char *name; - struct hostent *he; - struct hostent_data data; - - (void) gethostbyname_r(name, he, &data); - ], tcl_cv_api_gethostbyname_r_3=yes, tcl_cv_api_gethostbyname_r_3=no)]) - tcl_ok=$tcl_cv_api_gethostbyname_r_3 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETHOSTBYNAME_R_3, 1, - [Define to 1 if gethostbyname_r takes 3 args.]) - fi - fi - fi - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETHOSTBYNAME_R, 1, - [Define to 1 if gethostbyname_r is available.]) - fi -])]) - -#-------------------------------------------------------------------- -# SC_TCL_GETPWUID_R -# -# Check if we have MT-safe variant of getpwuid() and if yes, -# which one exactly. -# -# Arguments: -# None -# -# Results: -# -# Might define the following vars: -# HAVE_GETPWUID_R -# HAVE_GETPWUID_R_4 -# HAVE_GETPWUID_R_5 -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_GETPWUID_R], [AC_CHECK_FUNC(getpwuid_r, [ - AC_CACHE_CHECK([for getpwuid_r with 5 args], tcl_cv_api_getpwuid_r_5, [ - AC_TRY_COMPILE([ - #include - #include - ], [ - uid_t uid; - struct passwd pw, *pwp; - char buf[512]; - int buflen = 512; - - (void) getpwuid_r(uid, &pw, buf, buflen, &pwp); - ], tcl_cv_api_getpwuid_r_5=yes, tcl_cv_api_getpwuid_r_5=no)]) - tcl_ok=$tcl_cv_api_getpwuid_r_5 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETPWUID_R_5, 1, - [Define to 1 if getpwuid_r takes 5 args.]) - else - AC_CACHE_CHECK([for getpwuid_r with 4 args], tcl_cv_api_getpwuid_r_4, [ - AC_TRY_COMPILE([ - #include - #include - ], [ - uid_t uid; - struct passwd pw; - char buf[512]; - int buflen = 512; - - (void)getpwnam_r(uid, &pw, buf, buflen); - ], tcl_cv_api_getpwuid_r_4=yes, tcl_cv_api_getpwuid_r_4=no)]) - tcl_ok=$tcl_cv_api_getpwuid_r_4 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETPWUID_R_4, 1, - [Define to 1 if getpwuid_r takes 4 args.]) - fi - fi - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETPWUID_R, 1, - [Define to 1 if getpwuid_r is available.]) - fi -])]) - -#-------------------------------------------------------------------- -# SC_TCL_GETPWNAM_R -# -# Check if we have MT-safe variant of getpwnam() and if yes, -# which one exactly. -# -# Arguments: -# None -# -# Results: -# -# Might define the following vars: -# HAVE_GETPWNAM_R -# HAVE_GETPWNAM_R_4 -# HAVE_GETPWNAM_R_5 -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_GETPWNAM_R], [AC_CHECK_FUNC(getpwnam_r, [ - AC_CACHE_CHECK([for getpwnam_r with 5 args], tcl_cv_api_getpwnam_r_5, [ - AC_TRY_COMPILE([ - #include - #include - ], [ - char *name; - struct passwd pw, *pwp; - char buf[512]; - int buflen = 512; - - (void) getpwnam_r(name, &pw, buf, buflen, &pwp); - ], tcl_cv_api_getpwnam_r_5=yes, tcl_cv_api_getpwnam_r_5=no)]) - tcl_ok=$tcl_cv_api_getpwnam_r_5 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETPWNAM_R_5, 1, - [Define to 1 if getpwnam_r takes 5 args.]) - else - AC_CACHE_CHECK([for getpwnam_r with 4 args], tcl_cv_api_getpwnam_r_4, [ - AC_TRY_COMPILE([ - #include - #include - ], [ - char *name; - struct passwd pw; - char buf[512]; - int buflen = 512; - - (void)getpwnam_r(name, &pw, buf, buflen); - ], tcl_cv_api_getpwnam_r_4=yes, tcl_cv_api_getpwnam_r_4=no)]) - tcl_ok=$tcl_cv_api_getpwnam_r_4 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETPWNAM_R_4, 1, - [Define to 1 if getpwnam_r takes 4 args.]) - fi - fi - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETPWNAM_R, 1, - [Define to 1 if getpwnam_r is available.]) - fi -])]) - -#-------------------------------------------------------------------- -# SC_TCL_GETGRGID_R -# -# Check if we have MT-safe variant of getgrgid() and if yes, -# which one exactly. -# -# Arguments: -# None -# -# Results: -# -# Might define the following vars: -# HAVE_GETGRGID_R -# HAVE_GETGRGID_R_4 -# HAVE_GETGRGID_R_5 -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_GETGRGID_R], [AC_CHECK_FUNC(getgrgid_r, [ - AC_CACHE_CHECK([for getgrgid_r with 5 args], tcl_cv_api_getgrgid_r_5, [ - AC_TRY_COMPILE([ - #include - #include - ], [ - gid_t gid; - struct group gr, *grp; - char buf[512]; - int buflen = 512; - - (void) getgrgid_r(gid, &gr, buf, buflen, &grp); - ], tcl_cv_api_getgrgid_r_5=yes, tcl_cv_api_getgrgid_r_5=no)]) - tcl_ok=$tcl_cv_api_getgrgid_r_5 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETGRGID_R_5, 1, - [Define to 1 if getgrgid_r takes 5 args.]) - else - AC_CACHE_CHECK([for getgrgid_r with 4 args], tcl_cv_api_getgrgid_r_4, [ - AC_TRY_COMPILE([ - #include - #include - ], [ - gid_t gid; - struct group gr; - char buf[512]; - int buflen = 512; - - (void)getgrgid_r(gid, &gr, buf, buflen); - ], tcl_cv_api_getgrgid_r_4=yes, tcl_cv_api_getgrgid_r_4=no)]) - tcl_ok=$tcl_cv_api_getgrgid_r_4 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETGRGID_R_4, 1, - [Define to 1 if getgrgid_r takes 4 args.]) - fi - fi - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETGRGID_R, 1, - [Define to 1 if getgrgid_r is available.]) - fi -])]) - -#-------------------------------------------------------------------- -# SC_TCL_GETGRNAM_R -# -# Check if we have MT-safe variant of getgrnam() and if yes, -# which one exactly. -# -# Arguments: -# None -# -# Results: -# -# Might define the following vars: -# HAVE_GETGRNAM_R -# HAVE_GETGRNAM_R_4 -# HAVE_GETGRNAM_R_5 -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_TCL_GETGRNAM_R], [AC_CHECK_FUNC(getgrnam_r, [ - AC_CACHE_CHECK([for getgrnam_r with 5 args], tcl_cv_api_getgrnam_r_5, [ - AC_TRY_COMPILE([ - #include - #include - ], [ - char *name; - struct group gr, *grp; - char buf[512]; - int buflen = 512; - - (void) getgrnam_r(name, &gr, buf, buflen, &grp); - ], tcl_cv_api_getgrnam_r_5=yes, tcl_cv_api_getgrnam_r_5=no)]) - tcl_ok=$tcl_cv_api_getgrnam_r_5 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETGRNAM_R_5, 1, - [Define to 1 if getgrnam_r takes 5 args.]) - else - AC_CACHE_CHECK([for getgrnam_r with 4 args], tcl_cv_api_getgrnam_r_4, [ - AC_TRY_COMPILE([ - #include - #include - ], [ - char *name; - struct group gr; - char buf[512]; - int buflen = 512; - - (void)getgrnam_r(name, &gr, buf, buflen); - ], tcl_cv_api_getgrnam_r_4=yes, tcl_cv_api_getgrnam_r_4=no)]) - tcl_ok=$tcl_cv_api_getgrnam_r_4 - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETGRNAM_R_4, 1, - [Define to 1 if getgrnam_r takes 4 args.]) - fi - fi - if test "$tcl_ok" = yes; then - AC_DEFINE(HAVE_GETGRNAM_R, 1, - [Define to 1 if getgrnam_r is available.]) - fi -])]) - -AC_DEFUN([SC_TCL_IPV6],[ - NEED_FAKE_RFC2553=0 - AC_CHECK_FUNCS(getnameinfo getaddrinfo freeaddrinfo gai_strerror,,[NEED_FAKE_RFC2553=1]) - AC_CHECK_TYPES([ - struct addrinfo, - struct in6_addr, - struct sockaddr_in6, - struct sockaddr_storage],,[NEED_FAKE_RFC2553=1],[[ -#include -#include -#include -#include -]]) -if test "x$NEED_FAKE_RFC2553" = "x1"; then - AC_DEFINE([NEED_FAKE_RFC2553], 1, - [Use compat implementation of getaddrinfo() and friends]) - AC_LIBOBJ([fake-rfc2553]) - AC_CHECK_FUNC(strlcpy) -fi -]) -# Local Variables: -# mode: autoconf -# End: ADDED tclconfig/practcl.tcl Index: tclconfig/practcl.tcl ================================================================== --- /dev/null +++ tclconfig/practcl.tcl @@ -0,0 +1,4822 @@ +### +# Practcl +# An object oriented templating system for stamping out Tcl API calls to C +### +puts [list LOADED practcl.tcl from [info script]] + +package require TclOO +### +# Seek out Tcllib if it's available +### +set tcllib_path {} +foreach path {.. ../.. ../../..} { + foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] { + set tclib_path $path + lappend ::auto_path $path + break + } + if {$tcllib_path ne {}} break +} + +### +# Build utility functions +### + + +### +# Extend http to follow redirects (ala Sourceforge downloads) +### +namespace eval ::http {} +proc ::http::_followRedirects {url args} { + while 1 { + set token [geturl $url -validate 1] + set ncode [ncode $token] + if { $ncode eq "404" } { + error "URL Not found" + } + switch -glob $ncode { + 30[1237] {### redirect - see below ###} + default {cleanup $token ; return $url} + } + upvar #0 $token state + array set meta [set ${token}(meta)] + cleanup $token + if {![info exists meta(Location)]} { + return $url + } + set url $meta(Location) + unset meta + } + return $url +} + +proc ::http::wget {url destfile {verbose 1}} { + package require http + set tmpchan [open $destfile w] + fconfigure $tmpchan -translation binary + if { $verbose } { + puts [list GETTING [file tail $destfile] from $url] + } + set real_url [_followRedirects $url] + set token [geturl $real_url -channel $tmpchan -binary yes] + if {[ncode $token] != "200"} { + error "DOWNLOAD FAILED" + } + cleanup $token + close $tmpchan +} + +namespace eval ::practcl {} + +### +# A command to do nothing. A handy way of +# negating an instruction without +# having to comment it completely out. +# It's also a handy attachment point for +# an object to be named later +### +if {[info command ::noop] eq {}} { + proc ::noop args {} +} + +proc ::practcl::debug args { + #puts $args + ::practcl::cputs ::DEBUG_INFO $args +} + +### +# Drop in a static copy of Tcl +### +proc ::practcl::doexec args { + puts [list {*}$args] + exec {*}$args >&@ stdout +} + +proc ::practcl::doexec_in {path args} { + set PWD [pwd] + cd $path + puts [list {*}$args] + exec {*}$args >&@ stdout + cd $PWD +} + +proc ::practcl::dotclexec args { + puts [list [info nameofexecutable] {*}$args] + exec [info nameofexecutable] {*}$args >&@ stdout +} + +proc ::practcl::domake {path args} { + set PWD [pwd] + cd $path + puts [list *** $path ***] + puts [list make {*}$args] + exec make {*}$args >&@ stdout + cd $PWD +} + +proc ::practcl::domake.tcl {path args} { + set PWD [pwd] + cd $path + puts [list *** $path ***] + puts [list make.tcl {*}$args] + exec [info nameofexecutable] make.tcl {*}$args >&@ stdout + cd $PWD +} + +proc ::practcl::fossil {path args} { + set PWD [pwd] + cd $path + puts [list {*}$args] + exec fossil {*}$args >&@ stdout + cd $PWD +} + + +proc ::practcl::fossil_status {dir} { + if {[info exists ::fosdat($dir)]} { + return $::fosdat($dir) + } + set result { +tags experimental +version {} + } + set pwd [pwd] + cd $dir + set info [exec fossil status] + cd $pwd + foreach line [split $info \n] { + if {[lindex $line 0] eq "checkout:"} { + set hash [lindex $line end-3] + set maxdate [lrange $line end-2 end-1] + dict set result hash $hash + dict set result maxdate $maxdate + regsub -all {[^0-9]} $maxdate {} isodate + dict set result isodate $isodate + } + if {[lindex $line 0] eq "tags:"} { + set tags [lrange $line 1 end] + dict set result tags $tags + break + } + } + set ::fosdat($dir) $result + return $result +} + +proc ::practcl::os {} { + return [${::practcl::MAIN} define get TEACUP_OS] +} + +if {[::package vcompare $::tcl_version 8.6] < 0} { + # Approximate ::zipfile::mkzip with exec calls + proc ::practcl::mkzip {exename barekit vfspath} { + set path [file dirname [file normalize $exename]] + set zipfile [file join $path [file rootname $exename].zip] + file copy -force $barekit $exename + set pwd [pwd] + cd $vfspath + exec zip -r $zipfile . + cd $pwd + set fout [open $exename a] + set fin [open $zipfile r] + chan configure $fout -translation binary + chan configure $fin -translation binary + chan copy $fin $fout + chan close $fin + chan close $fout + exec zip -A $exename + } + proc ::practcl::sort_dict list { + set result {} + foreach key [lsort -dictionary [dict keys $list]] { + dict set result $key [dict get $list $key] + } + return $result + } +} else { + proc ::practcl::mkzip {exename barekit vfspath} { + ::practcl::tcllib_require zipfile::mkzip + ::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath + } + proc ::practcl::sort_dict list { + return [::lsort -stride 2 -dictionary $list] + } +} + +proc ::practcl::local_os {} { + # If we have already run this command, return + # a cached copy of the data + if {[info exists ::practcl::LOCAL_INFO]} { + return $::practcl::LOCAL_INFO + } + set result [array get ::practcl::CONFIG] + dict set result TEACUP_PROFILE unknown + dict set result TEACUP_OS unknown + dict set result EXEEXT {} + set windows 0 + if {$::tcl_platform(platform) eq "windows"} { + set windows 1 + } + if {$windows} { + set system "windows" + set arch ix86 + dict set result TEACUP_PROFILE win32-ix86 + dict set result TEACUP_OS windows + dict set result EXEEXT .exe + } else { + set system [exec uname -s]-[exec uname -r] + set arch unknown + dict set result TEACUP_OS generic + } + dict set result TEA_PLATFORM $system + dict set result TEA_SYSTEM $system + if {[info exists ::SANDBOX]} { + dict set result sandbox $::SANDBOX + } + switch -glob $system { + Linux* { + dict set result TEACUP_OS linux + set arch [exec uname -m] + dict set result TEACUP_PROFILE "linux-glibc2.3-$arch" + } + GNU* { + set arch [exec uname -m] + dict set result TEACUP_OS "gnu" + } + NetBSD-Debian { + set arch [exec uname -m] + dict set result TEACUP_OS "netbsd-debian" + } + OpenBSD-* { + set arch [exec arch -s] + dict set result TEACUP_OS "openbsd" + } + Darwin* { + set arch [exec uname -m] + dict set result TEACUP_OS "macosx" + if {$arch eq "x86_64"} { + dict set result TEACUP_PROFILE "macosx10.5-i386-x86_84" + } else { + dict set result TEACUP_PROFILE "macosx-universal" + } + } + OpenBSD* { + set arch [exec arch -s] + dict set result TEACUP_OS "openbsd" + } + } + if {$arch eq "unknown"} { + catch {set arch [exec uname -m]} + } + switch -glob $arch { + i*86 { + set arch "ix86" + } + amd64 { + set arch "x86_64" + } + } + dict set result TEACUP_ARCH $arch + if {[dict get $result TEACUP_PROFILE] eq "unknown"} { + dict set result TEACUP_PROFILE [dict get $result TEACUP_OS]-$arch + } + set OS [dict get $result TEACUP_OS] + dict set result os $OS + + # Look for a local preference file + set pathlist {} + set userhome [file normalize ~/tcl] + set local_install [file join $userhome lib] + switch $OS { + windows { + set userhome [file join [file normalize $::env(LOCALAPPDATA)] Tcl] + if {[file exists c:/Tcl/Teapot]} { + dict set result teapot c:/Tcl/Teapot + } + } + macosx { + set userhome [file join [file normalize {~/Library/Application Support/}] Tcl] + if {[file exists {~/Library/Application Support/ActiveState/Teapot/repository/}]} { + dict set result teapot [file normalize {~/Library/Application Support/ActiveState/Teapot/repository/}] + } + dict set result local_install [file normalize ~/Library/Tcl] + if {![dict exists $result sandbox]} { + dict set result sandbox [file normalize ~/Library/Tcl/sandbox] + } + } + default { + } + } + dict set result userhome $userhome + # Load user preferences + if {[file exists [file join $userhome practcl.rc]]} { + set dat [::practcl::cat [file join $path practcl.rc]] + } + if {![dict exists $result prefix]} { + dict set result prefix $userhome + } + + # Create a default path for the teapot + if {![dict exists $result teapot]} { + dict set result teapot [file join $userhome teapot] + } + # Create a default path for the local sandbox + if {![dict exists $result sandbox]} { + dict set result sandbox [file join $userhome sandbox] + } + # Create a default path for download folder + if {![dict exists $result download]} { + dict set result download [file join $userhome download] + } + # Path to install local packages + if {![dict exists $result local_install]} { + dict set result local_install [file join $userhome lib] + } + if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} { + dict set result fossil_mirror $::env(FOSSIL_MIRROR) + } + + set ::practcl::LOCAL_INFO $result + return $result +} + + +### +# Detect local platform +### +proc ::practcl::config.tcl {path} { + dict set result buildpath $path + set result [local_os] + set OS [dict get $result TEACUP_OS] + set windows 0 + dict set result USEMSVC 0 + if {[file exists [file join $path config.tcl]]} { + # We have a definitive configuration file. Read its content + # and take it as gospel + set cresult [read_rc_file [file join $path config.tcl]] + set cresult [::practcl::de_shell $cresult] + if {[dict exists $cresult srcdir] && ![dict exists $cresult sandbox]} { + dict set cresult sandbox [file dirname [dict get $cresult srcdir]] + } + set result [dict merge $result [::practcl::de_shell $cresult]] + } + if {[file exists [file join $path config.site]]} { + # No config.tcl file is present but we do seed + dict set result USEMSVC 0 + foreach {f v} [::practcl::de_shell [::practcl::read_sh_file [file join $path config.site]]] { + dict set result $f $v + dict set result XCOMPILE_${f} $v + } + dict set result CONFIG_SITE [file join $path config.site] + if {[dict exist $result XCOMPILE_CC] && [regexp mingw [dict get $result XCOMPILE_CC]]} { + set windows 1 + } + } elseif {[info exists ::env(VisualStudioVersion)]} { + set windows 1 + dict set result USEMSVC 1 + } + if {$windows && [dict get $result TEACUP_OS] ne "windows"} { + if {![dict exists exists $result TEACUP_ARCH]} { + dict set result TEACUP_ARCH ix86 + } + dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH] + dict set result TEACUP_OS windows + dict set result EXEEXT .exe + } + return $result +} + + +### +# Convert an MSYS path to a windows native path +### +if {$::tcl_platform(platform) eq "windows"} { +proc ::practcl::msys_to_tclpath msyspath { + return [exec sh -c "cd $msyspath ; pwd -W"] +} +} else { +proc ::practcl::msys_to_tclpath msyspath { + return [file normalize $msyspath] +} +} + +### +# Bits stolen from fileutil +### +proc ::practcl::cat fname { + set fname [open $fname r] + set data [read $fname] + close $fname + return $data +} + +proc ::practcl::file_lexnormalize {sp} { + set spx [file split $sp] + + # Resolution of embedded relative modifiers (., and ..). + + if { + ([lsearch -exact $spx . ] < 0) && + ([lsearch -exact $spx ..] < 0) + } { + # Quick path out if there are no relative modifiers + return $sp + } + + set absolute [expr {![string equal [file pathtype $sp] relative]}] + # A volumerelative path counts as absolute for our purposes. + + set sp $spx + set np {} + set noskip 1 + + while {[llength $sp]} { + set ele [lindex $sp 0] + set sp [lrange $sp 1 end] + set islast [expr {[llength $sp] == 0}] + + if {[string equal $ele ".."]} { + if { + ($absolute && ([llength $np] > 1)) || + (!$absolute && ([llength $np] >= 1)) + } { + # .. : Remove the previous element added to the + # new path, if there actually is enough to remove. + set np [lrange $np 0 end-1] + } + } elseif {[string equal $ele "."]} { + # Ignore .'s, they stay at the current location + continue + } else { + # A regular element. + lappend np $ele + } + } + if {[llength $np] > 0} { + return [eval [linsert $np 0 file join]] + # 8.5: return [file join {*}$np] + } + return {} +} + +proc ::practcl::file_relative {base dst} { + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + if {![string equal [file pathtype $base] [file pathtype $dst]]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + set base [file_lexnormalize [file join [pwd] $base]] + set dst [file_lexnormalize [file join [pwd] $dst]] + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[string equal [lindex $dst 0] [lindex $base 0]]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + set dst [linsert $dst 0 ..] + incr baselen -1 + } + # 8.5: set dst [file join {*}$dst] + set dst [eval [linsert $dst 0 file join]] + } + + return $dst +} + +# Try to load a package, and failing that +# retrieve tcllib +proc ::practcl::tcllib_require {pkg args} { + # Try to load the package from the local environment + if {[catch [list ::package require $pkg {*}$args] err]==0} { + return $err + } + ::practcl::LOCAL tool tcllib load + uplevel #0 [list ::package require $pkg {*}$args] +} + +namespace eval ::practcl::platform {} + +proc ::practcl::platform::tcl_core_options {os} { + ### + # Download our required packages + ### + set tcl_config_opts {} + # Auto-guess options for the local operating system + switch $os { + windows { + #lappend tcl_config_opts --disable-stubs + } + linux { + } + macosx { + lappend tcl_config_opts --enable-corefoundation=yes --enable-framework=no + } + } + lappend tcl_config_opts --with-tzdata + return $tcl_config_opts +} + +proc ::practcl::platform::tk_core_options {os} { + ### + # Download our required packages + ### + set tk_config_opts {} + + # Auto-guess options for the local operating system + switch $os { + windows { + } + linux { + lappend tk_config_opts --enable-xft=no --enable-xss=no + } + macosx { + lappend tk_config_opts --enable-aqua=yes + } + } + return $tk_config_opts +} + +### +# Read a stylized key/value list stored in a file +### +proc ::practcl::read_rc_file {filename {localdat {}}} { + set result $localdat + set fin [open $filename r] + set bufline {} + set rawcount 0 + set linecount 0 + while {[gets $fin thisline]>=0} { + incr rawcount + append bufline \n $thisline + if {![info complete $bufline]} continue + set line [string trimleft $bufline] + set bufline {} + if {[string index [string trimleft $line] 0] eq "#"} continue + append result \n $line + #incr linecount + #set key [lindex $line 0] + #set value [lindex $line 1] + #dict set result $key $value + } + return $result +} + +### +# topic: e71f3f61c348d56292011eec83e95f0aacc1c618 +# description: Converts a XXX.sh file into a series of Tcl variables +### +proc ::practcl::read_sh_subst {line info} { + regsub -all {\x28} $line \x7B line + regsub -all {\x29} $line \x7D line + + #set line [string map $key [string trim $line]] + foreach {field value} $info { + catch {set $field $value} + } + if [catch {subst $line} result] { + return {} + } + set result [string trim $result] + return [string trim $result '] +} + +### +# topic: 03567140cca33c814664c7439570f669b9ab88e6 +### +proc ::practcl::read_sh_file {filename {localdat {}}} { + set fin [open $filename r] + set result {} + if {$localdat eq {}} { + set top 1 + set local [array get ::env] + dict set local EXE {} + } else { + set top 0 + set local $localdat + } + while {[gets $fin line] >= 0} { + set line [string trim $line] + if {[string index $line 0] eq "#"} continue + if {$line eq {}} continue + catch { + if {[string range $line 0 6] eq "export "} { + set eq [string first "=" $line] + set field [string trim [string range $line 6 [expr {$eq - 1}]]] + set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] + dict set result $field [read_sh_subst $value $local] + dict set local $field $value + } elseif {[string range $line 0 7] eq "include "} { + set subfile [read_sh_subst [string range $line 7 end] $local] + foreach {field value} [read_sh_file $subfile $local] { + dict set result $field $value + } + } else { + set eq [string first "=" $line] + if {$eq > 0} { + set field [read_sh_subst [string range $line 0 [expr {$eq - 1}]] $local] + set value [string trim [string range $line [expr {$eq+1}] end] '] + #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] + dict set local $field $value + dict set result $field $value + } + } + } err opts + if {[dict get $opts -code] != 0} { + #puts $opts + puts "Error reading line:\n$line\nerr: $err\n***" + return $err {*}$opts + } + } + return $result +} + +### +# A simpler form of read_sh_file tailored +# to pulling data from (tcl|tk)Config.sh +### +proc ::practcl::read_Config.sh filename { + set fin [open $filename r] + set result {} + set linecount 0 + while {[gets $fin line] >= 0} { + set line [string trim $line] + if {[string index $line 0] eq "#"} continue + if {$line eq {}} continue + catch { + set eq [string first "=" $line] + if {$eq > 0} { + set field [string range $line 0 [expr {$eq - 1}]] + set value [string trim [string range $line [expr {$eq+1}] end] '] + #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] + dict set result $field $value + incr $linecount + } + } err opts + if {[dict get $opts -code] != 0} { + #puts $opts + puts "Error reading line:\n$line\nerr: $err\n***" + return $err {*}$opts + } + } + return $result +} + +### +# A simpler form of read_sh_file tailored +# to pulling data from a Makefile +### +proc ::practcl::read_Makefile filename { + set fin [open $filename r] + set result {} + while {[gets $fin line] >= 0} { + set line [string trim $line] + if {[string index $line 0] eq "#"} continue + if {$line eq {}} continue + catch { + set eq [string first "=" $line] + if {$eq > 0} { + set field [string trim [string range $line 0 [expr {$eq - 1}]]] + set value [string trim [string trim [string range $line [expr {$eq+1}] end] ']] + switch $field { + PKG_LIB_FILE { + dict set result libfile $value + } + srcdir { + if {$value eq "."} { + dict set result srcdir [file dirname $filename] + } else { + dict set result srcdir $value + } + } + PACKAGE_NAME { + dict set result name $value + } + PACKAGE_VERSION { + dict set result version $value + } + LIBS { + dict set result PRACTCL_LIBS $value + } + PKG_LIB_FILE { + dict set result libfile $value + } + } + } + } err opts + if {[dict get $opts -code] != 0} { + #puts $opts + puts "Error reading line:\n$line\nerr: $err\n***" + return $err {*}$opts + } + # the Compile field is about where most TEA files start getting silly + if {$field eq "compile"} { + break + } + } + return $result +} + +## Append arguments to a buffer +# The command works like puts in that each call will also insert +# a line feed. Unlike puts, blank links in the interstitial are +# suppressed +proc ::practcl::cputs {varname args} { + upvar 1 $varname buffer + if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} { + + } + if {[info exist buffer]} { + if {[string index $buffer end] ne "\n"} { + append buffer \n + } + } else { + set buffer \n + } + # Trim leading \n's + append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end] +} + + +proc ::practcl::tcl_to_c {body} { + set result {} + foreach rawline [split $body \n] { + set line [string map [list \" \\\" \\ \\\\] $rawline] + cputs result "\n \"$line\\n\" \\" + } + return [string trimright $result \\] +} + + +proc ::practcl::_tagblock {text {style tcl} {note {}}} { + if {[string length [string trim $text]]==0} { + return {} + } + set output {} + switch $style { + tcl { + ::practcl::cputs output "# BEGIN $note" + } + c { + ::practcl::cputs output "/* BEGIN $note */" + } + default { + ::practcl::cputs output "# BEGIN $note" + } + } + ::practcl::cputs output $text + switch $style { + tcl { + ::practcl::cputs output "# END $note" + } + c { + ::practcl::cputs output "/* END $note */" + } + default { + ::practcl::cputs output "# END $note" + } + } + return $output +} + +proc ::practcl::_isdirectory name { + return [file isdirectory $name] +} + +### +# Return true if the pkgindex file contains +# any statement other than "package ifneeded" +# and/or if any package ifneeded loads a DLL +### +proc ::practcl::_pkgindex_directory {path} { + set buffer {} + set pkgidxfile [file join $path pkgIndex.tcl] + if {![file exists $pkgidxfile]} { + # No pkgIndex file, read the source + foreach file [glob -nocomplain $path/*.tm] { + set file [file normalize $file] + set fname [file rootname [file tail $file]] + ### + # We used to be able to ... Assume the package is correct in the filename + # No hunt for a "package provides" + ### + set package [lindex [split $fname -] 0] + set version [lindex [split $fname -] 1] + ### + # Read the file, and override assumptions as needed + ### + set fin [open $file r] + set dat [read $fin] + close $fin + # Look for a teapot style Package statement + foreach line [split $dat \n] { + set line [string trim $line] + if { [string range $line 0 9] != "# Package " } continue + set package [lindex $line 2] + set version [lindex $line 3] + break + } + # Look for a package provide statement + foreach line [split $dat \n] { + set line [string trim $line] + if { [string range $line 0 14] != "package provide" } continue + set package [lindex $line 2] + set version [lindex $line 3] + break + } + append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n + } + foreach file [glob -nocomplain $path/*.tcl] { + if { [file tail $file] == "version_info.tcl" } continue + set fin [open $file r] + set dat [read $fin] + close $fin + if {![regexp "package provide" $dat]} continue + set fname [file rootname [file tail $file]] + # Look for a package provide statement + foreach line [split $dat \n] { + set line [string trim $line] + if { [string range $line 0 14] != "package provide" } continue + set package [lindex $line 2] + set version [lindex $line 3] + if {[string index $package 0] in "\$ \["} continue + if {[string index $version 0] in "\$ \["} continue + append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n + break + } + } + return $buffer + } + set fin [open $pkgidxfile r] + set dat [read $fin] + close $fin + set trace 0 + #if {[file tail $path] eq "tool"} { + # set trace 1 + #} + set thisline {} + foreach line [split $dat \n] { + append thisline $line \n + if {![info complete $thisline]} continue + set line [string trim $line] + if {[string length $line]==0} { + set thisline {} ; continue + } + if {[string index $line 0] eq "#"} { + set thisline {} ; continue + } + if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} { + if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"} + set thisline {} ; continue + } + if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} { + if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" } + set thisline {} ; continue + } + if {![regexp "package.*ifneeded" $thisline]} { + # This package index contains arbitrary code + # source instead of trying to add it to the master + # package index + if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" } + return {source [file join $dir pkgIndex.tcl]} + } + append buffer $thisline \n + set thisline {} + } + if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} + return $buffer +} + + +proc ::practcl::_pkgindex_path_subdir {path} { + set result {} + foreach subpath [glob -nocomplain [file join $path *]] { + if {[file isdirectory $subpath]} { + lappend result $subpath {*}[_pkgindex_path_subdir $subpath] + } + } + return $result +} +### +# Index all paths given as though they will end up in the same +# virtual file system +### +proc ::practcl::pkgindex_path args { + set stack {} + set buffer { +lappend ::PATHSTACK $dir + } + foreach base $args { + set base [file normalize $base] + set paths [::practcl::_pkgindex_path_subdir $base] + set i [string length $base] + # Build a list of all of the paths + foreach path $paths { + if {$path eq $base} continue + set path_indexed($path) 0 + } + set path_indexed($base) 1 + set path_indexed([file join $base boot tcl]) 1 + #set path_index([file join $base boot tk]) 1 + + foreach path $paths { + if {$path_indexed($path)} continue + set thisdir [file_relative $base $path] + #set thisdir [string range $path $i+1 end] + #append buffer "# DIR $thisdir" \n + set idxbuf [::practcl::_pkgindex_directory $path] + if {[string length $idxbuf]} { + incr path_indexed($path) + append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n + append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n + } + } + } + append buffer { +set dir [lindex $::PATHSTACK end] +set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] +} + return $buffer +} + +### +# topic: 64319f4600fb63c82b2258d908f9d066 +# description: Script to build the VFS file system +### +proc ::practcl::installDir {d1 d2} { + + puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] + file delete -force -- $d2 + file mkdir $d2 + + foreach ftail [glob -directory $d1 -nocomplain -tails *] { + set f [file join $d1 $ftail] + if {[file isdirectory $f] && [string compare CVS $ftail]} { + installDir $f [file join $d2 $ftail] + } elseif {[file isfile $f]} { + file copy -force $f [file join $d2 $ftail] + if {$::tcl_platform(platform) eq {unix}} { + file attributes [file join $d2 $ftail] -permissions 0644 + } else { + file attributes [file join $d2 $ftail] -readonly 1 + } + } + } + + if {$::tcl_platform(platform) eq {unix}} { + file attributes $d2 -permissions 0755 + } else { + file attributes $d2 -readonly 1 + } +} + +proc ::practcl::copyDir {d1 d2 {toplevel 1}} { + if {$toplevel} { + puts [list ::practcl::copyDir $d1 -> $d2] + } + #file delete -force -- $d2 + file mkdir $d2 + + foreach ftail [glob -directory $d1 -nocomplain -tails *] { + set f [file join $d1 $ftail] + if {[file isdirectory $f] && [string compare CVS $ftail]} { + copyDir $f [file join $d2 $ftail] 0 + } elseif {[file isfile $f]} { + file copy -force $f [file join $d2 $ftail] + } + } +} + +::oo::class create ::practcl::metaclass { + superclass ::oo::object + + method script script { + eval $script + } + + method source filename { + source $filename + } + + method initialize {} {} + + method define {submethod args} { + my variable define + switch $submethod { + dump { + return [array get define] + } + add { + set field [lindex $args 0] + if {![info exists define($field)]} { + set define($field) {} + } + foreach arg [lrange $args 1 end] { + if {$arg ni $define($field)} { + lappend define($field) $arg + } + } + return $define($field) + } + remove { + set field [lindex $args 0] + if {![info exists define($field)]} { + return + } + set rlist [lrange $args 1 end] + set olist $define($field) + set nlist {} + foreach arg $olist { + if {$arg in $rlist} continue + lappend nlist $arg + } + set define($field) $nlist + return $nlist + } + exists { + set field [lindex $args 0] + return [info exists define($field)] + } + getnull - + get - + cget { + set field [lindex $args 0] + if {[info exists define($field)]} { + return $define($field) + } + return [lindex $args 1] + } + set { + if {[llength $args]==1} { + set arglist [lindex $args 0] + } else { + set arglist $args + } + array set define $arglist + if {[dict exists $arglist class]} { + my select + } + } + default { + array $submethod define {*}$args + } + } + } + + method graft args { + my variable organs + if {[llength $args] == 1} { + error "Need two arguments" + } + set object {} + foreach {stub object} $args { + dict set organs $stub $object + oo::objdefine [self] forward <${stub}> $object + oo::objdefine [self] export <${stub}> + } + return $object + } + + method organ {{stub all}} { + my variable organs + if {![info exists organs]} { + return {} + } + if { $stub eq "all" } { + return $organs + } + if {[dict exists $organs $stub]} { + return [dict get $organs $stub] + } + } + + method link {command args} { + my variable links + switch $command { + object { + foreach obj $args { + foreach linktype [$obj linktype] { + my link add $linktype $obj + } + } + } + add { + ### + # Add a link to an object that was externally created + ### + if {[llength $args] ne 2} { error "Usage: link add LINKTYPE OBJECT"} + lassign $args linktype object + if {[info exists links($linktype)] && $object in $links($linktype)} { + return + } + lappend links($linktype) $object + } + remove { + set object [lindex $args 0] + if {[llength $args]==1} { + set ltype * + } else { + set ltype [lindex $args 1] + } + foreach {linktype elements} [array get links $ltype] { + if {$object in $elements} { + set nlist {} + foreach e $elements { + if { $object ne $e } { lappend nlist $e } + } + set links($linktype) $nlist + } + } + } + list { + if {[llength $args]==0} { + return [array get links] + } + if {[llength $args] != 1} { error "Usage: link list LINKTYPE"} + set linktype [lindex $args 0] + if {![info exists links($linktype)]} { + return {} + } + return $links($linktype) + } + dump { + return [array get links] + } + } + } + + method select {} { + my variable define + set class {} + if {[info exists define(class)]} { + if {[info command $define(class)] ne {}} { + set class $define(class) + } elseif {[info command ::practcl::$define(class)] ne {}} { + set class ::practcl::$define(class) + } else { + switch $define(class) { + default { + set class ::practcl::object + } + } + } + } + if {$class ne {}} { + ::oo::objdefine [self] class $class + } + if {[::info exists define(oodefine)]} { + ::oo::objdefine [self] $define(oodefine) + unset define(oodefine) + } + } +} + +proc ::practcl::trigger {args} { + foreach name $args { + if {[dict exists $::make_objects $name]} { + [dict get $::make_objects $name] triggers + } + } +} + +proc ::practcl::depends {args} { + foreach name $args { + if {[dict exists $::make_objects $name]} { + [dict get $::make_objects $name] check + } + } +} + +proc ::practcl::target {name info} { + set obj [::practcl::target_obj new $name $info] + dict set ::make_objects $name $obj + if {[dict exists $info aliases]} { + foreach item [dict get $info aliases] { + if {![dict exists $::make_objects $item]} { + dict set ::make_objects $item $obj + } + } + } + set ::make($name) 0 + set ::trigger($name) 0 + set filename [$obj define get filename] + if {$filename ne {}} { + set ::target($name) $filename + } +} + +### Batch Tasks + +proc ::practcl::de_shell {data} { + set values {} + foreach flag {DEFS TCL_DEFS TK_DEFS} { + if {[dict exists $data $flag]} { + #set value {} + #foreach item [dict get $data $flag] { + # append value " " [string map {{ } {\ }} $item] + #} + dict set values $flag [dict get $data $flag] + } + } + set map {} + lappend map {${PKG_OBJECTS}} %LIBRARY_OBJECTS% + lappend map {$(PKG_OBJECTS)} %LIBRARY_OBJECTS% + lappend map {${PKG_STUB_OBJECTS}} %LIBRARY_STUB_OBJECTS% + lappend map {$(PKG_STUB_OBJECTS)} %LIBRARY_STUB_OBJECTS% + + if {[dict exists $data name]} { + lappend map %LIBRARY_NAME% [dict get $data name] + lappend map %LIBRARY_VERSION% [dict get $data version] + lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} [dict get $data version]] + if {[dict exists $data libprefix]} { + lappend map %LIBRARY_PREFIX% [dict get $data libprefix] + } else { + lappend map %LIBRARY_PREFIX% [dict get $data prefix] + } + } + foreach flag [dict keys $data] { + if {$flag in {TCL_DEFS TK_DEFS DEFS}} continue + set value [string trim [dict get $data $flag] \"] + dict set map "\$\{${flag}\}" $value + dict set map "\$\(${flag}\)" $value + #dict set map "\$${flag}" $value + dict set map "%${flag}%" $value + dict set values $flag [dict get $data $flag] + #dict set map "\$\{${flag}\}" $proj($flag) + } + set changed 1 + while {$changed} { + set changed 0 + foreach {field value} $values { + if {$field in {TCL_DEFS TK_DEFS DEFS}} continue + dict with values {} + set newval [string map $map $value] + if {$newval eq $value} continue + set changed 1 + dict set values $field $newval + } + } + return $values +} + +### +# Ancestor-less class intended to be a mixin +# which defines a family of build related behaviors +# that are modified when targetting either gcc or msvc +### +::oo::class create ::practcl::build { + ## method DEFS + # This method populates 4 variables: + # name - The name of the package + # version - The version of the package + # defs - C flags passed to the compiler + # includedir - A list of paths to feed to the compiler for finding headers + # + method build-cflags {PROJECT DEFS namevar versionvar defsvar} { + upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs + set name [string tolower [${PROJECT} define get name [${PROJECT} define get pkg_name]]] + set NAME [string toupper $name] + set version [${PROJECT} define get version [${PROJECT} define get pkg_vers]] + if {$version eq {}} { + set version 0.1a + } + set defs $DEFS + foreach flag { + -DPACKAGE_NAME + -DPACKAGE_VERSION + -DPACKAGE_TARNAME + -DPACKAGE_STRING + } { + if {[set i [string first $flag $defs]] >= 0} { + set j [string first -D $flag [expr {$i+[string length $flag]}]] + set predef [string range $defs 0 [expr {$i-1}]] + set postdef [string range $defs $j end] + set defs "$predef $postdef" + } + } + append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" + append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" + return $defs + } + + method build-tclkit_main {PROJECT PKG_OBJS} { + ### + # Build static package list + ### + set statpkglist {} + dict set statpkglist Tk {autoload 0} + foreach {ofile info} [${PROJECT} compile-products] { + if {![dict exists $info object]} continue + set cobj [dict get $info object] + foreach {pkg info} [$cobj static-packages] { + dict set statpkglist $pkg $info + } + } + foreach cobj [list {*}${PKG_OBJS} $PROJECT] { + foreach {pkg info} [$cobj static-packages] { + dict set statpkglist $pkg $info + } + } + + set result {} + $PROJECT include {} + $PROJECT include {"tclInt.h"} + $PROJECT include {"tclFileSystem.h"} + $PROJECT include {} + $PROJECT include {} + $PROJECT include {} + $PROJECT include {} + $PROJECT include {} + + $PROJECT code header { +#ifndef MODULE_SCOPE +# define MODULE_SCOPE extern +#endif + +/* +** Provide a dummy Tcl_InitStubs if we are using this as a static +** library. +*/ +#ifndef USE_TCL_STUBS +# undef Tcl_InitStubs +# define Tcl_InitStubs(a,b,c) TCL_VERSION +#endif +#define STATIC_BUILD 1 +#undef USE_TCL_STUBS + +/* Make sure the stubbed variants of those are never used. */ +#undef Tcl_ObjSetVar2 +#undef Tcl_NewStringObj +#undef Tk_Init +#undef Tk_MainEx +#undef Tk_SafeInit +} + + # Build an area of the file for #define directives and + # function declarations + set define {} + set mainhook [$PROJECT define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] + set mainfunc [$PROJECT define get TCL_LOCAL_APPINIT Tclkit_AppInit] + set mainscript [$PROJECT define get main.tcl main.tcl] + set vfsroot [$PROJECT define get vfsroot [file join [$PROJECT define get ZIPFS_VOLUME] app]] + set vfs_main "${vfsroot}/${mainscript}" + set vfs_tcl_library "${vfsroot}/boot/tcl" + set vfs_tk_library "${vfsroot}/boot/tk" + + set map {} + foreach var { + vfsroot mainhook mainfunc vfs_main vfs_tcl_library vfs_tk_library + } { + dict set map %${var}% [set $var] + } + set preinitscript { +set ::odie(boot_vfs) {%vfsroot%} +set ::SRCDIR {%vfsroot%} +if {[file exists {%vfs_tcl_library%}]} { + set ::tcl_library {%vfs_tcl_library%} + set ::auto_path {} +} +if {[file exists {%vfs_tk_library%}]} { + set ::tk_library {%vfs_tk_library%} +} +} ; # Preinitscript + + set zvfsboot { +/* + * %mainhook% -- + * Performs the argument munging for the shell + */ + } + ::practcl::cputs zvfsboot { + CONST char *archive; + Tcl_FindExecutable(*argv[0]); + archive=Tcl_GetNameOfExecutable(); + } + # We have to initialize the virtual filesystem before calling + # Tcl_Init(). Otherwise, Tcl_Init() will not be able to find + # its startup script files. + if {[$PROJECT define get tip_430 0]} { + ::practcl::cputs zvfsboot " if(!TclZipfsMount(NULL, archive, \"%vfsroot%\", NULL)) \x7B " + } else { + $PROJECT include {"tclZipfs.h"} + ::practcl::cputs zvfsboot { Tclzipfs_Init(NULL);} + ::practcl::cputs zvfsboot " if(!Tclzipfs_Mount(NULL, archive, \"%vfsroot%\", NULL)) \x7B " + } + ::practcl::cputs zvfsboot { + Tcl_Obj *vfsinitscript; + vfsinitscript=Tcl_NewStringObj("%vfs_main%",-1); + Tcl_IncrRefCount(vfsinitscript); + if(Tcl_FSAccess(vfsinitscript,F_OK)==0) { + /* Startup script should be set before calling Tcl_AppInit */ + Tcl_SetStartupScript(vfsinitscript,NULL); + } + } + ::practcl::cputs zvfsboot " TclSetPreInitScript([::practcl::tcl_to_c $preinitscript])\;" + ::practcl::cputs zvfsboot " \x7D else \x7B" + ::practcl::cputs zvfsboot " TclSetPreInitScript([::practcl::tcl_to_c { +foreach path { + ../tcl +} { + set p [file join $path library init.tcl] + if {[file exists [file join $path library init.tcl]]} { + set ::tcl_library [file normalize [file join $path library]] + break + } +} +foreach path { + ../tk +} { + if {[file exists [file join $path library tk.tcl]]} { + set ::tk_library [file normalize [file join $path library]] + break + } +} +}])\;" + + ::practcl::cputs zvfsboot " \x7D" + ::practcl::cputs zvfsboot " return TCL_OK;" + + if {[$PROJECT define get TEACUP_OS] eq "windows"} { + set header {int %mainhook%(int *argc, TCHAR ***argv)} + } else { + set header {int %mainhook%(int *argc, char ***argv)} + } + $PROJECT c_function [string map $map $header] [string map $map $zvfsboot] + + practcl::cputs appinit "int %mainfunc%(Tcl_Interp *interp) \x7B" + + # Build AppInit() + set appinit {} + practcl::cputs appinit { + if ((Tcl_Init)(interp) == TCL_ERROR) { + return TCL_ERROR; + } +} + set main_init_script {} + + foreach {statpkg info} $statpkglist { + set initfunc {} + if {[dict exists $info initfunc]} { + set initfunc [dict get $info initfunc] + } + if {$initfunc eq {}} { + set initfunc [string totitle ${statpkg}]_Init + } + # We employ a NULL to prevent the package system from thinking the + # package is actually loaded into the interpreter + $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" + set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] + append main_init_script \n [list set ::kitpkg(${statpkg}) $script] + if {[dict get $info autoload]} { + ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" + ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" + } else { + ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" + append main_init_script \n $script + } + } + append main_init_script \n { +if {[file exists [file join $::SRCDIR packages.tcl]]} { + #In a wrapped exe, we don't go out to the environment + set dir $::SRCDIR + source [file join $::SRCDIR packages.tcl] +} +# Specify a user-specific startup file to invoke if the application +# is run interactively. Typically the startup file is "~/.apprc" +# where "app" is the name of the application. If this line is deleted +# then no user-specific startup file will be run under any conditions. + } + append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]] + practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);" + practcl::cputs appinit { return TCL_OK;} + $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] +} + +} + + +::oo::class create ::practcl::build.gcc { + superclass ::practcl::build + + method build-compile-sources {PROJECT COMPILE {CPPCOMPILE {}}} { + set EXTERN_OBJS {} + set OBJECTS {} + set result {} + set builddir [$PROJECT define get builddir] + file mkdir [file join $builddir objs] + set debug [$PROJECT define get debug 0] + if {$CPPCOMPILE eq {}} { + set CPPCOMPILE $COMPILE + } + set task [${PROJECT} compile-products] + ### + # Compile the C sources + ### + foreach {ofile info} $task { + dict set task $ofile done 0 + if {[dict exists $info external] && [dict get $info external]==1} { + dict set task $ofile external 1 + } else { + dict set task $ofile external 0 + } + if {[dict exists $info library]} { + dict set task $ofile done 1 + continue + } + # Products with no cfile aren't compiled + if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} { + dict set task $ofile done 1 + continue + } + set cfile [dict get $info cfile] + set ofilename [file join $builddir objs [file tail $ofile]] + if {$debug} { + set ofilename [file join $builddir objs [file rootname [file tail $ofile]].debug.o] + } + dict set task $ofile filename $ofilename + if {[file exists $ofilename] && [file mtime $ofilename]>[file mtime $cfile]} { + lappend result $ofilename + dict set task $ofile done 1 + continue + } + if {![dict exist $info command]} { + if {[file extension $cfile] in {.c++ .cpp}} { + set cmd $CPPCOMPILE + } else { + set cmd $COMPILE + } + if {[dict exists $info extra]} { + append cmd " [dict get $info extra]" + } + append cmd " -c $cfile" + append cmd " -o $ofilename" + dict set task $ofile command $cmd + } + } + set completed 0 + while {$completed==0} { + set completed 1 + foreach {ofile info} $task { + set waiting {} + if {[dict exists $info done] && [dict get $info done]} continue + if {[dict exists $info depend]} { + foreach file [dict get $info depend] { + if {[dict exists $task $file command] && [dict exists $task $file done] && [dict get $task $file done] != 1} { + set waiting $file + break + } + } + } + if {$waiting ne {}} { + set completed 0 + puts "$ofile waiting for $waiting" + continue + } + if {[dict exists $info command]} { + set cmd [dict get $info command] + puts "$cmd" + exec {*}$cmd >&@ stdout + } + lappend result [dict get $info filename] + dict set task $ofile done 1 + } + } + return $result +} + +method build-Makefile {path PROJECT} { + array set proj [$PROJECT define dump] + set path $proj(builddir) + cd $path + set includedir . + #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] + foreach include [$PROJECT generate-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + set INCLUDES "-I[join $includedir " -I"]" + set NAME [string toupper $proj(name)] + set result {} + set products {} + set libraries {} + set thisline {} + ::practcl::cputs result "${NAME}_DEFS = $proj(DEFS)\n" + ::practcl::cputs result "${NAME}_INCLUDES = -I\"[join $includedir "\" -I\""]\"\n" + ::practcl::cputs result "${NAME}_COMPILE = \$(CC) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" + ::practcl::cputs result "${NAME}_CPPCOMPILE = \$(CXX) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" + + foreach {ofile info} [$PROJECT compile-products] { + dict set products $ofile $info + if {[dict exists $info library]} { +lappend libraries $ofile +continue + } + if {[dict exists $info depend]} { + ::practcl::cputs result "\n${ofile}: [dict get $info depend]" + } else { + ::practcl::cputs result "\n${ofile}:" + } + set cfile [dict get $info cfile] + if {[file extension $cfile] in {.c++ .cpp}} { + set cmd "\t\$\(${NAME}_CPPCOMPILE\)" + } else { + set cmd "\t\$\(${NAME}_COMPILE\)" + } + if {[dict exists $info extra]} { + append cmd " [dict get $info extra]" + } + append cmd " -c [dict get $info cfile] -o \$@\n\t" + ::practcl::cputs result $cmd + } + + set map {} + lappend map %LIBRARY_NAME% $proj(name) + lappend map %LIBRARY_VERSION% $proj(version) + lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)] + lappend map %LIBRARY_PREFIX% [$PROJECT define getnull libprefix] + + if {[string is true [$PROJECT define get SHARED_BUILD]]} { + set outfile [$PROJECT define get libfile] + } else { + set outfile [$PROJECT shared_library] + } + $PROJECT define set shared_library $outfile + ::practcl::cputs result " +${NAME}_SHLIB = $outfile +${NAME}_OBJS = [dict keys $products] +" + + #lappend map %OUTFILE% {\[$]@} + lappend map %OUTFILE% $outfile + lappend map %LIBRARY_OBJECTS% "\$(${NAME}_OBJS)" + ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" + ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_SHARED_LIB]]" + if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} { + ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]]" + } + ::practcl::cputs result {} + if {[string is true [$PROJECT define get SHARED_BUILD]]} { + #set outfile [$PROJECT static_library] + set outfile $proj(name).a + } else { + set outfile [$PROJECT define get libfile] + } + $PROJECT define set static_library $outfile + dict set map %OUTFILE% $outfile + ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" + ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]" + ::practcl::cputs result {} + return $result +} + +### +# Produce a static or dynamic library +### +method build-library {outfile PROJECT} { + array set proj [$PROJECT define dump] + set path $proj(builddir) + cd $path + set includedir . + #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] + if {[$PROJECT define get tk 0]} { + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]] + lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]] + } + foreach include [$PROJECT generate-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + my build-cflags $PROJECT $proj(DEFS) name version defs + set NAME [string toupper $name] + set debug [$PROJECT define get debug 0] + set os [$PROJECT define get TEACUP_OS] + + set INCLUDES "-I[join $includedir " -I"]" + if {$debug} { + set COMPILE "$proj(CC) $proj(CFLAGS_DEBUG) -ggdb \ +$proj(CFLAGS_WARNING) $INCLUDES $defs" + + if {[info exists proc(CXX)]} { + set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS_DEBUG) -ggdb \ + $defs $proj(CFLAGS_WARNING)" + } else { + set COMPILECPP $COMPILE + } + } else { + set COMPILE "$proj(CC) $proj(CFLAGS) $defs $INCLUDES " + + if {[info exists proc(CXX)]} { + set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS) $defs" + } else { + set COMPILECPP $COMPILE + } + } + + set products [my build-compile-sources $PROJECT $COMPILE $COMPILECPP] + + set map {} + lappend map %LIBRARY_NAME% $proj(name) + lappend map %LIBRARY_VERSION% $proj(version) + lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)] + lappend map %OUTFILE% $outfile + lappend map %LIBRARY_OBJECTS% $products + lappend map {${CFLAGS}} "$proj(CFLAGS_DEFAULT) $proj(CFLAGS_WARNING)" + + if {[string is true [$PROJECT define get SHARED_BUILD 1]]} { + set cmd [$PROJECT define get PRACTCL_SHARED_LIB] + append cmd " [$PROJECT define get PRACTCL_LIBS]" + set cmd [string map $map $cmd] + puts $cmd + exec {*}$cmd >&@ stdout + if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} { + set cmd [string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]] + puts $cmd + exec {*}$cmd >&@ stdout + } + } else { + set cmd [string map $map [$PROJECT define get PRACTCL_STATIC_LIB]] + puts $cmd + exec {*}$cmd >&@ stdout + } + set ranlib [$PROJECT define get RANLIB] + if {$ranlib ni {{} :}} { + catch {exec $ranlib $outfile} + } +} + +### +# Produce a static executable +### +method build-tclsh {outfile PROJECT} { + puts " BUILDING STATIC TCLSH " + set TCLOBJ [$PROJECT project TCLCORE] + set TKOBJ [$PROJECT project TKCORE] + set ODIEOBJ [$PROJECT project odie] + + set PKG_OBJS {} + foreach item [$PROJECT link list package] { + if {[string is true [$item define get static]]} { + lappend PKG_OBJS $item + } + } + array set TCL [$TCLOBJ config.sh] + array set TK [$TKOBJ config.sh] + set path [file dirname $outfile] + cd $path + ### + # For a static Tcl shell, we need to build all local sources + # with the same DEFS flags as the tcl core was compiled with. + # The DEFS produced by a TEA extension aren't intended to operate + # with the internals of a staticly linked Tcl + ### + my build-cflags $PROJECT $TCL(defs) name version defs + set debug [$PROJECT define get debug 0] + set NAME [string toupper $name] + set result {} + set libraries {} + set thisline {} + set OBJECTS {} + set EXTERN_OBJS {} + foreach obj $PKG_OBJS { + $obj compile + set config($obj) [$obj config.sh] + } + set os [$PROJECT define get TEACUP_OS] + set TCLSRCDIR [$TCLOBJ define get srcdir] + set TKSRCDIR [$TKOBJ define get srcdir] + + set includedir . + foreach include [$TCLOBJ generate-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + lappend includedir [::practcl::file_relative $path [file normalize ../tcl/compat/zlib]] + foreach include [$PROJECT generate-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + + set INCLUDES "-I[join $includedir " -I"]" + if {$debug} { + set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) -ggdb \ +$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" + } else { + set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ +$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" + } + append COMPILE " " $defs + lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE] + if {[${PROJECT} define get TEACUP_OS] eq "windows"} { + set windres [$PROJECT define get RC windres] + set RSOBJ [file join $path build tclkit.res.o] + set RCSRC [${PROJECT} define get kit_resource_file] + if {$RCSRC eq {} || ![file exists $RCSRC]} { + set RCSRC [file join $TKSRCDIR win rc wish.rc] + } + set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD] + set TCLSRC [file normalize $TCLSRCDIR] + set TKSRC [file normalize $TKSRCDIR] + + lappend cmd --include [::practcl::file_relative $path [file join $TCLSRC generic]] \ + --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]] + foreach item [${PROJECT} define get resource_include] { + lappend cmd --include [::practcl::file_relative $path [file normalize $item]] + } + lappend cmd $RCSRC + ::practcl::doexec {*}$cmd + + lappend OBJECTS $RSOBJ + set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} + set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} + } else { + set LDFLAGS_CONSOLE {} + set LDFLAGS_WINDOW {} + } + puts "***" + if {$debug} { + set cmd "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) \ +$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" + } else { + set cmd "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ +$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" + } + append cmd " $OBJECTS" + append cmd " $EXTERN_OBJS " + # On OSX it is impossibly to generate a completely static + # executable + if {[$PROJECT define get TEACUP_OS] ne "macosx"} { + append cmd " -static " + } + if {$debug} { + if {$os eq "windows"} { + append cmd " -L${TCL(src_dir)}/win -ltcl86g" + append cmd " -L${TK(src_dir)}/win -ltk86g" + } else { + append cmd " -L${TCL(src_dir)}/unix -ltcl86g" + append cmd " -L${TK(src_dir)}/unix -ltk86g" + } + } else { + append cmd " $TCL(build_lib_spec) $TK(build_lib_spec)" + } + foreach obj $PKG_OBJS { + append cmd " [$obj linker-products $config($obj)]" + } + append cmd " $TCL(libs) $TK(libs)" + foreach obj $PKG_OBJS { + append cmd " [$obj linker-external $config($obj)]" + } + if {$debug} { + if {$os eq "windows"} { + append cmd " -L${TCL(src_dir)}/win ${TCL(stub_lib_flag)}" + append cmd " -L${TK(src_dir)}/win ${TK(stub_lib_flag)}" + } else { + append cmd " -L${TCL(src_dir)}/unix ${TCL(stub_lib_flag)}" + append cmd " -L${TK(src_dir)}/unix ${TK(stub_lib_flag)}" + } + } else { + append cmd " $TCL(build_stub_lib_spec)" + append cmd " $TK(build_stub_lib_spec)" + } + append cmd " -o $outfile $LDFLAGS_CONSOLE" + puts "LINK: $cmd" + exec {*}$cmd >&@ stdout +} +} + + +::oo::class create ::practcl::build.msvc { + superclass ::practcl::build + +} + +::oo::class create ::practcl::target_obj { + superclass ::practcl::metaclass + + constructor {name info} { + my variable define triggered domake + set triggered 0 + set domake 0 + set define(name) $name + set data [uplevel 2 [list subst $info]] + array set define $data + my select + my initialize + } + + method do {} { + my variable domake + return $domake + } + + method check {} { + my variable needs_make domake + if {$domake} { + return 1 + } + if {[info exists needs_make]} { + return $needs_make + } + set needs_make 0 + foreach item [my define get depends] { + if {![dict exists $::make_objects $item]} continue + set depobj [dict get $::make_objects $item] + if {$depobj eq [self]} { + puts "WARNING [self] depends on itself" + continue + } + if {[$depobj check]} { + set needs_make 1 + } + } + if {!$needs_make} { + set filename [my define get filename] + if {$filename ne {} && ![file exists $filename]} { + set needs_make 1 + } + } + return $needs_make + } + + method triggers {} { + my variable triggered domake define + if {$triggered} { + return $domake + } + set triggered 1 + foreach item [my define get depends] { + if {![dict exists $::make_objects $item]} continue + set depobj [dict get $::make_objects $item] + if {$depobj eq [self]} { + puts "WARNING [self] triggers itself" + continue + } else { + set r [$depobj check] + if {$r} { + $depobj triggers + } + } + } + if {[info exists ::make($define(name))] && $::make($define(name))} { + return + } + set ::make($define(name)) 1 + ::practcl::trigger {*}[my define get triggers] + } +} + + +### +# Define the metaclass +### +::oo::class create ::practcl::object { + superclass ::practcl::metaclass + + constructor {parent args} { + my variable links define + set organs [$parent child organs] + my graft {*}$organs + array set define $organs + array set define [$parent child define] + array set links {} + if {[llength $args]==1 && [file exists [lindex $args 0]]} { + my InitializeSourceFile [lindex $args 0] + } elseif {[llength $args] == 1} { + set data [uplevel 1 [list subst [lindex $args 0]]] + array set define $data + my select + my initialize + } else { + array set define [uplevel 1 [list subst $args]] + my select + my initialize + } + } + + + method include_dir args { + my define add include_dir {*}$args + } + + method include_directory args { + my define add include_dir {*}$args + } + + method Collate_Source CWD {} + + + method child {method} { + return {} + } + + method InitializeSourceFile filename { + my define set filename $filename + set class {} + switch [file extension $filename] { + .tcl { + set class ::practcl::dynamic + } + .h { + set class ::practcl::cheader + } + .c { + set class ::practcl::csource + } + .ini { + switch [file tail $filename] { + module.ini { + set class ::practcl::module + } + library.ini { + set class ::practcl::subproject + } + } + } + .so - + .dll - + .dylib - + .a { + set class ::practcl::clibrary + } + } + if {$class ne {}} { + oo::objdefine [self] class $class + my initialize + } + } + + method add args { + my variable links + set object [::practcl::object new [self] {*}$args] + foreach linktype [$object linktype] { + lappend links($linktype) $object + } + return $object + } + + method go {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable links + foreach {linktype objs} [array get links] { + foreach obj $objs { + $obj go + } + } + ::practcl::debug [list /[self] [self method] [self class]] + } + + method code {section body} { + my variable code + ::practcl::cputs code($section) $body + } + + method Ofile filename { + set lpath [my define get localpath] + if {$lpath eq {}} { + set lpath [my define get name] + } + return ${lpath}_[file rootname [file tail $filename]].o + } + + method compile-products {} { + set filename [my define get filename] + set result {} + if {$filename ne {}} { + if {[my define exists ofile]} { + set ofile [my define get ofile] + } else { + set ofile [my Ofile $filename] + my define set ofile $ofile + } + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]] object [self]] + } + foreach item [my link list subordinate] { + lappend result {*}[$item compile-products] + } + return $result + } + + method generate-include-directory {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result [my define get include_dir] + foreach obj [my link list product] { + foreach path [$obj generate-include-directory] { + lappend result $path + } + } + return $result + } + + method generate-debug {{spaces {}}} { + set result {} + ::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my define get filename]] links [my link list]]" + foreach item [my link list subordinate] { + practcl::cputs result [$item generate-debug "$spaces "] + } + return $result + } + + # Empty template methods + method generate-cheader {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cfunct cstruct methods tcltype tclprocs + set result {} + if {[info exists code(header)]} { + ::practcl::cputs result $code(header) + } + foreach obj [my link list product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + set dat [$obj generate-cheader] + if {[string length [string trim $dat]]} { + ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cheader */" + ::practcl::cputs result $dat + ::practcl::cputs result "/* END [$obj define get filename] generate-cheader */" + } + } + ::practcl::debug [list cfunct [info exists cfunct]] + if {[info exists cfunct]} { + foreach {funcname info} $cfunct { + if {[dict get $info public]} continue + ::practcl::cputs result "[dict get $info header]\;" + } + } + ::practcl::debug [list tclprocs [info exists tclprocs]] + if {[info exists tclprocs]} { + foreach {name info} $tclprocs { + if {[dict exists $info header]} { + ::practcl::cputs result "[dict get $info header]\;" + } + } + } + ::practcl::debug [list methods [info exists methods] [my define get cclass]] + + if {[info exists methods]} { + set thisclass [my define get cclass] + foreach {name info} $methods { + if {[dict exists $info header]} { + ::practcl::cputs result "[dict get $info header]\;" + } + } + # Add the initializer wrapper for the class + ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp)\;" + } + return $result + } + + method generate-public-define {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code + set result {} + if {[info exists code(public-define)]} { + ::practcl::cputs result $code(public-define) + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-define] + } + return $result + } + + method generate-public-macro {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code + set result {} + if {[info exists code(public-macro)]} { + ::practcl::cputs result $code(public-macro) + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-macro] + } + return $result + } + + method generate-public-typedef {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cstruct + set result {} + if {[info exists code(public-typedef)]} { + ::practcl::cputs result $code(public-typedef) + } + if {[info exists cstruct]} { + # Add defintion for native c data structures + foreach {name info} $cstruct { + if {[dict get $info public]==0} continue + ::practcl::cputs result "typedef struct $name ${name}\;" + if {[dict exists $info aliases]} { + foreach n [dict get $info aliases] { + ::practcl::cputs result "typedef struct $name ${n}\;" + } + } + } + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-typedef] + } + return $result + } + + method generate-private-typedef {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cstruct + set result {} + if {[info exists code(private-typedef)]} { + ::practcl::cputs result $code(private-typedef) + } + if {[info exists cstruct]} { + # Add defintion for native c data structures + foreach {name info} $cstruct { + if {[dict get $info public]==1} continue + ::practcl::cputs result "typedef struct $name ${name}\;" + if {[dict exists $info aliases]} { + foreach n [dict get $info aliases] { + ::practcl::cputs result "typedef struct $name ${n}\;" + } + } + } + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-private-typedef] + } + return $result + } + + method generate-public-structure {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cstruct + set result {} + if {[info exists code(public-structure)]} { + ::practcl::cputs result $code(public-structure) + } + if {[info exists cstruct]} { + foreach {name info} $cstruct { + if {[dict get $info public]==0} continue + if {[dict exists $info comment]} { + ::practcl::cputs result [dict get $info comment] + } + ::practcl::cputs result "struct $name \{[dict get $info body]\}\;" + } + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-structure] + } + return $result + } + + + method generate-private-structure {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cstruct + set result {} + if {[info exists code(private-structure)]} { + ::practcl::cputs result $code(private-structure) + } + if {[info exists cstruct]} { + foreach {name info} $cstruct { + if {[dict get $info public]==1} continue + if {[dict exists $info comment]} { + ::practcl::cputs result [dict get $info comment] + } + ::practcl::cputs result "struct $name \{[dict get $info body]\}\;" + } + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-private-structure] + } + return $result + } + + method generate-public-headers {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code tcltype + set result {} + if {[info exists code(public-header)]} { + ::practcl::cputs result $code(public-header) + } + if {[info exists tcltype]} { + foreach {type info} $tcltype { + if {![dict exists $info cname]} { + set cname [string tolower ${type}]_tclobjtype + dict set tcltype $type cname $cname + } else { + set cname [dict get $info cname] + } + ::practcl::cputs result "extern const Tcl_ObjType $cname\;" + } + } + if {[info exists code(public)]} { + ::practcl::cputs result $code(public) + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-headers] + } + return $result + } + + method generate-stub-function {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cfunct tcltype + set result {} + foreach mod [my link list product] { + foreach {funct def} [$mod generate-stub-function] { + dict set result $funct $def + } + } + if {[info exists cfunct]} { + foreach {funcname info} $cfunct { + if {![dict get $info export]} continue + dict set result $funcname [dict get $info header] + } + } + return $result + } + + method generate-public-function {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cfunct tcltype + set result {} + + if {[my define get initfunc] ne {}} { + ::practcl::cputs result "int [my define get initfunc](Tcl_Interp *interp);" + } + if {[info exists cfunct]} { + foreach {funcname info} $cfunct { + if {![dict get $info public]} continue + ::practcl::cputs result "[dict get $info header]\;" + } + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-function] + } + return $result + } + + method generate-public-includes {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set includes {} + foreach item [my define get public-include] { + if {$item ni $includes} { + lappend includes $item + } + } + foreach mod [my link list product] { + foreach item [$mod generate-public-includes] { + if {$item ni $includes} { + lappend includes $item + } + } + } + return $includes + } + method generate-public-verbatim {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set includes {} + foreach item [my define get public-verbatim] { + if {$item ni $includes} { + lappend includes $item + } + } + foreach mod [my link list subordinate] { + foreach item [$mod generate-public-verbatim] { + if {$item ni $includes} { + lappend includes $item + } + } + } + return $includes + } + ### + # This methods generates the contents of an amalgamated .h file + # which describes the public API of this module + ### + method generate-h {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + set includes [my generate-public-includes] + foreach inc $includes { + if {[string index $inc 0] ni {< \"}} { + ::practcl::cputs result "#include \"$inc\"" + } else { + ::practcl::cputs result "#include $inc" + } + } + + foreach method { + generate-public-define + generate-public-macro + generate-public-typedef + generate-public-structure + } { + ::practcl::cputs result "/* BEGIN SECTION $method */" + ::practcl::cputs result [my $method] + ::practcl::cputs result "/* END SECTION $method */" + } + + foreach file [my generate-public-verbatim] { + ::practcl::cputs result "/* BEGIN $file */" + ::practcl::cputs result [::practcl::cat $file] + ::practcl::cputs result "/* END $file */" + } + + foreach method { + generate-public-headers + generate-public-function + } { + ::practcl::cputs result "/* BEGIN SECTION $method */" + ::practcl::cputs result [my $method] + ::practcl::cputs result "/* END SECTION $method */" + } + return $result + } + + method IncludeAdd {headervar args} { + upvar 1 $headervar headers + foreach inc $args { + if {[string index $inc 0] ni {< \"}} { + set inc "\"$inc\"" + } + if {$inc ni $headers} { + lappend headers $inc + } + } + } + + ### + # This methods generates the contents of an amalgamated .c file + # which implements the loader for a batch of tools + ### + method generate-c {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result { +/* This file was generated by practcl */ + } + set includes {} + + foreach mod [my link list product] { + # Signal modules to formulate final implementation + $mod go + } + set headers {} + + my IncludeAdd headers + if {[my define get tk 0]} { + my IncludeAdd headers + } + if {[my define get output_h] ne {}} { + my IncludeAdd headers [my define get output_h] + } + my IncludeAdd headers {*}[my define get include] + + foreach mod [my link list dynamic] { + my IncludeAdd headers {*}[$mod define get include] + } + foreach inc $headers { + ::practcl::cputs result "#include $inc" + } + foreach {method} { + generate-cheader + generate-private-typedef + generate-private-structure + generate-cstruct + generate-constant + generate-cfunct + generate-cmethod + } { + set dat [my $method] + if {[string length [string trim $dat]]} { + ::practcl::cputs result "/* BEGIN $method [my define get filename] */" + ::practcl::cputs result $dat + ::practcl::cputs result "/* END $method [my define get filename] */" + } + } + ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] + return $result + } + + + method generate-loader {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + if {[my define get initfunc] eq {}} return + ::practcl::cputs result " +extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \{" + ::practcl::cputs result { + /* Initialise the stubs tables. */ + #ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR; + if (TclOOInitializeStubs(interp, "1.0") == NULL) return TCL_ERROR; +} + if {[my define get tk 0]} { + ::practcl::cputs result { if (Tk_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR;} + } + ::practcl::cputs result { #endif} + set TCLINIT [my generate-tcl-pre] + if {[string length $TCLINIT]} { + ::practcl::cputs result " if(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR ;" + } + foreach item [my link list product] { + if {[$item define get output_c] ne {}} { + ::practcl::cputs result [$item generate-cinit-external] + } else { + ::practcl::cputs result [$item generate-cinit] + } + } + set TCLINIT [my generate-tcl-post] + if {[string length $TCLINIT]} { + ::practcl::cputs result " if(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR ;" + } + if {[my define exists pkg_name]} { + ::practcl::cputs result " if (Tcl_PkgProvide(interp, \"[my define get pkg_name [my define get name]]\" , \"[my define get pkg_vers [my define get version]]\" )) return TCL_ERROR\;" + } + ::practcl::cputs result " return TCL_OK\;\n\}\n" + return $result + } + + ### + # This methods generates any Tcl script file + # which is required to pre-initialize the C library + ### + method generate-tcl-pre {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + my variable code + if {[info exists code(tcl)]} { + set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] + } + if {[info exists code(tcl-pre)]} { + set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] + } + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-tcl-pre] + } + return $result + } + + method generate-tcl-post {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + my variable code + if {[info exists code(tcl-post)]} { + set result [::practcl::_tagblock $code(tcl-post) tcl [my define get filename]] + } + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-tcl-post] + } + return $result + } + + method static-packages {} { + set result [my define get static_packages] + set statpkg [my define get static_pkg] + set initfunc [my define get initfunc] + if {$initfunc ne {}} { + set pkg_name [my define get pkg_name] + if {$pkg_name ne {}} { + dict set result $pkg_name initfunc $initfunc + dict set result $pkg_name version [my define get version [my define get pkg_vers]] + dict set result $pkg_name autoload [my define get autoload 0] + } + } + foreach item [my link list subordinate] { + foreach {pkg info} [$item static-packages] { + dict set result $pkg $info + } + } + return $result + } + + method target {method args} { + switch $method { + is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } + } + } + +} + +::oo::class create ::practcl::product { + superclass ::practcl::object + + method linktype {} { + return {subordinate product} + } + + method include header { + my define add include $header + } + + method cstructure {name definition {argdat {}}} { + my variable cstruct + dict set cstruct $name body $definition + foreach {f v} $argdat { + dict set cstruct $name $f $v + } + if {![dict exists $cstruct $name public]} { + dict set cstruct $name public 1 + } + } + + method generate-cinit {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code + set result {} + if {[info exists code(cinit)]} { + ::practcl::cputs result $code(cinit) + } + if {[my define get initfunc] ne {}} { + ::practcl::cputs result " if([my define get initfunc](interp)!=TCL_OK) return TCL_ERROR\;" + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach obj [my link list product] { + ::practcl::cputs result [$obj generate-cinit] + } + return $result + } +} + +### +# Dynamic blocks do not generate their own .c files, +# instead the contribute to the amalgamation +# of the main library file +### +::oo::class create ::practcl::dynamic { + superclass ::practcl::product + + # Retrieve any additional source files required + + method compile-products {} { + set filename [my define get output_c] + set result {} + if {$filename ne {}} { + if {[my define exists ofile]} { + set ofile [my define get ofile] + } else { + set ofile [my Ofile $filename] + my define set ofile $ofile + } + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] + } else { + set filename [my define get cfile] + if {$filename ne {}} { + if {[my define exists ofile]} { + set ofile [my define get ofile] + } else { + set ofile [my Ofile $filename] + my define set ofile $ofile + } + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] + } + } + foreach item [my link list subordinate] { + lappend result {*}[$item compile-products] + } + return $result + } + + method implement path { + my go + my Collate_Source $path + if {[my define get output_c] eq {}} return + set filename [file join $path [my define get output_c]] + my define set cfile $filename + set fout [open $filename w] + puts $fout [my generate-c] + if {[my define get initfunc] ne {}} { + puts $fout "extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \x7B" + puts $fout [my generate-cinit] + if {[my define get pkg_name] ne {}} { + puts $fout " Tcl_PkgProvide(interp, \"[my define get pkg_name]\", \"[my define get pkg_vers]\");" + } + puts $fout " return TCL_OK\;" + puts $fout "\x7D" + } + close $fout + } + + method initialize {} { + set filename [my define get filename] + if {$filename eq {}} { + return + } + if {[my define get name] eq {}} { + my define set name [file tail [file rootname $filename]] + } + if {[my define get localpath] eq {}} { + my define set localpath [my define get localpath]_[my define get name] + } + ::source $filename + } + + method linktype {} { + return {subordinate product dynamic} + } + + ### + # Populate const static data structures + ### + method generate-cstruct {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cstruct methods tcltype + set result {} + if {[info exists code(struct)]} { + ::practcl::cputs result $code(struct) + } + foreach obj [my link list dynamic] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-cstruct] + } + return $result + } + + method generate-constant {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + my variable code cstruct methods tcltype + if {[info exists code(constant)]} { + ::practcl::cputs result "/* [my define get filename] CONSTANT */" + ::practcl::cputs result $code(constant) + } + if {[info exists cstruct]} { + foreach {name info} $cstruct { + set map {} + lappend map @NAME@ $name + lappend map @MACRO@ GET[string toupper $name] + + if {[dict exists $info deleteproc]} { + lappend map @DELETEPROC@ [dict get $info deleteproc] + } else { + lappend map @DELETEPROC@ NULL + } + if {[dict exists $info cloneproc]} { + lappend map @CLONEPROC@ [dict get $info cloneproc] + } else { + lappend map @CLONEPROC@ NULL + } + ::practcl::cputs result [string map $map { +const static Tcl_ObjectMetadataType @NAME@DataType = { + TCL_OO_METADATA_VERSION_CURRENT, + "@NAME@", + @DELETEPROC@, + @CLONEPROC@ +}; +#define @MACRO@(OBJCONTEXT) (@NAME@ *) Tcl_ObjectGetMetadata(OBJCONTEXT,&@NAME@DataType) +}] + } + } + if {[info exists tcltype]} { + foreach {type info} $tcltype { + dict with info {} + ::practcl::cputs result "const Tcl_ObjType $cname = \{\n .freeIntRepProc = &${freeproc},\n .dupIntRepProc = &${dupproc},\n .updateStringProc = &${updatestringproc},\n .setFromAnyProc = &${setfromanyproc}\n\}\;" + } + } + + if {[info exists methods]} { + set mtypes {} + foreach {name info} $methods { + set callproc [dict get $info callproc] + set methodtype [dict get $info methodtype] + if {$methodtype in $mtypes} continue + lappend mtypes $methodtype + ### + # Build the data struct for this method + ### + ::practcl::cputs result "const static Tcl_MethodType $methodtype = \{" + ::practcl::cputs result " .version = TCL_OO_METADATA_VERSION_CURRENT,\n .name = \"$name\",\n .callProc = $callproc," + if {[dict exists $info deleteproc]} { + set deleteproc [dict get $info deleteproc] + } else { + set deleteproc NULL + } + if {$deleteproc ni { {} NULL }} { + ::practcl::cputs result " .deleteProc = $deleteproc," + } else { + ::practcl::cputs result " .deleteProc = NULL," + } + if {[dict exists $info cloneproc]} { + set cloneproc [dict get $info cloneproc] + } else { + set cloneproc NULL + } + if {$cloneproc ni { {} NULL }} { + ::practcl::cputs result " .cloneProc = $cloneproc\n\}\;" + } else { + ::practcl::cputs result " .cloneProc = NULL\n\}\;" + } + dict set methods $name methodtype $methodtype + } + } + foreach obj [my link list dynamic] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-constant] + } + return $result + } + + ### + # Generate code that provides subroutines called by + # Tcl API methods + ### + method generate-cfunct {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cfunct + set result {} + if {[info exists code(funct)]} { + ::practcl::cputs result $code(funct) + } + if {[info exists cfunct]} { + foreach {funcname info} $cfunct { + ::practcl::cputs result "/* $funcname */" + ::practcl::cputs result "\n[dict get $info header]\{[dict get $info body]\}" + } + } + foreach obj [my link list dynamic] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} { + continue + } + ::practcl::cputs result [$obj generate-cfunct] + } + return $result + } + + ### + # Generate code that provides implements Tcl API + # calls + ### + method generate-cmethod {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code methods tclprocs + set result {} + if {[info exists code(method)]} { + ::practcl::cputs result $code(method) + } + + if {[info exists tclprocs]} { + foreach {name info} $tclprocs { + if {![dict exists $info body]} continue + set callproc [dict get $info callproc] + set header [dict get $info header] + set body [dict get $info body] + ::practcl::cputs result "/* Tcl Proc $name */" + ::practcl::cputs result "${header} \{${body}\}" + } + } + + + if {[info exists methods]} { + set thisclass [my define get cclass] + foreach {name info} $methods { + if {![dict exists $info body]} continue + set callproc [dict get $info callproc] + set header [dict get $info header] + set body [dict get $info body] + ::practcl::cputs result "/* OO Method $thisclass $name */" + ::practcl::cputs result "${header} \{${body}\}" + } + # Build the OO_Init function + ::practcl::cputs result "/* Loader for $thisclass */" + ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp) \{" + ::practcl::cputs result [string map [list @CCLASS@ $thisclass @TCLCLASS@ [my define get class]] { + /* + ** Build the "@TCLCLASS@" class + */ + Tcl_Obj* nameObj; /* Name of a class or method being looked up */ + Tcl_Object curClassObject; /* Tcl_Object representing the current class */ + Tcl_Class curClass; /* Tcl_Class representing the current class */ + + /* + * Find the "@TCLCLASS@" class, and attach an 'init' method to it. + */ + + nameObj = Tcl_NewStringObj("@TCLCLASS@", -1); + Tcl_IncrRefCount(nameObj); + if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { + Tcl_DecrRefCount(nameObj); + return TCL_ERROR; + } + Tcl_DecrRefCount(nameObj); + curClass = Tcl_GetObjectAsClass(curClassObject); +}] + if {[dict exists $methods constructor]} { + set mtype [dict get $methods constructor methodtype] + ::practcl::cputs result [string map [list @MTYPE@ $mtype] { + /* Attach the constructor to the class */ + Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &@MTYPE@, NULL)); + }] + } + foreach {name info} $methods { + dict with info {} + if {$name in {constructor destructor}} continue + ::practcl::cputs result [string map [list @NAME@ $name @MTYPE@ $methodtype] { + nameObj=Tcl_NewStringObj("@NAME@",-1); + Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); + Tcl_DecrRefCount(nameObj); +}] + if {[dict exists $info aliases]} { + foreach alias [dict get $info aliases] { + if {[dict exists $methods $alias]} continue + ::practcl::cputs result [string map [list @NAME@ $alias @MTYPE@ $methodtype] { + nameObj=Tcl_NewStringObj("@NAME@",-1); + Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); + Tcl_DecrRefCount(nameObj); +}] + } + } + } + ::practcl::cputs result " return TCL_OK\;\n\}\n" + } + foreach obj [my link list dynamic] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-cmethod] + } + return $result + } + + method generate-cinit-external {} { + if {[my define get initfunc] eq {}} { + return "/* [my define get filename] declared not initfunc */" + } + return " if([my define get initfunc](interp)) return TCL_ERROR\;" + } + + ### + # Generate code that runs when the package/module is + # initialized into the interpreter + ### + method generate-cinit {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + my variable code methods tclprocs + if {[info exists code(nspace)]} { + ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" + foreach nspace $code(nspace) { + ::practcl::cputs result [string map [list @NSPACE@ $nspace] { + modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); + if(!modPtr) { + modPtr = Tcl_CreateNamespace(interp, "@NSPACE@", NULL, NULL); + } +}] + } + ::practcl::cputs result " \}" + } + if {[info exists code(tclinit)]} { + ::practcl::cputs result $code(tclinit) + } + if {[info exists code(cinit)]} { + ::practcl::cputs result $code(cinit) + } + if {[info exists code(initfuncts)]} { + foreach func $code(initfuncts) { + ::practcl::cputs result " if (${func}(interp) != TCL_OK) return TCL_ERROR\;" + } + } + if {[info exists tclprocs]} { + foreach {name info} $tclprocs { + set map [list @NAME@ $name @CALLPROC@ [dict get $info callproc]] + ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] + if {[dict exists $info aliases]} { + foreach alias [dict get $info aliases] { + set map [list @NAME@ $alias @CALLPROC@ [dict get $info callproc]] + ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] + } + } + } + } + + if {[info exists code(nspace)]} { + ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" + foreach nspace $code(nspace) { + ::practcl::cputs result [string map [list @NSPACE@ $nspace] { + modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); + Tcl_CreateEnsemble(interp, modPtr->fullName, modPtr, TCL_ENSEMBLE_PREFIX); + Tcl_Export(interp, modPtr, "[a-z]*", 1); +}] + } + ::practcl::cputs result " \}" + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach obj [my link list product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} { + ::practcl::cputs result [$obj generate-cinit-external] + } else { + ::practcl::cputs result [$obj generate-cinit] + } + } + return $result + } + + method c_header body { + my variable code + ::practcl::cputs code(header) $body + } + + method c_code body { + my variable code + ::practcl::cputs code(funct) $body + } + method c_function {header body {info {}}} { + set header [string map "\t \ \n \ \ \ \ " $header] + my variable code cfunct + foreach regexp { + {(.*) ([a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} + {(.*) (\x2a[a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} + } { + if {[regexp $regexp $header all keywords funcname arglist]} { + dict set cfunct $funcname header $header + dict set cfunct $funcname body $body + dict set cfunct $funcname keywords $keywords + dict set cfunct $funcname arglist $arglist + dict set cfunct $funcname inline [expr {"inline" ni $keywords}] + dict set cfunct $funcname public [expr {"static" ni $keywords}] + dict set cfunct $funcname export [expr {"STUB_EXPORT" in $keywords}] + foreach {f v} $info { + dict set cfunct $f $v + } + return + } + } + foreach {f v} $info { + dict set cfunct $f $v + } + ::practcl::cputs code(header) "$header\;" + # Could not parse that block as a function + # append it verbatim to our c_implementation + ::practcl::cputs code(funct) "$header [list $body]" + } + + + method cmethod {name body {arginfo {}}} { + my variable methods code + foreach {f v} $arginfo { + dict set methods $name $f $v + } + dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ +$body" + } + + method c_tclproc_nspace nspace { + my variable code + if {![info exists code(nspace)]} { + set code(nspace) {} + } + if {$nspace ni $code(nspace)} { + lappend code(nspace) $nspace + } + } + + method c_tclproc_raw {name body {arginfo {}}} { + my variable tclprocs code + + foreach {f v} $arginfo { + dict set tclprocs $name $f $v + } + dict set tclprocs $name body $body + } + + method go {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + next + my variable methods code cstruct tclprocs + if {[info exists methods]} { + ::practcl::debug [self] methods [my define get cclass] + set thisclass [my define get cclass] + foreach {name info} $methods { + # Provide a callproc + if {![dict exists $info callproc]} { + set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} OOMethod_${thisclass}_${name}]] + dict set methods $name callproc $callproc + } else { + set callproc [dict get $info callproc] + } + if {[dict exists $info body] && ![dict exists $info header]} { + dict set methods $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext ,int objc ,Tcl_Obj *const *objv)" + } + if {![dict exists $info methodtype]} { + set methodtype [string map {{ } _ : _} OOMethodType_${thisclass}_${name}] + dict set methods $name methodtype $methodtype + } + } + if {![info exists code(initfuncts)] || "${thisclass}_OO_Init" ni $code(initfuncts)} { + lappend code(initfuncts) "${thisclass}_OO_Init" + } + } + set thisnspace [my define get nspace] + + if {[info exists tclprocs]} { + ::practcl::debug [self] tclprocs [dict keys $tclprocs] + foreach {name info} $tclprocs { + if {![dict exists $info callproc]} { + set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} TclCmd_${thisnspace}_${name}]] + dict set tclprocs $name callproc $callproc + } else { + set callproc [dict get $info callproc] + } + if {[dict exists $info body] && ![dict exists $info header]} { + dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])" + } + } + } + ::practcl::debug [list /[self] [self method] [self class]] + } + + # Once an object marks itself as some + # flavor of dynamic, stop trying to morph + # it into something else + method select {} {} + + + method tcltype {name argdat} { + my variable tcltype + foreach {f v} $argdat { + dict set tcltype $name $f $v + } + if {![dict exists tcltype $name cname]} { + dict set tcltype $name cname [string tolower $name]_tclobjtype + } + lappend map @NAME@ $name + set info [dict get $tcltype $name] + foreach {f v} $info { + lappend map @[string toupper $f]@ $v + } + foreach {func fpat template} { + freeproc {@Name@Obj_freeIntRepProc} {void @FNAME@(Tcl_Obj *objPtr)} + dupproc {@Name@Obj_dupIntRepProc} {void @FNAME@(Tcl_Obj *srcPtr,Tcl_Obj *dupPtr)} + updatestringproc {@Name@Obj_updateStringRepProc} {void @FNAME@(Tcl_Obj *objPtr)} + setfromanyproc {@Name@Obj_setFromAnyProc} {int @FNAME@(Tcl_Interp *interp,Tcl_Obj *objPtr)} + } { + if {![dict exists $info $func]} { + error "$name does not define $func" + } + set body [dict get $info $func] + # We were given a function name to call + if {[llength $body] eq 1} continue + set fname [string map [list @Name@ [string totitle $name]] $fpat] + my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body] + dict set tcltype $name $func $fname + } + } +} + +::oo::class create ::practcl::cheader { + superclass ::practcl::product + + method compile-products {} {} + method generate-cinit {} {} +} + +::oo::class create ::practcl::csource { + superclass ::practcl::product +} + +::oo::class create ::practcl::clibrary { + superclass ::practcl::product + + method linker-products {configdict} { + return [my define get filename] + } + +} + +### +# In the end, all C code must be loaded into a module +# This will either be a dynamically loaded library implementing +# a tcl extension, or a compiled in segment of a custom shell/app +### +::oo::class create ::practcl::module { + superclass ::practcl::dynamic + + method child which { + switch $which { + organs { + return [list project [my define get project] module [self]] + } + } + } + + method initialize {} { + set filename [my define get filename] + if {$filename eq {}} { + return + } + if {[my define get name] eq {}} { + my define set name [file tail [file dirname $filename]] + } + if {[my define get localpath] eq {}} { + my define set localpath [my define get name]_[my define get name] + } + ::practcl::debug [self] SOURCE $filename + my source $filename + } + + method implement path { + my go + my Collate_Source $path + foreach item [my link list dynamic] { + if {[catch {$item implement $path} err]} { + puts "Skipped $item: $err" + } + } + foreach item [my link list module] { + if {[catch {$item implement $path} err]} { + puts "Skipped $item: $err" + } + } + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set filename [my define get output_c] + if {$filename eq {}} { + ::practcl::debug [list /[self] [self method] [self class]] + return + } + set cout [open [file join $path [file rootname $filename].c] w] + puts $cout [subst {/* +** This file is generated by the [info script] script +** any changes will be overwritten the next time it is run +*/}] + puts $cout [my generate-c] + puts $cout [my generate-loader] + close $cout + ::practcl::debug [list /[self] [self method] [self class]] + } + + method linktype {} { + return {subordinate product dynamic module} + } +} + +::oo::class create ::practcl::autoconf { + + ### + # find or fake a key/value list describing this project + ### + method config.sh {} { + my variable conf_result + if {[info exists conf_result]} { + return $conf_result + } + set result {} + set name [my define get name] + set PWD $::CWD + set builddir [my define get builddir] + my unpack + set srcdir [my define get srcdir] + if {![file exists $builddir]} { + my Configure + } + set filename [file join $builddir config.tcl] + # Project uses the practcl template. Use the leavings from autoconf + if {[file exists $filename]} { + set dat [::practcl::config.tcl $builddir] + foreach {item value} [::practcl::sort_dict $dat] { + dict set result $item $value + } + set conf_result $result + return $result + } + set filename [file join $builddir ${name}Config.sh] + if {[file exists $filename]} { + set l [expr {[string length $name]+1}] + foreach {field dat} [::practcl::read_Config.sh $filename] { + set field [string tolower $field] + if {[string match ${name}_* $field]} { + set field [string range $field $l end] + } + dict set result $field $dat + } + set conf_result $result + return $result + } + ### + # Oh man... we have to guess + ### + set filename [file join $builddir Makefile] + if {![file exists $filename]} { + error "Could not locate any configuration data in $srcdir" + } + foreach {field dat} [::practcl::read_Makefile $filename] { + dict set result $field $dat + } + set conf_result $result + cd $PWD + return $result + } +} + + +::oo::class create ::practcl::project { + superclass ::practcl::module ::practcl::autoconf + + constructor args { + my variable define + if {[llength $args] == 1} { + set rawcontents [lindex $args 0] + } else { + set rawcontents $args + } + if {[catch {uplevel 1 [list subst $rawcontents]} contents]} { + set contents $rawcontents + } + ### + # The first instance of ::practcl::project (or its descendents) + # registers itself as the ::practcl::MAIN. If a project other + # than ::practcl::LOCAL is created, odds are that was the one + # the developer intended to be the main project + ### + if {$::practcl::MAIN eq "::practcl::LOCAL"} { + set ::practcl::MAIN [self] + } + # DEFS fields need to be passed unchanged and unsubstituted + # as we need to preserve their escape characters + foreach field {TCL_DEFS DEFS TK_DEFS} { + if {[dict exists $rawcontents $field]} { + dict set contents $field [dict get $rawcontents $field] + } + } + array set define $contents + my select + my initialize + } + + method add_project {pkg info {oodefine {}}} { + set os [my define get TEACUP_OS] + if {$os eq {}} { + set os [::practcl::os] + my define set os $os + } + set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]] + if {[dict exists $info os] && ($os ni [dict get $info os])} return + # Select which tag to use here. + # For production builds: tag-release + set profile [my define get profile release]: + if {[dict exists $info profile $profile]} { + dict set info tag [dict get $info profile $profile] + } + if {[my define get USEMSVC 0]} { + dict set info USEMSVC 1 + } + set obj [namespace current]::PROJECT.$pkg + if {[info command $obj] eq {}} { + set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0 class subproject.binary] $info]] + } + my link object $obj + oo::objdefine $obj $oodefine + $obj define set masterpath $::CWD + $obj go + return $obj + } + + method add_tool {pkg info {oodefine {}}} { + set info [dict merge [::practcl::local_os] $info] + set os [dict get $info TEACUP_OS] + set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]] + if {[dict exists $info os] && ($os ni [dict get $info os])} return + # Select which tag to use here. + # For production builds: tag-release + set profile [my define get profile release]: + if {[dict exists $info profile $profile]} { + dict set info tag [dict get $info profile $profile] + } + set obj [namespace current]::TOOL.$pkg + if {[info command $obj] eq {}} { + set obj [::practcl::tool create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0] $info]] + } + my link object $obj + oo::objdefine $obj $oodefine + $obj define set masterpath $::CWD + $obj go + return $obj + } + + method child which { + switch $which { + organs { + # A library can be a project, it can be a module. Any + # subordinate modules will indicate their existance + return [list project [self] module [self]] + } + } + } + + method linktype {} { + return project + } + + # Exercise the methods of a sub-object + method project {pkg args} { + set obj [namespace current]::PROJECT.$pkg + if {[llength $args]==0} { + return $obj + } + ${obj} {*}$args + } + + method select {} { + next + ### + # Select the toolset to use for this project + ### + my variable define + set class {} + if {[info exists define(toolset)]} { + if {[info command $define(toolset)] ne {}} { + set class $define(toolset) + } elseif {[info command ::practcl::$define(toolset)] ne {}} { + set class ::practcl::$define(toolset) + } else { + switch $define(toolset) { + default { + set class ::practcl::build.gcc + } + } + } + } else { + if {[info exists ::env(VisualStudioVersion)]} { + set class ::practcl::build.msvc + } else { + set class ::practcl::build.gcc + } + } + ::oo::objdefine [self] mixin $class + } + + method tool {pkg args} { + set obj [namespace current]::TOOL.$pkg + if {[llength $args]==0} { + return $obj + } + ${obj} {*}$args + } +} + +::oo::class create ::practcl::library { + superclass ::practcl::project + + method compile-products {} { + set result {} + foreach item [my link list subordinate] { + lappend result {*}[$item compile-products] + } + set filename [my define get output_c] + if {$filename ne {}} { + set ofile [file rootname [file tail $filename]]_main.o + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] + } + return $result + } + + method generate-tcl-loader {} { + set result {} + set PKGINIT [my define get pkginit] + set PKG_NAME [my define get name [my define get pkg_name]] + set PKG_VERSION [my define get pkg_vers [my define get version]] + if {[string is true [my define get SHARED_BUILD 0]]} { + set LIBFILE [my define get libfile] + ::practcl::cputs result [string map \ + [list @LIBFILE@ $LIBFILE @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { +# Shared Library Style +load [file join [file dirname [file join [pwd] [info script]]] @LIBFILE@] @PKGINIT@ +package provide @PKG_NAME@ @PKG_VERSION@ +}] + } else { + ::practcl::cputs result [string map \ + [list @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { +# Tclkit Style +load {} @PKGINIT@ +package provide @PKG_NAME@ @PKG_VERSION@ +}] + } + return $result + } + + method go {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set name [my define getnull name] + if {$name eq {}} { + set name generic + my define name generic + } + if {[my define get tk] eq {@TEA_TK_EXTENSION@}} { + my define set tk 0 + } + set output_c [my define getnull output_c] + if {$output_c eq {}} { + set output_c [file rootname $name].c + my define set output_c $output_c + } + set output_h [my define getnull output_h] + if {$output_h eq {}} { + set output_h [file rootname $output_c].h + my define set output_h $output_h + } + set output_tcl [my define getnull output_tcl] + #if {$output_tcl eq {}} { + # set output_tcl [file rootname $output_c].tcl + # my define set output_tcl $output_tcl + #} + #set output_mk [my define getnull output_mk] + #if {$output_mk eq {}} { + # set output_mk [file rootname $output_c].mk + # my define set output_mk $output_mk + #} + set initfunc [my define getnull initfunc] + if {$initfunc eq {}} { + set initfunc [string totitle $name]_Init + my define set initfunc $initfunc + } + set output_decls [my define getnull output_decls] + if {$output_decls eq {}} { + set output_decls [file rootname $output_c].decls + my define set output_decls $output_decls + } + my variable links + foreach {linktype objs} [array get links] { + foreach obj $objs { + $obj go + } + } + ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] + } + + method implement path { + my go + my Collate_Source $path + foreach item [my link list dynamic] { + if {[catch {$item implement $path} err]} { + puts "Skipped $item: $err" + } + } + foreach item [my link list module] { + if {[catch {$item implement $path} err]} { + puts "Skipped $item: $err" + } + } + set cout [open [file join $path [my define get output_c]] w] + puts $cout [subst {/* +** This file is generated by the [info script] script +** any changes will be overwritten the next time it is run +*/}] + puts $cout [my generate-c] + puts $cout [my generate-loader] + close $cout + + set macro HAVE_[string toupper [file rootname [my define get output_h]]]_H + set hout [open [file join $path [my define get output_h]] w] + puts $hout [subst {/* +** This file is generated by the [info script] script +** any changes will be overwritten the next time it is run +*/}] + puts $hout "#ifndef ${macro}" + puts $hout "#define ${macro}" + puts $hout [my generate-h] + puts $hout "#endif" + close $hout + + set output_tcl [my define get output_tcl] + if {$output_tcl ne {}} { + set tclout [open [file join $path [my define get output_tcl]] w] + puts $tclout "### +# This file is generated by the [info script] script +# any changes will be overwritten the next time it is run +###" + puts $tclout [my generate-tcl-pre] + puts $tclout [my generate-tcl-loader] + puts $tclout [my generate-tcl-post] + close $tclout + } + } + + method generate-decls {pkgname path} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set outfile [file join $path/$pkgname.decls] + + ### + # Build the decls file + ### + set fout [open $outfile w] + puts $fout [subst {### + # $outfile + # + # This file was generated by [info script] + ### + + library $pkgname + interface $pkgname + }] + + ### + # Generate list of functions + ### + set stubfuncts [my generate-stub-function] + set thisline {} + set functcount 0 + foreach {func header} $stubfuncts { + puts $fout [list declare [incr functcount] $header] + } + puts $fout [list export "int [my define get initfunc](Tcl_Inter *interp)"] + puts $fout [list export "char *[string totitle [my define get name]]_InitStubs(Tcl_Inter *interp, char *version, int exact)"] + + close $fout + + ### + # Build [package]Decls.h + ### + set hout [open [file join $path ${pkgname}Decls.h] w] + + close $hout + + set cout [open [file join $path ${pkgname}StubInit.c] w] +puts $cout [string map [list %pkgname% $pkgname %PkgName% [string totitle $pkgname]] { +#ifndef USE_TCL_STUBS +#define USE_TCL_STUBS +#endif +#undef USE_TCL_STUB_PROCS + +#include "tcl.h" +#include "%pkgname%.h" + + /* + ** Ensure that Tdom_InitStubs is built as an exported symbol. The other stub + ** functions should be built as non-exported symbols. + */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +%PkgName%Stubs *%pkgname%StubsPtr; + + /* + **---------------------------------------------------------------------- + ** + ** %PkgName%_InitStubs -- + ** + ** Checks that the correct version of %PkgName% is loaded and that it + ** supports stubs. It then initialises the stub table pointers. + ** + ** Results: + ** The actual version of %PkgName% that satisfies the request, or + ** NULL to indicate that an error occurred. + ** + ** Side effects: + ** Sets the stub table pointers. + ** + **---------------------------------------------------------------------- + */ + +char * +%PkgName%_InitStubs (Tcl_Interp *interp, char *version, int exact) +{ + char *actualVersion; + actualVersion = Tcl_PkgRequireEx(interp, "%pkgname%", version, exact,(ClientData *) &%pkgname%StubsPtr); + if (!actualVersion) { + return NULL; + } + if (!%pkgname%StubsPtr) { + Tcl_SetResult(interp,"This implementation of %PkgName% does not support stubs",TCL_STATIC); + return NULL; + } + return actualVersion; +} +}] + close $cout + } + + # Backward compadible call + method generate-make path { + my build-Makefile $path [self] + } + + method install-headers {} { + set result {} + return $result + } + + method linktype {} { + return library + } + + # Create a "package ifneeded" + # Args are a list of aliases for which this package will answer to + method package-ifneeded {args} { + set result {} + set name [my define get pkg_name [my define get name]] + set version [my define get pkg_vers [my define get version]] + if {$version eq {}} { + set version 0.1a + } + set output_tcl [my define get output_tcl] + if {$output_tcl ne {}} { + set script "\[list source \[file join \$dir $output_tcl\]\]" + } elseif {[string is true -strict [my define get SHARED_BUILD]]} { + set script "\[list load \[file join \$dir [my define get libfile]\] $name\]" + } else { + # Provide a null passthrough + set script "\[list package provide $name $version\]" + } + set result "package ifneeded [list $name] [list $version] $script" + foreach alias $args { + set script "package require $name $version \; package provide $alias $version" + append result \n\n [list package ifneeded $alias $version $script] + } + return $result + } + + + method shared_library {} { + set name [string tolower [my define get name [my define get pkg_name]]] + set NAME [string toupper $name] + set version [my define get version [my define get pkg_vers]] + set map {} + lappend map %LIBRARY_NAME% $name + lappend map %LIBRARY_VERSION% $version + lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] + lappend map %LIBRARY_PREFIX% [my define getnull libprefix] + set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]][my define get SHLIB_SUFFIX] + return $outfile + } +} + +::oo::class create ::practcl::tclsh { + superclass ::practcl::library + + method Collate_Source CWD { + my define set SHARED_BUILD 1 + set name [my define get name] + + if {![my define exists TCL_LOCAL_APPINIT]} { + my define set TCL_LOCAL_APPINIT Tclkit_AppInit + } + if {![my define exists TCL_LOCAL_MAIN_HOOK]} { + my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook + } + set PROJECT [self] + set os [$PROJECT define get TEACUP_OS] + puts [list BUILDING TCLSH FOR OS $os] + set TCLOBJ [$PROJECT project TCLCORE] + set TKOBJ [$PROJECT project TKCORE] + set ODIEOBJ [$PROJECT project odie] + + set TCLSRCDIR [$TCLOBJ define get srcdir] + set PKG_OBJS {} + foreach item [$PROJECT link list package] { + if {[string is true [$item define get static]]} { + lappend PKG_OBJS $item + } + } + # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK + if {$os eq "windows"} { + set PLATFORM_SRC_DIR win + my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] + } else { + set PLATFORM_SRC_DIR unix + my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] + } + + my define add include_dir [file join $TCLSRCDIR generic] + my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] + # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK + my build-tclkit_main $PROJECT $PKG_OBJS + } +} + +::oo::class create ::practcl::tclkit { + superclass ::practcl::tclsh + + method Collate_Source CWD { + my define set SHARED_BUILD 0 + set name [my define get name] + + if {![my define exists TCL_LOCAL_APPINIT]} { + my define set TCL_LOCAL_APPINIT Tclkit_AppInit + } + if {![my define exists TCL_LOCAL_MAIN_HOOK]} { + my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook + } + + set PROJECT [self] + set os [$PROJECT define get TEACUP_OS] + puts [list BUILDING KIT FOR OS $os] + set TCLOBJ [$PROJECT project TCLCORE] + set TKOBJ [$PROJECT project TKCORE] + set ODIEOBJ [$PROJECT project odie] + + set TCLSRCDIR [$TCLOBJ define get srcdir] + set TKSRCDIR [$TKOBJ define get srcdir] + set PKG_OBJS {} + foreach item [$PROJECT link list package] { + if {[string is true [$item define get static]]} { + lappend PKG_OBJS $item + } + } + # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK + if {$os eq "windows"} { + set PLATFORM_SRC_DIR win + my add class csource filename [file join $TCLSRCDIR win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.1 autoload 1 + my add class csource filename [file join $TCLSRCDIR win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 autoload 1 + my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] + } else { + set PLATFORM_SRC_DIR unix + my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] + } + ### + # Add local static Zlib implementation + ### + set cdir [file join $TCLSRCDIR compat zlib] + foreach file { + adler32.c compress.c crc32.c + deflate.c infback.c inffast.c + inflate.c inftrees.c trees.c + uncompr.c zutil.c + } { + my add [file join $cdir $file] + } + + ### + # Pre 8.7, Tcl doesn't include a Zipfs implementation + # in the core. Grab the one from odielib + ### + set zipfs [file join $TCLSRCDIR generic tclZipfs.c] + if {![$PROJECT define exists ZIPFS_VOLUME]} { + $PROJECT define set ZIPFS_VOLUME "zipfs:/" + } + $PROJECT code header "#define ZIPFS_VOLUME \"[$PROJECT define get ZIPFS_VOLUME]\"" + if {[file exists $zipfs]} { + $TCLOBJ define set tip_430 1 + my define set tip_430 1 + } else { + # The Tclconfig project maintains a mirror of the version + # released with the Tcl core + my define set tip_430 0 + ::practcl::LOCAL tool odie load + set COMPATSRCROOT [::practcl::LOCAL tool odie define get srcdir] + set cdir [file join $COMPATSRCROOT compat zipfs] + my define add include_dir $cdir + set zipfs [file join $cdir tclZipfs.c] + my add class csource filename $zipfs initfunc Tclzipfs_Init pkg_name zipfs pkg_vers 1.1 autoload 1 extra "-DZIPFS_VOLUME=\"[$PROJECT define get ZIPFS_VOLUME]\"" + } + + my define add include_dir [file join $TKSRCDIR generic] + my define add include_dir [file join $TKSRCDIR $PLATFORM_SRC_DIR] + my define add include_dir [file join $TKSRCDIR bitmaps] + my define add include_dir [file join $TKSRCDIR xlib] + my define add include_dir [file join $TCLSRCDIR generic] + my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] + my define add include_dir [file join $TCLSRCDIR compat zlib] + # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK + my build-tclkit_main $PROJECT $PKG_OBJS + } + + ## Wrap an executable + # + method wrap {PWD exename vfspath args} { + cd $PWD + if {![file exists $vfspath]} { + file mkdir $vfspath + } + foreach item [my link list core.library] { + set name [$item define get name] + set libsrcdir [$item define get srcdir] + if {[file exists [file join $libsrcdir library]]} { + ::practcl::copyDir [file join $libsrcdir library] [file join $vfspath boot $name] + } + } + # Assume the user will populate the VFS path + #if {[my define get installdir] ne {}} { + # ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib] + #} + foreach arg $args { + ::practcl::copyDir $arg $vfspath + } + + set fout [open [file join $vfspath packages.tcl] w] + puts $fout { + set ::PKGIDXFILE [info script] + set dir [file dirname $::PKGIDXFILE] + } + #set BASEVFS [my define get BASEVFS] + set EXEEXT [my define get EXEEXT] + + set tclkit_bare [my define get tclkit_bare] + + set buffer [::practcl::pkgindex_path $vfspath] + puts $fout $buffer + puts $fout { + # Advertise statically linked packages + foreach {pkg script} [array get ::kitpkg] { + eval $script + } + } + close $fout + ::practcl::mkzip ${exename}${EXEEXT} $tclkit_bare $vfspath + if { [my define get TEACUP_OS] ne "windows" } { + file attributes ${exename}${EXEEXT} -permissions a+x + } + } +} + +### +# Standalone class to manage code distribution +# This class is intended to be mixed into another class +# (Thus the lack of ancestors) +### +oo::class create ::practcl::distribution { + + method DistroMixIn {} { + my define set scm none + } + + method Sandbox {} { + if {[my define exists sandbox]} { + return [my define get sandbox] + } + if {[my organ project] ni {::noop {}}} { + set sandbox [my define get sandbox] + if {$sandbox ne {}} { + my define set sandbox $sandbox + return $sandbox + } + } + set sandbox [file normalize [file join $::CWD .. $pkg]] + my define set sandbox $sandbox + return $sandbox + } + + method SrcDir {} { + set pkg [my define get name] + if {[my define exists srcdir]} { + return [my define get srcdir] + } + set sandbox [my Sandbox] + set srcdir [file join [my Sandbox] $pkg] + my define set srcdir $srcdir + return $srcdir + } + + method ScmSelect {} { + if {[my define exists scm]} { + return [my define get scm] + } + set srcdir [my SrcDir] + set classprefix ::practcl::distribution. + if {[file exists $srcdir]} { + foreach class [::info commands ${classprefix}*] { + if {[$class claim_path $srcdir]} { + oo::objdefine [self] mixin $class + my define set scm [string range $class [string length ::practcl::distribution.] end] + } + } + } + foreach class [::info commands ${classprefix}*] { + if {[$class claim_object [self]]} { + oo::objdefine [self] mixin $class + my define set scm [string range $class [string length ::practcl::distribution.] end] + } + } + if {[my define get scm] eq {}} { + error "No SCM selected" + } + return [my define get scm] + } + + method ScmTag {} {} + method ScmClone {} {} + method ScmUnpack {} {} + method ScmUpdate {} {} + + method unpack {} { + my ScmSelect + set srcdir [my SrcDir] + if {[file exists $srcdir]} { + return + } + set pkg [my define get name] + if {[my define exists download]} { + # Utilize a staged download + set download [my define get download] + if {[file exists [file join $download $pkg.zip]]} { + ::practcl::tcllib_require zipfile::decode + ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir + return + } + } + my ScmSelect + my ScmUnpack + } + + method update {} { + my ScmSelect + my ScmUpdate + } +} + +oo::objdefine ::practcl::distribution { + method claim_path path { + return false + } + method claim_object object { + return false + } +} + +oo::class create ::practcl::distribution.fossil { + superclass ::practcl::distribution + + # Clone the source + method ScmClone {} { + set srcdir [my SrcDir] + if {[file exists [file join $srcdir .fslckout]]} { + return + } + if {[file exists [file join $srcdir _FOSSIL_]]} { + return + } + if {![::info exists ::practcl::fossil_dbs]} { + # Get a list of local fossil databases + set ::practcl::fossil_dbs [exec fossil all list] + } + set pkg [my define get name] + # Return an already downloaded fossil repo + foreach line [split $::practcl::fossil_dbs \n] { + set line [string trim $line] + if {[file rootname [file tail $line]] eq $pkg} { + return $line + } + } + set download [::practcl::LOCAL define get download] + set fosdb [file join $download $pkg.fos] + if {[file exists $fosdb]} { + return $fosdb + } + + file mkdir [file join $download fossil] + set fosdb [file join $download fossil $pkg.fos] + if {[file exists $fosdb]} { + return $fosdb + } + + set cloned 0 + # Attempt to clone from a local network mirror + if {[::practcl::LOCAL define exists fossil_mirror]} { + set localmirror [::practcl::LOCAL define get fossil_mirror] + catch { + ::practcl::doexec fossil clone $localmirror/$pkg $fosdb + set cloned 1 + } + if {$cloned} { + return $fosdb + } + } + # Attempt to clone from the canonical source + if {[my define get fossil_url] ne {}} { + catch { + ::practcl::doexec fossil clone [my define get fossil_url] $fosdb + set cloned 1 + } + if {$cloned} { + return $fosdb + } + } + # Fall back to the fossil mirror on the island of misfit toys + ::practcl::doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb + return $fosdb + } + + method ScmTag {} { + if {[my define exists scm_tag]} { + return [my define get scm_tag] + } + if {[my define exists tag]} { + set tag [my define get tag] + } else { + set tag trunk + } + my define set scm_tag $tag + return $tag + } + + method ScmUnpack {} { + set srcdir [my SrcDir] + if {[file exists [file join $srcdir .fslckout]]} { + return 0 + } + if {[file exists [file join $srcdir _FOSSIL_]]} { + return 0 + } + set CWD [pwd] + set fosdb [my ScmClone] + set tag [my ScmTag] + file mkdir $srcdir + ::practcl::fossil $srcdir open $fosdb $tag + return 1 + } + + method ScmUpdate {} { + if {[my ScmUnpack]} { + return + } + set srcdir [my SrcDir] + set tag [my ScmTag] + ::practcl::fossil $srcdir update $tag + } +} + +oo::objdefine ::practcl::distribution.fossil { + + # Check for markers in the source root + method claim_path path { + if {[file exists [file join $path .fslckout]]} { + return true + } + if {[file exists [file join $path _FOSSIL_]]} { + return true + } + return false + } + + # Check for markers in the metadata + method claim_object obj { + set path [$obj define get srcdir] + if {[my claim_path $path]} { + return true + } + if {[$obj define get fossil_url] ne {}} { + return true + } + return false + } +} + +oo::class create ::practcl::distribution.git { + + method ScmTag {} { + if {[my define exists scm_tag]} { + return [my define get scm_tag] + } + if {[my define exists tag]} { + set tag [my define get tag] + } else { + set tag master + } + my define set scm_tag $tag + return $tag + } + + method ScmUnpack {} { + set srcdir [my SrcDir] + if {[file exists [file join $srcdir .git]]} { + return 0 + } + set CWD [pwd] + set tag [my ScmTag] + set pkg [my define get name] + if {[my define exists git_url]} { + ::practcl::doexec git clone --branch $tag [my define get git_url] $srcdir + } else { + ::practcl::doexec git clone --branch $tag https://github.com/eviltwinskippy/$pkg $srcdir + } + return 1 + } + + method ScmUpdate {} { + if {[my ScmUnpack]} { + return + } + set srcdir [my SrcDir] + set tag [my ScmTag] + ::practcl::doexec_in $srcdir git pull $tag + cd $CWD + } + +} +oo::objdefine ::practcl::distribution.git { + method claim_path path { + if {[file exists [file join $path .git]]} { + return true + } + return false + } + method claim_object obj { + set path [$obj define get srcdir] + if {[my claim_path $path]} { + return true + } + if {[$obj define get git_url] ne {}} { + return true + } + return false + } +} + +### +# Meta repository +# The default is an inert source code block +### +oo::class create ::practcl::subproject { + superclass ::practcl::object ::practcl::distribution + + method compile {} {} + + method critcl args { + if {![info exists critcl]} { + ::pratcl::LOCAL tool critcl load + set critcl [file join [::pratcl::LOCAL tool critcl define get srcdir] main.tcl + } + set srcdir [my SourceRoot] + set PWD [pwd] + cd $srcdir + ::pratcl::dotclexec $critcl {*}$args + cd $PWD + } + + method go {} { + set name [my define get name] + set srcdir [my SrcDir] + my define set localsrcdir $srcdir + my define add include_dir [file join $srcdir generic] + my sources + } + + # Install project into the local build system + method install args {} + + method linktype {} { + return {subordinate package} + } + + method linker-products {configdict} {} + + method linker-external {configdict} { + if {[dict exists $configdict PRACTCL_LIBS]} { + return [dict get $configdict PRACTCL_LIBS] + } + } + + method sources {} {} +} + +### +# A project which the kit compiles and integrates +# the source for itself +### +oo::class create ::practcl::subproject.source { + superclass ::practcl::subproject ::practcl::library + + method linktype {} { + return {subordinate package source} + } + +} + +# a copy from the teapot +oo::class create ::practcl::subproject.teapot { + superclass ::practcl::subproject + + method install-local {} { + my install-vfs + } + + method install DEST { + set pkg [my define get pkg_name [my define get name]] + set download [my define get download] + my unpack + set prefix [string trimleft [my define get prefix] /] + ::practcl::tcllib_require zipfile::decode + ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg] + } +} + +oo::class create ::practcl::subproject.kettle { + superclass ::practcl::subproject + + method install-local {} { + my install-vfs + } + + method kettle {path args} { + my variable kettle + if {![info exists kettle]} { + ::pratcl::LOCAL tool kettle load + set kettle [file join [::pratcl::LOCAL tool kettle define get srcdir] kettle] + } + set srcdir [my SourceRoot] + ::pratcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args + } + + method install DEST { + my kettle reinstall --prefix $DEST + } +} + +oo::class create ::practcl::subproject.critcl { + superclass ::practcl::subproject + + method install-local {} { + my install-vfs + } + + method install DEST { + my critcl -pkg [my define get name] + set srcdir [my SourceRoot] + ::pratcl::copyDir [file join $srcdir [my define get name]] [file join $DEST lib [my define get name]] + } +} + + +oo::class create ::practcl::subproject.sak { + superclass ::practcl::subproject + + method install-local {} { + my install-vfs + } + + method install DEST { + ### + # Handle teapot installs + ### + set pkg [my define get pkg_name [my define get name]] + my unpack + set prefix [string trimleft [my define get prefix] /] + set srcdir [my define get srcdir] + ::practcl::dotclexec [file join $srcdir installer.tcl] \ + -pkg-path [file join $DEST $prefix lib $pkg] \ + -no-examples -no-html -no-nroff \ + -no-wait -no-gui -no-apps + } +} + +### +# A binary package +### +oo::class create ::practcl::subproject.binary { + superclass ::practcl::subproject ::practcl::autoconf + + method compile-products {} {} + + method ConfigureOpts {} { + set opts {} + set builddir [my define get builddir] + if {[my define get broken_destroot 0]} { + set PREFIX [my define get prefix_broken_destdir] + } else { + set PREFIX [my define get prefix] + } + if {[my define get CONFIG_SITE] != {}} { + lappend opts --host=[my define get HOST] + lappend opts --with-tclsh=[info nameofexecutable] + } + if {[my 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 define get tclsrcdir]]]] + set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my define get tclsrcdir] .. generic]]] + lappend opts --with-tcl=$TCLSRCDIR --with-tclinclude=$TCLGENERIC + } + if {[my define exists tksrcdir]} { + set TKSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my define get tksrcdir]]]] + set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my define get tksrcdir] .. generic]]] + lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC + } + lappend opts {*}[my define get config_opts] + if {![regexp -- "--prefix" $opts]} { + lappend opts --prefix=$PREFIX + } + #--exec_prefix=$PREFIX + #if {$::tcl_platform(platform) eq "windows"} { + # lappend opts --disable-64bit + #} + if {[my define get static 1]} { + lappend opts --disable-shared --disable-stubs + # + } else { + lappend opts --enable-shared + } + return $opts + } + + method go {} { + next + my define set builddir [my BuildDir [my define get masterpath]] + } + + method linker-products {configdict} { + if {![my define get static 0]} { + return {} + } + set srcdir [my define get builddir] + if {[dict exists $configdict libfile]} { + return " [file join $srcdir [dict get $configdict libfile]]" + } + } + + method static-packages {} { + if {![my define get static 0]} { + return {} + } + set result [my define get static_packages] + set statpkg [my define get static_pkg] + set initfunc [my define get initfunc] + if {$initfunc ne {}} { + set pkg_name [my define get pkg_name] + if {$pkg_name ne {}} { + dict set result $pkg_name initfunc $initfunc + set version [my define get version] + if {$version eq {}} { + set info [my config.sh] + set version [dict get $info version] + set pl {} + if {[dict exists $info patch_level]} { + set pl [dict get $info patch_level] + append version $pl + } + my define set version $version + } + dict set result $pkg_name version $version + dict set result $pkg_name autoload [my define get autoload 0] + } + } + foreach item [my link list subordinate] { + foreach {pkg info} [$item static-packages] { + dict set result $pkg $info + } + } + return $result + } + + method BuildDir {PWD} { + set name [my define get name] + return [my define get builddir [file join $PWD pkg.$name]] + } + + method compile {} { + set name [my define get name] + set PWD $::CWD + cd $PWD + my unpack + set srcdir [file normalize [my SrcDir]] + my Collate_Source $PWD + + ### + # Build a starter VFS for both Tcl and wish + ### + set srcdir [my define get srcdir] + if {[my define get static 1]} { + puts "BUILDING Static $name $srcdir" + } else { + puts "BUILDING Dynamic $name $srcdir" + } + if {[my define get USEMSVC 0]} { + cd $srcdir + ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my define get installdir] release + } else { + cd $::CWD + set builddir [file normalize [my define get builddir]] + file mkdir $builddir + if {![file exists [file join $builddir Makefile]]} { + my Configure + } + if {[file exists [file join $builddir make.tcl]]} { + ::practcl::domake.tcl $builddir library + } else { + ::practcl::domake $builddir all + } + } + cd $PWD + } + + method Configure {} { + cd $::CWD + my unpack + set srcdir [file normalize [my define get srcdir]] + set builddir [file normalize [my define get builddir]] + file mkdir $builddir + if {[my define get USEMSVC 0]} { + return + } + if {![file exists [file join $srcdir tclconfig install-sh]]} { + # ensure we have tclconfig with all of the trimmings + set teapath {} + if {[file exists [file join $srcdir .. tclconfig install-sh]]} { + set teapath [file join $srcdir .. tclconfig] + } else { + set tclConfigObj [::practcl::LOCAL tool tclconfig] + $tclConfigObj load + set teapath [$tclConfigObj define get srcdir] + } + set teapath [file normalize $teapath] + #file mkdir [file join $srcdir tclconfig] + if {[catch {file link -symbolic [file join $srcdir tclconfig] $teapath}]} { + ::practcl::copyDir [file join $teapath] [file join $srcdir tclconfig] + } + } + set opts [my ConfigureOpts] + puts [list PKG [my define get name] CONFIGURE {*}$opts] + cd $builddir + if {[my define get CONFIG_SITE] ne {}} { + set ::env(CONFIG_SITE) [my define get CONFIG_SITE] + } + catch {exec sh [file join $srcdir configure] {*}$opts >& [file join $builddir practcl.log]} + cd $::CWD + } + + method install DEST { + set PWD [pwd] + set PREFIX [my define get prefix] + ### + # Handle teapot installs + ### + set pkg [my define get pkg_name [my define get name]] + if {[my define get teapot] ne {}} { + set TEAPOT [my define get teapot] + set found 0 + foreach ver [my define get pkg_vers [my define get version]] { + set teapath [file join $TEAPOT $pkg$ver] + if {[file exists $teapath]} { + set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]] + ::practcl::copyDir $teapath $dest + return + } + } + } + my compile + if {[my define get USEMSVC 0]} { + set srcdir [my define get srcdir] + cd $srcdir + puts "[self] VFS INSTALL $DEST" + ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST install + } else { + set builddir [my define get builddir] + if {[file exists [file join $builddir make.tcl]]} { + # Practcl builds can inject right to where we need them + puts "[self] VFS INSTALL $DEST (Practcl)" + ::practcl::domake.tcl $builddir install-package $DEST + } elseif {[my define get broken_destroot 0] == 0} { + # Most modern TEA projects understand DESTROOT in the makefile + puts "[self] VFS INSTALL $DEST (TEA)" + ::practcl::domake $builddir install DESTDIR=$DEST + } else { + # But some require us to do an install into a fictitious filesystem + # and then extract the gooey parts within. + # (*cough*) TkImg + set PREFIX [my define get prefix] + set BROKENROOT [::practcl::msys_to_tclpath [my define get prefix_broken_destdir]] + file delete -force $BROKENROOT + file mkdir $BROKENROOT + ::practcl::domake $builddir $install + ::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]] + file delete -force $BROKENROOT + } + } + cd $PWD + } + + method Autoconf {} { + ### + # Re-run autoconf for this project + # Not a good idea in practice... but in the right hands it can be useful + ### + set pwd [pwd] + set srcdir [file normalize [my define get srcdir]] + cd $srcdir + foreach template {configure.ac configure.in} { + set input [file join $srcdir $template] + if {[file exists $input]} { + puts "autoconf -f $input > [file join $srcdir configure]" + exec autoconf -f $input > [file join $srcdir configure] + } + } + cd $pwd + } +} + +oo::class create ::practcl::subproject.core { + superclass ::practcl::subproject.binary + + # On the windows platform MinGW must build + # from the platform directory in the source repo + method BuildDir {PWD} { + return [my define get localsrcdir] + } + + method Configure {} { + if {[my define get USEMSVC 0]} { + return + } + set opts [my ConfigureOpts] + set builddir [file normalize [my define get builddir]] + set localsrcdir [file normalize [my define get localsrcdir]] + puts [list PKG [my define get name] CONFIGURE {*}$opts] + cd $localsrcdir + if {[my define get CONFIG_SITE] ne {}} { + set ::env(CONFIG_SITE) [my define get CONFIG_SITE] + } + catch {exec sh [file join $localsrcdir configure] {*}$opts >& [file join $builddir practcl.log]} + } + + method ConfigureOpts {} { + set opts {} + set builddir [file normalize [my define get builddir]] + set PREFIX [my define get prefix] + if {[my define get CONFIG_SITE] != {}} { + lappend opts --host=[my define get HOST] + lappend opts --with-tclsh=[info nameofexecutable] + } + lappend opts {*}[my define get config_opts] + if {![regexp -- "--prefix" $opts]} { + lappend opts --prefix=$PREFIX + } + #--exec_prefix=$PREFIX + lappend opts --disable-shared + return $opts + } + + method go {} { + set name [my define get name] + set os [my define get TEACUP_OS] + puts [list [self] PROJECT [my organ project] OS $os] + set srcdir [my SrcDir] + my define add include_dir [file join $srcdir generic] + switch $os { + windows { + my define set localsrcdir [file join $srcdir win] + my define add include_dir [file join $srcdir win] + } + default { + my define set localsrcdir [file join $srcdir unix] + my define add include_dir [file join $srcdir $name unix] + } + } + my define set builddir [my BuildDir [my define get masterpath]] + } + + method linktype {} { + return {subordinate core.library} + } +} + + +### +# Classes to manage tools that needed in the local environment +# to compile and/or installed other packages +### +oo::class create ::practcl::tool { + superclass ::practcl::object ::practcl::distribution + + method critcl args { + if {![info exists critcl]} { + ::pratcl::LOCAL tool critcl load + set critcl [file join [::pratcl::LOCAL tool critcl define get srcdir] main.tcl + } + set srcdir [my SourceRoot] + set PWD [pwd] + cd $srcdir + ::pratcl::dotclexec $critcl {*}$args + cd $PWD + } + + method SourceRoot {} { + set info [my define dump] + set result $info + if {![my define exists srcdir]} { + if {[dict exists $info srcdir]} { + set srcdir [dict get $info srcdir] + } elseif {[dict exists $info sandbox]} { + set srcdir [file join [dict get $info sandbox] $pkg] + } else { + set srcdir [file join $::CWD .. $pkg] + } + dict set result srcdir $srcdir + my define set srcdir $srcdir + } + return [my define get srcdir] + } + + method linktype {} { + return tool + } + + # Return boolean if present + method present {} { + return 1 + } + + # Procedure to install in the local environment + method install {} { + my unpack + } + + # Procedure to load into the local interpreter + method load {} { + my variable loaded + if {[info exists loaded]} { + return 0 + } + if {![my present]} { + my install + } + my LocalLoad + set loaded 1 + } + + method LocalLoad {} {} +} + +oo::class create ::practcl::tool.source { + superclass ::practcl::tool + + method present {} { + return [file exists [my define get srcdir]] + } + + method toplevel_script {} { + my load + return [file join [my SourceRoot] [my define get toplevel_script]] + } + + method LocalLoad {} { + set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] + if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { + set ::auto_path [linsert $::auto_path 0 $LibraryRoot] + } + } +} + +### +# Create an object to represent the local environment +### +set ::practcl::MAIN ::practcl::LOCAL +# Defer the creation of the ::pratcl::LOCAL object until it is called +# in order to allow packages to +set ::auto_index(::practcl::LOCAL) { + ::practcl::project create ::practcl::LOCAL + ::practcl::LOCAL define set [::practcl::local_os] + # Until something better comes along, use ::practcl::LOCAL + # as our main project + # Add tclconfig as a project of record + ::practcl::LOCAL add_tool tclconfig { + tag trunk class tool.source fossil_url http://core.tcl.tk/tclconfig + } + # Add tcllib as a project of record + ::practcl::LOCAL add_tool tcllib { + tag trunk class tool.source fossil_url http://core.tcl.tk/tcllib + } + ::practcl::LOCAL add_tool kettle { + tag trunk class tool.source fossil_url http://fossil.etoyoc.com/fossil/kettle + } + ::practcl::LOCAL add_tool critcl { + tag trunk class tool.source + git_url http://github.com/andreas-kupries/critcl + } + ::practcl::LOCAL add_tool odie { + tag trunk class tool.source + fossil_url http://fossil.etoyoc.com/fossil/odie + } +} +package provide practcl 0.7