summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/source/latex/tcldoc/dtxload.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/texmf-dist/source/latex/tcldoc/dtxload.tcl')
-rw-r--r--Master/texmf-dist/source/latex/tcldoc/dtxload.tcl361
1 files changed, 361 insertions, 0 deletions
diff --git a/Master/texmf-dist/source/latex/tcldoc/dtxload.tcl b/Master/texmf-dist/source/latex/tcldoc/dtxload.tcl
new file mode 100644
index 00000000000..af26546a774
--- /dev/null
+++ b/Master/texmf-dist/source/latex/tcldoc/dtxload.tcl
@@ -0,0 +1,361 @@
+## (auto-install)
+##
+## This is file `dtxload.tcl',
+## generated with the docstrip utility.
+##
+## The original source files were:
+##
+## dtxload.dtx (with options: `tcl')
+##
+## This file may be distributed and/or modified under the conditions
+## of the LaTeX Project Public License, either version 1.2 of this
+## license or (at your option) any later version. The latest version
+## of this license is in
+## http://www.latex-project.org/lppl.txt
+## and version 1.2 or later is part of all distributions of LaTeX
+## version 1999/12/01 or later.
+##
+## This file may only be distributed together with a copy of the source
+## file from which it was generated. You may distribute that source file
+## without this generated file.
+##
+alpha::feature dtxload 1.1 {TeX} {
+ # When set, the Load Tcl Code command will be disabled in
+ # TeX files whose suffix is not dtx.
+ newPref flag onlyLoadDtxFiles 1 TeX
+ # When set, the Load Tcl Code command will only extract code
+ # from code lines in tcl and tcl* environments.
+ newPref flag onlyLoadTclEnvs 1 TeX
+ # This is the key binding for dtxload's Load Tcl Code command.
+ newPref binding loadTclCode <O/L TeX "" dtxload::load TeX
+} "" "" uninstall {this-file} \
+ maintainer {"Lars Hellstr\x9am" Lars.Hellstrom@math.umu.se} \
+ help {The dtxload package implements a command for loading
+ Tcl code that is embedded in a .dtx file without docstripping
+ the file first. For more help, LaTeX the file dtxload.dtx.}
+namespace eval dtxload {}
+proc dtxload::eval_guard {e} {
+ global dtxload::known_expressions
+ if {![info exists dtxload::known_expressions($e)]} then {
+ set dtxload::known_expressions($e)\
+ [expr {"yes" ==\
+ "[askyesno "Should <$e> modules be included?"]"}]
+ }
+ set dtxload::known_expressions($e)
+}
+proc dtxload::push_module {e p} {
+ global dtxload::module_stack
+ lappend dtxload::module_stack [list $e $p]
+}
+proc dtxload::pop_module {e p} {
+ global dtxload::module_stack dtxload::module_included\
+ dtxload::next_module_idx
+ set len [llength ${dtxload::module_stack}]
+ if {$len==0} then {return}
+ set L [lindex ${dtxload::module_stack} [expr {$len-1}]]
+ if {[lindex $L 0] != $e} then {
+ switch [buttonAlert "Module nesting error: <*[lindex $L 0]>\
+ module ended by </$e>. For which guards should the positions\
+ be pushed?" None Start End Both]\
+ {
+ Start {dtxload::push_bookmarks [lindex $L 1]}
+ End {dtxload::push_bookmarks $p}
+ Both {dtxload::push_bookmarks [lindex $L 1] $p}
+ }
+ }
+ set dtxload::module_stack\
+ [lreplace ${dtxload::module_stack} end end]
+ if {$len>=${dtxload::next_module_idx}} then {
+ incr dtxload::next_module_idx -1
+ }
+ if {[llength $L]>2} then {
+ set dtxload::module_included [lindex $L 2]
+ }
+}
+proc dtxload::push_bookmarks {args} {
+ global markStack markName
+ foreach pos $args {
+ set name mark$markName
+ incr markName
+ createTMark $name $pos
+ set fileName [win::Current]
+ set markStack [linsert $markStack 0 [list $fileName $name]]
+ }
+}
+proc dtxload::update_included {} {
+ global dtxload::module_included dtxload::module_stack\
+ dtxload::next_module_idx
+ while {${dtxload::module_included} &&\
+ ${dtxload::next_module_idx}<[llength ${dtxload::module_stack}]}\
+ {
+ set L [lindex ${dtxload::module_stack} ${dtxload::next_module_idx}]
+ lappend L ${dtxload::module_included}
+ set dtxload::module_stack [lreplace ${dtxload::module_stack}\
+ ${dtxload::next_module_idx} ${dtxload::next_module_idx} $L]
+ incr dtxload::next_module_idx
+ set dtxload::module_included [dtxload::eval_guard [lindex $L 0]]
+ }
+}
+proc dtxload::extract_line {startpos endpos} {
+ global dtxload::in_tcl_env onlyLoadTclEnvs dtxload::module_included
+ for {set pos $startpos} {[pos::compare {$pos<$endpos}]}\
+ {set pos $pos2} {
+ set pos2 [nextLineStart $pos]
+ if {$pos2>$endpos} then {set pos2 $endpos}
+ set line [getText $pos $pos2]
+ switch -regexp -- $line {
+ {^%<<} {
+ if {!$onlyLoadTclEnvs || ${dtxload::in_tcl_env}} then {
+ dtxload::update_included
+ if {${dtxload::module_included}} then {
+ alertnote "docstrip verbatim mode guard line\
+ encountered. Verbatim mode extraction is\
+ currently not supported, so I stop here."
+ goto $pos
+ return [list $endpos]
+ }
+ }
+ set endtag %[string trimright [string trimright\
+ [string range $line 3 end] \n\r] \ ]
+ while {[string trimright [string trimright $line \n\r] \ ]\
+ != $endtag} {
+ set pos $pos2
+ if {[pos::compare {$pos>=$endpos}]}\
+ then {return [list $pos]}
+ set pos2 [nextLineStart $pos]
+ if {$pos2>$endpos} then {set pos2 $endpos}
+ set line [getText $pos $pos2]
+ }
+ }
+ {^%<[*/]} {
+ if {![regexp {^%<(\*|/)([^>]+)>} $line foo modifier\
+ expression]}\
+ then {
+ if {"[askyesno "Malformed guard line \"$line\"\
+ encountered. Push position?"]"=="yes"}\
+ then {dtxload::push_bookmarks $pos}
+ } elseif {$modifier=="*"} then {
+ dtxload::push_module $expression $pos
+ } else {
+ dtxload::pop_module $expression $pos
+ }
+ }
+ {^%<} {
+ if {![regexp {^%<(-|\+|)([^>]+)>(.*)$} $line\
+ foo modifier expression code]}\
+ then {
+ if {"[askyesno "Malformed guard line \"$line\"\
+ encountered. Push position?"]"=="yes"}\
+ then {dtxload::push_bookmarks $pos}
+ } elseif {!$onlyLoadTclEnvs || ${dtxload::in_tcl_env}} then {
+ dtxload::update_included
+ if {${dtxload::module_included}} then {
+ if {[dtxload::eval_guard $expression] !=\
+ ($modifier=="-")}\
+ then {return [list $pos2 $code $pos]}
+ }
+ }
+ }
+ {^%} {
+ while {[regexp -indices {\\(begin|end) *{tcl\*?}} $line\
+ match type]} {
+ set dtxload::in_tcl_env\
+ [expr {"[eval string range \$line $type]"=="begin"}]
+ set line [string range $line\
+ [expr {[lindex $match 1]+1}] end]
+ }
+ }
+ default {
+ if {!$onlyLoadTclEnvs || ${dtxload::in_tcl_env}} then {
+ dtxload::update_included
+ if {${dtxload::module_included}}\
+ then {return [list $pos2 $line $pos]}
+ }
+ }
+ }
+ }
+ list $endpos
+}
+proc dtxload::evaluate {t} {
+ global errorInfo errorCode evaluateRemotely tcl_platform
+ if {!$evaluateRemotely} then {
+ if {[set code [catch {uplevel \#0 $t} msg]] == 1} then {
+ set L [split $errorInfo \n]
+ set errorInfo [join [lrange $L 0 [expr {[llength $L] - 4}]] \n]
+ }
+ list $code $msg $errorInfo $errorCode
+ } elseif {$tcl_platform(platform) == "macintosh"} then {
+ global tclshSig
+ app::ensureRunning $tclshSig
+ list [catch {
+ aebuild::result -t 30000 '${tclshSig}' misc dosc ----\
+ [aebuild::TEXT $t]
+ } res]\
+ $res
+ } else {
+ global tclshInterp
+ if {![info exists tclshInterp]} {
+ if {[catch {tcltk::findTclshInterp}]} {
+ return [list 1 "No shell selected"]
+ }
+ }
+ if {$tcl_platform(platform) == "windows"} {
+ if {[dde services Tk $tclshInterp] == ""} {
+ alertnote "The remote shell has died, please select a new one."
+ unset tclshInterp
+ return [dtxload::evaluate $t]
+ }
+ list [catch {dde execute Tk $tclshInterp $t} res] $res
+ } else {
+ list [catch {send $tclshInterp $t} res] $res
+ }
+ }
+}
+proc dtxload::message_log {script} {
+ set res [dtxload::evaluate $script]
+ if {[lindex $res 0]==1} then {
+ message "Tcl eval error: [lindex $res 1]"
+ expr 1
+ } else {
+ if {[string length [lindex $res 1]] == 0} then {
+ message "Tcl eval OK."
+ } else {
+ message "Tcl eval OK: [lindex $res 1]"
+ }
+ expr 0
+ }
+}
+if {[info exists dtxload::log_window_name]} then {
+ unset dtxload::log_window_name
+}
+proc dtxload::window_log {script} {
+ upvar #0 dtxload::log_window_name win
+ global win::Modes Shel::startPrompt Shel::endPrompt
+ if {[set win::Modes($win)] == "Shel"} then {
+ global Shel::histnum
+ regsub -all \n [string trimright $script] " ; " text
+ history add $text
+ set Shel::histnum [history nextid]
+ }
+ set pos [maxPos -w $win]
+ select -w $win $pos $pos
+ set dtxprompt "${Shel::startPrompt}dtxload${Shel::endPrompt} "
+ if {[set win::Modes($win)] != "Shel"} then {
+ insertText -w $win \r$dtxprompt
+ } else {
+ set stdprompt [Alpha::Prompt]
+ set pos2 [pos::math $pos - [string length $stdprompt]]
+ if {[getText -w $win $pos2 $pos] != $stdprompt} then {
+ insertText -w $win \r$dtxprompt
+ } else {
+ replaceText -w $win $pos2 $pos $dtxprompt
+ refresh
+ }
+ }
+ regsub -all \n [string trimright $script] \r$dtxprompt text
+ insertText -w $win "$text\r"
+ set res [dtxload::evaluate $script]
+ if {[lindex $res 0]==1} then {
+ insertText -w $win "Error: [lindex $res 1]\r"
+ if {[llength $res]>2} then {
+ global errorInfo
+ set errorInfo [lindex $res 2]
+ }
+ message "Tcl eval error"
+ } else {
+ if {[string length [lindex $res 1]]>0}\
+ then {insertText -w $win "[lindex $res 1]\r"}
+ message "Tcl eval OK"
+ }
+ if {[set win::Modes($win)] == "Shel"}\
+ then {insertText -w $win [Alpha::Prompt]}
+ expr {[lindex $res 0]==1}
+}
+proc dtxload::load {} {
+ global onlyLoadDtxFiles
+ if {$onlyLoadDtxFiles && ![string match *.dtx [win::CurrentTail]]}\
+ then {
+ message "Not a .dtx file."
+ return
+ }
+ set startpos [getPos]
+ set endpos [selEnd]
+ if {[pos::compare {$startpos == $endpos}]} then {
+ set startpos [minPos]
+ set endpos [maxPos]
+ }
+ global dtxload::log_window_name
+ if {
+ [info exists dtxload::log_window_name] &&
+ [lsearch -exact [winNames] ${dtxload::log_window_name}]!=-1
+ } then {set log dtxload::window_log}\
+ else {set log dtxload::message_log}
+ global dtxload::in_tcl_env dtxload::module_stack\
+ dtxload::next_module_idx dtxload::module_included
+ set dtxload::in_tcl_env\
+ [expr {[getText $startpos [pos::math {$startpos+1}]] != "%"}]
+ set dtxload::module_stack {}
+ set dtxload::next_module_idx 0
+ set dtxload::module_included 1
+ set script ""
+ set escaped 0
+ set spos none
+ while {[pos::compare $startpos < $endpos]} {
+ set extract [dtxload::extract_line $startpos $endpos]
+ if {[llength $extract]>1} then {
+ if {[string length $script]==0} then {
+ set spos [lindex $extract 2]
+ }
+ set line [lindex $extract 1]
+ if {$escaped} then {set line [string trimleft $line]}
+ set escaped [regsub -all\
+ "((^|\[^\\\\\])(\\\\\\\\)*)\\\\(\r|\n|\r\n)$" $line {\1 } line]
+ if {!$escaped} then {regsub "\r\n?\$" $line \n line}
+ append script $line
+ if {!$escaped && [info complete $script]} then {
+ if {[$log $script]} then {
+ select $spos $endpos
+ markHilite
+ return
+ } else {
+ set script ""
+ }
+ }
+ } elseif {$spos=="none"} then {
+ message "No extractable code found."
+ }
+ set startpos [lindex $extract 0]
+ }
+ if {[string length $script]>0 && [$log $script]} then {
+ select $spos $endpos
+ markHilite
+ } else {
+ global dtxload::known_expressions
+ if {[info exists dtxload::known_expressions]}\
+ then {unset dtxload::known_expressions}
+ }
+}
+proc dtxload::logdest {type {win "dtxload log"}} {
+ global dtxload::log_window_name
+ switch -exact -- $type {
+ status {
+ if {[info exists dtxload::log_window_name]}\
+ then {unset dtxload::log_window_name}
+ }
+ here {set dtxload::log_window_name [win::CurrentTail]}
+ window {
+ if {[lsearch -exact [winNames] $win] == -1} then {
+ new -n $win -shell 1 -text "This is a dtxload log window.\r"
+ }
+ set dtxload::log_window_name $win
+ }
+ shell {
+ Shel::start "Alpha" $win\
+ "This is a dtxload log window (and Alpha Tcl shell).\r"
+ set dtxload::log_window_name $win
+ }
+ }
+}
+##
+##
+## End of file `dtxload.tcl'.