summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Master/source/tltcl/LICENSE60
-rw-r--r--Master/source/tltcl/kitcreator-0.11.0.tar.gzbin0 -> 212938 bytes
-rw-r--r--Master/source/tltcl/metakit-2.4.9.7.tar.gzbin0 -> 868310 bytes
-rw-r--r--Master/source/tltcl/tcl8.6.8.tar.gzbin0 -> 9793786 bytes
-rw-r--r--Master/source/tltcl/tclvfs-20080503.tar.gzbin0 -> 258723 bytes
-rw-r--r--Master/source/tltcl/tk8.6.8.tar.gzbin0 -> 4319854 bytes
-rw-r--r--Master/source/tltcl/tltcl.README54
-rw-r--r--Master/source/tltcl/zlib-1.2.8.tar.gzbin0 -> 571091 bytes
-rwxr-xr-xMaster/tlpkg/tltcl/tclkit.exebin0 -> 6297510 bytes
-rw-r--r--Master/tlpkg/tltcl/tltcl.tcl507
10 files changed, 621 insertions, 0 deletions
diff --git a/Master/source/tltcl/LICENSE b/Master/source/tltcl/LICENSE
new file mode 100644
index 00000000000..d8fe08dc831
--- /dev/null
+++ b/Master/source/tltcl/LICENSE
@@ -0,0 +1,60 @@
+The MIT License is applied to all files in this distribution, except:
+ kitsh/buildsrc/kitsh-0.0/boot.tcl
+ kitsh/buildsrc/kitsh-0.0/boot.tcl.h
+ kitsh/buildsrc/kitsh-0.0/kit.rc
+ kitsh/buildsrc/kitsh-0.0/kit.ico
+ kitsh/buildsrc/kitsh-0.0/kitInit.c
+ kitsh/buildsrc/kitsh-0.0/license.terms
+ kitsh/buildsrc/kitsh-0.0/pwb.c
+ kitsh/buildsrc/kitsh-0.0/rechan.c
+ kitsh/buildsrc/kitsh-0.0/zipvfs.tcl
+ kitsh/buildsrc/kitsh-0.0/zipvfs.tcl.h
+ kitsh/buildsrc/kitsh-0.0/zlib.c
+ kitsh/buildsrc/kitsh-0.0/winMain.c
+ kitsh/buildsrc/kitsh-0.0/mk4tcl.tcl
+ kitsh/buildsrc/kitsh-0.0/mk4tcl.tcl.h
+ kitdll/buildsrc/kitdll-0.0/rechan.c
+ kitdll/buildsrc/kitdll-0.0/zlib.c
+ kitdll/buildsrc/kitdll-0.0/kitInit.c
+ kitdll/buildsrc/kitdll-0.0/boot.tcl
+ kitdll/buildsrc/kitdll-0.0/pwb.c
+
+Please see "kitsh/buildsrc/kitsh-0.0/license.terms" for licensing information
+regarding these files.
+
+Files that are downloaded are under different licenses (grouped by project):
+ * Tcl: Tcl/Tk License <http://www.tcl.tk/software/tcltk/license.html>
+ * Tk: Tcl/Tk License <http://www.tcl.tk/software/tcltk/license.html>
+ * Itcl: Tcl/Tk License <http://incrtcl.sourceforge.net/itcl/copyright.html>
+ * Mk4tcl: MIT License <http://www.equi4.com/metakit/license.html>
+ * TclVFS: BSD License
+ * Thread: Tcl/Tk License <http://www.tcl.tk/software/tcltk/license.html>
+ * ZLib: Zlib License <http://www.gzip.org/zlib/zlib_license.html>
+
+The final result of this build process is a derivative work of all of these
+projects and is restricted by the cumulative licensing requirements of all of
+them.
+
+All other files in this distribution are licensed under the terms of the MIT
+License, below:
+The MIT License
+
+Copyright (c) 2010 Roy S. Keene
+
+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
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
diff --git a/Master/source/tltcl/kitcreator-0.11.0.tar.gz b/Master/source/tltcl/kitcreator-0.11.0.tar.gz
new file mode 100644
index 00000000000..49eb0dac352
--- /dev/null
+++ b/Master/source/tltcl/kitcreator-0.11.0.tar.gz
Binary files differ
diff --git a/Master/source/tltcl/metakit-2.4.9.7.tar.gz b/Master/source/tltcl/metakit-2.4.9.7.tar.gz
new file mode 100644
index 00000000000..82378e0e26a
--- /dev/null
+++ b/Master/source/tltcl/metakit-2.4.9.7.tar.gz
Binary files differ
diff --git a/Master/source/tltcl/tcl8.6.8.tar.gz b/Master/source/tltcl/tcl8.6.8.tar.gz
new file mode 100644
index 00000000000..c8577f40564
--- /dev/null
+++ b/Master/source/tltcl/tcl8.6.8.tar.gz
Binary files differ
diff --git a/Master/source/tltcl/tclvfs-20080503.tar.gz b/Master/source/tltcl/tclvfs-20080503.tar.gz
new file mode 100644
index 00000000000..6bbdf4a087b
--- /dev/null
+++ b/Master/source/tltcl/tclvfs-20080503.tar.gz
Binary files differ
diff --git a/Master/source/tltcl/tk8.6.8.tar.gz b/Master/source/tltcl/tk8.6.8.tar.gz
new file mode 100644
index 00000000000..21cbb485ddc
--- /dev/null
+++ b/Master/source/tltcl/tk8.6.8.tar.gz
Binary files differ
diff --git a/Master/source/tltcl/tltcl.README b/Master/source/tltcl/tltcl.README
new file mode 100644
index 00000000000..4f54395cd9a
--- /dev/null
+++ b/Master/source/tltcl/tltcl.README
@@ -0,0 +1,54 @@
+tclkit.exe is a single-file Tcl/Tk runtime. The one included in TeX
+Live is generated with kitcreator. This program downloads and
+compiles tcl, tk and various pieces of infrastructure.
+
+I used kitcreator's README file for guidance in generating
+tclkit.exe:
+
+from the root of the unpacked kitcreator archive I first created a
+native Linux tclkit:
+
+./kitcreator
+mv tclkit-8.6.8 tclkit-local
+
+From this same directory I ran the following script:
+
+================
+#!/bin/bash
+export TCLKIT=`pwd`/tclkit-local
+export CROSS=i686-w64-mingw32
+
+export CC=${CROSS}-gcc
+export CXX=${CROSS}-c++
+export AR=${CROSS}-ar
+export RANLIB=${CROSS}-ranlib
+export STRIP=${CROSS}-strip
+export RC=${CROSS}-windres
+./kitcreator --host=${CROSS}
+
+mv tclkit-8.6.8 tclkit.exe
+================
+
+This directory contains the archives of kitcreator and the archives
+it downloaded during the build process.
+
+The LICENSE file is the one I found in the root of the kitcreator
+archive.
+
+As to the urls of the downloaded files: a command
+
+find . -name "build*.sh" -exec grep '^SRCURL=' \{} \;
+
+generated the following output:
+
+SRCURL="http://sourceforge.net/projects/incrtcl/files/%5BIncr%20Tcl_Tk%5D-source/Itcl%20${ITCLVERS}/itcl${ITCLVERS}${ITCLVERSEXTRA}.tar.gz/download"
+SRCURL="http://prdownloads.sourceforge.net/tcl/tcl${TCLVERS}-src.tar.gz"
+SRCURL="http://sourceforge.net/projects/tcl/files/Thread%20Extension/${THREADVERS}/thread${THREADVERS}.tar.gz/download"
+SRCURL="http://www.equi4.com/pub/mk/metakit-${MK4VERS}.tar.gz"
+SRCURL="http://pkgs.fedoraproject.org/repo/pkgs/metakit/metakit-${MK4VERS}.tar.gz/17330257376eea657827ed632ea62c9e/metakit-${MK4VERS}.tar.gz"
+SRCURL="http://prdownloads.sourceforge.net/tcl/tk${TCLVERS}-src.tar.gz"
+
+The itcl- and thread- packages listed above were not actually downloaded.
+
+Siep Kroonenberg
+November 2018
diff --git a/Master/source/tltcl/zlib-1.2.8.tar.gz b/Master/source/tltcl/zlib-1.2.8.tar.gz
new file mode 100644
index 00000000000..ed88885bd40
--- /dev/null
+++ b/Master/source/tltcl/zlib-1.2.8.tar.gz
Binary files differ
diff --git a/Master/tlpkg/tltcl/tclkit.exe b/Master/tlpkg/tltcl/tclkit.exe
new file mode 100755
index 00000000000..c58dacd579c
--- /dev/null
+++ b/Master/tlpkg/tltcl/tclkit.exe
Binary files differ
diff --git a/Master/tlpkg/tltcl/tltcl.tcl b/Master/tlpkg/tltcl/tltcl.tcl
new file mode 100644
index 00000000000..75e9c12e724
--- /dev/null
+++ b/Master/tlpkg/tltcl/tltcl.tcl
@@ -0,0 +1,507 @@
+#!/usr/bin/env wish
+
+# Copyright 2018 Siep Kroonenberg
+
+# This file is licensed under the GNU General Public License version 2
+# or any later version.
+
+# common declarations for tlshell.tcl and install-tl-gui.tcl
+
+set ::plain_unix 0
+if {$::tcl_platform(platform) eq "unix" && $::tcl_platform(os) ne "Darwin"} {
+ set ::plain_unix 1
+}
+
+# process ID of the perl program that will run in the background
+set ::perlpid 0
+
+set any_mirror "http://mirror.ctan.org/systems/texlive/tlnet"
+
+proc get_stacktrace {} {
+ set level [info level]
+ set s ""
+ for {set i 1} {$i < $level} {incr i} {
+ append s [format "Level %u: %s\n" $i [info level $i]]
+ }
+ return $s
+} ; # get_stacktrace
+
+proc err_exit {{mess ""}} {
+ if {$mess eq ""} {set mess "Error"}
+ append mess "\n" [get_stacktrace]
+ if $::plain_unix {
+ # plain_unix: avoid a RenderBadPicture error on quitting.
+ # 'send' changes the shutdown sequence,
+ # which avoids triggering the bug.
+ # 'tk appname <something>' restores 'send' and avoids the bug
+ bind . <Destroy> {
+ catch {tk appname appname}
+ }
+ }
+ tk_messageBox -icon error -message $mess
+ # kill perl process, just in case
+ if $::perlpid {
+ catch {
+ if {$::tcl_platform(platform) eq "unix"} {
+ exec -ignorestderr "kill" $::perlpid
+ } else {
+ exec -ignorestderr "taskkill" "/pid" $::perlpid
+ }
+ }
+ }
+ exit
+} ; # err_exit
+
+# localization support
+
+# for the sake of our translators we use our own translation function
+# which can use .po files directly. This allows them to check their work
+# without creating or waiting for a conversion to .msg.
+# We still use the msgcat module for detecting default locale.
+# Otherwise, the localization code borrows much from Norbert Preining's
+# translation module for TL.
+
+proc load_translations {} {
+
+ # check the command-line for a lang parameter
+ set ::lang ""
+ set i 0
+ while {$i < $::argc} {
+ set p [lindex $::argv $i]
+ incr i
+ if {$p eq "-lang" || $p eq "--lang"} {
+ if {$i < $::argc} {
+ set ::lang [lindex $::argv $i]
+ break
+ }
+ } elseif {[string range $p 0 5] eq "-lang="} {
+ set ::lang [string range $p 6 end]
+ break
+ } elseif {[string range $p 0 6] eq "--lang="} {
+ set ::lang [string range $p 7 end]
+ break
+ }
+ }
+ unset i
+
+ # First fallback: check config file.
+ # $TEXMFCONFIG/tlmgr/config can have a setting for gui-lang.
+ # There will not be one for the installer, only for tlmgr.
+ if {! [info exists ::lang] || $::lang eq ""} {
+ foreach tmf {"TEXMFCONFIG" "TEXMFSYSCONFIG"} {
+ if [catch {exec kpsewhich -var-value $tmf} d] {
+ break; # apparently there is not yet a TL installation
+ }
+ if [catch {open [file join $d "tlmgr" "config"] r} fid] continue
+ while 1 {
+ if [chan eof $fid] {
+ break
+ }
+ if [catch {chan gets $fid} l] break
+ if {[regexp {^\s*gui-lang\s*=\s*(\S+)$} $l m ::lang]} {
+ break
+ }
+ }
+ chan close $fid
+ if {[info exists ::lang] && $::lang ne ""} break
+ }
+ }
+
+ # second fallback: what does msgcat think about it? Note that
+ # msgcat checks the environment and on windows also the registry.
+ if {! [info exists ::lang] || $::lang eq ""} {
+ package require msgcat
+ set ::lang [::msgcat::mclocale]
+ }
+
+ set messcat ""
+ if {$::lang ne ""} {
+ set messcat ""
+ set maybe ""
+ set ::lang [string tolower $::lang]
+ set tdir [file join $::instroot "tlpkg" "translations"]
+ foreach f [glob -directory $tdir *.po] {
+ set ln_f [string tolower [string range [file tail $f] 0 end-3]]
+ if {$ln_f eq $::lang} {
+ set messcat $f
+ break
+ } elseif {[string range $ln_f 0 1] eq [string range $::lang 0 1]} {
+ set maybe $f
+ }
+ }
+ if {$messcat eq ""} {
+ set messcat $maybe
+ }
+ }
+
+ # parse messcat.
+ # for now, just skip lines which make no sense.
+ # empty messcat: no suitable message catalog
+ if {$messcat ne ""} {
+ # create array with msgid keys and msgstr values
+ if {! [catch {open $messcat r} fid]} {
+ fconfigure $fid -encoding utf-8
+ set inmsgid 0
+ set inmsgstr 0
+ set msgid ""
+ set msgstr ""
+ while 1 {
+ if [chan eof $fid] break
+ if [catch {chan gets $fid} l] break
+ if [regexp {^\s*#} $l] continue
+ if [regexp {^\s*$} $l] {
+ # empty line separates msgid/msgstr pairs
+ if $inmsgid {
+ # msgstr lines missing
+ # puts stderr "no translation for $msgid in $messcat"
+ set msgid ""
+ set msgstr ""
+ set inmsgid 0
+ set inmsgstr 0
+ continue
+ }
+ if $inmsgstr {
+ # empty line signals end of msgstr
+ if {$msgstr ne ""} {
+ set msgid [string map {"\\n" "\n"} $msgid]
+ set msgstr [string map {"\\n" "\n"} $msgstr]
+ set msgid [string map {"\\\\" "\\"} $msgid]
+ set msgstr [string map {"\\\\" "\\"} $msgstr]
+ set ::TRANS($msgid) $msgstr
+ }
+ set msgid ""
+ set msgstr ""
+ set inmsgid 0
+ set inmsgstr 0
+ continue
+ }
+ continue
+ } ; # empty line
+ if [regexp {^msgid\s+"(.*)"\s*$} $l m msgid] {
+ # note. a failed match will leave msgid alone
+ set inmsgid 1
+ continue
+ }
+ if [regexp {^"(.*)"\s*$} $l m s] {
+ if $inmsgid {
+ append msgid $s
+ } elseif $inmsgstr {
+ append msgstr $s
+ }
+ continue
+ }
+ if [regexp {^msgstr\s+"(.*)"\s*$} $l m msgstr] {
+ set inmsgstr 1
+ set inmsgid 0
+ }
+ }
+ chan close $fid
+ }
+ }
+}
+load_translations
+
+proc __ {s args} {
+ if {[info exists ::TRANS($s)]} {
+ set s $::TRANS($s)
+ #} else {
+ # puts stderr "No translation found for $s\n[get_stacktrace]"
+ }
+ if {$args eq ""} {
+ return $s
+ } else {
+ return [format $s {*}$args]
+ }
+}
+
+# string representation of booleans
+proc yes_no {b} {
+ if $b {
+ set ans [__ "Yes"]
+ } else {
+ set ans [__ "No"]
+ }
+ return $ans
+}
+
+if {$::tcl_platform(os) eq "Darwin"} {
+ # avoid warnings 'tar: Failed to set default locale'
+ set ::env(LC_ALL) "en_US.UTF-8"
+}
+
+### fonts ###
+
+# no bold text for messages; `userDefault' indicates priority
+option add *Dialog.msg.font TkDefaultFont userDefault
+
+# normal size bold
+font create bfont {*}[font configure TkDefaultFont]
+font configure bfont -weight bold
+# larger, not bold: lfont
+font create lfont {*}[font configure TkDefaultFont]
+font configure lfont -size [expr {round(1.2 * [font actual lfont -size])}]
+# larger and bold
+font create hfont {*}[font configure lfont]
+font configure hfont -weight bold
+# extra large and bold
+font create titlefont {*}[font configure TkDefaultFont]
+font configure titlefont -weight bold \
+ -size [expr {round(1.5 * [font actual titlefont -size])}]
+
+## italicized items; not used
+#font create it_font {*}[font configure TkDefaultFont]
+#font configure it_font -slant italic
+
+# width of '0', as a very rough estimate of average character width
+# assume height == width*2
+set ::cw [font measure TkDefaultFont "0"]
+
+# default foreground color and disabled foreground color
+# may not be black in e.g. dark color schemes
+set blk [ttk::style lookup TButton -foreground]
+set gry [ttk::style lookup TButton -foreground disabled]
+
+# 'default' padding
+
+proc ppack {wdg args} { ; # pack command with padding
+ pack $wdg {*}$args -padx 3 -pady 3
+}
+
+proc pgrid {wdg args} { ; # grid command with padding
+ grid $wdg {*}$args -padx 3 -pady 3
+}
+
+# unicode symbols as fake checkboxes in ttk::treeview widgets
+
+proc mark_sym {mrk} {
+ if {$::tcl_platform(platform) eq "windows"} {
+ # under windows, these look slightly better than
+ # the non-windows selections
+ if $mrk {
+ return "\u25C9" ; # 'fisheye'
+ } else {
+ return "\u25CB" ; # 'white circle'
+ }
+ } else {
+ if $mrk {
+ return "\u25A3" ; # 'white square containing black small square'
+ } else {
+ return "\u25A1" ; # 'white square'
+ }
+ }
+} ; # mark_sym
+
+# for help output
+set ::env(NOPERLDOC) 1
+
+##### dialog support #####
+
+# for example code, look at dialog.tcl, part of Tk itself
+
+# global variable for dialog return value, in case the outcome
+# must be handled by the caller rather than by the dialog itself:
+set ::dialog_ans {}
+
+# start new toplevel with settings appropriate for a dialog
+proc create_dlg {wnd {p .}} {
+ unset -nocomplain ::dialog_ans
+ catch {destroy $wnd} ; # no error if it does not exist
+ toplevel $wnd -class Dialog
+ wm withdraw $wnd
+ if [winfo viewable $p] {wm transient $wnd $p}
+ if $::plain_unix {wm attributes $wnd -type dialog}
+ wm protocol $wnd WM_DELETE_WINDOW {destroy $wnd}
+}
+
+# Place a dialog centered wrt its parent.
+# If its geometry is somehow not yet available,
+# its upperleft corner will be centered.
+
+proc place_dlg {wnd {p "."}} {
+ set g [wm geometry $p]
+ scan $g "%dx%d+%d+%d" pw ph px py
+ set hcenter [expr {$px + $pw / 2}]
+ set vcenter [expr {$py + $ph / 2}]
+ set g [wm geometry $wnd]
+ set wh [winfo reqheight $wnd]
+ set ww [winfo reqwidth $wnd]
+ set wx [expr {$hcenter - $ww / 2}]
+ if {$wx < 0} { set wx 0}
+ set wy [expr {$vcenter - $wh / 2}]
+ if {$wy < 0} { set wy 0}
+ wm geometry $wnd [format "+%d+%d" $wx $wy]
+ wm state $wnd normal
+ wm attributes $wnd -topmost
+ raise $wnd $p
+ tkwait visibility $wnd
+ focus $wnd
+ grab set $wnd
+} ; # place_dlg
+
+proc end_dlg {ans wnd} {
+ set ::dialog_ans $ans
+ set p [winfo parent $wnd]
+ if {$p eq ""} {set p "."}
+ raise $p
+ destroy $wnd
+} ; # end_dlg
+
+##### directories #####
+
+# slash flipping
+proc forward_slashify {s} {
+ regsub -all {\\} $s {/} r
+ return $r
+}
+proc native_slashify {s} {
+ if {$::tcl_platform(platform) eq "windows"} {
+ regsub -all {/} $s {\\} r
+ } else {
+ regsub -all {\\} $s {/} r
+ }
+ return $r
+}
+
+# unix: choose_dir replacing native directory browser
+
+if {$::tcl_platform(platform) eq "unix"} {
+
+ # Based on the tcl/tk widget demo.
+ # Also for MacOS, because we want to see /usr.
+ # For windows, the native browser widget is better.
+
+ ## Code to populate a single directory node
+ proc populateTree {tree node} {
+ if {[$tree set $node type] ne "directory"} {
+ set type [$tree set $node type]
+ return
+ }
+ $tree delete [$tree children $node]
+ foreach f [lsort [glob -nocomplain -directory $node *]] {
+ set type [file type $f]
+ if {$type eq "directory"} {
+ $tree insert $node end \
+ -id $f -text [file tail $f] -values [list $type]
+ # Need at least one child to make this node openable,
+ # will be deleted when actually populating this node
+ $tree insert $f 0 -text "dummy"
+ }
+ }
+ # Stop this code from rerunning on the current node
+ $tree set $node type processedDirectory
+ }
+
+ proc choose_dir {initdir {parent .}} {
+
+ create_dlg .browser $parent
+ wm title .browser [__ "Browse..."]
+
+ # wallpaper
+ pack [ttk::frame .browser.bg -padding 3] -fill both -expand 1
+ ## Create the tree and set it up
+ pack [ttk::frame .browser.fr0] -in .browser.bg -fill both -expand 1
+ set tree [ttk::treeview .browser.tree \
+ -columns {type} -displaycolumns {} -selectmode browse \
+ -yscroll ".browser.vsb set"]
+ .browser.tree column 0 -minwidth 500 -stretch 0
+ ttk::scrollbar .browser.vsb -orient vertical -command "$tree yview"
+ # hor. scrolling does not work, but toplevel and widget are resizable
+ $tree heading \#0 -text "/"
+ $tree insert {} end -id "/" -text "/" -values [list "directory"]
+
+ populateTree $tree "/"
+ bind $tree <<TreeviewOpen>> {
+ populateTree %W [%W focus]
+ }
+ bind $tree <ButtonRelease-1> {
+ .browser.tree heading \#0 -text [%W focus]
+ }
+
+ ## Arrange the tree and its scrollbar in the toplevel
+ # horizontal scrolling does not work.
+ # possible solution: very wide treeview in smaller paned window
+ # (may as well use pack in the absence of a horizontal scrollbar)
+ grid $tree .browser.vsb -sticky nsew -in .browser.fr0
+ grid columnconfigure .browser.fr0 0 -weight 1
+ grid rowconfigure .browser.fr0 0 -weight 1
+
+ # ok and cancel buttons
+ pack [ttk::frame .browser.fr1] -in .browser.bg -fill x -expand 1
+ ppack [ttk::button .browser.ok -text [__ "Ok"]] \
+ -in .browser.fr1 -side right
+ ppack [ttk::button .browser.cancel -text [__ "Cancel"]] \
+ -in .browser.fr1 -side right
+ .browser.ok configure -command {
+ set ::dialog_ans [.browser.tree focus]
+ destroy .browser
+ }
+ .browser.cancel configure -command {
+ set ::dialog_ans ""
+ destroy .browser
+ }
+ unset -nocomplain ::dialog_ans
+
+ # navigate tree to $initdir
+ set chosenDir {}
+ foreach d [file split [file normalize $initdir]] {
+ set nextdir [file join $chosenDir $d]
+ if [file isdirectory $nextdir] {
+ if {! [$tree exists $nextdir]} {
+ $tree insert $chosenDir end -id $nextdir \
+ -text $d -values [list "directory"]
+ }
+ populateTree $tree $nextdir
+ set chosenDir $nextdir
+ } else {
+ break
+ }
+ }
+ $tree see $chosenDir
+ $tree selection set [list $chosenDir]
+ $tree focus $chosenDir
+ $tree heading \#0 -text $chosenDir
+
+ place_dlg .browser $parent
+ tkwait window .browser
+ return $::dialog_ans
+ }; # choose_dir
+
+}; # if unix
+
+proc browse4dir {inidir {parent .}} {
+ if {$::tcl_platform(platform) eq "unix"} {
+ return [choose_dir $inidir $parent]
+ } else {
+ return [tk_chooseDirectory \
+ -initialdir $inidir -title [__ "Select or type"] -parent $parent]
+ }
+} ; # browse4dir
+
+# browse for a directory and store in entry- or label widget $w
+proc dirbrowser2widget {w} {
+ set wclass [winfo class $w]
+ if {$wclass eq "Entry" || $wclass eq "TEntry"} {
+ set is_entry 1
+ } elseif {$wclass eq "Label" || $wclass eq "TLabel"} {
+ set is_entry 0
+ } else {
+ err_exit "browse2widget invoked with unsupported widget class $wclass"
+ }
+ if $is_entry {
+ set retval [$w get]
+ } else {
+ set retval [$w cget -text]
+ }
+ set retval [browse4dir $retval [winfo parent $w]]
+ if {$retval eq ""} {
+ return 0
+ } else {
+ if {$wclass eq "Entry" || $wclass eq "TEntry"} {
+ $w delete 0 end
+ $w insert 0 $retval
+ } else {
+ $w configure -text $retval
+ }
+ return 1
+ }
+}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-10 05:14:18 +0000