Internet File Formats/InternetFileFormatsCD.bin/text/latex/mac/alpha60.hqx/Tcl/SystemCode/misc.tcl

Text File | 1995-07-16 | 17.1 KB | 703 lines

#===========================================================================
# Information about a selection or window.
#===========================================================================
proc wordCount {} {
    if {[set chars [expr {[selEnd] - [getPos]}]]} {
        set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
        set text [getSelect]
    } else {
        set chars [maxPos]
        set lines [lindex [posToRowCol $chars] 0]
        set text [getText 0 [maxPos]]
    }
    if {[regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " ret]} {
        set words [llength $ret]
    } else {
        set words [llength $text]
    }
    alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
}

# proc matchingLines {} {
#     if [catch {prompt "Regular expression:" ""} reg] return
#     if {![string length $reg]} return
#     set reg ^.*$reg.*$
#     set pos [getPos]
#     set matches 0
#     while {![catch {search -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
#         append lines "\r" [format "%4d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch]
#         set pos [lindex $mtch 1]
#         incr matches
#     }
#     new
#     insertText [format "%d matching lines\r-----" $matches] $lines "\r"
# }
set lastMatchingLines ""

proc matchingLines {} {
    global lastMatchingLines

    if [catch {prompt "Regular expression:" $lastMatchingLines} reg] return
    set lastMatchingLines $reg
    if {![string length $reg]} return
    set reg ^.*$reg.*$
    set pos 0
    set fileName [lindex [winNames -f] 0]
    set matches 0
    while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
        append lines "\r" [format "Line %d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch] "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t░$fileName"
        set pos [lindex $mtch 1]
        incr matches
    }
    new -n {* Matching Lines *}
    insertText [format "%d matching lines (<cr> to go to match)\r-----" $matches] $lines "\r"
    select [nextLineStart [nextLineStart 0]] [nextLineStart [nextLineStart [nextLineStart 0]]]

    global winModes
    set name [lindex [winNames] 0]
    changeMode [set winModes($name) Brws]
    setWinInfo dirty 0
    setWinInfo read-only 1

    shrinkWindow
}

#=============================================================================
# Random functions.
#=============================================================================

#***********************************************************************
#                                                                      *
#   Comment box and uncomment box courtesy of Igor Mikolic-Torreira.   *
#                                                                      *
#**********************************************************************/

proc commentBox {} {

# Preliminaries

    if {[getPos] == [selEnd]} {
        alertnote "Must select region to be commented."
        return
    }
    global mode
    watchCursor

# Set what the comment block will look like

    case $mode in {
        "Bib TeX" {
            set begComment "%"
            set begComLen 1
            set endComment "%"
            set endComLen 1
            set fillChar "%"
            set spaceOffset 3
        }
        "Text" {
            set begComment "!"
            set begComLen 1
            set endComment "!"
            set endComLen 1
            set fillChar "!"
            set spaceOffset 3
        }
        "Fort" {
            set begComment "C"
            set begComLen 1
            set endComment "C"
            set endComLen 1
            set fillChar "C"
            set spaceOffset 3
        }
        "Tcl" {
            set begComment "#"
            set begComLen 1
            set endComment "#"
            set endComLen 1
            set fillChar "#"
            set spaceOffset 3
        }
        "C C++" {
            set begComment "/*"
            set begComLen 2
            set endComment "*/"
            set endComLen 2
            set fillChar "*"
            set spaceOffset 3
        }
        default {
            alertnote "I don't know what comments should look like in this mode.  Sorry."
            return
        }
    }
    set aSpace " "

# First make sure we grab a full block of lines and adjust highlight

    set start [getPos]
    set start [lineStart $start]
    set end [selEnd]
    set end [nextLineStart [expr $end-1]]
    select $start $end

# Now get rid of any tabs

    if { $end < [maxPos] } then {
        createTMark stopComment [expr $end+1]
        tabsToSpaces
        gotoTMark stopComment
        set end [expr [getPos]-1]
        removeTMark stopComment
    } else {
        tabsToSpaces
        set end [maxPos]
    }
    select $start $end
    set text [getText $start $end]

# Next turn it into a list of lines--possibly drop an empty 'last line'

    set lineList [split $text "\r"]
    set emptyLine [lsearch $lineList {}]
    if { $emptyLine != -1 } then {
        set numLines [llength $lineList]
        set lineList [lrange $lineList 0 [expr $numLines-2]]
    }
    set numLines [llength $lineList]

# Find the longest line length and determine the new line length

    set maxLength 0
    foreach thisLine $lineList {
        set thisLength [string length $thisLine]
        if { $thisLength > $maxLength } then {
            set maxLength $thisLength
        }
    }
    set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]

# Now create the top & bottom bars and a blank line

    set topBar $begComment
    for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
        set topBar $topBar$fillChar
    }
    set botBar ""
    for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
        set botBar $botBar$fillChar
    }
    set botBar $botBar$endComment
    set blankLine $fillChar
    for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
        set blankLine $blankLine$aSpace
    }
    set blankLine $blankLine$fillChar

# For each line add stuff on left and spaces and stuff on right for box sides
# and concatenate everything into 'text'.  Start with topBar; end with botBar

    set text $topBar\r$blankLine\r

    set frontStuff $fillChar
    set backStuff $fillChar
    for { set i 0 } { $i < $spaceOffset } { incr i } {
        set frontStuff $frontStuff$aSpace
        set backStuff $aSpace$backStuff
    }
    set backStuffLen [string length $backStuff]

    for { set i 0 } { $i < $numLines } { incr i } {
        set thisLine [lindex $lineList $i ]
        set thisLine $frontStuff$thisLine
        set thisLength [string length $thisLine]
        set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
        for { set j 0 } { $j < $howMuchPad } { incr j } {
            set thisLine $thisLine$aSpace
        }
        set thisLine $thisLine$backStuff
        set text $text$thisLine\r
    }

    set text $text$blankLine\r$botBar\r

# Now replace the old stuff, turn spaces to tabs, and highlight

    replaceText    $start $end    $text
    set end [expr {$start+[string length $text]}]
    createTMark stopComment [expr $end+1]
    select $start $end
    spacesToTabs
    gotoTMark stopComment
    set end [expr [getPos]-1]
    removeTMark stopComment
    select $start $end
}



proc uncommentBox {} {

# Preliminaries

    if {[getPos] == [selEnd]} {
        alertnote "Must select region to be uncommented."
        return
    }
    global mode
    watchCursor

# Set what the comment block will look like

    case $mode in {
        "Bib TeX" {
            set begComment "%"
            set begComLen 1
            set endComment "%"
            set endComLen 1
            set fillChar "%"
            set spaceOffset 3
        }
        "Text" {
            set begComment "!"
            set begComLen 1
            set endComment "!"
            set endComLen 1
            set fillChar "!"
            set spaceOffset 3
        }
        "Fort" {
            set begComment "C"
            set begComLen 1
            set endComment "C"
            set endComLen 1
            set fillChar "C"
            set spaceOffset 3
        }
        "Tcl" {
            set begComment "#"
            set begComLen 1
            set endComment "#"
            set endComLen 1
            set fillChar "#"
            set spaceOffset 3
        }
        "C C++" {
            set begComment "/*"
            set begComLen 2
            set endComment "*/"
            set endComLen 2
            set fillChar "*"
            set spaceOffset 3
        }
        default {
            alertnote "I don't know what comments should look like in this mode.  Sorry."
            return
        }
    }
    set aSpace " "
    set aTab \t

# First make sure we grab a full block of lines

    set start [getPos]
    set start [lineStart $start]
    set end [selEnd]
    set end [nextLineStart [expr $end-1]]
    set text [getText $start $end]

# Make sure we're at the start and end of the box

    set startOK [string first $begComment $text]
    set endOK [string last $endComment $text]
    set textLength [string length $text]
    if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } then {
        alertnote "You must highlight the entire comment box, including the borders."
        return
    }

# Now get rid of any tabs

    if { $end < [maxPos] } then {
        createTMark stopComment [expr $end+1]
        tabsToSpaces
        gotoTMark stopComment
        set end [expr [getPos]-1]
        removeTMark stopComment
    } else {
        tabsToSpaces
        set end [maxPos]
    }
    select $start $end
    set text [getText $start $end]

# Next turn it into a list of lines--possibly drop an empty 'last line'

    set lineList [split $text "\r"]
    set emptyLine [lsearch $lineList {}]
    if { $emptyLine != -1 } then {
        set numLines [llength $lineList]
        set lineList [lrange $lineList 0 [expr $numLines-2]]
    }
    set numLines [llength $lineList]

# Delete the first and last lines, recompute number of lines

    set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
    set lineList [lreplace $lineList 0 0 ]
    set numLines [llength $lineList]

# Eliminate 2nd and 2nd-to-last lines if they are empty

    set eliminate $fillChar$aSpace$aTab
    set thisLine [lindex $lineList [expr $numLines-1]]
    set thisLine [string trim $thisLine $eliminate]
    if { [string length $thisLine] == 0 } then {
        set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
    }
    set thisLine [lindex $lineList 0]
    set thisLine [string trim $thisLine $eliminate]
    if { [string length $thisLine] == 0 } then {
        set lineList [lreplace $lineList 0 0 ]
    }
    set numLines [llength $lineList]

# For each line trim stuff on left and spaces and stuff on right and splice

    set dropFromLeft [expr $spaceOffset+1]
    set text ""
    for { set i 0 } { $i < $numLines } { incr i } {
        set thisLine [lindex $lineList $i]
        set thisLine [string trimright $thisLine $eliminate]
        set thisLine [string range $thisLine $dropFromLeft end]
        set text $text$thisLine\r
    }

# Now replace the old stuff, convert spaces back to tabs

    replaceText    $start $end    $text
    set end [expr {$start+[string    length $text]}]
    createTMark stopComment [expr $end+1]
    select $start $end
    spacesToTabs
    gotoTMark stopComment
    set end [expr [getPos]-1]
    removeTMark stopComment
    select $start $end
}


#================================================================================

proc nextFunc {} {
    searchFunc 1
}

proc prevFunc {} {
    searchFunc 0
}

proc searchFunc {dir} {
    global funcExpr
    set pos [getPos]
    select $pos
    if ($dir==1) {
        incr pos
    } else {
        set pos [expr $pos-1]
    }
    if {![catch {search -s -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
        eval select $res
    }
}

#===========================================================================
# Comment routines.
#===========================================================================
proc commentPara {} {
}



#===========================================================================
# Sorting the selection.
# AUTHOR: David C. Black     [e-mail]
#===========================================================================
proc sortLines {} {
    set ends [getEndpts]
    set start [lindex $ends 0]
    set end  [lindex $ends 1]
    if {$start == $end} {
        alertnote "You must highlight the section you wish to sort."
        return
    }
    if {[lookAt [expr $end-1]] != "\r"} {
        alertnote "The selection must consist only of complete lines."
        return
    }
    set text [getText $start [expr {$end-1}]]
    set text [join [lsort [split $text "\r"]] "\r"]
    replaceText $start [expr {$end-1}] $text
    select $start $end
}



#===========================================================================
# Dump all current settings into a file.
#===========================================================================
proc insertGlobalSettings {} {
    uplevel #0 {
        foreach var [info globals] {
            if {![catch {set $var}]} {
                insertText "set " $var " \{" [set $var] "\}\r"
            }
        }
    }
}


#================================================================================
# Substitute global variables in possibly nested list.
#================================================================================
proc subVars {words} {
    global silly
    global a
    set silly $words
    set out {}
    foreach a $words {
        if {[llength $a] == 1} {
            lappend out [uplevel #0 {eval set x $a}]
        } else {
            lappend out [subVars $a]
        }
    }
    return $out
}

#================================================================================
# Block shift left and right.
#================================================================================

proc shiftLeft {} {
    global shiftChar
    doShiftLeft "\t"

}
proc shiftLeftSpace {} {
    global shiftChar
    doShiftLeft " "
}

proc doShiftLeft {shiftChar} {
     set start [lineStart [getPos]]
     set end [nextLineStart [expr [selEnd] - 1]]
    if {$start >= $end} {set end [nextLineStart $start]}

    set text [split [getText $start [expr $end - 1]] "\r"]

    set textout ""

    foreach line $text {
        if {[string index $line 0] == $shiftChar} {
            lappend textout [string range $line 1 end]
        } else {
            lappend textout $line
        }
    }

    set text [join $textout "\r"]
    replaceText $start [expr $end - 1] $text
    select $start [expr 1 + $start + [string length $text]]
}


proc shiftRight {} {
    global shiftChar
    doShiftRight "\t"

}
proc shiftRightSpace {} {
    global shiftChar
    doShiftRight " "
}
proc doShiftRight {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [expr [selEnd] - 1]]
    if {$start >= $end} {set end [nextLineStart $start]}

    set text [split [getText $start [expr $end - 1]] "\r"]

    set textout ""

    foreach line $text {
        lappend textout $shiftChar$line
    }

    set text [join $textout "\r"]
    replaceText $start [expr $end - 1] $text
    select $start [expr 1 + $start + [string length $text]]
}



# rglobText [option list] dir pat
# 'dir' should be a properly formed directory, ending w/ a ':'. 'pat' should be
# a simple pattern w/ no directory specifications (i.e. "*.c").
proc rglobText {optlist dir pat} {

    message "$dir"
    set cmd [concat glob -t TEXT $optlist]
    lappend cmd $dir$pat
    if {[catch {eval $cmd} files]} {
        set files ""
    }

    if {![catch {glob $dir*} all]} {
        foreach f $all {
            if {[file isdir $f]} {
                set files [concat $files [rglobText $optlist $f: $pat]]
            }
        }
    }
    return $files
}


proc switchApp {} {
    set procs ""
    foreach p [processes] {
        lappend procs [lindex $p 0]
    }
    set to [listpick -p "Switch to app:" [lsort $procs]]
    if {[string length $to]} {
        switchTo $to
    }
}


proc selectAll {} {
    select 0 [maxPos]
}


proc twiddle {} {
    set pos [getPos]
    if {!$pos || ($pos == [maxPos])} return;
    if {[string length [set text [getSelect]]]} {
        if {[string length $text] == 1} {
            return
        } else {
            set sel [expr [selEnd] - 1]
            set one [lookAt $sel]
            set two [lookAt $pos]
            replaceText $pos [expr $sel + 1] "$one[getText [expr $pos+1] $sel]$two"
            select $pos [expr $sel+1]
            return
        }
    }
    set one [lookAt $pos]
    set two [lookAt [expr $pos-1]]
    replaceText [expr $pos-1] [expr $pos + 1] "$one$two"
    select  [expr $pos-1] [expr $pos + 1]
}

proc twiddleWords {} {
    global wordBreakPreface wordBreak

    if {[getPos] != [selEnd]} {
        set start1 [getPos]; set end2 [selEnd]
        select $start1
        forwardWord; set end1 [getPos]
        goto $end2
        backwardWord; set start2 [getPos]
    } else {
        select [set pos [getPos]]
        backwardWord; set start1 [getPos]
        forwardWord; set end1 [getPos]
        goto $pos
        forwardWord; set end2 [getPos]
        backwardWord; set start2 [getPos]
    }

    if {$start1 != $start2} {
        set mid [getText $end1 $start2]
        replaceText $start1 $end2 "[getText $start2 $end2]$mid[getText $start1 $end1]"
        select $start1 $end2
    }
}

#================================================================================
# Print a window using John Cho's Enscriptor (A text file printing app that
# works like Adobe Enscript.)
#

proc setupPrintMenu {} {
    global pathComments defaultPrinter modifiedVars
    if {![info exists defaultPrinter]} {
        set defaultPrinter "Alpha"
        lappend modifiedVars defaultPrinter
    }
    set m [list {/P<SPrint╔} {/P<S<I<OPrint All╔} {(-} Alpha $pathComments(kodexPath) $pathComments(enscriptorPath) $pathComments(droppsPath)]
    menu -m -n print -p printProc $m

    foreach item $m {
        if {$item == $defaultPrinter} {
            markMenuItem -m print $item on
        } else {
            markMenuItem -m print $item off
        }
    }
}

proc printProc {menu item} {
    global modifiedVars defaultPrinter pathComments
    switch -glob $item {
        "Print All"        {    if {$defaultPrinter == "Alpha"} {
                                printAll
                            } else {
                                foreach f [winNames -f] {
                                    printFile $f
                                }
                            }
                        }
        "Print"            {printFile [lindex [winNames -f] 0]}
        "Alpha"            {set defaultPrinter "Alpha"; lappend modifiedVars defaultPrinter; setupPrintMenu}
        "Kodex*"        {set defaultPrinter $pathComments(kodexPath); lappend modifiedVars defaultPrinter; setupPrintMenu}
        "Enscr*"        {set defaultPrinter $pathComments(enscriptorPath); lappend modifiedVars defaultPrinter; setupPrintMenu}
        "Send*"            {set defaultPrinter $pathComments(droppsPath); lappend modifiedVars defaultPrinter; setupPrintMenu}
    }
}


proc printFile {fname} {
    global defaultPrinter

    switch -glob $defaultPrinter {
        "Alpha"            {print}
        "Kodex*"        {openAndSendFile $fname kodexPath Kodex KoDX}
        "Enscr*"        {openAndSendFile $fname enscriptorPath Enscriptor Ens3}
        "Send*"            {openAndSendFile $fname droppsPath {DropÑPS} {DÑPS}}
    }
}


proc openAndSendFile {fname path name sig} {
    global $path

    catch {checkRunning $name $sig $path} name

    if {[winDirty]} {
        if {[askyesno "Save '$fname'?"] == "yes"} {
            save
        }
    }
    message "Sending to '$name'..."
    if {[catch {sendOpenEvent noReply $name $fname}] } {
        beep
    } else {
        switchTo $name
    }
    message ""
}