home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 September (IDG) / Sep99.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / coreFixes.tcl < prev    next >
Encoding:
Text File  |  1999-05-03  |  9.6 KB  |  338 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "coreFixes.tcl"
  6.  #                                    created: 31/7/97 {2:09:16 am} 
  7.  #                                last update: 05/03/1999 {18:22:35 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Reorganisation carried out by Vince Darley with much help from Tom 
  15.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  16.  # Alpha is shareware; please register with the author using the register 
  17.  # button in the about box.
  18.  #  
  19.  # This file contains Tcl procs which wrap around or replace
  20.  # core (hard-coded) Alpha procs to fix some bugs they may have.
  21.  # Sadly most core Alpha bugs can't be fixed in this way.
  22.  # 
  23.  # Ultimately, one hopes, these bugs will be fixed and these procs
  24.  # can be removed...
  25.  # ###################################################################
  26.  ##
  27.  
  28. # ◊◊◊◊ Buggy procs ◊◊◊◊ #
  29.  
  30. # so any selections present are maintained
  31. rename centerRedraw __centerRedraw
  32. ;proc centerRedraw {args} {
  33.     lappend selectionEndPoints [getPos] [selEnd]
  34.     uplevel __centerRedraw $args
  35.     eval select $selectionEndPoints 
  36. }
  37.  
  38. # so any selections present are maintained
  39. rename insertToTop __insertToTop
  40. ;proc insertToTop {args} {
  41.     lappend selectionEndPoints [getPos] [selEnd]
  42.     uplevel __insertToTop $args
  43.     eval select $selectionEndPoints 
  44. }
  45.  
  46. # not really a 'fix', but it's much more efficient in many places if
  47. # you can set the mode of a window in advance  ---- else you switch
  48. # modes twice on opening the window!  This version of 'new' has a new
  49. # flag '-m' which lets you set the mode.  It also returns the name
  50. # of the window which was really opened.  Any additional flags received
  51. # by this proc are assumed to be arguments to be passed to 'setWinInfo',
  52. # except without the leading '-'.  So, for instance you can do:
  53. #     new -n "blah" -tabsize 4 -shell 1
  54. # Also args '-text' to set the text, or a useful new flag '-info'
  55. # which takes the text as the next arg, and automatically sets the
  56. # window to a read-only shell window, and scrolls to the top after
  57. # inserting the given text.  Useful for all those 'info' windows Alpha
  58. # uses!
  59. rename new __new
  60. ;proc new {args} {
  61.     set i 0
  62.     set where {}
  63.     while {[set arg [lindex $args $i]] != ""} {
  64.     incr i
  65.     switch -- $arg {
  66.         "-n" { 
  67.         set name [lindex $args $i]
  68.         incr i
  69.         }
  70.         "-g" { 
  71.         eval lappend where "-g" [lrange $args $i [incr i 3]]
  72.         incr i
  73.         }
  74.         "-m" { 
  75.         set mode [lindex $args $i]
  76.         set mi $i
  77.         incr i
  78.         }
  79.         default {
  80.         set other($arg) [lindex $args $i]
  81.         incr i
  82.         }
  83.     }
  84.     }
  85.     if {![info exists name]} {
  86.     set name "Untitled"
  87.     }
  88.     if {[info tclversion] < 8.0} {
  89.     # Alpha can't cope with colons in names
  90.     regsub -all : $name . name
  91.     }
  92.     set newname $name
  93.     
  94.     if {[lsearch -exact [winNames -f] $name] != -1} {
  95.     set i 2
  96.     while {[lsearch -exact [winNames -f] "$name <$i>"] != -1} {
  97.         incr i
  98.     }
  99.     append name " <${i}>"
  100.     }
  101.     if {![info exists mode]} {
  102.     set mode [file::whichModeForWin $newname]
  103.     }
  104.     if {[info exists mode]} {
  105.     global win::Modes
  106.     set win::Modes($name) $mode
  107.     }
  108.     
  109.     # In this section, we want to see if we need to temporally shadow out
  110.     # the global tabSize value with another value so as to avoid having to
  111.     # monkey with the winInfo array after the creation of the window
  112.     global tabSize ${mode}modeVars global::_oldTabSize
  113.     if {[info exists other(-tabsize)]} {
  114.     set global::_oldTabSize $tabSize 
  115.     set tabSize $other(-tabsize) 
  116.     unset other(-tabsize)
  117.     } elseif {[info exists ${mode}modeVars(tabSize)]} {
  118.     # The mode that the new window will open up in
  119.     # has its own value tabSize
  120.     set  global::_oldTabSize $tabSize 
  121.     set tabSize [set ${mode}modeVars(tabSize)]
  122.     }
  123.  
  124.     global alpha::platform
  125.     if {${alpha::platform} != "alpha"} {
  126.     eval __new -n [list $name] $where
  127.     } else {
  128.     eval __new -n [list $newname] $where
  129.     }
  130.     if {![info exists mode]} { 
  131.     set name [win::Current]
  132.     }
  133.     if {[info exists other(-info)]} {
  134.     setWinInfo -w $name shell 1
  135.     insertText $other(-info)
  136.     setWinInfo -w $name read-only 1
  137.     goto [minPos]
  138.     unset other(-info)
  139.     }
  140.     # We must do shell first, then text, then dirty and then others
  141.     # in any order.  Else we'd get errors like can't make window read-only
  142.     # when dirty if they were in the wrong order...
  143.     if {[info exists other(-shell)]} {
  144.     setWinInfo -w $name shell $other(-shell)
  145.     unset other(-shell)
  146.     }
  147.     if {[info exists other(-text)]} {
  148.     insertText $other(-text)
  149.     unset other(-text)
  150.     }
  151.     if {[info exists other(-dirty)]} {
  152.     setWinInfo -w $name dirty $other(-dirty)
  153.     unset other(-dirty)
  154.     }
  155.     if {[info exists other]} {
  156.     foreach a [array names other] {
  157.         setWinInfo -w $name [string range $a 1 end] $other($a)
  158.     }
  159.     }
  160.     return $name 
  161. }
  162.  
  163. # If the position to blink is offscreen, show a message with context
  164. rename blink __blink
  165. ;proc blink {pos} {
  166.     __blink $pos
  167.     getWinInfo w
  168.     if {[info exists w(currline)]} {
  169.     set topl $w(currline)
  170.     set endl [expr {$topl + $w(linesdisp)}]
  171.     scan [posToRowCol $pos] "%d %d" row col
  172.     if {$row < $topl || $row >= $endl} {
  173.         message "Matching '[getText [lineStart $pos] [pos::math $pos + 1]]'"
  174.     }
  175.     }
  176. }
  177.  
  178. # keep window vertical position the same
  179. rename revert __revert
  180. ;proc revert {args} {
  181.     getWinInfo w
  182.     set topl $w(currline)
  183.     uplevel __revert $args
  184.     revertHook [win::Current]
  185.     display [rowColToPos $topl 0]
  186. }
  187.  
  188. rename save __save
  189. ;proc save {} {
  190.     global win::Modified
  191.     set name [win::Current]
  192.     set origName $name
  193.     if {![file exists $name] && \
  194.       !([regsub { <[0-9]+>$} $name {} name] && [file exists $name])} {
  195.     if {[info exists win::Modified($origName)]} {
  196.         if {![dialog::yesno "The file appears to have been moved\
  197.           since it was last opened or saved.  Are you sure you\
  198.           want to save it?"]} {
  199.         error "Save aborted by user, since file appears to\
  200.           have been moved."
  201.         }
  202.     }
  203.     # It's a new window which has never been saved
  204.     set isNew 1
  205.     } else {
  206.     getFileInfo $name info
  207.     if {[set win::Modified($origName)] < $info(modified)} {
  208.         # File has changed on disk
  209.         if {![dialog::yesno "This file has changed on disk.  Are you\
  210.           sure you want to save it?"]} {
  211.         error "Save aborted by user, since newer file existed."
  212.         }
  213.     }
  214.     }
  215.     uplevel __save
  216.     # New windows don't get savePostHook called until Alpha 8, so
  217.     # we have to do it manually 
  218.     if {[info exists isNew] && ([info tclversion] < 8.0)} {
  219.     # The user may have cancelled the save
  220.     set name [win::Current]
  221.     if {[file exists $name] || \
  222.       ([regsub { <[0-9]+>$} $name {} name] && [file exists $name])} {
  223.         savePostHook [win::Current]
  224.     }
  225.     }
  226. }
  227.  
  228.  
  229. rename print __print
  230. ;proc print {args} {
  231.     # make sure we've got our procs loaded, else Alpha can't print
  232.     catch {printLeftHeader}
  233.     catch {printRightHeader}
  234.     if {[llength $args]} {
  235.     if {[catch __print [lindex $args 0]]} {
  236.         file::openQuietly [lindex $args 0]
  237.         uplevel __print
  238.     } 
  239.     } else {
  240.     uplevel __print
  241.     }
  242. }
  243.  
  244. # ◊◊◊◊ Procs fixed in Alpha 8 ◊◊◊◊ #
  245.  
  246. if {[info tclversion] >= 8.0} {
  247.     # We just have this proc to help people who haven't updated their code
  248.     # to use Tcl 8's native routines.  It will vanish eventually.
  249.     ;proc mkdir {dir} {
  250.     file mkdir $dir
  251.     }
  252.     return
  253. }
  254.  
  255. rename saveAs __saveAs
  256. ;proc saveAs {args} {
  257.     uplevel __saveAs $args
  258.     savePostHook [win::Current]
  259. }
  260.  
  261. # old version is a bit picky
  262. if {![string length [info commands __cd]]} {
  263.     rename cd __cd
  264. }
  265. ;proc cd args {
  266.     if {$args == ".."} { set args "::" }
  267.     if {$args == "."} { set args ":" }
  268.     if {[llength $args]} {
  269.     set path [string trim [eval list $args] "        \{\}"]
  270.     if {![regexp {:$} $path]} { append path ":" }
  271.     if {![file isdir $path] && [file isdir [pwd]$path]} {
  272.         set path ":$path"
  273.     }
  274.     __cd $path
  275.     } else {
  276.     global HOME
  277.     __cd $HOME
  278.     }
  279. }
  280.  
  281. # fix for Alpha trapping command clicks on lines which contain ':'
  282. # unnecessarily.
  283. rename icURL __icURL
  284. ;proc icURL {args} {
  285.     if {[catch {eval __icURL $args}]} {
  286.     set mods [getModifiers]
  287.     # Alpha highlights the wrong piece of text, so find mouse pos
  288.     # and generate a new piece position
  289.     if {![catch {mousePos} pos]} {
  290.         goto [eval rowColToPos $pos]
  291.     }
  292.     cmdDoubleClick -1 -1 \
  293.       [expr {$mods & 34}] [expr {$mods & 72}] [expr {$mods & 144}]
  294.     }
  295. }
  296. # bring to front does nothing if already foremost 
  297. # (the original calls activateHook, changeMode....)
  298. rename bringToFront __bringToFront
  299. ;proc bringToFront {name} {
  300.     global win::Current
  301.     if {[file tail $name] != [file tail ${win::Current}]} { 
  302.     __bringToFront $name 
  303.     }
  304. }
  305.  
  306. # if you select a directory from inside it, it has a ':', if you select
  307. # from outside, it doesn't have a colon.  There is another problem, which
  308. # is that Alpha won't let you select a volume, only a folder within a 
  309. # volume, but I haven't fixed that here.
  310. rename get_directory __get_directory
  311. ;proc get_directory {args} {
  312.     set dir [eval __get_directory $args]
  313.     regsub {:$} $dir {} dir
  314.     return $dir
  315. }
  316.  
  317.  
  318. # Setting fonts and tabs doesn't need to dirty the window
  319. rename setFontsTabs __setFontsTabs
  320. ;proc setFontsTabs {args} {
  321.     set d [winDirty]
  322.     uplevel __setFontsTabs $args
  323.     if {!$d && [winDirty]} {
  324.     setWinInfo dirty 0
  325.     }
  326. }
  327.  
  328. # Fixes two bugs: the message in the status window was incorrect (shows
  329. # the search, not replace string.  Also a replace string of nothing was
  330. # rejected.
  331. rename enterReplaceString ""
  332. ;proc enterReplaceString {} {
  333.     set t [getSelect]
  334.     replaceString $t
  335.     message "Entered replace '$t'"
  336. }
  337.  
  338.