"Fossies" - the Fresh Open Source Software Archive 
Member "install-tl-20231204/tlpkg/installer/install-tl-gui.tcl" (15 Mar 2022, 65983 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-2022 Siep Kroonenberg
4
5 # This file is licensed under the GNU General Public License version 2
6 # or any later version.
7
8 # Tcl/Tk frontend for TeX Live installer
9
10 # Installation can be divided into three stages:
11 #
12 # 1. preliminaries. This stage may involve some interaction with the user,
13 # which can be channeled through message boxes
14 # 2. a menu
15 # 3. the actual installation
16 #
17 # During stage 1. and 3. this wrapper collects stdout and stderr from
18 # the perl installer, with stderr being redirected to stdout.
19 # This output will be displayed in a text widget during stage 3,
20 # and in debug mode also in stage 1.
21 # During stage 3, we shall use event-driven, non-blocking I/O, which is
22 # needed for a scrolling display of installer output.
23 #
24 # Main window:
25 # filled successively with:
26 # - a logo, and 'loading...' label, by way of splash
27 # - a menu for stage 2
28 # - a log text widget for tracking stage 3
29 # ::out_log should be cleared before stage 3.
30 #
31 # In profile mode, the menu stage is skipped.
32
33 package require Tk
34
35 # security: disable send
36 catch {rename send {}}
37
38 # This file should be in $::instroot/tlpkg/installer.
39 # On non-windows platforms, install-tl functions as a wrapper
40 # for this file if it encounters a parameter '-gui' (but not -gui text).
41 # This allows automatic inclusion of a '--' parameter to separate
42 # tcl parameters from script parameters.
43
44 set ::instroot [file normalize [info script]]
45 set ::instroot [file dirname [file dirname [file dirname $::instroot]]]
46
47 # declarations, initializations and procs shared with tlshell.tcl.
48 # tltcl may want to know whether or not it was invoked by tlshell:
49 set ::invoker [file tail [info script]]
50 if [string match -nocase ".tcl" [string range $::invoker end-3 end]] {
51 set ::invoker [string range $::invoker 0 end-4]
52 }
53 source [file join $::instroot "tlpkg" "tltcl" "tltcl.tcl"]
54 unset ::invoker
55
56 ### initialize some globals ###
57
58 # perl installer process id
59 set ::perlpid 0
60
61 set ::out_log {}; # list of strings
62
63 set ::perlbin "perl"
64 if {$::tcl_platform(platform) eq "windows"} {
65 # the batch wrapper should have put perl.exe on the searchpath
66 set ::perlbin "perl.exe"
67 }
68
69 # menu modes
70 set ::advanced 0
71 set ::alltrees 0
72
73 # interactively select repository; default false
74 set ::select_repo 0
75
76 proc kill_perl {} {
77 if $::perlpid {
78 catch {
79 if {$::tcl_platform(platform) eq "unix"} {
80 exec -ignorestderr kill $::perlpid >& /dev/null
81 } else {
82 exec -ignorestderr taskkill /pid $::perlpid /t /f
83 }
84 }
85 }
86 }
87
88 proc err_exit {{mess ""}} {
89 if {$mess eq ""} {set mess "Error"}
90 append mess "\n" [get_stacktrace]
91 tk_messageBox -icon error -message $mess
92 # kill perl process, just in case
93 kill_perl
94 exit
95 } ; # err_exit
96
97 # warning about non-empty target tree
98 set ::td_warned 0
99
100 proc is_nonempty {td} {
101 if {! [file exists $td]} {return 0}
102 return [expr {[llength [glob -nocomplain -directory $td *]] > 0}]
103 }
104
105 proc td_warn {td} {
106 set ans [tk_messageBox -icon warning -type ok \
107 -message [__ "Target directory %s non-empty;\nmay cause trouble!" $td]]
108 set ::td_warned 1
109 }
110
111 proc td_question {td} {
112 set ans [tk_messageBox -icon warning -type yesno \
113 -message [__ "Target directory %s non-empty;\nare you sure?" $td]]
114 set ::td_warned 1
115 return $ans
116 }
117
118 ### procedures, mostly organized bottom-up ###
119
120 # the procedures which provide the menu with the necessary backend data,
121 # i.e. read_descs, read_vars and read_menu_data, are defined near the end.
122
123 set clock0 [clock milliseconds]
124 set profiling 0
125 proc show_time {s} {
126 if $::profiling {
127 puts [format "%s: %d" $s [expr {[clock milliseconds] - $::clock0}]]
128 }
129 }
130
131 # for debugging frontend-backend communication:
132 # write to a logfile which is shared with the backend.
133 # both parties open, append and close every time.
134
135 set dblogdir "/tmp"
136 if [info exists ::env(TMPDIR)] {
137 set dblogdir $::env(TMPDIR)
138 } elseif [info exists ::env(TMP)] {
139 set dblogdir $::env(TMP)
140 } elseif [info exists ::env(TEMP)] {
141 set dblogdir $::env(TEMP)
142 }
143 set ::dblfile [file join $dblogdir "dblog"]
144 unset dblogdir
145
146 proc dblog {s} {
147 set db [open $::dblfile a]
148 set t [get_stacktrace]
149 puts $db "TCL: $s\n$t"
150 close $db
151 }
152
153 # welcome message now provided by install-tl
154
155 # regular read_line
156 proc read_line {} {
157 while 1 {
158 if [catch {chan gets $::inst l} len] {
159 # catch [chan close $::inst]
160 err_exit "
161 Error while reading from Perl back end.
162 This should not have happened!"
163 } elseif {$len < 0} {
164 # catch [chan close $::inst]
165 return [list -1 ""]
166 } elseif {[string range $l 0 1] eq "D:" || [string range $l 0 2] eq "DD:" \
167 || [string range $l 0 3] eq "DDD:"} {
168 lappend ::out_log $l
169 } else {
170 return [list $len $l]
171 }
172 }
173 }; # read_line
174
175 proc read_line_no_eof {} {
176 set ll [read_line]
177 if {[lindex $ll 0] < 0} {
178 log_exit "
179 Unexpected closed backend.
180 This should not have happened!"
181 }
182 set l [lindex $ll 1]
183 # TODO: test under debug mode
184 return $l
185 }; # read_line_no_eof
186
187 # non-blocking i/o: callback for "readable" while the splash screen is up
188 # and the back end tries to contact the repository
189 proc read_line_loading {} {
190 set l "" ; # will contain the line to be read
191 if {([catch {chan gets $::inst l} len] || [chan eof $::inst])} {
192 catch {chan close $::inst}
193 # note. the normal way to terminate is terminating the GUI shell.
194 # This closes stdin of the child
195 } elseif {$len >= 0} {
196 if {$l eq "endload"} {
197 chan configure $::inst -blocking 1
198 chan event $::inst readable {}
199 set ::loaded 1
200 }
201 }
202 }; # read_line_loading
203
204 # non-blocking i/o: callback for "readable" during stage 3, installation
205 # ::out_log should no longer be needed
206 proc read_line_cb {} {
207 set l "" ; # will contain the line to be read
208 if {([catch {chan gets $::inst l} len] || [chan eof $::inst])} {
209 catch {chan close $::inst}
210 # note. the normal way to terminate is terminating the GUI shell.
211 # This closes stdin of the child
212 .close state !disabled
213 if [winfo exists .abort] {.abort state disabled}
214 } elseif {$len >= 0} {
215 # regular output
216 .log.tx configure -state normal
217 .log.tx insert end "$l\n"
218 .log.tx yview moveto 1
219 if {$::tcl_platform(os) ne "Darwin"} {.log.tx configure -state disabled}
220 }
221 }; # read_line_cb
222
223 proc maybe_abort {} {
224 set ans [tk_messageBox -message [__ "Really abort?"] -type yesno \
225 -default no]
226 if {$ans eq "no"} {
227 return
228 }
229 catch {chan close $::inst}
230 kill_perl
231 exit
232 }
233
234 # modify parameter list for either restarting gui installer
235 # or for starting back end
236
237 proc replace_lang_parameter {} {
238 # edit original command line by removing any language parameter
239 # and adding a repository parameter $m. same for language
240 set i [llength $::argv]
241 while {$i > 0} {
242 incr i -1
243 set p [lindex $::argv $i]
244 if {$p eq "-lang" || $p eq "-gui-lang"} {
245 set j [expr {$i+1}]
246 if {$j < [llength $::argv]} {
247 set ::argv [lreplace $::argv $i $j]
248 } else {
249 set ::argv [lreplace $::argv $i]
250 }
251 set ::argv [lreplace $::argv $i [expr {$i+1}]]
252 }
253 }
254 lappend ::argv "-lang" $::lang
255 }
256
257 proc replace_repo_parameter {m} {
258 # edit original command line by removing any repository parameter
259 # and adding a repository parameter $m. same for language
260 set i $::argc
261 while {$i > 0} {
262 incr i -1
263 set p [lindex $::argv $i]
264 if {$p in {"-location" "-url" "-repository" "-repos" "-repo"}} {
265 set j [expr {$i+1}]
266 if {$j < [llength $::argv]} {
267 set ::argv [lreplace $::argv $i $j]
268 } else {
269 set ::argv [lreplace $::argv $i]
270 }
271 }
272 }
273 lappend ::argv "-repository" $m
274 }
275
276 # restart installer with chosen repository
277 proc restart_with_mir {m} {
278 # edit original command line by removing any repository parameter
279 # and adding a repository parameter $m. same for language
280 replace_repo_parameter $m
281 replace_lang_parameter
282 set cmd [linsert $::argv 0 [info nameofexecutable] [info script] "--"]
283
284 # terminate back end
285 catch {chan close $::inst}
286 kill_perl
287
288 # restart install-tl with edited command-line
289 exec {*}$cmd &
290 exit
291 } ; # restart_with_mir
292
293 proc continue_with_mir {m} {
294 replace_repo_parameter $m
295 set ::mir_selected 1 ; # this will cause select_mirror to finish up
296 }
297
298 # add $::instroot as local repository if applicable
299 proc mirror_menu_plus {wnd cmd} {
300 set have_local 0
301 if [file isdirectory [file join $::instroot "archive"]] {
302 set have_local 1
303 } elseif [file readable \
304 [file join $::instroot "texmf-dist" "web2c" "texmf.cnf"]] {
305 set have_local 1
306 }
307 mirror_menu $wnd $cmd
308 if {[winfo class $wnd] ne "TMenubutton"} {
309 error_exit "No mirror list found"
310 } else {
311 if $have_local {
312 $wnd.m insert 0 command -label "$::instroot ([__ "Local repository"])" \
313 -command "$cmd $::instroot"
314 }
315 }
316 return $wnd
317 }
318
319 ##############################################################
320
321 ##### special-purpose uses of main window: select_mirror, splash, log #####
322
323 proc pre_splash {} {
324 # build splash window minus buttons
325 wm withdraw .
326
327 # picture and logo
328 catch {
329 image create photo tlimage -file \
330 [file join $::instroot "tlpkg" "installer" "texlion.gif"]
331 pack [frame .white -background white] -side top -fill x -expand 1
332 label .image -image tlimage -background white
333 pack .image -in .white
334 }
335
336 # wallpaper for remaining widgets
337 pack [ttk::frame .bg -padding 3pt] -fill both -expand 1
338
339 # frame for buttons (abort button, mirrors dropdown menu)
340 pack [ttk::frame .splfb] -in .bg -side bottom -fill x
341 }
342
343 proc select_mirror {} {
344
345 # buttons: abort button, mirrors dropdown menu, continue
346 ppack [mirror_menu_plus .splfb.slmir_m continue_with_mir] \
347 -side right
348 ppack [ttk::button .splfb.slmir_a -text [__ "Abort"] -command maybe_abort] \
349 -side right
350
351 update
352 wm state . normal
353 raise .
354 vwait ::mir_selected
355 } ; # select_mirror
356
357 proc make_splash {} {
358 wm withdraw .
359
360 # we want this if select_mirror has run:
361 foreach c [winfo children .splfb] {
362 catch {destroy $c}
363 }
364
365 ppack [ttk::button .spl_a -text [__ "Abort"] -command maybe_abort] \
366 -side right -in .splfb
367 ppack [mirror_menu_plus .spl_o restart_with_mir] -side right -in .splfb
368
369 # some text
370 ppack [ttk::label .text -text [__ "TeX Live Installer"] \
371 -font hfont] -in .bg
372 if {! $::select_repo} {
373 ppack [ttk::label .loading -text [__ "Trying to load %s.
374
375 If this takes too long, press Abort or choose another repository." \
376 $::prelocation]] -in .bg
377 }
378
379 update
380 wm state . normal
381 raise .
382 }; # make_splash
383
384 # ATM ::out_log will be shown only at the end
385 proc show_log {{do_abort 0}} {
386 wm withdraw .
387 foreach c [winfo children .] {
388 catch {destroy $c}
389 }
390
391 # wallpaper
392 pack [ttk::frame .bg -padding 3pt] -fill both -expand 1
393
394 # buttons at bottom
395 pack [ttk::frame .bottom] -in .bg -side bottom -fill x
396 ttk::button .close -text [__ "Close"] -command exit
397 ppack .close -in .bottom -side right
398 if $do_abort {
399 ttk::button .abort -text [__ "Abort"] -command maybe_abort
400 ppack .abort -in .bottom -side right
401 }
402 bind . <Escape> {
403 if {[winfo exists .close] && ! [.close instate disabled]} {.close invoke}
404 }
405
406 # logs plus their scrollbars
407 pack [ttk::frame .log] -in .bg -fill both -expand 1
408 pack [ttk::scrollbar .log.scroll -command ".log.tx yview"] \
409 -side right -fill y
410 ppack [text .log.tx -height 20 -wrap word -font TkDefaultFont \
411 -yscrollcommand ".log.scroll set"] \
412 -expand 1 -fill both
413 .log.tx configure -state normal
414 .log.tx delete 1.0 end
415 foreach l $::out_log {
416 .log.tx insert end "$l\n"
417 }
418 if {$::tcl_platform(os) ne "Darwin"} {.log.tx configure -state disabled}
419 .log.tx yview moveto 1
420
421 wm resizable . 1 1
422 wm overrideredirect . 0
423 update
424 wm state . normal
425 raise .
426 }; # show_log
427
428 proc log_exit {{mess ""}} {
429 if {$mess ne ""} {lappend ::out_log $mess}
430 catch {chan close $::inst} ; # should terminate perl
431 if {[llength $::out_log] > 0} {
432 if {[llength $::out_log] < 10} {
433 tk_messageBox -icon info -message [join $::out_log "\n"]
434 exit
435 } else {
436 show_log ; # its close button exits
437 }
438 } else {
439 exit
440 }
441 }; # log_exit
442
443 ##### installation root #####
444
445 proc update_full_path {} {
446 set val [file join \
447 [.tltd.prefix_l cget -text] \
448 [.tltd.name_l cget -text] \
449 [.tltd.rel_l cget -text]]
450 set val [native_slashify $val]
451 .tltd.path_l configure -text $val
452 # ask perl to check path
453 chan puts $::inst "checkdir"
454 chan puts $::inst [forward_slashify [.tltd.path_l cget -text]]
455 chan flush $::inst
456 if {[read_line_no_eof] eq "0"} {
457 .tltd.path_l configure -text \
458 [__ "Cannot be created or cannot be written to"] \
459 -foreground red
460 .tltd.ok_b state disabled
461 } else {
462 .tltd.path_l configure -text $val -foreground $::blk
463 .tltd.ok_b state !disabled
464 }
465 return
466 } ; # update_full_path
467
468 proc edit_name {} {
469 create_dlg .tled .tltd
470 wm title .tled [__ "Directory name..."]
471 if $::plain_unix {wm attributes .tled -type dialog}
472
473 # wallpaper
474 pack [ttk::frame .tled.bg -padding 3pt] -fill both -expand 1
475
476 # widgets
477 ttk::label .tled.l -text [__ "Change name (slashes not allowed)"]
478 pack .tled.l -in .tled.bg -padx 5pt -pady 5pt
479 ttk::entry .tled.e -width 20
480 .tled.e state !disabled
481 pack .tled.e -in .tled.bg -pady 5pt
482 .tled.e insert 0 [.tltd.name_l cget -text]
483
484 # now frame with ok and cancel buttons
485 pack [ttk::frame .tled.buttons] -in .tled.bg -fill x
486 ttk::button .tled.ok_b -text [__ "Ok"] -command {
487 if [regexp {[\\/]} [.tled.e get]] {
488 tk_messageBox -type ok -icon error -message [__ "No slashes allowed"]
489 } else {
490 .tltd.name_l configure -text [.tled.e get]
491 update_full_path
492 end_dlg "" .tled
493 }
494 }
495 ppack .tled.ok_b -in .tled.buttons -side right -padx 5pt -pady 5pt
496 ttk::button .tled.cancel_b -text [__ "Cancel"] -command {end_dlg "" .tled}
497 ppack .tled.cancel_b -in .tled.buttons -side right -padx 5pt -pady 5pt
498 bind .tled <Escape> {.tled.cancel_b invoke}
499
500 wm protocol .tled WM_DELETE_WINDOW \
501 {cancel_or_destroy .tled.cancel_b .tled}
502 wm resizable .tled 0 0
503 place_dlg .tled .tltd
504 } ; # edit_name
505
506 proc toggle_rel {} {
507 if {[.tltd.rel_l cget -text] ne ""} {
508 set ans \
509 [tk_messageBox -message \
510 [__ "TL release component highly recommended!\nAre you sure?"] \
511 -title [__ "Warning"] \
512 -type yesno \
513 -default no]
514 if {$ans eq no} {
515 return
516 }
517 .tltd.rel_l configure -text ""
518 .tltd.sep1_l configure -text " "
519 .tltd.rel_b configure -text [__ "Add year"]
520 } else {
521 .tltd.rel_l configure -text $::release_year
522 .tltd.sep1_l configure -text [file separator]
523 .tltd.rel_b configure -text [__ "Remove year"]
524 }
525 update_full_path
526 } ; # toggle_rel
527
528 proc commit_canonical_local {} {
529 if {[file tail $::vars(TEXDIR)] eq $::release_year} {
530 set l [file dirname $::vars(TEXDIR)]
531 } else {
532 set l $::vars(TEXDIR)
533 }
534 if {[forward_slashify $l] ne \
535 [forward_slashify [file dirname $::vars(TEXMFLOCAL)]]} {
536 set ::vars(TEXMFLOCAL) [forward_slashify [file join $l "texmf-local"]]
537 }
538 }
539
540 proc commit_root {} {
541 set td [.tltd.path_l cget -text]
542 set ::td_warned 0
543 if [is_nonempty $td] {
544 if {[td_question $td] ne yes} return
545 }
546 set ::vars(TEXDIR) [forward_slashify [.tltd.path_l cget -text]]
547 set ::vars(TEXMFSYSVAR) "$::vars(TEXDIR)/texmf-var"
548 set ::vars(TEXMFSYSCONFIG) "$::vars(TEXDIR)/texmf-config"
549 if [winfo exists .tspvl] {
550 .tspvl configure -text [file join $::vars(TEXDIR) "texmf-dist"]
551 }
552 commit_canonical_local
553
554 if {$::vars(instopt_portable)} {
555 set ::vars(TEXMFHOME) $::vars(TEXMFLOCAL)
556 set ::vars(TEXMFVAR) $::vars(TEXMFSYSVAR)
557 set ::vars(TEXMFCONFIG) $::vars(TEXMFSYSCONFIG)
558 }
559 destroy .tltd
560 update_vars
561 }
562
563 ### main directory dialog ###
564
565 proc texdir_setup {} {
566
567 ### widgets ###
568
569 create_dlg .tltd .
570 wm title .tltd [__ "Installation root"]
571
572 # wallpaper
573 pack [ttk::frame .tltd.bg -padding 3pt] -expand 1 -fill both
574
575 # full path
576 pack [ttk::label .tltd.path_l -font lfont -anchor center] \
577 -in .tltd.bg -pady 10pt -fill x -expand 1
578
579 # installation root components, gridded
580 pack [ttk::frame .tltd.fr1 -borderwidth 2pt -relief groove] \
581 -in .tltd.bg -fill x -expand 1
582 grid columnconfigure .tltd.fr1 0 -weight 1
583 grid columnconfigure .tltd.fr1 2 -weight 1
584 grid columnconfigure .tltd.fr1 4 -weight 1
585 set rw -1
586 # path components, as labels
587 incr rw
588 pgrid [ttk::label .tltd.prefix_l] -in .tltd.fr1 -row $rw -column 0
589 pgrid [ttk::label .tltd.sep0_l -text "/"] \
590 -in .tltd.fr1 -row $rw -column 1
591 pgrid [ttk::label .tltd.name_l] -in .tltd.fr1 -row $rw -column 2
592 pgrid [ttk::label .tltd.sep1_l -text "/"] \
593 -in .tltd.fr1 -row $rw -column 3
594 pgrid [ttk::label .tltd.rel_l -width 6] \
595 -in .tltd.fr1 -row $rw -column 4
596 # corresponding buttons
597 incr rw
598 set prefix_text [__ "Prefix"]
599 pgrid [ttk::button .tltd.prefix_b -text "${prefix_text}... \u00B9" \
600 -command {if [dirbrowser2widget .tltd.prefix_l] update_full_path}] \
601 -in .tltd.fr1 -row $rw -column 0
602 pgrid [ttk::button .tltd.name_b -text [__ "Change"] -command edit_name] \
603 -in .tltd.fr1 -row $rw -column 2
604 pgrid [ttk::button .tltd.rel_b -text [__ "Remove year"] \
605 -command toggle_rel] \
606 -in .tltd.fr1 -row $rw -column 4
607
608 set note_text [__ "Prefix must exist"]
609 ppack [ttk::label .tltd.notes -text "\u00B9 ${note_text}"] \
610 -in .tltd.bg -fill x -anchor w
611
612 # windows: note about localized names
613 if {$::tcl_platform(platform) eq "windows"} {
614 .tltd.prefix_b configure -text "${prefix_text}... \u00B9 \u00B2"
615 set loc_text \
616 [__ "Localized directory names will be replaced by their real names"]
617 .tltd.notes configure -justify left \
618 -text "\u00B9 ${note_text}\n\u00B2 ${loc_text}"
619 ppack .tltd.notes -in .tltd.bg -fill x
620 }
621
622 # ok/cancel buttons
623 pack [ttk::frame .tltd.frbt] -in .tltd.bg -pady {10pt 0pt} -fill x
624 ttk::button .tltd.ok_b -text [__ "Ok"] -command commit_root
625 ppack .tltd.ok_b -in .tltd.frbt -side right
626 ttk::button .tltd.cancel_b -text [__ "Cancel"] \
627 -command {destroy .tltd}
628 ppack .tltd.cancel_b -in .tltd.frbt -side right
629 bind .tltd <Escape> {.tltd.cancel_b invoke}
630
631 ### initialization and callbacks ###
632
633 set val [native_slashify [file normalize $::vars(TEXDIR)]]
634 regsub {[\\/]$} $val {} val
635
636 set initdir $val
637 set name ""
638 set rel ""
639
640 # TL release subdirectory at the end?
641 set rel_pat {[\\/](}
642 append rel_pat $::release_year {)$}
643 if [regexp $rel_pat $initdir m rel] {
644 set rel $::release_year
645 regsub $rel_pat $initdir {} initdir
646 }
647 .tltd.rel_l configure -text $rel
648
649 # next-last component
650 regexp {^(.*)[\\/]([^\\/]*)$} $initdir m initdir name
651 .tltd.name_l configure -text $name
652
653 # backtrack remaining initdir to something that exists
654 # and assign it to prefix
655 set initprev ""
656 while {! [file isdirectory $initdir]} {
657 set initprev $initdir
658 regexp {^(.*)[\\/]([^\\/]*)} $initdir m initdir m1
659 if {$initprev eq $initdir} break
660 }
661
662 if {$initdir eq "" || \
663 ($::tcl_platform(platform) eq "windows" && \
664 [string index $initdir end] eq ":")} {
665 append initdir "/"
666 }
667 .tltd.prefix_l configure -text $initdir
668 update_full_path
669
670 bind .tltd <Return> commit_root
671 bind .tltd <Escape> {destroy .tltd}
672
673 wm protocol .tltd WM_DELETE_WINDOW \
674 {cancel_or_destroy .tltd.cancel_b .tltd}
675 wm resizable .tltd 1 0
676 place_dlg .tltd
677 } ; # texdir_setup
678
679 ##### other directories: TEXMFLOCAL, TEXMFHOME, portable #####
680
681 proc edit_dir {d} {
682 create_dlg .td .
683 wm title .td $d
684 if $::plain_unix {wm attributes .td -type dialog}
685
686 # wallpaper
687 pack [ttk::frame .td.bg -padding 3pt] -fill both -expand 1
688
689 if {$d eq "TEXMFHOME"} {
690 # explain tilde
691 if {$::tcl_platform(platform) eq "windows"} {
692 set ev "%USERPROFILE%"
693 set xpl $::env(USERPROFILE)
694 } else {
695 set ev "\$HOME"
696 set xpl $::env(HOME)
697 }
698 ppack [ttk::label .td.tilde \
699 -text [__ "'~' equals %s, e.g. %s" $ev $xpl]] \
700 -in .td.bg -anchor w
701 }
702
703 # other widgets
704
705 ppack [ttk::entry .td.e -width 60] -in .td.bg -fill x
706 .td.e insert 0 [native_slashify $::vars($d)]
707
708 pack [ttk::frame .td.f] -fill x -expand 1
709 ttk::button .td.ok -text [__ "Ok"] -command {end_dlg [.td.e get] .td}
710 ppack .td.ok -in .td.f -side right
711 ttk::button .td.cancel -text [__ "Cancel"] -command {end_dlg "" .td}
712 ppack .td.cancel -in .td.f -side right
713 bind .td <Escape> {.td.cancel invoke}
714
715 wm protocol .td WM_DELETE_WINDOW \
716 {cancel_or_destroy .td.cancel .td}
717 wm resizable .td 1 0
718 place_dlg .td .
719 tkwait window .td
720 if {[info exists ::dialog_ans] && $::dialog_ans ne ""} {
721 set ::vars($d) [forward_slashify $::dialog_ans]
722 if $::vars(instopt_portable) {
723 if {$d eq "TEXMFLOCAL"} {set ::vars(TEXMFHOME) $::vars($d)}
724 if {$d eq "TEXMFSYSVAR"} {set ::vars(TEXMFVAR) $::vars($d)}
725 if {$d eq "TEXMFSYSCONFIG"} {set ::vars(TEXMFCONFIG) $::vars($d)}
726 update
727 }
728 }
729 }
730
731 proc port_dis_or_activate {toggled} {
732 if {!$::advanced} return
733 set yn [yes_no $::vars(instopt_portable)]
734 .dirportvl configure -text $yn
735 if {$::vars(instopt_portable)} {
736 set ::vars(TEXMFHOME) $::vars(TEXMFLOCAL)
737 set ::vars(TEXMFVAR) $::vars(TEXMFSYSVAR)
738 set ::vars(TEXMFCONFIG) $::vars(TEXMFSYSCONFIG)
739 .thomeb state disabled
740 if $::alltrees {
741 .tvb state disabled
742 .tcb state disabled
743 }
744 if {$::tcl_platform(platform) eq "windows"} {
745 # adjust_path
746 set ::vars(instopt_adjustpath) 0
747 .pathb state disabled
748 .pathl configure -foreground $::gry
749 # desktop integration
750 set ::vars(instopt_desktop_integration) 0
751 .dkintb state disabled
752 .dkintl configure -foreground $::gry
753 # file associations
754 set ::vars(instopt_file_assocs) 0
755 .assocb state disabled
756 .assocl configure -foreground $::gry
757 # multi-user
758 if $::is_admin {
759 set ::vars(instopt_w32_multi_user) 0
760 .adminb state disabled
761 .adminl configure -foreground $::gry
762 }
763 } else {
764 set ::vars(instopt_adjustpath) 0
765 .symspec state disabled
766 .pathb state disabled
767 .pathl configure -foreground $::gry
768 }
769 } else {
770 if $toggled {
771 set ::vars(TEXMFHOME) "~/texmf"
772 set ::vars(TEXMFVAR) "~/.texlive${::release_year}/texmf-var"
773 set ::vars(TEXMFCONFIG) "~/.texlive${::release_year}/texmf-config"
774 } ; # else leave alone
775 #.tlocb state !disabled
776 .thomeb state !disabled
777 if $::alltrees {
778 #.tsysvb state !disabled
779 #.tsyscb state !disabled
780 .tvb state !disabled
781 .tcb state !disabled
782 }
783 if {$::tcl_platform(platform) eq "windows"} {
784 # adjust_path
785 set ::vars(instopt_adjustpath) 1
786 .pathb state !disabled
787 .pathl configure -foreground $::blk
788 # desktop integration
789 set ::vars(instopt_desktop_integration) 1
790 .dkintb state !disabled
791 .dkintl configure -foreground $::blk
792 # file associations
793 set ::vars(instopt_file_assocs) 1
794 .assocb state !disabled
795 .assocl configure -foreground $::blk
796 # multi-user
797 if $::is_admin {
798 set ::vars(instopt_w32_multi_user) 1
799 .adminb state !disabled
800 .adminl configure -foreground $::blk
801 }
802 } else {
803 # set ::vars(instopt_adjustpath) 0
804 # leave false, still depends on symlink paths
805 .symspec state !disabled
806 if [dis_enable_symlink_option] {
807 .pathb state !disabled
808 .pathl configure -foreground $::blk
809 }
810 }
811 }
812 }
813
814 proc toggle_port {} {
815 set ::vars(instopt_portable) [expr {!$::vars(instopt_portable)}]
816 port_dis_or_activate 1
817 commit_canonical_local
818 }; # toggle_port
819
820 #############################################################
821
822 ##### selections: binaries, scheme, collections #####
823
824 proc show_stats {} {
825 # n. of additional platforms
826 if [winfo exists .binlm] {
827 if {$::vars(n_systems_selected) < 2} {
828 .binlm configure -text [__ "None"]
829 } else {
830 .binlm configure -text [expr {$::vars(n_systems_selected) - 1}]
831 }
832 }
833 # n. out of n. packages
834 if [winfo exists .lcolv] {
835 .lcolv configure -text \
836 [format "%d / %d" \
837 $::vars(n_collections_selected) \
838 $::vars(n_collections_available)]
839 }
840 if [winfo exists .schml] {
841 .schml configure -text [__ $::scheme_descs($::vars(selected_scheme))]
842 }
843 # diskspace: can use -textvariable here
844 # paper size
845 }; # show_stats
846
847 #############################################################
848
849 ### binaries ###
850
851 # toggle platform in treeview widget, but not in underlying data
852 proc toggle_bin {b} {
853 if {$b eq $::vars(this_platform)} {
854 tk_messageBox -message [__ "Cannot deselect own platform"]
855 return
856 }
857 set m [.tlbin.lst set $b "mk"]
858 if {$m eq [mark_sym 0]} {
859 .tlbin.lst set $b "mk" [mark_sym 1]
860 } else {
861 .tlbin.lst set $b "mk" [mark_sym 0]
862 }
863 }; # toggle_bin
864
865 proc save_bin_selections {} {
866 set ::vars(n_systems_selected) 0
867 foreach b [.tlbin.lst children {}] {
868 set bb "binary_$b"
869 if {[.tlbin.lst set $b "mk"] ne [mark_sym 0]} {
870 incr ::vars(n_systems_selected)
871 set ::vars($bb) 1
872 } else {
873 set ::vars($bb) 0
874 }
875 if {$b eq "win32"} {
876 set ::vars(collection-wintools) $::vars($bb)
877 }
878 }
879 update_vars
880 show_stats
881 }; # save_bin_selections
882
883 proc sort_bins_by_value {n m} {
884 return [string compare [__ $::bin_descs($n)] [__ $::bin_descs($m)]]
885 }
886
887 proc select_binaries {} {
888 create_dlg .tlbin .
889 wm title .tlbin [__ "Binaries"]
890
891 # wallpaper
892 pack [ttk::frame .tlbin.bg -padding 3pt] -expand 1 -fill both
893
894 # ok, cancel buttons
895 pack [ttk::frame .tlbin.buts] -in .tlbin.bg -side bottom -fill x
896 ttk::button .tlbin.ok -text [__ "Ok"] -command \
897 {save_bin_selections; update_vars; end_dlg 1 .tlbin}
898 ppack .tlbin.ok -in .tlbin.buts -side right
899 ttk::button .tlbin.cancel -text [__ "Cancel"] -command {end_dlg 0 .tlbin}
900 ppack .tlbin.cancel -in .tlbin.buts -side right
901 bind .tlbin <Escape> {.tlbin.cancel invoke}
902
903 # treeview for binaries, with checkbox column and vertical scrollbar
904 pack [ttk::frame .tlbin.binsf] -in .tlbin.bg -expand 1 -fill both
905
906 ttk::treeview .tlbin.lst -columns {mk desc} -show {} \
907 -selectmode extended -yscrollcommand {.tlbin.binsc set}
908
909 ttk::scrollbar .tlbin.binsc -orient vertical -command {.tlbin.lst yview}
910 .tlbin.lst column mk -stretch 0 -width [expr {$::cw * 3}]
911 .tlbin.lst column desc -stretch 1
912 foreach b [lsort -command sort_bins_by_value [array names ::bin_descs]] {
913 set bb "binary_$b"
914 .tlbin.lst insert {} end -id $b -values \
915 [list [mark_sym $::vars($bb)] [__ $::bin_descs($b)]]
916 }
917 set_tree_col_width .tlbin.lst "desc"
918 pgrid .tlbin.lst -in .tlbin.binsf -row 0 -column 0 -sticky news
919 pgrid .tlbin.binsc -in .tlbin.binsf -row 0 -column 1 -sticky ns
920 grid columnconfigure .tlbin.binsf 0 -weight 1
921 grid rowconfigure .tlbin.binsf 0 -weight 1
922 bind .tlbin.lst <space> {toggle_bin [.tlbin.lst focus]}
923 bind .tlbin.lst <Return> {toggle_bin [.tlbin.lst focus]}
924 bind .tlbin.lst <ButtonRelease-1> \
925 {toggle_bin [.tlbin.lst identify item %x %y]}
926
927 wm protocol .tlbin WM_DELETE_WINDOW \
928 {cancel_or_destroy .tlbin.cancel .tlbin}
929 wm resizable .tlbin 1 1
930 place_dlg .tlbin .
931 }; # select_binaries
932
933 #############################################################
934
935 ### scheme ###
936
937 proc select_scheme {} {
938 create_dlg .tlschm .
939 wm title .tlschm [__ "Schemes"]
940
941 # wallpaper
942 pack [ttk::frame .tlschm.bg -padding 3pt] -fill both -expand 1
943
944 # buttons at bottom
945 pack [ttk::frame .tlschm.buts] -in .tlschm.bg -side bottom -fill x
946 ttk::button .tlschm.ok -text [__ "Ok"] -command {
947 # tree selection is a list:
948 set ::vars(selected_scheme) [lindex [.tlschm.lst selection] 0]
949 foreach v [array names ::vars] {
950 if {[string range $v 0 6] eq "scheme-"} {
951 if {$v eq $::vars(selected_scheme)} {
952 set ::vars($v) 1
953 } else {
954 set ::vars($v) 0
955 }
956 }
957 }
958 update_vars
959 show_stats
960 end_dlg 1 .tlschm
961 }
962 ppack .tlschm.ok -in .tlschm.buts -side right
963 ttk::button .tlschm.cancel -text [__ "Cancel"] -command {end_dlg 0 .tlschm}
964 ppack .tlschm.cancel -in .tlschm.buts -side right
965 bind .tlschm <Escape> {.tlschm.cancel invoke}
966
967 # schemes list. use treeview rather than listbox for uniform formatting
968 ttk::treeview .tlschm.lst -columns {desc} -show {} -selectmode browse \
969 -height [llength $::schemes_order]
970 ppack .tlschm.lst -in .tlschm.bg -fill both -expand 1
971 foreach s $::schemes_order {
972 .tlschm.lst insert {} end -id $s -values [list [__ $::scheme_descs($s)]]
973 }
974 set_tree_col_width .tlschm.lst "desc"
975 # we already made sure that $::vars(selected_scheme) has a valid value
976 .tlschm.lst selection set [list $::vars(selected_scheme)]
977
978 wm protocol .tlschm WM_DELETE_WINDOW \
979 {cancel_or_destroy tlschm.cancel .tlschm}
980 wm resizable .tlschm 1 0
981 place_dlg .tlschm .
982 }; # select_scheme
983
984 #############################################################
985
986 ### collections ###
987
988 # toggle collection in treeview widget, but not in underlying data
989 proc toggle_coll {cs c} {
990 # cs: treeview widget; c: selected child item
991 set m [$cs set $c "mk"]
992 if {$m eq [mark_sym 0]} {
993 $cs set $c "mk" [mark_sym 1]
994 } else {
995 $cs set $c "mk" [mark_sym 0]
996 }
997 }; # toggle_coll
998
999 proc save_coll_selections {} {
1000 foreach wgt {.tlcoll.other .tlcoll.lang} {
1001 foreach c [$wgt children {}] {
1002 if {[$wgt set $c "mk"] eq [mark_sym 0]} {
1003 set ::vars($c) 0
1004 } else {
1005 set ::vars($c) 1
1006 }
1007 }
1008 }
1009 set ::vars(selected_scheme) "scheme-custom"
1010 update_vars
1011 show_stats
1012 }; # save_coll_selections
1013
1014 proc sort_colls_by_value {n m} {
1015 return [string compare [__ $::coll_descs($n)] [__ $::coll_descs($m)]]
1016 }
1017
1018 proc select_collections {} {
1019 # 2018: more than 40 collections
1020 # The tcl installer acquires collections from install-menu-extl.pl,
1021 # but install-tl also has an array of collections.
1022 # Use treeview for checkbox column and display of
1023 # collection descriptions rather than names.
1024 # buttons: select all, select none, ok, cancel
1025 # should some collections be excluded? Check install-menu-* code.
1026 create_dlg .tlcoll .
1027 wm title .tlcoll [__ "Collections"]
1028
1029 # wallpaper
1030 pack [ttk::frame .tlcoll.bg -padding 3pt] -fill both -expand 1
1031
1032 # frame at bottom with ok and cancel buttons
1033 pack [ttk::frame .tlcoll.butf] -in .tlcoll.bg -side bottom -fill x
1034 ttk::button .tlcoll.ok -text [__ "Ok"] -command \
1035 {save_coll_selections; end_dlg 1 .tlcoll}
1036 ppack .tlcoll.ok -in .tlcoll.butf -side right
1037 ttk::button .tlcoll.cancel -text [__ "Cancel"] -command {end_dlg 0 .tlcoll}
1038 ppack .tlcoll.cancel -in .tlcoll.butf -side right
1039 bind .tlcoll <Escape> {.tlcoll.cancel invoke}
1040
1041 # Treeview and scrollbar for non-language- and language collections resp.
1042 pack [ttk::frame .tlcoll.both] -in .tlcoll.bg -expand 1 -fill both
1043
1044 foreach t {"lang" "other"} {
1045
1046 # frames with select all/none buttons, separately for lang and others
1047 set wgb .tlcoll.b$t
1048 ttk::frame $wgb
1049 ttk::label ${wgb}sel -text [__ "Select"]
1050 ttk::button ${wgb}all -text [__ "All"] -padding 1pt -command \
1051 "foreach c \[.tlcoll.$t children {}\] \{
1052 .tlcoll.$t set \$c mk \[mark_sym 1\]\}"
1053 ttk::button ${wgb}none -text [__ "None"] -padding 1pt -command \
1054 "foreach c \[.tlcoll.$t children {}\] \{
1055 .tlcoll.$t set \$c mk \[mark_sym 0\]\}"
1056 pack ${wgb}sel ${wgb}all ${wgb}none -in $wgb \
1057 -side left -padx 3pt -pady 3pt
1058
1059 # trees with collections and markers, lang and other separately
1060 set wgt ".tlcoll.$t"
1061 ttk::treeview $wgt -columns {mk desc} -show {headings} \
1062 -selectmode extended -yscrollcommand "${wgt}sc set"
1063 $wgt heading "mk" -text ""
1064 if {$t eq "lang"} {
1065 $wgt heading "desc" -text [__ "Languages"]
1066 } else {
1067 $wgt heading "desc" -text [__ "Other collections"]
1068 }
1069 # and their vertical scrollbars
1070 ttk::scrollbar ${wgt}sc -orient vertical -command "$wgt yview"
1071 $wgt column mk -width [expr {$::cw * 3}] -stretch 0
1072 $wgt column desc -stretch 1
1073
1074 bind $wgt <space> {toggle_coll %W [%W focus]}
1075 bind $wgt <Return> {toggle_coll %W [%W focus]}
1076 bind $wgt <ButtonRelease-1> {toggle_coll %W [%W identify item %x %y]}
1077 }
1078 grid .tlcoll.blang x .tlcoll.bother -in .tlcoll.both -sticky w
1079 grid .tlcoll.lang .tlcoll.langsc .tlcoll.other .tlcoll.othersc \
1080 -in .tlcoll.both
1081 grid columnconfigure .tlcoll.both 0 -weight 1
1082 grid columnconfigure .tlcoll.both 1 -weight 0
1083 grid columnconfigure .tlcoll.both 2 -weight 2
1084 grid columnconfigure .tlcoll.both 3 -weight 0
1085 grid configure .tlcoll.lang .tlcoll.other .tlcoll.langsc .tlcoll.othersc \
1086 -sticky nsew
1087 grid rowconfigure .tlcoll.both 1 -weight 1
1088
1089
1090 foreach c [lsort -command sort_colls_by_value [array names ::coll_descs]] {
1091 if [string equal -length 15 "collection-lang" $c] {
1092 set wgt ".tlcoll.lang"
1093 } else {
1094 set wgt ".tlcoll.other"
1095 }
1096 $wgt insert {} end -id $c -values \
1097 [list [mark_sym $::vars($c)] [__ $::coll_descs($c)]]
1098 }
1099 set_tree_col_width .tlcoll.lang "desc"
1100 set_tree_col_width .tlcoll.other "desc"
1101
1102 wm protocol .tlcoll WM_DELETE_WINDOW \
1103 {cancel_or_destroy .tlcoll.cancel .tlcoll}
1104 wm resizable .tlcoll 1 1
1105 place_dlg .tlcoll .
1106 }; # select_collections
1107
1108 ##################################################
1109
1110 # option handling
1111
1112 # for multi-value options:
1113 # below, $c is a combobox with values $l. The index of the current value in $l
1114 # corresponds to the value of $::vars($v).
1115
1116 proc var2combo {v c} {
1117 $c current $::vars($v)
1118 }
1119 proc combo2var {c v} {
1120 set ::vars($v) [$c current]
1121 }
1122 # if the variable has an impact on what to install:
1123 proc combo2var_calc {c v} {
1124 combo2var c v
1125 update_vars
1126 show_stats
1127 }
1128
1129 ##### desktop integration; platform-specific #####
1130
1131 if {$::tcl_platform(platform) ne "windows"} {
1132
1133 ### symlinks into standard directories ###
1134
1135 # 'file writable' is only a check of unix permissions
1136 # use proc dir_writable instead
1137 proc dest_ok {d} {
1138 if {$d eq ""} {return 0}
1139 set its 1
1140 while 1 {
1141 if [file exists $d] {
1142 if {! [file isdirectory $d]} {
1143 return 0
1144 } elseif {! [dir_writable $d]} {
1145 return 0
1146 } else {
1147 return 1
1148 }
1149 } ; # if file exists
1150 # try a level up
1151 set d [file dirname $d]
1152 set its [expr {$its + 1}]
1153 if {$its > 3} {return 0}
1154 }
1155 return 0
1156 }
1157
1158 proc dis_enable_symlink_option {} {
1159 set ok 1
1160 foreach v {"bin" "man" "info"} {
1161 set vv "tlpdbopt_sys_$v"
1162 if {! [info exists ::vars($vv)]} {set ok 0; break}
1163 set d $::vars($vv)
1164 if {![dest_ok $d]} {set ok 0; break}
1165 }
1166 if {$ok && !$::vars(instopt_portable)} {
1167 .pathb state !disabled
1168 .pathl configure -foreground $::blk
1169 } else {
1170 set ok 0
1171 .pathb state disabled
1172 .pathl configure -foreground $::gry
1173 set ::vars(instopt_adjustpath) 0
1174 }
1175 return $ok
1176 }
1177
1178 # check validity of all three proposed symlink target directories.
1179 # do not dis/enable .pathb until return from .edsyms dialog.
1180 proc check_sym_entries {} {
1181 set ok 1
1182 foreach v {"bin" "man" "info"} {
1183 if [dest_ok [.edsyms.${v}e get]] {
1184 .edsyms.${v}mk configure -text "\u2714" -foreground $::blk
1185 } else {
1186 .edsyms.${v}mk configure -text "\u2718" -foreground red
1187 set ok 0
1188 }
1189 }
1190 if $ok {
1191 .edsyms.warn configure -text ""
1192 } else {
1193 .edsyms.warn configure -text \
1194 [__ "Warning. Not all configured directories are writable!"]
1195 }
1196 }
1197
1198 proc commit_sym_entries {} {
1199 foreach v {"bin" "man" "info"} {
1200 set vv "tlpdbopt_sys_$v"
1201 set ::vars($vv) [.edsyms.${v}e get]
1202 if {[string index $::vars($vv) 0] eq "~"} {
1203 set ::vars($vv) "$::env(HOME)[string range $::vars($vv) 1 end]"
1204 }
1205 }
1206 if [dis_enable_symlink_option] {
1207 set ::vars(instopt_adjustpath) 1
1208 }
1209 }
1210
1211 proc edit_symlinks {} {
1212
1213 create_dlg .edsyms .
1214 wm title .edsyms [__ "Symlinks"]
1215
1216 pack [ttk::frame .edsyms.bg -padding 3pt] -expand 1 -fill both
1217 set rw -1
1218
1219 pack [ttk::frame .edsyms.fr0] -in .edsyms.bg -expand 1 -fill both
1220 foreach v {"bin" "man" "info"} {
1221 incr rw
1222 # description
1223 pgrid [ttk::label .edsyms.${v}l -text ""] \
1224 -in .edsyms.fr0 -row $rw -column 0 -sticky e
1225 # ok mark
1226 pgrid [ttk::label .edsyms.${v}mk -text ""] \
1227 -in .edsyms.fr0 -row $rw -column 1
1228 # entry widget
1229 pgrid [ttk::entry .edsyms.${v}e -width 40] \
1230 -in .edsyms.fr0 -row $rw -column 2
1231 set vv "tlpdbopt_sys_$v"
1232 if [info exists ::vars($vv)] {
1233 .edsyms.${v}e insert 0 $::vars($vv)
1234 }; # else leave empty
1235 bind .edsyms.${v}e <KeyRelease> {+check_sym_entries}
1236 # browse button
1237 pgrid [ttk::button .edsyms.${v}br -text [__ "Browse..."] -command \
1238 "dirbrowser2widget .edsyms.${v}e; check_sym_entries"] \
1239 -in .edsyms.fr0 -row $rw -column 3
1240 }
1241 .edsyms.binl configure -text [__ "Binaries"]
1242 .edsyms.manl configure -text [__ "Man pages"]
1243 .edsyms.infol configure -text [__ "Info pages"]
1244
1245 # warning about read-only target directories
1246 incr rw
1247 pgrid [ttk::label .edsyms.warn -foreground red] \
1248 -in .edsyms.fr0 -column 2 -columnspan 2 -sticky w
1249
1250 grid columnconfigure .edsyms.fr0 0 -weight 0
1251 grid columnconfigure .edsyms.fr0 1 -weight 0
1252 grid columnconfigure .edsyms.fr0 2 -weight 1
1253 grid columnconfigure .edsyms.fr0 3 -weight 0
1254
1255 # ok, cancel
1256 pack [ttk::frame .edsyms.fr1] -expand 1 -fill both
1257 ppack [ttk::button .edsyms.ok -text [__ "Ok"] -command {
1258 commit_sym_entries; end_dlg 1 .edsyms}] -in .edsyms.fr1 -side right
1259 ppack [ttk::button .edsyms.cancel -text [__ "Cancel"] -command {
1260 end_dlg 0 .edsyms}] -in .edsyms.fr1 -side right
1261 bind .edsyms <Escape> {.edsyms.cancel invoke}
1262
1263 check_sym_entries
1264
1265 wm protocol .edsyms WM_DELETE_WINDOW \
1266 {cancel_or_destroy .edsyms.cancel .edsyms}
1267 wm resizable .edsyms 1 0
1268 place_dlg .edsyms .
1269 } ; # edit_symlinks
1270 } ; # $::tcl_platform(platform) ne "windows"
1271
1272 #############################################################
1273
1274 proc set_language {l} {
1275 set ::lang $l
1276 load_translations
1277 run_menu
1278 }
1279
1280 proc set_fontscale {s} {
1281 set ::tkfontscale $s
1282 redo_fonts
1283 run_menu
1284 }
1285
1286 proc zoom {n} {
1287 if {$n <= 0} {set n 1}
1288 set_fontscale [expr {$n*$::tkfontscale}]
1289 }
1290
1291 # menus: disable tearoff feature
1292 option add *Menu.tearOff 0
1293
1294 #############################################################
1295
1296 # the main menu interface will at certain events send the current values of
1297 # the ::vars array to install-tl[-tcl], which will send back an updated version
1298 # of this array.
1299 # We still use blocking i/o: frontend and backend wait for each other.
1300
1301 ## default_bg color, only used for menus under ::plain_unix
1302 if [catch {ttk::style lookup TFrame -background} ::default_bg] {
1303 set ::default_bg white
1304 }
1305
1306 proc abort_menu {} {
1307 set ::out_log {}
1308 set ::menu_ans "no_inst"
1309 # i.e. anything but advanced, alltrees or startinst
1310 }
1311
1312 proc maybe_install {} {
1313 if {($::vars(free_size)!=-1) && \
1314 ($::vars(total_size) >= ($::vars(free_size)-100))} {
1315 tk_messageBox -icon error -message [__ "Not enough room"]
1316 } else {
1317 set ::menu_ans "startinst"
1318 }
1319 }
1320
1321 proc run_menu {} {
1322 #if [info exists ::env(dbgui)] {
1323 # puts "\ndbgui: run_menu: advanced is now $::advanced"
1324 # puts "dbgui: run_menu: alltrees is now $::alltrees"
1325 #}
1326 wm withdraw .
1327 foreach c [winfo children .] {
1328 catch {destroy $c}
1329 }
1330
1331 if $::plain_unix {
1332 # plain_unix: avoid a possible RenderBadPicture error on quitting
1333 # when there is a menu.
1334 # 'send' bypasses the bug by changing the shutdown sequence.
1335 # 'tk appname <something>' restores 'send'.
1336 bind . <Destroy> {
1337 catch {tk appname appname}
1338 }
1339 }
1340
1341 # name in titlebar; should be redefined after any language switch
1342 wm title . [__ "TeX Live Installer"]
1343
1344 # menu, for language selection and font scaling
1345 menu .mn
1346 . configure -menu .mn
1347 if $::plain_unix {
1348 .mn configure -borderwidth 1pt
1349 .mn configure -background $::default_bg
1350 }
1351 .mn add command -command abort_menu -label [__ "Abort"]
1352
1353
1354 if {[llength $::langs] > 1} {
1355 menu .mn.lang
1356 .mn add cascade -label [__ "GUI language"] -menu .mn.lang
1357 foreach l [lsort $::langs] {
1358 if {$l eq $::lang} {
1359 set mlabel "$l *"
1360 } else {
1361 set mlabel $l
1362 }
1363 .mn.lang add command -label $mlabel -command "set_language $l"
1364 }
1365 }
1366
1367 menu .mn.fscale
1368 .mn add cascade -label [__ "Font scaling"] -menu .mn.fscale
1369 .mn.fscale add command -label \
1370 "[__ "Current:"] [format { %.2f} $::tkfontscale]"
1371 foreach s {0.6 0.8 1 1.2 1.6 2 2.5 3 3.8 5 6 7.5 9} {
1372 .mn.fscale add command -label $s -command "set_fontscale $s"
1373 }
1374
1375 # browser-style keyboard shortcuts for scaling
1376 bind . <Control-KeyRelease-minus> {zoom 0.8}
1377 bind . <Control-KeyRelease-equal> {zoom 1.25}
1378 bind . <Control-Shift-KeyRelease-equal> {zoom 1.25}
1379 bind . <Control-KeyRelease-plus> {zoom 1.25}
1380 bind . <Control-KeyRelease-0> {set_fontscale 1}
1381 if {$::tcl_platform(os) eq "Darwin"} {
1382 bind . <Command-KeyRelease-minus> {zoom 0.8}
1383 bind . <Command-KeyRelease-equal> {zoom 1.25}
1384 bind . <Command-Shift-KeyRelease-equal> {zoom 1.25}
1385 bind . <Command-KeyRelease-plus> {zoom 1.25}
1386 bind . <Command-KeyRelease-0> {set_fontscale 1}
1387 }
1388
1389 # wallpaper, for a uniform background
1390 pack [ttk::frame .bg -padding 3pt] -fill both -expand 1
1391
1392 # title
1393 ttk::label .title -text [__ "TeX Live %s Installer" $::release_year] \
1394 -font titlefont
1395 pack .title -pady {10pt 1pt} -in .bg
1396 pack [ttk::label .svn -text "r. $::svn"] -in .bg
1397
1398 pack [ttk::separator .seph0 -orient horizontal] \
1399 -in .bg -pady 3pt -fill x
1400
1401 # frame at bottom with install/quit buttons
1402 pack [ttk::frame .final] \
1403 -in .bg -side bottom -pady {5pt 2pt} -fill x
1404 ppack [ttk::button .install -text [__ "Install"] -command maybe_install] \
1405 -in .final -side right
1406 ppack [ttk::button .quit -text [__ "Quit"] -command {
1407 set ::out_log {}
1408 set ::menu_ans "no_inst"}] -in .final -side right
1409 bind . <Escape> whataboutclose
1410 if {!$::advanced} {
1411 ppack [ttk::button .adv -text [__ "Advanced"] -command {
1412 set ::menu_ans "advanced"
1413 #if [info exists ::env(dbgui)] {puts "dbgui: requested advanced"}
1414 }] -in .final -side left
1415 }
1416 pack [ttk::separator .seph1 -orient horizontal] \
1417 -in .bg -side bottom -pady 3pt -fill x
1418
1419 # directories, selections
1420 # advanced and basic have different frame setups
1421 if $::advanced {
1422 pack [ttk::frame .left] -in .bg -side left -fill both -expand 1
1423 set curf .left
1424 } else {
1425 pack [ttk::frame .main] -in .bg -side top -fill both -expand 1
1426 set curf .main
1427 }
1428
1429 # directory section
1430 pack [ttk::frame .dirf] -in $curf -fill x
1431 grid columnconfigure .dirf 1 -weight 1
1432 set rw -1
1433
1434 if $::advanced {
1435 incr rw
1436 # labelframes do not look quite right on macos,
1437 # instead, separate label widget for title
1438 pgrid [ttk::label .dirftitle -text [__ "Installation root"] \
1439 -font hfont] \
1440 -in .dirf -row $rw -column 0 -columnspan 3 -sticky w
1441 .dirftitle configure -text [__ "Directories"]
1442 }
1443
1444 incr rw
1445 pgrid [ttk::label .tdirll] -in .dirf -row $rw -column 0 -sticky nw
1446 set s [__ "Installation root"]
1447 if $::advanced {
1448 .tdirll configure -text "TEXDIR:\n$s"
1449 } else {
1450 .tdirll configure -text $s
1451 }
1452 pgrid [ttk::label .tdirvl -textvariable ::vars(TEXDIR)] \
1453 -in .dirf -row $rw -column 1 -sticky nw
1454 pgrid [ttk::button .tdirb -text [__ "Change"] -command texdir_setup] \
1455 -in .dirf -row $rw -column 2 -sticky new
1456
1457 if $::advanced {
1458 if $::alltrees {
1459 incr rw
1460 pgrid [ttk::label .tspll -text [__ "Main tree"]] \
1461 -in .dirf -row $rw -column 0 -sticky nw
1462 pgrid [ttk::label .tspvl] -in .dirf -row $rw -column 1 -sticky nw
1463 .tspvl configure -text [file join $::vars(TEXDIR) "texmf-dist"]
1464
1465 incr rw
1466 pgrid [ttk::label .tsysvll -text "TEXMFSYSVAR"] \
1467 -in .dirf -row $rw -column 0 -sticky nw
1468 pgrid [ttk::label .tsysvvl -textvariable ::vars(TEXMFSYSVAR)] \
1469 -in .dirf -row $rw -column 1 -sticky nw
1470 ttk::button .tsysvb -text [__ "Change"] -command {edit_dir "TEXMFSYSVAR"}
1471 pgrid .tsysvb -in .dirf -row $rw -column 2 -sticky new
1472
1473 incr rw
1474 pgrid [ttk::label .tsyscll -text "TEXMFSYSCONFIG"] \
1475 -in .dirf -row $rw -column 0 -sticky nw
1476 pgrid [ttk::label .tsyscvl -textvariable ::vars(TEXMFSYSCONFIG)] \
1477 -in .dirf -row $rw -column 1 -sticky nw
1478 ttk::button .tsyscb -text [__ "Change"] \
1479 -command {edit_dir "TEXMFSYSCONFIG"}
1480 pgrid .tsyscb -in .dirf -row $rw -column 2 -sticky new
1481 }
1482 incr rw
1483 set s [__ "Local additions"]
1484 pgrid [ttk::label .tlocll -text "TEXMFLOCAL:\n$s"] \
1485 -in .dirf -row $rw -column 0 -sticky nw
1486 pgrid [ttk::label .tlocvl -textvariable ::vars(TEXMFLOCAL)] \
1487 -in .dirf -row $rw -column 1 -sticky nw
1488 ttk::button .tlocb -text [__ "Change"] -command {edit_dir "TEXMFLOCAL"}
1489 pgrid .tlocb -in .dirf -row $rw -column 2 -sticky new
1490
1491 incr rw
1492 set s [__ "Per-user additions"]
1493 pgrid [ttk::label .thomell -text "TEXMFHOME:\n$s"] \
1494 -in .dirf -row $rw -column 0 -sticky nw
1495 pgrid [ttk::label .thomevl -textvariable ::vars(TEXMFHOME)] \
1496 -in .dirf -row $rw -column 1 -sticky nw
1497 ttk::button .thomeb -text [__ "Change"] -command {edit_dir "TEXMFHOME"}
1498 pgrid .thomeb -in .dirf -row $rw -column 2 -sticky ne
1499 if $::alltrees {
1500 incr rw
1501 pgrid [ttk::label .tvll -text "TEXMFVAR"] \
1502 -in .dirf -row $rw -column 0 -sticky nw
1503 pgrid [ttk::label .tvvl -textvariable ::vars(TEXMFVAR)] \
1504 -in .dirf -row $rw -column 1 -sticky nw
1505 ttk::button .tvb -text [__ "Change"] -command {edit_dir "TEXMFVAR"}
1506 pgrid .tvb -in .dirf -row $rw -column 2 -sticky new
1507 incr rw
1508 pgrid [ttk::label .tcll -text "TEXMFCONFIG"] \
1509 -in .dirf -row $rw -column 0 -sticky nw
1510 pgrid [ttk::label .tcvl -textvariable ::vars(TEXMFCONFIG)] \
1511 -in .dirf -row $rw -column 1 -sticky nw
1512 ttk::button .tcb -text [__ "Change"] \
1513 -command {edit_dir "TEXMFCONFIG"}
1514 pgrid .tcb -in .dirf -row $rw -column 2 -sticky new
1515 }
1516
1517 incr rw
1518 if {!$::alltrees} {
1519 ttk::button .tmoreb -text [__ "More ..."] -command {
1520 set ::menu_ans "alltrees"
1521 #if [info exists ::env(dbgui)] {puts "dbgui: requested alltrees"}
1522 }
1523 pgrid .tmoreb -in .dirf -row $rw -column 2 -sticky ne
1524 }
1525
1526 incr rw
1527 pgrid [ttk::label .dirportll \
1528 -text [__ "Portable setup:\nMay reset TEXMFLOCAL\nand TEXMFHOME"]] \
1529 -in .dirf -row $rw -column 0 -sticky nw
1530 pgrid [ttk::label .dirportvl] -in .dirf -row $rw -column 1 -sticky nw
1531 pgrid [ttk::button .tportb -text [__ "Toggle"] -command toggle_port] \
1532 -in .dirf -row $rw -column 2 -sticky ne
1533 .dirportvl configure -text [yes_no $::vars(instopt_portable)]
1534
1535 # platforms section
1536 if {$::tcl_platform(platform) ne "windows"} {
1537 pack [ttk::frame .platf] -in .left -fill x
1538 grid columnconfigure .platf 1 -weight 1
1539 set rw -1
1540
1541 incr rw
1542 pgrid [ttk::label .binftitle -text [__ "Platforms"] -font hfont] \
1543 -in .platf -row $rw -column 0 -columnspan 3 -sticky w
1544
1545 # current platform
1546 incr rw
1547 ttk::label .binl0 \
1548 -text [__ "Current platform:"]
1549 pgrid .binl0 -in .platf -row $rw -column 0 -sticky w
1550 ttk::label .binl1 \
1551 -text [__ "$::bin_descs($::vars(this_platform))"]
1552 pgrid .binl1 -in .platf -row $rw -column 1 -sticky w
1553 # additional platforms
1554 incr rw
1555 pgrid [ttk::label .binll -text [__ "N. of additional platform(s):"]] \
1556 -in .platf -row $rw -column 0 -sticky w
1557 pgrid [ttk::label .binlm] -in .platf -row $rw -column 1 -sticky w
1558 pgrid [ttk::button .binb -text [__ "Change"] -command select_binaries] \
1559 -in .platf -row $rw -column 2 -sticky e
1560 }
1561
1562 # Selections section
1563 pack [ttk::frame .selsf] -in .left -fill x
1564 grid columnconfigure .selsf 1 -weight 1
1565 set rw -1
1566
1567 incr rw
1568 pgrid [ttk::label .selftitle -text [__ "Selections"] -font hfont] \
1569 -in .selsf -row $rw -column 0 -columnspan 3 -sticky w
1570
1571 # schemes
1572 incr rw
1573 pgrid [ttk::label .schmll -text [__ "Scheme:"]] \
1574 -in .selsf -row $rw -column 0 -sticky w
1575 pgrid [ttk::label .schml -text ""] \
1576 -in .selsf -row $rw -column 1 -sticky w
1577 pgrid [ttk::button .schmb -text [__ "Change"] -command select_scheme] \
1578 -in .selsf -row $rw -column 2 -sticky e
1579
1580 # collections
1581 incr rw
1582 pgrid [ttk::label .lcoll -text [__ "N. of collections:"]] \
1583 -in .selsf -row $rw -column 0 -sticky w
1584 pgrid [ttk::label .lcolv] -in .selsf -row $rw -column 1 -sticky w
1585 pgrid [ttk::button .collb -text [__ "Customize"] \
1586 -command select_collections] \
1587 -in .selsf -row $rw -column 2 -sticky e
1588 }
1589
1590 # total size and available space
1591 # curf: current frame
1592 set curf [expr {$::advanced ? ".selsf" : ".dirf"}]
1593 incr rw
1594 ttk::label .lsize -text [__ "Disk space required (in MB):"]
1595 ttk::label .size_req -textvariable ::vars(total_size)
1596 pgrid .lsize -in $curf -row $rw -column 0 -sticky w
1597 pgrid .size_req -in $curf -row $rw -column 1 -sticky w
1598 if {$::vars(free_size) != -1} {
1599 incr rw
1600 ttk::label .lavail -text [__ "Disk space available (in MB):"]
1601 ttk::label .avail -textvariable ::vars(free_size)
1602 pgrid .lavail -in $curf -row $rw -column 0 -sticky w
1603 pgrid .avail -in $curf -row $rw -column 1 -sticky w
1604 }
1605
1606 ########################################################
1607 # right side: options
1608 # 3 columns. Column 1 can be merged with either 0 or 2.
1609
1610 if $::advanced {
1611
1612 pack [ttk::separator .sepv -orient vertical] \
1613 -in .bg -side left -padx 3pt -fill y
1614 pack [ttk::frame .options] -in .bg -side right -fill both -expand 1
1615
1616 set curf .options
1617 grid columnconfigure .options 0 -weight 1
1618 set rw -1
1619
1620 incr rw
1621 pgrid [ttk::label .optitle -text [__ "Options"] -font hfont] \
1622 -in $curf -row $rw -column 0 -columnspan 3 -sticky w
1623 } else {
1624 set curf .dirf
1625 }
1626
1627 # instopt_letter
1628 set ::lpapers {"A4" "Letter"}
1629 incr rw
1630 pgrid [ttk::label .paperl -text [__ "Default paper size"]] \
1631 -in $curf -row $rw -column 0 -sticky w
1632 pgrid [ttk::combobox .paperb -values $::lpapers -state readonly -width 8] \
1633 -in $curf -row $rw -column 1 -columnspan 2 -sticky e
1634 var2combo "instopt_letter" .paperb
1635 bind .paperb <<ComboboxSelected>> {+combo2var .paperb "instopt_letter"}
1636
1637 if $::advanced {
1638 # instopt_write18_restricted
1639 incr rw
1640 pgrid [ttk::label .write18l -text \
1641 [__ "Allow execution of restricted list of programs via \\write18"]] \
1642 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1643 ttk::checkbutton .write18b -variable ::vars(instopt_write18_restricted)
1644 pgrid .write18b -in $curf -row $rw -column 2 -sticky e
1645
1646 # tlpdbopt_create_formats
1647 incr rw
1648 pgrid [ttk::label .formatsl -text [__ "Create all format files"]] \
1649 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1650 ttk::checkbutton .formatsb -variable ::vars(tlpdbopt_create_formats)
1651 pgrid .formatsb -in $curf -row $rw -column 2 -sticky e
1652
1653 # tlpdbopt_install_docfiles
1654 if $::vars(doc_splitting_supported) {
1655 incr rw
1656 pgrid [ttk::label .docl -text [__ "Install font/macro doc tree"]] \
1657 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1658 ttk::checkbutton .docb -variable ::vars(tlpdbopt_install_docfiles) \
1659 -command {update_vars; show_stats}
1660 pgrid .docb -in $curf -row $rw -column 2 -sticky e
1661 }
1662
1663 # tlpdbopt_install_srcfiles
1664 if $::vars(src_splitting_supported) {
1665 incr rw
1666 pgrid [ttk::label .srcl -text [__ "Install font/macro source tree"]] \
1667 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1668 ttk::checkbutton .srcb -variable ::vars(tlpdbopt_install_srcfiles) \
1669 -command {update_vars; show_stats}
1670 pgrid .srcb -in $curf -row $rw -column 2 -sticky e
1671 }
1672 }
1673
1674 if {$::tcl_platform(platform) eq "windows"} {
1675
1676 if $::advanced {
1677 # instopt_adjustpath
1678 incr rw
1679 pgrid [ttk::label .pathl -text [__ "Adjust searchpath"]] \
1680 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1681 ttk::checkbutton .pathb -variable ::vars(instopt_adjustpath)
1682 pgrid .pathb -in $curf -row $rw -column 2 -sticky e
1683
1684 # tlpdbopt_desktop_integration
1685 set ::desk_int \
1686 [list [__ "No shortcuts"] [__ "TeX Live menu"] [__ "Launcher entry"]]
1687 incr rw
1688 pgrid [ttk::label .dkintl -text [__ "Desktop integration"]] \
1689 -in $curf -row $rw -column 0 -sticky w
1690 pgrid [ttk::combobox .dkintb -values $::desk_int -state readonly \
1691 -width 20] \
1692 -in $curf -row $rw -column 1 -columnspan 2 -sticky e
1693 var2combo "tlpdbopt_desktop_integration" .dkintb
1694 bind .dkintb <<ComboboxSelected>> \
1695 {+combo2var .dkintb "tlpdbopt_desktop_integration"}
1696
1697 # tlpdbopt_file_assocs
1698 set ::assoc [list [__ "None"] [__ "Only new"] [__ "All"]]
1699 incr rw
1700 pgrid [ttk::label .assocl -text [__ "File associations"]] \
1701 -in $curf -row $rw -column 0 -sticky w
1702 pgrid [ttk::combobox .assocb -values $::assoc -state readonly -width 12] \
1703 -in $curf -row $rw -column 1 -columnspan 2 -sticky e
1704 var2combo "tlpdbopt_file_assocs" .assocb
1705 bind .assocb <<ComboboxSelected>> \
1706 {+combo2var .assocb "tlpdbopt_file_assocs"}
1707 }
1708
1709 # tlpdbopt_w32_multi_user
1710 incr rw
1711 pgrid [ttk::label .adminl -text [__ "Install for all users"]] \
1712 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1713 ttk::checkbutton .adminb -variable ::vars(tlpdbopt_w32_multi_user)
1714 pgrid .adminb -in $curf -row $rw -column 2 -sticky e
1715 if {!$::is_admin} {
1716 .adminb state disabled
1717 .adminl configure -foreground $::gry
1718 }
1719
1720 # collection-texworks
1721 incr rw
1722 pgrid [ttk::label .texwl -text [__ "Install TeXworks front end"]] \
1723 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1724 ttk::checkbutton .texwb -variable ::vars(collection-texworks)
1725 .texwb configure -command \
1726 {set ::vars(selected_scheme) "scheme-custom"; update_vars; show_stats}
1727 pgrid .texwb -in $curf -row $rw -column 2 -sticky e
1728 } else {
1729 if $::advanced {
1730 # instopt_adjustpath, unix edition: symlinks
1731 # tlpdbopt_sys_[bin|info|man]
1732 incr rw
1733 pgrid [ttk::label .pathl \
1734 -text [__ "Create symlinks in standard directories"]] \
1735 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1736 pgrid [ttk::checkbutton .pathb -variable ::vars(instopt_adjustpath)] \
1737 -in $curf -row $rw -column 2 -sticky e
1738 dis_enable_symlink_option; # enable only if standard directories ok
1739 incr rw
1740 pgrid [ttk::button .symspec -text [__ "Specify directories"] \
1741 -command edit_symlinks] \
1742 -in $curf -row $rw -column 1 -columnspan 2 -sticky e
1743 }
1744 }
1745
1746 if $::advanced {
1747 # spacer/filler
1748 incr rw
1749 pgrid [ttk::label .spaces -text " "] -in $curf -row $rw -column 0
1750 grid rowconfigure $curf $rw -weight 1
1751 # final entry: instopt_adjustrepo
1752 incr rw
1753 pgrid [ttk::label .ctanl -text \
1754 [__ "After install, set CTAN as source for package updates"]] \
1755 -in $curf -row $rw -column 0 -columnspan 2 -sticky w
1756 pgrid [ttk::checkbutton .ctanb -variable ::vars(instopt_adjustrepo)] \
1757 -in $curf -row $rw -column 2 -sticky e
1758 }
1759
1760 if $::advanced {port_dis_or_activate 0}
1761 show_stats
1762 wm overrideredirect . 0
1763 wm resizable . 0 0
1764 update
1765 wm state . normal
1766 raise .
1767 if {$::tcl_platform(platform) eq "windows"} {wm deiconify .}
1768 if {[is_nonempty $::vars(TEXDIR)] && ! $::td_warned} {
1769 td_warn $::vars(TEXDIR)
1770 }
1771 #if [info exists ::env(dbgui)] {puts "dbgui: unsetting menu_ans"}
1772 unset -nocomplain ::menu_ans
1773 vwait ::menu_ans
1774 #if [info exists ::env(dbgui)] {puts "dbgui0: menu_ans is $::menu_ans"}
1775 return $::menu_ans
1776 }; # run_menu
1777
1778 #############################################################
1779
1780 # we need data from the backend.
1781 # choices of schemes, platforms and options impact choices of
1782 # collections and required disk space.
1783 # the vars array contains all this variable information.
1784 # the calc_depends proc communicates with the backend to update this array.
1785
1786 proc read_descs {} {
1787 set l [read_line_no_eof]
1788 if {$l ne "descs"} {
1789 err_exit "'descs' expected but $l found"
1790 }
1791 while 1 {
1792 set l [read_line_no_eof]
1793 if [regexp {^([^:]+): (\S+) (.*)$} $l m p c d] {
1794 if {$c eq "Collection"} {
1795 set ::coll_descs($p) $d
1796 } elseif {$c eq "Scheme"} {
1797 set ::scheme_descs($p) $d
1798 }
1799 } elseif {$l eq "enddescs"} {
1800 break
1801 } else {
1802 err_exit "Illegal line $l in descs section"
1803 }
1804 }
1805 set ::scheme_descs(scheme-custom) [__ "Custom scheme"]
1806 }
1807
1808 proc read_vars {} {
1809 set l [read_line_no_eof]
1810 if {$l ne "vars"} {
1811 err_exit "'vars' expected but $l found"
1812 }
1813 while 1 {
1814 set l [read_line_no_eof]
1815 if [regexp {^([^:]+): (.*)$} $l m k v] {
1816 set ::vars($k) $v
1817 } elseif {$l eq "endvars"} {
1818 break
1819 } else {
1820 err_exit "Illegal line $l in vars section"
1821 }
1822 }
1823 if {"total_size" ni [array names ::vars]} {
1824 set ::vars(total_size) 0
1825 }
1826 }; # read_vars
1827
1828 proc write_vars {} {
1829 chan puts $::inst "vars"
1830 foreach v [array names ::vars] {chan puts $::inst "$v: $::vars($v)"}
1831 chan puts $::inst "endvars"
1832 chan flush $::inst
1833 }
1834
1835 proc update_vars {} {
1836 chan puts $::inst "calc"
1837 write_vars
1838 read_vars
1839 }
1840
1841 proc read_menu_data {} {
1842 # the expected order is: year, svn, descs, vars, schemes (one line), binaries
1843 # note. lindex returns an empty string if the index argument is too high.
1844 # empty lines result in an err_exit.
1845
1846 # year; should be first line
1847 set l [read_line_no_eof]
1848 if [regexp {^year: (\S+)$} $l d y] {
1849 set ::release_year $y
1850 } else {
1851 err_exit "year expected but $l found"
1852 }
1853
1854 # revision; should be second line
1855 set l [read_line_no_eof]
1856 if [regexp {^svn: (\S+)$} $l d y] {
1857 set ::svn $y
1858 } else {
1859 err_exit "revision expected but $l found"
1860 }
1861
1862 # windows: admin status
1863 if {$::tcl_platform(platform) eq "windows"} {
1864 set l [read_line_no_eof]
1865 if [regexp {^admin: ([01])$} $l d a] {
1866 set ::is_admin $a
1867 } else {
1868 err_exit "admin: \[0|1\] expected but $l found"
1869 }
1870 }
1871
1872 read_descs
1873
1874 read_vars
1875
1876 # schemes order (one line)
1877 set l [read_line_no_eof]
1878 if [regexp {^schemes_order: (.*)$} $l m sl] {
1879 set ::schemes_order $sl
1880 } else {
1881 err_exit "schemes_order expected but $l found"
1882 }
1883 if {"selected_scheme" ni [array names ::vars] || \
1884 $::vars(selected_scheme) ni $::schemes_order} {
1885 set ::vars(selected_scheme) [lindex $::schemes_order 0]
1886 }
1887
1888 # binaries
1889 set l [read_line_no_eof]
1890 if {$l ne "binaries"} {
1891 err_exit "'binaries' expected but $l found"
1892 }
1893 while 1 {
1894 set l [read_line_no_eof]
1895 if [regexp {^([^:]+): (.*)$} $l m k v] {
1896 set ::bin_descs($k) $v
1897 } elseif {$l eq "endbinaries"} {
1898 break
1899 } else {
1900 err_exit "Illegal line $l in binaries section"
1901 }
1902 }
1903
1904 set l [read_line_no_eof]
1905 if {$l ne "endmenudata"} {
1906 err_exit "'endmenudata' expected but $l found"
1907 }
1908 }; # read_menu_data
1909
1910 proc answer_to_perl {} {
1911 # we just got a line "mess_yesno" from perl
1912 # finish reading the message text, put it in a message box
1913 # and write back the answer
1914 set mess {}
1915 while 1 {
1916 set ll [read_line]
1917 if {[lindex $ll 0] < 0} {
1918 err_exit "Error while reading from Perl backend"
1919 } else {
1920 set l [lindex $ll 1]
1921 }
1922 if {$l eq "endmess"} {
1923 break
1924 } else {
1925 lappend mess $l
1926 }
1927 }
1928 set m [join $mess "\n"]
1929 set ans [tk_messageBox -type yesno -icon question -message $m]
1930 chan puts $::inst [expr {$ans eq yes ? "y" : "n"}]
1931 chan flush $::inst
1932 }; # answer_to_perl
1933
1934 proc run_installer {} {
1935 set ::out_log {}
1936 show_log 1; # 1: with abort button
1937 .close state disabled
1938 chan puts $::inst "startinst"
1939 write_vars
1940 # the backend was already running and needs no further encouragement
1941
1942 # switch to non-blocking i/o
1943 chan configure $::inst -buffering line -blocking 0
1944 chan event $::inst readable read_line_cb
1945 raise .
1946 if {$::tcl_platform(platform) eq "windows"} {wm deiconify .}
1947 }; # run_installer
1948
1949 proc whataboutclose {} {
1950 if [winfo exists .abort] {
1951 # log window with abort
1952 .abort invoke
1953 } elseif [winfo exists .log] {
1954 # log window without abort
1955 .close invoke
1956 } elseif [winfo exists .quit] {
1957 # menu window
1958 .quit invoke
1959 }
1960 # no action for close button of splash screen
1961 }
1962
1963 proc main_prog {} {
1964
1965 wm protocol . WM_DELETE_WINDOW whataboutclose
1966
1967 # handle some command-line arguments.
1968 # the argument list should already be normalized: '--' => '-', "=" => ' '
1969 set ::prelocation "..."
1970 set ::mir_selected 1 ; # i.e. default or set by parameter
1971 set l [llength $::argv]
1972 set i $l
1973 while {$i > 0} {
1974 set iplus $i
1975 incr i -1
1976 set p [lindex $::argv $i]
1977 if {$p in {"-location" "-url" "-repository" "-repos" "-repo"}} {
1978 # check for repository argument: bail out if obviously invalid
1979 if {$iplus<$l} {
1980 set p [lindex $::argv $iplus]
1981 if {$p ne "ctan" && ! [possible_repository $p]} {
1982 err_exit [__ "%s not a local or remote repository" $p]
1983 }
1984 set ::prelocation $p
1985 } else {
1986 err_exit [__ "%s requires an argument" $p]
1987 }
1988 } elseif {$p eq "-select-repository"} {
1989 # in this case, we start with selecting a repository
1990 # from a mirror list and modify ::argv to take the selection
1991 # into account before contacting the perl back end.
1992 unset -nocomplain ::mir_selected
1993 # remove this argument
1994 set ::argv [lreplace $::argv $i $i]
1995 }
1996 }
1997 unset i
1998
1999 pre_splash
2000 if {! [info exists ::mir_selected]} {
2001 select_mirror
2002 # waits for ::mir_selected
2003 }
2004 make_splash
2005
2006 # start install-tl-[tcl] via a pipe.
2007 set cmd [list "|${::perlbin}" "${::instroot}/install-tl" \
2008 "-from_ext_gui" {*}$::argv "2>@1"]
2009 if [catch {open $cmd r+} ::inst] {
2010 err_exit "Error starting Perl backend"
2011 }
2012
2013 show_time "opened pipe"
2014 set ::perlpid [pid $::inst]
2015
2016 # for windows < 10: make sure the main window is still on top
2017 raise .
2018
2019 chan configure $::inst -buffering line -blocking 1
2020
2021 # possible input from perl until the menu starts:
2022 # - question about prior canceled installation
2023 # - location (actual repository)
2024 # - menu data
2025 set answer ""
2026 unset -nocomplain ::loaded
2027 while 1 { ; # initial perl output
2028 set ll [read_line]
2029 if {[lindex $ll 0] < 0} {
2030 break
2031 }
2032 set l [lindex $ll 1]
2033 # There may be occasion for a dialog
2034 if {$l eq "mess_yesno"} {
2035 answer_to_perl
2036 } elseif [string match "location: ?*" $l] {
2037 # this one comes straight from install-tl, rather than
2038 # from install-tl-extl.pl
2039 # installer about to contact repository, which may
2040 # fail and cause an indefinite delay
2041 chan configure $::inst -blocking 0
2042 chan event $::inst readable read_line_loading
2043 if [winfo exists .loading] {
2044 .loading configure -text [__ "Trying to load %s.
2045
2046 If this takes too long, press Abort or choose another repository." \
2047 [string range $l 10 end]]
2048 update
2049 }
2050 break
2051 }
2052 }
2053 # waiting till the repository has been loaded
2054 vwait ::loaded
2055 unset ::loaded
2056 # resume reading from back end in blocking mode
2057 while 1 {
2058 set ll [read_line]
2059 if {[lindex $ll 0] < 0} {
2060 break
2061 }
2062 set l [lindex $ll 1]
2063 if {$l eq "menudata"} {
2064 # so we do want a menu and expect menu data,
2065 # parsing which may take a while
2066 read_menu_data
2067 show_time "read menu data from perl"
2068 set ::advanced 0
2069 set ::alltrees 0
2070 set answer [run_menu]
2071 #if [info exists ::env(dbgui)] {puts "dbgui1: menu_ans is $::menu_ans"}
2072 if {$answer eq "advanced"} {
2073 # this could only happen if $::advanced was 0
2074 set ::advanced 1
2075 #if [info exists ::env(dbgui)] {puts "dbgui: Setting advanced to 1"}
2076 set answer [run_menu]
2077 if {$answer eq "alltrees"} {
2078 set ::alltrees 1
2079 #if [info exists ::env(dbgui)] {puts "dbgui: Setting alltrees to 1"}
2080 set answer [run_menu]
2081 }
2082 }
2083 break
2084 } elseif {$l eq "startinst"} {
2085 # use an existing profile:
2086 set ::out_log {}
2087 set answer "startinst"
2088 break
2089 } else {
2090 lappend ::out_log $l
2091 }
2092 }
2093 if {$answer eq "startinst"} {
2094 # disable browser-style keyboard shortcuts for scaling
2095 bind . <Control-KeyRelease-minus> {}
2096 bind . <Control-KeyRelease-equal> {}
2097 bind . <Control-Shift-KeyRelease-equal> {}
2098 bind . <Control-KeyRelease-plus> {}
2099 bind . <Control-KeyRelease-0> {}
2100 if {$::tcl_platform(os) eq "Darwin"} {
2101 bind . <Command-KeyRelease-minus> {}
2102 bind . <Command-KeyRelease-equal> {}
2103 bind . <Command-Shift-KeyRelease-equal> {}
2104 bind . <Command-KeyRelease-plus> {}
2105 bind . <Command-KeyRelease-0> {}
2106 }
2107
2108 run_installer
2109 # invokes show_log which first destroys previous children
2110 } else {
2111 log_exit
2112 }
2113 }; # main_prog
2114
2115 #file delete $::dblfile
2116
2117 main_prog