1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
|
#!/usr/bin/env wish
# Copyright 2017 Siep Kroonenberg
# This file is licensed under the GNU General Public License version 2
# or any later version.
package require Tk
# searchpath:
# windows: most scripts run via [w]runscript, which adjusts the searchpath
# for the current process.
# unix/linux: tlshell.tcl should be run via a symlink in a directory
# which also contains (a symlink to) kpsewhich.
# This directory will be prepended to the searchpath.
# kpsewhich will disentangle symlinks.
# security: disable send
catch {rename send {}}
set ddebug 0
proc do_debug {s} {
if {$::ddebug} {
puts stderr $s
# catch in case the widget concerned has not yet been created
catch {.lw.dbg.tx configure -state normal; .lw.dbg.tx insert end "$s\n"}
}
}
proc get_stack {} {
set level [info level]
set s ""
for {set i 1} {$i < $level} {incr i} {
append s [format "Level %u: %s\n" $i [info level $i]]
}
return $s
}
# unicode characters as tag indicators, in hex. This is pretty safe,
# since Tk will use glyphs from other fonts if necessary.
# With bitmaps, we would have to worry about HiDpi displays.
set mrk [format %c 0x25a3] ; # 'white square containing black small square'
set nomrk [format %c 0x25a1] ; # 'white square'
set progname [info script]
regexp {^.*[\\/]([^\\/\.]*)(?:\....)?$} $progname dummy progname
set procid [pid]
set tempsub "" ; # subdirectory for temporary files
# the stderr and stdout of tlmgr are each read into a list of strings
set err_log {}
set out_log {}
# callback for reading tlmgr pipe
set pipe_cb ""
set lnum -1
# dict of (local and global) package dicts
set pkgs [dict create]
set do_remote 0 ; # get local packages
set have_remote 0 ; # remote packages loaded
# filtering the package list, parameter should be package NAME
set filt ""
proc filt_local {p} {
return [dict get $::pkgs $p localrev]
}
proc filt_collections {p} {
set c [dict get $::pkgs $p "category"]
return [expr \"$c\" eq \"Collection\"]
}
proc filt_upgradable {p} {
do_debug "Is $p upgradable?"
set lr [dict get $::pkgs $p localrev]
set rr [dict get $::pkgs $p remoterev]
do_debug "$p: comparing $lr and $rr"
if {$lr == 0} {
return 0
} elseif {$rr == 0} {
return 0
}
return [expr $rr > $lr]
}
set prmpt "tlmgr>"
set busy 0
proc maketemp {ext} {
set fname ""
foreach i {0 1 2 3 4 5 6 7 8 9} { ; # ten tries
set fname [file join $::tempsub "[expr int(10000.0*rand())]$ext"]
if {[file exist $fname]} {set fname ""; continue}
# create empty file. although we just want a name,
# we must make sure that it can be created.
set fid [open $fname w]
close $fid
if {! [file exists $fname]} {error "Cannot create temporary file"}
if {$::tcl_platform(platform) eq "unix"} {
file attributes $fname -permissions 0600
}
break
}
if {$fname eq ""} {error "Cannot create temporary file"}
return $fname
}
# TODO:
# replace messagebox with a custom toplevel with a text widget
# in case there is a lot of text
proc err_exit {} {
do_debug "error exit"
read_err
tk_messageBox -message [join $::err_log "\n"] -type ok -icon error
exit
}
proc read_err {} {
#do_debug "read_err"
set len 0
while 1 {
set len [chan gets $::err l]
if {$len >= 0} {
lappend ::err_log $l
} else {
break
}
}
}
# about [chan] gets:
# if a second parameter is supplied
# then this variable receives the result, with EOL stripped,
# and the return value is the string length, possibly 0
# EOF is indicated by a return value of -1.
proc read_line {} {
incr ::lnum
set l "" ; # will contain the line to be read
if {([catch {chan gets $::tlshl l} len] || [chan eof $::tlshl])} {
do_debug "read_line: failing to read"
catch {chan close $::tlshl}
err_exit
# note. the right way to terminate is terminating the shell
} elseif {$len >= 0} {
# do_debug "read: $l"
if {[string first $::prmpt $l] == 0} {
# prompt line: done with command
enable_widgets 1
read_err
if {$::pipe_cb ne ""} {
do_debug "$::lnum: prompt found, $l"
$::pipe_cb "finish"
}
} else {
lappend ::out_log $l
if {$::pipe_cb ne ""} {$::pipe_cb "line" "$l"}
}
}
} ; # read_line
# copy error strings to error page, which is sent to top.
# This by itself does not map the logs toplevel .lw
proc show_err_log {} {
#do_debug "show_err_log"
.lw.err.tx configure -state normal
.lw.err.tx delete 1.0 end
if {[llength $::err_log] > 0} {
foreach l $::err_log {.lw.err.tx insert end "$l\n"}
.lw.err.tx yview moveto 1
.lw.logs select .lw.err
}
if {$::tcl_platform(os) ne "Darwin"} {
# os x: text widget disabled => no selection possible
.lw.err.tx configure -state disabled
}
} ; # show_err_log
# package info popup for the package having focus
proc popup_focused {itm} {
run_cmd "info $itm" package_popup_cb
}
# display packages: always display both local and remote revision columns.
# the caller should have set a filter for the packages to be displayed.
# ::pkgs should already be up to date
proc display_packages {} {
.pkglist delete [.pkglist children {}]
dict for {nm pk} $::pkgs {
if {$::filt eq "" || [$::filt $nm]} {
set vl [list $::nomrk $nm]
foreach k {localrev remoterev shortdesc} {
set vv [dict get $pk $k]
if {$vv eq "0" || $vv == 0} {set vv ""}
lappend vl $vv
}
.pkglist insert {} end -id $nm -values $vl
} ; # else do not display
}
update ; # uncomment if necessary
} ; # display_packages
##### selection tags in package list ############################
# 1. selections themselves get lost too easily
# 2. the -image option for ttk::treeview tags does not look right
# Therefore a do-it-yourself implementation with column #1 reserved for
# a marker, package name in column #2, and column #0 not displayed.
# the marker could have been prefixed to the package name in column #0,
# but I think a separate marker column is a cleaner solution.
proc toggle_marked {itm cl} {
# if toggle_marked is triggered by a mouse click
# then it should do nothing unless it was a click in column #1
if {$cl ne "#1"} {
return
}
if [.pkglist tag has marked $itm] {
.pkglist tag remove marked $itm
.pkglist set $itm mk $::nomrk
} else {
.pkglist tag add marked $itm
.pkglist set $itm mk $::mrk
}
} ; # toggle_marked
##### callbacks for file events of tlmgr pipe ::tlshl (names *_cb) #####
## template for pipe callback:
#proc template_cb {mode {l ""}} {
# if {$mode eq "line"} {
# # do something
# } elseif {$mode eq "init"} {
# # do something
# } elseif {$mode eq "finish"} {
# # do something
# } else {
# lappend ::err_log "Illegal call of whatever_cb"
# err_exit
# }
#}
proc early_cb {mode {l ""}} {
# for reading initial output tlmgr
if {$mode eq "finish"} {
set ::started 1
}
}
proc log_widget_cb {mode {l ""}} {
if {$mode eq "line"} {
.lw.log.tx configure -state normal
.lw.log.tx insert end "$l\n"
} elseif {$mode eq "init"} {
.lw.log.tx configure -state normal
.lw.log.tx delete 1.0 end
} elseif {$mode eq "finish"} {
.lw.log.tx yview moveto 1
.lw.logs select .lw.log
# error log on top if it contains anything
show_err_log
if {$::tcl_platform(os) ne "Darwin"} {
.lw.log.tx configure -state disabled
}
.ent.e configure -state normal
} else {
lappend ::err_log "Illegal call of log_widget_cb"
err_exit
}
} ; # log_widget_cb
proc packages_cb {mode {l ""}} {
if $::do_remote {
set re {^([^,]+),([0-9]+),([0-9]+),([^,]*),(.*)$}
} else {
set re {^([^,]+),([0-9]+),([^,]*),(.*)$}
}
if {$mode eq "line"} {
#do_debug $l
if {($::do_remote && [regexp $re $l m pname lrev rrev catg pdescr]) || \
((! $::do_remote) && [regexp $re $l m pname lrev catg pdescr])} {
# unknown revision: 0 in database, " " in displayed list
if {! $::do_remote} {set rrev 0}
# double-quotes: remove outer, unescape inner
if {[string index $pdescr 0] eq "\""} {
set pdescr [string range $pdescr 1 end-1]
}
set pdescr [regsub -all "\\\"" $pdescr "\""]
dict set ::pkgs $pname \
[list "localrev" $lrev "remoterev" $rrev \
"category" $catg shortdesc $pdescr]
} else {
#do_debug "$::lnum no match: $l"
}
return
} elseif {$mode eq "init"} {
# is it useful to remove items one by one?
# or will the garbage collector take care of it?
foreach nm [dict keys $::pkgs] {dict unset ::pkgs $nm}
do_debug "packages_cb init with do_remote $::do_remote and filt $::filt"
return
} elseif {$mode eq "finish"} {
do_debug "packages_cb finish with do_remote $::do_remote and filt $::filt"
set ::have_remote $::do_remote
#do_debug [get_stack]
display_packages
return
} else {
lappend ::err_log "Illegal call of packages_cb"
err_exit
}
} ; # packages_cb
proc package_popup_cb {mode {l ""}} {
if {$mode eq "finish"} {
tk_messageBox -message [join $::out_log "\n"]
}
}
# procs involving running tlmgr commands #########################
proc run_cmd {cmd {cb ""}} {
set ::pipe_cb $cb
do_debug "run_cmd \"$cmd\""
enable_widgets 0
set ::out_log {}
set ::err_log {}
set ::lnum 0
if {$::pipe_cb ne ""} {$::pipe_cb "init"}
chan puts $::tlshl $cmd
chan flush $::tlshl
}
proc run_entry {} {
# TODO: some validation of $cmd
do_debug "run_entry"
set cmd [.ent.e get]
if {$cmd eq ""} return
do_debug $cmd
.ent.e delete 0 end
#.ent.prv configure -text $cmd
run_cmd $cmd log_widget_cb
}
proc package_popup {itm} {
# tk_messageBox -message $itm
run_cmd "info $itm" package_popup_cb
}
# package list; use previously set values for ::do_remote and ::filt
# we already know that we need a package list from tlmgr
proc get_and_display_packages {} {
do_debug "get_and_display_packages: filt $::filt and remote $::do_remote"
foreach k [dict keys $::pkgs] {dict unset ::pkgs $k}
set ::have_remote 0
if {$::do_remote} {
run_cmd "info --data name,localrev,remoterev,category,shortdesc" \
packages_cb
} else {
set ::have_remote 0
run_cmd "info --only-installed --data name,localrev,category,shortdesc" \
packages_cb
}
}
proc show_all_packages {} {
set ::filt ""
if $::have_remote {
display_packages
} else {
set ::do_remote 1
get_and_display_packages ; # calls display_packages as finish callback
}
} ; # show_all_packages
proc show_local_packages {} {
set ::filt filt_local
set ::do_remote 0
if {[llength [dict keys $::pkgs]] == 0} {
do_debug "show_local_packages: no packages loaded"
set ::have_remote 0
get_and_display_packages
} else {
do_debug "show_local_packages: packages already loaded"
display_packages
}
} ; # show_local_packages
proc show_collections {} {
set ::filt filt_collections
if {! $::have_remote} {
set ::do_remote 1
get_and_display_packages
} else {
display_packages
}
} ; # show_collections
proc show_upgradable {} {
set ::filt filt_upgradable
if {! $::have_remote} {
# get a complete package list
set ::do_remote 1
do_debug "show_upgradable: remote not yet loaded"
get_and_display_packages
} else {
do_debug "show_upgradable: remote already loaded"
display_packages
}
} ; # show_upgradable
# (re)initialization procs ############################
proc start_tlmgr {} {
# start the TeX Live Manager shell interface
# capture stdout into the pipe, stderr into a temp file
# below, early_cb and vwait ::started together forces tlshell
# to process initial tlmgr output before continuing
set ::pipe_cb early_cb
unset -nocomplain ::started
set ::tlshl [open "|tlmgr --machine-readable shell 2>>$::err_file" w+]
set ::err [open $::err_file r]
chan configure $::tlshl -buffering line -blocking 0
chan event $::tlshl readable read_line
vwait ::started
show_local_packages
}
proc restart_self {} {
do_debug "trying to restart"
if {$::progname eq ""} {
tk_messageBox -message "progname not found; not restarting"
return
}
catch {chan close $::tlshl}
catch {chan close $::err}
exec $::progname &
# on windows, it may take several seconds before
# the old tlshell disappears.
# oh well, windows is still windows....
exit
}
# dummy widgets for vertical spacing
set idummy -1
proc spacing {w} {
incr ::idummy
pack [label $w.$::idummy -text " "]
}
#proc pgrid {wdg args} { ; # padded grid
# set l [list grid $wdg -padx 3 -pady 3]
# foreach v $args {lappend l $v}
# eval [join $l ""]
#}
proc make_widgets {} {
wm title . "$::progname $::procid"
# width of '0', as a rough estimate of character width
set cw [font measure TkTextFont "0"]
# various info
frame .topf
pack [label .busy -textvariable ::busy] -in .topf -side right -padx 3
pack [label .more -justify left -text "Buttons (more to come)"] \
-in .topf -side left -padx 3
pack .topf -side top -fill x -expand 1
# main buttons block
frame .buttons
grid [ttk::button .pkgl -text "Show all packages" \
-command show_all_packages] \
-in .buttons -column 0 -row 1 -sticky w -padx 3 -pady 3
grid [ttk::button .locals -text "Show installed packages" \
-command {show_local_packages}] \
-in .buttons -column 1 -row 1 -sticky w -padx 3 -pady 3
grid [ttk::button .coll -text "Show collections" \
-command {show_collections}] \
-in .buttons -column 2 -row 1 -sticky w -padx 3 -pady 3
grid [ttk::button .upgr -text "Show upgradable" \
-command {show_upgradable}] \
-in .buttons -column 3 -row 1 -sticky w
pack .buttons -side top -fill x -expand 1 -padx 3 -pady 3
# command entry
spacing .
frame .ent
pack [label .ent.l -text "Type command:"] -side left -padx 3
pack [entry .ent.e -width 40] -side left -padx 3
pack [ttk::button .ent.b -text Go -command run_entry] -side left -padx 3
bind .ent.e <Return> run_entry
pack .ent -fill x -side top -expand 1
#grid [label .ent.lprv -justify left -text "Last command entry: "] \
# -row 1 -column 0
#grid [label .ent.prv -justify left] -row 1 -column 1 -sticky w
# packages list (tlmgrgui uses an old HList widget)
spacing .
frame .fpkg
ttk::treeview .pkglist -columns \
{mk name localrev remoterev shortdesc} \
-show headings -height 8 -selectmode extended \
-xscrollcommand {.pkhsb set} -yscrollcommand {.pkvsb set}
foreach \
col {mk name localrev remoterev shortdesc} \
nm {"" Name "Local Rev." "Remote Rev." Description} {
.pkglist heading $col -text $nm -anchor w
}
.pkglist column mk -width [expr $cw * 3]
.pkglist column name -width [expr $cw * 25]
.pkglist column localrev -width [expr $cw * 12]
.pkglist column remoterev -width [expr $cw * 12]
.pkglist column shortdesc -width [expr $cw * 50]
ttk::scrollbar .pkhsb -orient horizontal -command {.pkglist xview}
ttk::scrollbar .pkvsb -orient vertical -command {.pkglist yview}
grid .pkglist -in .fpkg -row 0 -column 0 -sticky news
grid .pkvsb -in .fpkg -row 0 -column 1 -sticky ns
grid .pkhsb -in .fpkg -row 1 -column 0 -sticky ew
grid columnconfigure .fpkg 0 -weight 1
pack .fpkg -side top -expand 1
bind .pkglist <space> {toggle_marked [.pkglist focus] "#1"}
bind .pkglist <Return> {toggle_marked [.pkglist focus] "#1"}
bind .pkglist <ButtonRelease-1> {toggle_marked \
[.pkglist identify item %x %y] [.pkglist identify column %x %y]}
bind .pkglist <ButtonRelease-2> \
{popup_focused [.pkglist identify item %x %y]}
bind .pkglist <ButtonRelease-2> \
{popup_focused [.pkglist identify item %x %y]}
bind .pkglist <ButtonRelease-3> \
{popup_focused [.pkglist identify item %x %y]}
bind .pkglist <Control-ButtonRelease-1> \
{popup_focused [.pkglist identify item %x %y]}
# bottom of main window
frame .endbuttons
pack [ttk::button .q -text Quit -command exit] \
-in .endbuttons -side right -padx 3 -pady 3
pack [ttk::button .r -text "Restart self" -command restart_self] \
-in .endbuttons -side right -padx 3 -pady 3
ttk::button .showlogs -text "Show logs" -command {wm state .lw normal}
pack .showlogs -in .endbuttons -side right -padx 3
pack .endbuttons -side bottom -fill x -expand 1
# log displays: new toplevel
toplevel .lw
frame .lw.log
pack [ttk::scrollbar .lw.log.scroll -command ".lw.log.tx yview"] \
-side right -fill y
pack [text .lw.log.tx -height 10 -bd 2 -relief groove -wrap word \
-yscrollcommand ".lw.log.scroll set"] \
-expand 1 -fill both
.lw.log.tx yview moveto 1
frame .lw.err
pack [ttk::scrollbar .lw.err.scroll -command ".lw.err.tx yview"] \
-side right -fill y
pack [text .lw.err.tx -height 10 -bd 2 -relief groove -wrap word \
-yscrollcommand ".lw.err.scroll set"] \
-expand 1 -fill both
.lw.err.tx yview moveto 1
if $::ddebug {
frame .lw.dbg
pack [ttk::scrollbar .lw.dbg.scroll -command ".lw.dbg.tx yview"] \
-side right -fill y
pack [text .lw.dbg.tx -height 10 -bd 2 -relief groove -wrap word \
-yscrollcommand ".lw.dbg.scroll set"] \
-expand 1 -fill both
.lw.dbg.tx yview moveto 1
}
ttk::notebook .lw.logs
.lw.logs add .lw.log -text "Output"
.lw.logs add .lw.err -text "Errors"
if $::ddebug {
.lw.logs add .lw.dbg -text "Debug"
raise .lw.dbg .lw.logs
}
raise .lw.err .lw.logs
raise .lw.log .lw.logs
pack .lw.logs -in .lw -side top -fill both -expand 1 -padx 3
ttk::button .lw.close -text close -command {wm withdraw .lw}
pack .lw.close -side bottom -anchor e -padx 3 -pady 3
wm withdraw .lw
} ; # make_widgets
proc enable_widgets {yesno} {
if $yesno {
set st normal
set ttk_st !disabled
set ::busy "IDLE"
} else {
set st disabled
set ttk_st disabled
set ::busy "BUSY"
}
# buttons
.pkgl configure -state $ttk_st
# command entry
.ent.b configure -state $st
.ent.e configure -state $st
# package list
.pkglist state $ttk_st
# do not touch the log windows
# final buttons
.q configure -state $ttk_st
.r configure -state $ttk_st
.showlogs configure -state $ttk_st
} ; # enable_widgets
proc initialize {} {
# prepend TL to process searchpath (not needed on windows)
if {$::tcl_platform(platform) ne "windows"} {
set texbin [file dirname [info script]]
set savedir [pwd]
cd $texbin
set texbin [pwd]
cd $savedir
# prepend texbin to PATH, unless it is already the _first_
# path component
if {$::tcl_platform(platform) eq "unix"} {
set pathsep ":"
} else {
set pathsep ";"
}
set dirs [split $::env(PATH) $pathsep]
if {[lindex $dirs 0] ne $texbin} {
set ::env(PATH) "$texbin$pathsep$::env(PATH)"
}
}
# directory for temp files
set attemptdirs {}
foreach tmp {TMPDIR TEMP TMP} {
if {[lsearch [array names ::env] $tmp] >= 0} {
lappend attemptdirs $::env($tmp)
}
}
if {$::tcl_platform(os) eq "Darwin"} {
lappend attemptdirs "/private/tmp"
}
if {$::tcl_platform(platform) eq "unix"} {
lappend attemptdirs "/tmp"
}
lappend attemptdirs [pwd]
set ::tempsub ""
foreach tmp $attemptdirs {
if {$::tcl_platform(platform) eq "windows"} {
regsub -all {\\} $tmp {/} tmp
}
if {[file isdirectory $tmp]} {
# no real point in randomizing directory name itself
if {$::tcl_platform(platform) eq "unix"} {
set ::tempsub [file join $tmp $::env(USER)]
} else {
set ::tempsub [file join $tmp $::env(USERNAME)]
}
append ::tempsub "-tlshell"
if {! [catch {file mkdir $::tempsub}]} {break} ;# success
}
}
if {$::tempsub eq "" || [file isdirectory $::tempsub] == 0} {
error "Cannot create directory for temporary files"
}
# temp file for stderr
set ::err_file [maketemp ".err_tlshl"]
make_widgets
start_tlmgr
}; # initialize
initialize
|