path: root/Master/texmf-dist/source/latex/tcldoc/dtxload.tcl

## (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'.