add tlshell

git-svn-id: svn://tug.org/texlive/trunk@45015 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 295 insertions, 0 deletions

diff --git a/Master/texmf-dist/scripts/tlshell/tlshell.tcl b/Master/texmf-dist/scripts/tlshell/tlshell.tcl
new file mode 100755
index 00000000000..f724dcf720c
--- /dev/null
+++ b/Master/texmf-dist/scripts/tlshell/tlshell.tcl
@@ -0,0 +1,295 @@
+#!/usr/bin/env wish
+package require Tk
+
+# 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.
+
+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 {}
+
+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 ::err_log {}
+  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"
+    }
+  }
+  update
+}
+
+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
+  }
+  update
+  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"
+    update
+  } elseif {$mode eq "init"} {
+    .log.tx configure -state normal
+    .log.tx delete 1.0 end
+    update
+  } 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
+    update
+  } else {
+    lappend ::err_log "Illegal call of log_widget_cb"
+    err_exit
+  }
+} ; # log_widget_cb
+
+# running tlmgr ############################################
+
+proc run_cmd {cmd} {
+  do_debug "run_cmd \"$cmd\""
+  $::pipe_cb "init"
+  chan puts $::tlshl $cmd
+  chan flush $::tlshl
+  do_debug "posting busy"
+  set ::busy "BUSY"
+  update
+  do_debug "puts and flush"
+}
+
+proc run_entry {} {
+  # TODO: some validation of $cmd
+  do_debug "run_entry"
+  set cmd [.ent.e get]
+  do_debug $cmd
+  .ent.e delete 0 end
+  .prev.prv configure -text $cmd
+  update
+  .ent.e configure -state disabled
+  set ::pipe_cb log_widget_cb
+  run_cmd $cmd
+}
+
+proc make_widgets {} {
+  set textgray "#606060"
+
+  frame .ent
+  pack [label .ent.l -text "Type command:"] -side left
+  pack [button .ent.b -text Run -command run_entry] -side right
+  pack [entry .ent.e -width 60] -side left -fill x
+  pack .ent -fill x -side top
+  bind .ent.e <Return> run_entry
+
+  frame .prev
+  pack [label .prev.lprv -justify left -text "Last command entry: "] \
+      -side left
+  pack [label .prev.prv -justify left] \
+      -side left -fill x
+  pack [label .prev.busy -justify right -textvariable ::busy] -side right
+  pack .prev -side top -fill x
+
+  frame .log
+  pack [scrollbar .log.scroll -command ".log.tx yview" -bd 1] \
+      -side right -fill y
+  pack [text .log.tx -height 10 -width 80 -bd 2 -relief groove -wrap word \
+      -yscrollcommand ".log.scroll set" -fg $textgray] \
+      -expand 1 -fill both
+  .log.tx yview moveto 1
+
+  frame .err
+  pack [scrollbar .err.scroll -command ".err.tx yview" -bd 1] \
+      -side right -fill y
+  pack [text .err.tx -height 10 -width 80 -bd 2 -relief groove -wrap word \
+      -yscrollcommand ".err.scroll set" -fg $textgray] \
+      -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 both -expand 1 -padx 3 -pady 6
+
+  pack [button .b -text Quit -command exit]
+} ; # 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]} {
+      foreach i {0 1 2 3 4 5 6 7 8 9} {
+        # 10 tries to get a new name for this value of tmp
+        set ::tempsub [file join $tmp "tlshl[expr int(10000.0*rand())]"]
+        if {[file isdirectory $::tempsub]} {set ::tempsub ""; continue}
+        if {! [catch {file mkdir $::tempsub}]} {break} ;# success
+        else {set ::tempsub ""}
+      }
+      if {$::tempsub ne ""} {break}
+    }
+  }
+
+  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 the TeX Live Manager shell interface
+  # capture stdout into the pipe, stderr into a temp file
+  set ::tlshl [open "|tlmgr --autoflush 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
+  run_cmd "set machine-readable 1"
+}; # initialize
+
+initialize