diff options
Diffstat (limited to 'Master/texmf-dist/source/latex/tcldoc/dtxload.tcl')
| -rw-r--r-- | Master/texmf-dist/source/latex/tcldoc/dtxload.tcl | 361 |
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'. |