"Fossies" - the Fresh Open Source Software Archive 
Member "install-tl-20231127/tlpkg/tltcl/tltcl.tcl" (5 Apr 2023, 25692 Bytes) of package /linux/misc/install-tl-unx.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style:
standard) with prefixed line numbers.
Alternatively you can here
view or
download the uninterpreted source code file.
1 #!/usr/bin/env wish
2
3 # Copyright 2018-2020 Siep Kroonenberg
4
5 # This file is licensed under the GNU General Public License version 2
6 # or any later version.
7
8 # common declarations for tlshell.tcl and install-tl-gui.tcl
9
10 set ::plain_unix 0
11 if {$::tcl_platform(platform) eq "unix" && $::tcl_platform(os) ne "Darwin"} {
12 set ::plain_unix 1
13 }
14
15 if $::plain_unix {
16 # plain_unix: avoid a RenderBadPicture error on quitting.
17 # 'send' changes the shutdown sequence,
18 # which avoids triggering the bug.
19 # 'tk appname <something>' restores 'send' and avoids the bug
20 bind . <Destroy> {
21 catch {tk appname appname}
22 }
23 }
24
25 # process ID of the perl program that will run in the background
26 set ::perlpid 0
27
28 # mirrors
29
30 set any_mirror "https://mirror.ctan.org/systems/texlive/tlnet"
31
32 # turn name into a string suitable for a widget name
33 proc mangle_name {n} {
34 set n [string tolower $n]
35 set n [string map {" " "_"} $n]
36 return $n
37 } ; # mangle_name
38
39 set mirrors [dict create]
40 proc read_mirrors {} {
41 if [catch {open [file join $::instroot \
42 "tlpkg/installer/ctan-mirrors.pl"] r} fm] {
43 return 0
44 }
45 set re_geo {^\s*'([^']+)' => \{\s*$}
46 set re_url {^\s*'(.*)' => ([0-9]+)}
47 set re_clo {^\s*\},?\s*$}
48 set starting 1
49 set lnum 0 ; # line number for error messages
50 set ok 1 ; # no errors encountered yet
51 set countries {} ; # aggregate list of countries
52 set urls {} ; # aggregate list of urls
53 set continent ""
54 set country ""
55 set u ""
56 set in_cont 0
57 set in_coun 0
58 while {! [catch {chan gets $fm} line] && ! [chan eof $fm]} {
59 incr lnum
60 if $starting {
61 if {[string first "\$mirrors =" $line] == 0} {
62 set starting 0
63 continue
64 } else {
65 set ok 0
66 set msg "Unexpected line '$line' at start"
67 break
68 }
69 }
70 # starting is now dealt with.
71 if [regexp $re_geo $line dummy c] {
72 if {! $in_cont} {
73 set in_cont 1
74 set continent $c
75 set cont_dict [dict create]
76 if {$continent in [dict keys $::mirrors]} {
77 set ok 0
78 set msg "Duplicate continent $c at line $lnum"
79 break
80 }
81 } elseif {! $in_coun} {
82 set in_coun 1
83 set country $c
84 if {$country in $countries} {
85 set ok 0
86 set msg "Duplicate country $c at line $lnum"
87 break
88 }
89 lappend countries $country
90 dict set cont_dict $country {}
91 } else {
92 set ok 0
93 set msg "Unexpected continent- or country line $line at line $lnum"
94 break
95 }
96 } elseif [regexp $re_url $line dummy u n] {
97 if {! $in_coun} {
98 set ok 0
99 set msg "Unexpected url line $line at line $lnum"
100 break
101 } elseif {$n ne "1"} {
102 continue
103 }
104 append u "systems/texlive/tlnet"
105 if {$u in $urls} {
106 set ok 0
107 set msg "Duplicate url $u at line $lnum"
108 break
109 }
110 dict lappend cont_dict $country $u
111 lappend urls $u
112 set u ""
113 } elseif [regexp $re_clo $line] {
114 if $in_coun {
115 set in_coun 0
116 set country ""
117 } elseif $in_cont {
118 set in_cont 0
119 dict set ::mirrors $continent $cont_dict
120 set continent ""
121 } else {
122 break ; # should close mirror list
123 }
124 } ; # ignore other lines
125 }
126 close $fm
127 } ; # read_mirrors
128
129 # cascading dropdown mirror menu
130 # parameter cmd should be a proc which does something with the selected url
131 proc mirror_menu {wnd cmd} {
132 destroy $wnd.m
133 if {[dict size $::mirrors] == 0} read_mirrors
134 if {[dict size $::mirrors] > 0} {
135 ttk::menubutton $wnd -text [__ "Specific mirror..."] \
136 -direction below -menu $wnd.m
137 menu $wnd.m
138 dict for {cont d_cont} $::mirrors {
139 set c_ed [mangle_name $cont]
140 menu $wnd.m.$c_ed
141 $wnd.m add cascade -label $cont -menu $wnd.m.$c_ed
142 dict for {cntr urls} $d_cont {
143 set n_ed [mangle_name $cntr]
144 menu $wnd.m.$c_ed.$n_ed
145 $wnd.m.$c_ed add cascade -label $cntr -menu $wnd.m.$c_ed.$n_ed
146 foreach u $urls {
147 $wnd.m.$c_ed.$n_ed add command -label $u -command "$cmd $u"
148 }
149 }
150 }
151 } else {
152 ttk::label $wnd -text [__ "No mirror list available"]
153 }
154 return $wnd
155 }
156
157 proc possible_repository {s} {
158 if [regexp {^(https?|ftp|scp|ssh):\/\/.+} $s] {return 1}
159 if {[string first {file://} $s] == 0} {set s [string range $s 7 end]}
160 if [file isdirectory [file join $s "archive"]] {return 1}
161 if [file isdirectory [file join $s "texmf-dist/web2c"]] {return 1}
162 return 0
163 }
164
165 proc get_stacktrace {} {
166 set level [info level]
167 set s ""
168 for {set i 1} {$i < $level} {incr i} {
169 append s [format "Level %u: %s\n" $i [info level $i]]
170 }
171 return $s
172 } ; # get_stacktrace
173
174 proc normalize_argv {} {
175 # work back to front, to not disturb indices of unscanned list elements
176 set i $::argc
177 while 1 {
178 incr i -1
179 if {$i<0} break
180 set s [lindex $::argv $i]
181 if {[string range $s 0 1] eq "--"} {
182 set s [string range $s 1 end]
183 lset ::argv $i $s
184 }
185 set j [string first "=" $s]
186 if {$j > 0} {
187 set s0 [string range $s 0 [expr {$j-1}]]
188 set s1 [string range $s [expr {$j+1}] end]
189 set ::argv [lreplace $::argv $i $i $s0 $s1]
190 } elseif {$j==0} {
191 err_exit "Command-line argument $s starting with \"=\""
192 } ; # else leave alone
193 }
194 set ::argc [llength $::argv]
195 }
196 normalize_argv
197
198 # set width of a treeview column wide enough
199 # to fully display all entries
200 proc set_tree_col_width {tv cl} {
201 set len 0
202 foreach c [$tv children {}] {
203 # '<pathname> set <item> <column>' without a value parameter
204 # is really a get.
205 # Tree cells are set to use TkDefaultFont redo_fonts further down.
206 set l [font measure TkDefaultFont [$tv set $c $cl]]
207 if {$l > $len} {set len $l}
208 }
209 $tv column $cl -width [expr {$len+10}]
210 }
211
212 # localization support
213
214 # for the sake of our translators we use our own translation function
215 # which can use .po files directly. This allows them to check their work
216 # without creating or waiting for a conversion to .msg.
217 # We still use the msgcat module for detecting default locale.
218 # Otherwise, the localization code borrows much from Norbert Preining's
219 # translation module for TL.
220
221 package require msgcat
222
223 # available languages
224 set ::langs [list "en"]
225 foreach l [glob -nocomplain -directory \
226 [file join $::instroot "tlpkg" "translations"] *.po] {
227 lappend ::langs [string range [file tail $l] 0 end-3]
228 }
229
230 proc initialize_language {} {
231 # check the command-line for a lang parameter
232 set ::lang ""
233 set i 0
234 while {$i < $::argc} {
235 set p [lindex $::argv $i]
236 incr i
237 if {$p eq "-lang" || $p eq "-gui-lang"} {
238 if {$i < $::argc} {
239 set ::lang [lindex $::argv $i]
240 break
241 }
242 }
243 }
244 unset i
245
246 # First fallback, only for tlshell: check tlmgr config file
247 if {$::lang eq "" && [info exists ::invoker] && $::invoker eq "tlshell"} {
248 set ::lang [get_config_var "gui-lang"]
249 }
250
251 # try to set tcltk's locale to $::lang too. this may not work for 8.5.
252 if {$::lang ne ""} {::msgcat::mclocale $::lang}
253
254 # second fallback: what does msgcat think about it? Note that
255 # msgcat checks the environment and on windows also the registry.
256 if {$::lang eq ""} {set ::lang [::msgcat::mclocale]}
257
258 set messcat ""
259 if {$::lang ne ""} {
260 set messcat ""
261 set maybe ""
262 set ::lang [string tolower $::lang]
263 set tdir [file join $::instroot "tlpkg" "translations"]
264 foreach f [glob -nocomplain -directory $tdir *.po] {
265 set ln_f [string tolower [string range [file tail $f] 0 end-3]]
266 if {$ln_f eq $::lang} {
267 set messcat $f
268 break
269 } elseif {[string range $ln_f 0 1] eq [string range $::lang 0 1]} {
270 set maybe $f
271 }
272 }
273 if {$messcat eq "" && $maybe ne ""} {
274 set ::lang [string tolower [string range [file tail $maybe] 0 end-3]]
275 }
276 }
277 }
278 initialize_language
279
280 proc load_translations {} {
281 array unset ::TRANS
282 if {$::lang eq ""} return
283 set messcat [file join $::instroot "tlpkg" "translations" "${::lang}.po"]
284 # parse messcat.
285 # skip lines which make no sense
286 if [file exists $messcat] {
287 # create array with msgid keys and msgstr values
288 # in the case that we switch languages,
289 # we need to remove old translations,
290 # since the new set may not completely cover the old one
291 if {! [catch {open $messcat r} fid]} {
292 fconfigure $fid -encoding utf-8
293 set inmsgid 0
294 set inmsgstr 0
295 set msgid ""
296 set msgstr ""
297 while 1 {
298 if [chan eof $fid] break
299 if [catch {chan gets $fid} l] break
300 if [regexp {^\s*#} $l] continue
301 if [regexp {^\s*$} $l] {
302 # empty line separates msgid/msgstr pairs
303 if $inmsgid {
304 # msgstr lines missing
305 # puts stderr "no translation for $msgid in $messcat"
306 set msgid ""
307 set msgstr ""
308 set inmsgid 0
309 set inmsgstr 0
310 continue
311 }
312 if $inmsgstr {
313 # empty line signals end of msgstr
314 if {$msgstr ne ""} {
315 # unescape some characters
316 set msgid [string map {{\n} "\n"} $msgid]
317 set msgstr [string map {{\n} "\n"} $msgstr]
318 set msgid [string map {{\\} "\\"} $msgid]
319 set msgstr [string map {{\\} "\\"} $msgstr]
320 set msgid [string map {{\"} "\""} $msgid]
321 set msgstr [string map {{\"} "\""} $msgstr]
322 set ::TRANS($msgid) $msgstr
323 }
324 set msgid ""
325 set msgstr ""
326 set inmsgid 0
327 set inmsgstr 0
328 continue
329 }
330 continue
331 } ; # empty line
332 if [regexp {^msgid\s+"(.*)"\s*$} $l m msgid] {
333 # note. a failed match will leave msgid alone
334 set inmsgid 1
335 continue
336 }
337 if [regexp {^"(.*)"\s*$} $l m s] {
338 if $inmsgid {
339 append msgid $s
340 } elseif $inmsgstr {
341 append msgstr $s
342 }
343 continue
344 }
345 if [regexp {^msgstr\s+"(.*)"\s*$} $l m msgstr] {
346 set inmsgstr 1
347 set inmsgid 0
348 }
349 }
350 chan close $fid
351 }
352 }
353 }
354 load_translations
355
356 proc __ {s args} {
357 if {[info exists ::TRANS($s)]} {
358 set s $::TRANS($s)
359 #} else {
360 # puts stderr "No translation found for $s\n[get_stacktrace]"
361 }
362 if {$args eq ""} {
363 return $s
364 } else {
365 return [format $s {*}$args]
366 }
367 }
368
369 # string representation of booleans
370 proc yes_no {b} {
371 if $b {
372 set ans [__ "Yes"]
373 } else {
374 set ans [__ "No"]
375 }
376 return $ans
377 }
378
379 # avoid warnings from tar and perl about locale
380 set ::env(LC_ALL) "C"
381 unset -nocomplain ::env(LANG)
382 unset -nocomplain ::env(LANGUAGE)
383
384 ### fonts ###
385
386 # ttk defaults use TkDefaultFont and TkHeadingFont
387 # ttk classic theme also uses TkTextFont for TEntry
388 # ttk::combobox uses TkTextFont
389 # although only the first three appear to be used here, this may depend
390 # on the theme, so I resize all symbolic fonts anyway.
391
392 set dflfonts [list \
393 TkHeadingFont \
394 TkCaptionFont \
395 TkDefaultFont \
396 TkMenuFont \
397 TkTextFont \
398 TkTooltipFont \
399 TkFixedFont \
400 TkIconFont \
401 TkSmallCaptionFont \
402 ]
403 foreach f $::dflfonts {
404 set ::oldsize($f) [font configure $f -size]
405 }
406
407 font create bfont
408 font create lfont
409 font create hfont
410 font create titlefont
411
412 proc redo_fonts {} {
413
414 # note that ttk styles refer to the above symbolic font names
415 # and do not define fonts themselves
416
417 foreach f $::dflfonts {
418 font configure $f -size [expr { round($::oldsize($f)*$::tkfontscale)}]
419 }
420 # the above works for ttk::*button, ttk::treeview, notebook labels
421 unset -nocomplain f
422
423 option add *font TkDefaultFont
424 # the above works for menu items, ttk::label, text, ttk::entry
425 # including current value of ttk::combobox, ttk::combobox list items
426 # and non-ttk labels and buttons - which are not used here
427 # apparently, these widget classes use the X11 default font on Linux.
428
429 set ::cw \
430 [expr {max([font measure TkDefaultFont "0"],[font measure TkTextFont "0"])}]
431 # height: assume height == width*2
432 # workaround for treeview on windows on HiDPI displays
433 ttk::style configure Treeview -rowheight [expr {3 * $::cw}]
434 ttk::style configure Cell -font TkDefaultFont
435
436 # no bold text for messages; `userDefault' indicates priority
437 option add *Dialog.msg.font TkDefaultFont userDefault
438
439 # normal size bold
440 font configure bfont {*}[font configure TkDefaultFont]
441 font configure bfont -weight bold
442 # larger, not bold: lfont
443 font configure lfont {*}[font configure TkDefaultFont]
444 font configure lfont -size [expr {round(1.2 * [font actual lfont -size])}]
445 # larger and bold
446 font configure hfont {*}[font configure lfont]
447 font configure hfont -weight bold
448 # extra large and bold
449 font configure titlefont {*}[font configure TkDefaultFont]
450 font configure titlefont -weight bold \
451 -size [expr {round(1.5 * [font actual titlefont -size])}]
452
453 if $::plain_unix {
454 ttk::setTheme default ; # or classic.
455 # the settings below do not work right with clam and alt themes.
456 ttk::style configure TCombobox -arrowsize [expr {1.5*$::cw}]
457 ttk::style configure Item -indicatorsize [expr {1.5*$::cw}]
458 }
459 }
460
461 # initialize scaling factor
462
463 set ::tkfontscale ""
464 if {[info exists ::invoker] && $::invoker eq "tlshell"} {
465 set ::tkfontscale [get_config_var "tkfontscale"]
466 # is $::tkfontscale a number, and a reasonable one?
467 if {[scan $::tkfontscale {%f} f] != 1} { ; # not a number
468 set ::tkfontscale ""
469 } elseif {$::tkfontscale < 0} {
470 set ::tkfontscale ""
471 } elseif {$::tkfontscale < 0.5} {
472 set ::tkfontscale 0.5
473 } elseif {$::tkfontscale > 10} {
474 set ::tkfontscale 10
475 }
476 }
477 # most systems with a HiDPI display will be configured for it.
478 # set therefore the default simply to 1.
479 # users still have the option to scale fonts via the menu.
480 if {$::tkfontscale eq ""} {set ::tkfontscale 1}
481 redo_fonts
482
483 # icon
484 catch {
485 image create photo tl_logo -file \
486 [file join $::instroot "tlpkg" "tltcl" "tlmgr.gif"]
487 wm iconphoto . -default tl_logo
488 }
489
490 # default foreground color and disabled foreground color
491 # may not be black in e.g. dark color schemes
492 set blk [ttk::style lookup TButton -foreground]
493 set gry [ttk::style lookup TButton -foreground disabled]
494
495 # 'default' padding
496
497 proc ppack {wdg args} { ; # pack command with padding
498 pack $wdg {*}$args -padx 3pt -pady 3pt
499 }
500
501 proc pgrid {wdg args} { ; # grid command with padding
502 grid $wdg {*}$args -padx 3pt -pady 3pt
503 }
504
505 # unicode symbols as fake checkboxes in ttk::treeview widgets
506
507 proc mark_sym {mrk} {
508 if {$::tcl_platform(platform) eq "windows"} {
509 # under windows, these look slightly better than
510 # the non-windows selections
511 if $mrk {
512 return "\u2714" ; # 'heavy check mark'
513 } else {
514 return "\u25CB" ; # 'white circle'
515 }
516 } else {
517 if $mrk {
518 return "\u25A3" ; # 'white square containing black small square'
519 } else {
520 return "\u25A1" ; # 'white square'
521 }
522 }
523 } ; # mark_sym
524
525 # for help output
526 set ::env(NOPERLDOC) 1
527
528 ##### dialog support #####
529
530 # for example code, look at dialog.tcl, part of Tk itself
531
532 # In most cases, it is not necessary to explicitly define a handler for
533 # the WM_DELETE_WINDOW protocol. But if the cancel- or abort button would do
534 # anything special, then the close icon should not bypass this.
535
536 # widget classes which can be enabled and disabled.
537 # The text widget class is not included here.
538
539 set ::active_cls [list TButton TCheckbutton TRadiobutton TEntry Treeview]
540
541 # global variable for dialog return value, in case the outcome
542 # must be handled by the caller rather than by the dialog itself:
543 set ::dialog_ans {}
544
545 # start new toplevel with settings appropriate for a dialog
546 proc create_dlg {wnd {p .}} {
547 unset -nocomplain ::dialog_ans
548 catch {destroy $wnd} ; # no error if it does not exist
549 toplevel $wnd -class Dialog
550 wm withdraw $wnd
551 if [winfo viewable $p] {wm transient $wnd $p}
552 if $::plain_unix {wm attributes $wnd -type dialog}
553 }
554
555 # Place a dialog centered wrt its parent.
556 # If its geometry is somehow not yet available,
557 # its upperleft corner will be centered.
558
559 proc place_dlg {wnd {p "."}} {
560 update idletasks
561 set g [wm geometry $p]
562 scan $g "%dx%d+%d+%d" pw ph px py
563 set hcenter [expr {$px + $pw / 2}]
564 set vcenter [expr {$py + $ph / 2}]
565 set g [wm geometry $wnd]
566 set wh [winfo reqheight $wnd]
567 set ww [winfo reqwidth $wnd]
568 set wx [expr {$hcenter - $ww / 2}]
569 if {$wx < 0} { set wx 0}
570 set wy [expr {$vcenter - $wh / 2}]
571 if {$wy < 0} { set wy 0}
572 wm geometry $wnd [format "+%d+%d" $wx $wy]
573 update idletasks
574 wm state $wnd normal
575 raise $wnd $p
576 tkwait visibility $wnd
577 focus $wnd
578 grab set $wnd
579 } ; # place_dlg
580
581 # in case pressing the closing button leads to lengthy processing:
582 proc disable_dlg {wnd} {
583 foreach c [winfo children $wnd] {
584 if {[winfo class $c] in $::active_cls} {
585 catch {$c state disabled}
586 }
587 }
588 }
589
590 proc end_dlg {ans wnd} {
591 set ::dialog_ans $ans
592 set p [winfo parent $wnd]
593 if {$p eq ""} {set p "."}
594 raise $p
595 destroy $wnd
596 } ; # end_dlg
597
598 # a possibly useful callback for WM_DELETE_WINDOW
599 proc cancel_or_destroy {ctrl topl} {
600 if [winfo exists $ctrl] {
601 $ctrl invoke
602 } elseif [winfo exists $topl] {
603 destroy $topl
604 }
605 }
606
607 ##### directories #####
608
609 # slash flipping
610 proc forward_slashify {s} {
611 regsub -all {\\} $s {/} r
612 return $r
613 }
614 proc native_slashify {s} {
615 if {$::tcl_platform(platform) eq "windows"} {
616 regsub -all {/} $s {\\} r
617 } else {
618 regsub -all {\\} $s {/} r
619 }
620 return $r
621 }
622
623 # test whether a directory is writable.
624 # 'file writable' merely tests permissions, which may not be good enough
625 proc dir_writable {d} {
626 for {set x 0} {$x<100} {incr x} {
627 set y [expr {int(10000*rand())}]
628 set newfile [file join $d $y]
629 if [file exists $newfile] {
630 continue
631 } else {
632 if [catch {open $newfile w} fid] {
633 return 0
634 } else {
635 chan puts $fid "hello"
636 chan close $fid
637 if [file exists $newfile] {
638 file delete $newfile
639 return 1
640 } else {
641 return 0
642 }
643 }
644 }
645 }
646 return 0
647 }
648
649 # unix: choose_dir replacing native directory browser.
650 # the native FILE browser is ok, though.
651
652 if {$::tcl_platform(platform) eq "unix"} {
653
654 # Based on the directory browser from the tcl/tk widget demo.
655 # Also for MacOS, because we want to see /usr.
656 # For windows, the native browser widget is better.
657
658 ## Code to populate a single directory node
659 proc populateTree {tree node} {
660 if {[$tree set $node type] ne "directory"} {
661 set type [$tree set $node type]
662 return
663 }
664 $tree delete [$tree children $node]
665 foreach f [lsort [glob -nocomplain -directory $node *]] {
666 set type [file type $f]
667 if {$type eq "directory"} {
668 $tree insert $node end \
669 -id $f -text [file tail $f] -values [list $type]
670 # Need at least one child to make this node openable,
671 # will be deleted when actually populating this node
672 $tree insert $f 0 -text "dummy"
673 }
674 }
675 # Stop this code from rerunning on the current node
676 $tree set $node type processedDirectory
677 }
678
679 proc choose_dir {initdir {parent .}} {
680
681 create_dlg .browser $parent
682 wm title .browser [__ "Browse..."]
683
684 # wallpaper
685 pack [ttk::frame .browser.bg -padding 3pt] -fill both -expand 1
686
687 # ok and cancel buttons
688 pack [ttk::frame .browser.fr1] \
689 -in .browser.bg -side bottom -fill x
690 ppack [ttk::button .browser.ok -text [__ "Ok"]] \
691 -in .browser.fr1 -side right
692 ppack [ttk::button .browser.cancel -text [__ "Cancel"]] \
693 -in .browser.fr1 -side right
694 bind .browser <Escape> {.browser.cancel invoke}
695 wm protocol .browser WM_DELETE_WINDOW \
696 {cancel_or_destroy .browser.cancel .browser}
697 .browser.ok configure -command {
698 set ::dialog_ans [.browser.tree focus]
699 destroy .browser
700 }
701 .browser.cancel configure -command {
702 set ::dialog_ans ""
703 destroy .browser
704 }
705
706 ## Create the tree and set it up
707 pack [ttk::frame .browser.fr0] -in .browser.bg -fill both -expand 1
708 set tree [ttk::treeview .browser.tree \
709 -columns {type} -displaycolumns {} -selectmode browse \
710 -yscroll ".browser.vsb set"]
711 .browser.tree column 0 -stretch 1
712 ttk::scrollbar .browser.vsb -orient vertical -command "$tree yview"
713 # hor. scrolling does not work, but toplevel and widget are resizable
714 $tree heading \#0 -text "/"
715 $tree insert {} end -id "/" -text "/" -values [list "directory"]
716
717 populateTree $tree "/"
718 bind $tree <<TreeviewOpen>> {
719 populateTree %W [%W focus]
720 }
721 bind $tree <ButtonRelease-1> {
722 .browser.tree heading \#0 -text [%W focus]
723 }
724
725 ## Arrange the tree and its scrollbar in the toplevel
726 # Horizontal scrolling does not work, but resizing does.
727 grid $tree -in .browser.fr0 -row 0 -column 0 -sticky nsew
728 grid .browser.vsb -in .browser.fr0 -row 0 -column 1 -sticky ns
729 grid columnconfigure .browser.fr0 0 -weight 1
730 grid rowconfigure .browser.fr0 0 -weight 1
731 unset -nocomplain ::dialog_ans
732
733 # navigate tree to $initdir
734 set chosenDir {}
735 foreach d [file split [file normalize $initdir]] {
736 set nextdir [file join $chosenDir $d]
737 if [file isdirectory $nextdir] {
738 if {! [$tree exists $nextdir]} {
739 $tree insert $chosenDir end -id $nextdir \
740 -text $d -values [list "directory"]
741 }
742 populateTree $tree $nextdir
743 set chosenDir $nextdir
744 } else {
745 break
746 }
747 }
748 $tree see $chosenDir
749 $tree selection set [list $chosenDir]
750 $tree focus $chosenDir
751 $tree heading \#0 -text $chosenDir
752
753 place_dlg .browser $parent
754 tkwait window .browser
755 return $::dialog_ans
756 }; # choose_dir
757
758 }; # if unix
759
760 proc browse4dir {inidir {parent .}} {
761 if {$::tcl_platform(platform) eq "unix"} {
762 return [choose_dir $inidir $parent]
763 } else {
764 return [tk_chooseDirectory \
765 -initialdir $inidir -title [__ "Select or type"] -parent $parent]
766 }
767 } ; # browse4dir
768
769 # browse for a directory and store in entry- or label widget $w
770 proc dirbrowser2widget {w} {
771 set wclass [winfo class $w]
772 if {$wclass eq "Entry" || $wclass eq "TEntry"} {
773 set is_entry 1
774 } elseif {$wclass eq "Label" || $wclass eq "TLabel"} {
775 set is_entry 0
776 } else {
777 err_exit "browse2widget invoked with unsupported widget class $wclass"
778 }
779 if $is_entry {
780 set retval [$w get]
781 } else {
782 set retval [$w cget -text]
783 }
784 set retval [browse4dir $retval [winfo parent $w]]
785 if {$retval eq ""} {
786 return 0
787 } else {
788 if {$wclass eq "Entry" || $wclass eq "TEntry"} {
789 $w delete 0 end
790 $w insert 0 $retval
791 } else {
792 $w configure -text $retval
793 }
794 return 1
795 }
796 }
797
798 #### Unicode check- and radiobuttons ####
799
800 # on unix/linux the original indicators are hard-coded as bitmaps,
801 # which cannot scale with the rest of the interface.
802 # the hack below replaces them with unicode characters, which are scaled
803 # along with other text.
804 # This is implemented by removing the original indicators and prepending
805 # a unicode symbol and a unicode wide space to the text label.
806
807 # The combobox down arrow and the treeview triangles (directory browser)
808 # are scaled by normal style options at the end of redo_fonts.
809
810 if $::plain_unix {
811
812 # from General Punctuation, 2000-206f
813 set ::wsp \u2001 ; # wide space
814
815 # from Geometric Shapes, 25a0-25ff
816 set ::chk0 \u25a1
817 set ::chk1 \u25a3
818 set ::rad0 \u25cb
819 set ::rad1 \u25c9
820
821 # layouts copied from default theme, with indicator removed
822 ttk::style layout TCheckbutton "Checkbutton.padding -sticky nswe -children {Checkbutton.focus -side left -sticky w -children {Checkbutton.label -sticky nswe}}"
823 ttk::style layout TRadiobutton "Radiobutton.padding -sticky nswe -children {Radiobutton.focus -side left -sticky w -children {Radiobutton.label -sticky nswe}}"
824
825 proc tlupdate_check {w n e o} { ; # n, e, o added to keep trace happy
826 upvar [$w cget -variable] v
827 set s [$w cget -text]
828 set ck [expr {$v ? $::chk1 : $::chk0}]
829 set s0 [string index $s 0]
830 if {$s0 eq $::chk0 || $s0 eq $::chk1} {
831 set s "$ck$::wsp[string range $s 2 end]"
832 } else {
833 set s "$ck$::wsp$s"
834 }
835 if {[string length $s] == 2} {
836 # indicator plus wide space plus empty string. Remove wide space.
837 set s [string range $s 0 0]
838 }
839 $w configure -text $s
840 }
841 bind TCheckbutton <Map> {+tlupdate_check %W n e o}
842 bind TCheckbutton <Map> {+trace add variable [%W cget -variable] write \
843 [list tlupdate_check %W]}
844 bind TCheckbutton <Unmap> \
845 {+trace remove variable [%W cget -variable] write [list tlupdate_check %W]}
846
847 proc tlupdate_radio {w n e o} {
848 upvar [$w cget -variable] v
849 set ck [expr {$v eq [$w cget -value] ? $::rad1 : $::rad0}]
850 set s [$w cget -text]
851 set s0 [string index $s 0]
852 if {$s0 eq $::rad0 || $s0 eq $::rad1} {
853 set s "$ck$::wsp[string range $s 2 end]"
854 } else {
855 set s "$ck$::wsp$s"
856 }
857 if {[string length $s] == 2} {
858 # indicator plus wide space plus empty string. Remove wide space.
859 set s [string range $s 0 0]
860 }
861 $w configure -text $s
862 }
863
864 bind TRadiobutton <Map> {+tlupdate_radio %W n e o}
865 bind TRadiobutton <Map> {+trace add variable [%W cget -variable] write \
866 [list tlupdate_radio %W]}
867 bind TRadiobutton <Unmap> \
868 {+trace remove variable [%W cget -variable] write [list tlupdate_radio %W]}
869 }