summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/scripts/tlshell/tlshell.tcl
blob: 41a81cb5a326ecdbf980d7c81c6f1b59411f3297 (plain)
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
#!/usr/bin/env wish8.5
package require Tk

# This version:
# - example of doing something with selected database item
# - restart self

# windows: most scripts run via [w]runscript.

# linux: tlshell.tcl MUST  be run via a symlink in a directory
# which also contains (a symlink to) kpsewhich.
# This directory will be prepended to the searchpath.
# let kpsewhich disentangle symlinks.

# short wait in case of restart. Would this be useful?
# after 100

# for security:
catch {rename send {}}

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 {}

# pkgs: dict of package dicts
set pkgs {}

set prmpt "tlmgr>"
set busy 0

set ddebug 0
proc do_debug {s} {
  if {$::ddebug} {
    puts stderr $s
  }
}

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
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 {
    do_debug "read_err: one iteration"
    set len [chan gets $::err l]
    if {$len >= 0} {
      lappend ::err_log $l
    } else {
      return
    }
  }
}

# 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 {} {
  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
  } elseif {$len >= 0} {
    do_debug "read: $l"
    if {[string first $::prmpt $l] == 0} {
      # prompt line: done with command
      read_err
      set ::busy "IDLE"
      $::pipe_cb "finish"
    } else {
      lappend ::out_log $l
      $::pipe_cb "line" "$l"
    }
  }
}

proc show_err {} {
  do_debug "show_err"
  .err.tx configure -state normal
  .err.tx delete 1.0 end
  if {[llength $::err_log] > 0} {
    foreach l $::err_log {.err.tx insert end "$l\n"}
    .err.tx yview moveto 1
    .logs select .err
  }
  if {$::tcl_platform(os) ne "Darwin"} {
    # os x: text widget disabled => no selection possible
    .err.tx configure -state disabled
  }
}

# cb: short for callback (for file events of tlmgr pipe ::tlshl)

proc empty_cb {mode {l ""}} {}

set pipe_cb empty_cb

## template for non-empty pipe callback:
#proc packages_cb {mode {l ""}} {
#  if {$mode eq "line"} {
#  } elseif {$mode eq "init"} {
#  } elseif {$mode eq "finish"} {
#  } else {
#    lappend ::err_log "Illegal call of whatever_cb"
#    err_exit
#  }
#}

proc log_widget_cb {mode {l ""}} {
  if {$mode eq "line"} {
    .log.tx configure -state normal
    do_debug "to log widget:"
    do_debug $l
    .log.tx insert end "$l\n"
  } elseif {$mode eq "init"} {
    .log.tx configure -state normal
    .log.tx delete 1.0 end
  } elseif {$mode eq "finish"} {
    .log.tx yview moveto 1
    .logs select .log
    # error log on top if it contains anything
    show_err
    if {$::tcl_platform(os) ne "Darwin"} {
      .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 {$mode eq "line"} {
    # .pkglist configure -state normal
    set re {^([ i]) ([^: ]+): (.*)$}
    if {[regexp $re $l m is_inst pname pdescr]} {
      do_debug "Match: $l"
      # for now, we assume that there are no duplicates
      if {$is_inst eq " "} {set is_inst false} else {set is_inst true}
      dict set ::pkgs $pname {$pdescr $is_inst}
      .pkglist insert {} end -id $pname -values \
          [list [expr {$is_inst ? {X} : {}}] $pname $pdescr]
    } else {
      do_debug "No match: $l"
    }
  } elseif {$mode eq "init"} {
    foreach k [dict keys $::pkgs] {dict unset ::pkgs $k}
  } elseif {$mode eq "finish"} {
    # fill_package_listbox
  } else {
    lappend ::err_log "Illegal call of packages_cb"
    err_exit
  }
} ; # log_widget_cb

proc package_popup_cb {mode {l ""}} {
  if {$mode eq "finish"} {
    tk_messageBox -message [join $::out_log "\n"]
  }
}

# running tlmgr ############################################

proc run_cmd {cmd} {
  do_debug "run_cmd \"$cmd\""
  set ::out_log {}
  set ::err_log {}
  $::pipe_cb "init"
  chan puts $::tlshl $cmd
  chan flush $::tlshl
  do_debug "posting busy"
  set ::busy "BUSY"
  do_debug "puts and flush"
}

proc start_tlmgr {} {
  # start the TeX Live Manager shell interface
  # capture stdout into the pipe, stderr into a temp file
  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
  set ::pipe_cb empty_cb
}

# no more restart of tlmgr only

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 &
  exit
}

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
  .ent.e configure -state disabled
  set ::pipe_cb log_widget_cb
  run_cmd $cmd
}

proc package_popup {it} {
  # tk_messageBox -message $it
  set ::pipe_cb package_popup_cb
  run_cmd "info $it"
}

proc view_collections {} {
  set cmd "info collections"
  set ::pipe_cb packages_cb
  run_cmd $cmd
}

proc make_widgets {} {

  wm title . "$::progname $::procid"

  # width of '0', as a rough estimate of character width
  set cw [font measure TkTextFont "0"]

  frame .buttons
  grid [label .more -justify left -text "Buttons (more to come)"] \
      -in .buttons -column 0 -columnspan 2 -row 0 -sticky w
  grid [ttk::button .collections -text "Show collections" \
            -command view_collections] \
      -in .buttons -column 0 -row 1 -sticky w
  pack .buttons -side top -fill x -expand 1

  # command entry
  frame .ent
  grid [label .ent.l -text "Type command:" -justify left] -row 0 -column 0 \
      -sticky w
  grid [ttk::button .ent.b -text Run -command run_entry] \
      -row 0 -column 2 -sticky w
  grid [entry .ent.e -width 20] -row 0 -column 1 -sticky ew
  bind .ent.e <Return> run_entry
  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
  grid [label .ent.busy -justify right -textvariable ::busy] \
      -row 1 -column 2
  grid columnconfigure .ent 1 -weight 1
  pack .ent -fill x -side top -expand 1

  # packages list (tlmgrgui uses a ptk-specific HList widget)
  frame .fpkg
  ttk::treeview .pkglist -columns {ins name description} \
      -show headings -height 8 -selectmode browse \
      -xscrollcommand {.pkhsb set} -yscrollcommand {.pkvsb set}
  foreach col {ins name description} nm {{Inst.} Name Description} {
    .pkglist heading $col -text $nm -anchor w
  }
  .pkglist column ins -width [expr $cw * 5]
  .pkglist column name -width [expr $cw * 25]
  .pkglist column description -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 2 -weight 1
  pack .fpkg -side top -expand 1
  bind .pkglist <ButtonRelease> {package_popup [.pkglist identify item %x %y]}
  bind .pkglist <space> {package_popup [.pkglist selection]}
  bind .pkglist <Return> {package_popup [.pkglist selection]}

  # log displays
  frame .log
  pack [ttk::scrollbar .log.scroll -command ".log.tx yview"] \
      -side right -fill y
  pack [text .log.tx -height 10 -bd 2 -relief groove -wrap word \
      -yscrollcommand ".log.scroll set"] \
      -expand 1 -fill both
  .log.tx yview moveto 1

  frame .err
  pack [ttk::scrollbar .err.scroll -command ".err.tx yview"] \
      -side right -fill y
  pack [text .err.tx -height 10 -bd 2 -relief groove -wrap word \
      -yscrollcommand ".err.scroll set"] \
      -expand 1 -fill both
  .err.tx yview moveto 1

  ttk::notebook .logs
  .logs add .log -text "Output"
  .logs add .err -text "Errors"
  raise .err .logs
  raise .log .logs
  pack .logs -side top -fill x -expand 1 -padx 3 -pady 6

  # finally...
  frame .endbuttons
  pack [ttk::button .q -text Quit -command exit] \
      -in .endbuttons -side right
  # pack [ttk::button .r -text "Restart tlmgr" -command restart_tlmgr] \
  #     -in .endbuttons -side right
  pack [ttk::button .s -text "Restart self" -command restart_self] \
      -in .endbuttons -side right
  pack .endbuttons -side bottom -fill x -expand 1
} ; # make_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