text.tcl

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

# w -		The text window in which to copy

proc tkTextCopy w {
    global tkText tkBind

    if {![catch {set str [${w} get sel.first sel.last]}]} {
        clipboard clear -displayof ${w}
        catch {
            clipboard append -displayof ${w} -- ${str}
        }
        tkTextPushTagBuffer [tkTextCopyTagBuffer ${w} sel.first sel.last] 0

        # $w tag remove sel 1.0 end
        set tkBind(${w},arg) {}
        set tkText(${w},prevCmd) Copy
        set tkBind(${w},mesg) {}
    }
}

# tkTextCut --
# Cut currently marked region onto kill buffer stack
#
# Arguments:
# w -		The text window in which to cut

proc tkTextCut {w} {
    if {[selection own -displayof ${w}] != ${w}} {
        tkTextCheckMark ${w} 1
    }
    tkTextDelete ${w} emacs insert 1 1
}

# tkTextReTag --
# Wrapper around tag add/remove commands to handle undo.
#
# Arguments:
# w -		The text window in which to modify count
# ndx1,ndx2 -	Text indices surrounding text to retag
# rlist - 	List of Tags to remove
# alist - 	List of Tags to add

proc tkTextReTag {w ndx1 ndx2 rlist alist} {
    global tkText tkBind

    set cutbuf [tkTextCopyTagBuffer ${w} ${ndx1} ${ndx2}]
    foreach tagname ${rlist} {
        ${w} tag remove ${tagname} ${ndx1} ${ndx2}
    }
    foreach tagname ${alist} {
        ${w} tag add ${tagname} ${ndx1} ${ndx2}
    }
    tkTextUndoPush ${w} ${cutbuf} ${ndx1} ${ndx2}

    set tkText(${w},markActive) 0
    set tkBind(${w},arg) {}
    set tkText(${w},prevCmd) ReTag
    set tkBind(${w},mesg) {}
}

# tkTextNumKey --
# Check if currenlty building a number argument and if so, append to
# the argument. Otherwise, insert the number in the text.
#
# Arguments:
# w -		The text window in which to yank
# a -		The ascii character of key (decimal number)

proc tkTextNumKey {w a} {
    global tkText tkBind
    if {![string length $tkBind(${w},arg)]} {
        tkTextInsertChar ${w} ${a}
    } else {
        tkBindArgKey ${w} ${a}
    }
}

# tkTextPlaceChar --
# Returns the index of the character that is 'n' characters
# away from the current index
#
# Arguments:
# w -		The text window in which the cursor is to move.
# n -		The number of chars to move: -1 for left one char,
#		+1 for right one char.

proc tkTextPlaceChar {w n {ndx insert}} {
    global tkText

    set n [tkBindDefArg ${w} ${n}]
    if {${n} > -1} {
        set n "+${n}"
    }
    return [${w} index "${ndx} ${n} char"]
}

# tkTextPlaceWord --
# Returns the index of the character that is 'n' words
# away from the current index
#
# Arguments:
# w -		The text window in which the cursor is to move.
# n -		The number of words to move: -1 for left one word,
#		+1 for right one word.

proc tkTextPlaceWord {w n {ndx insert}} {
    global tkText

    set n [tkBindDefArg ${w} ${n}]
    return [tkTextWordIndex ${w} ${ndx} ${n}]
}

# tkTextPlaceHome --
# Moves cursor to beginning of current line and then 'n-1' lines
#
# Arguments:
# w -		The text window in which the cursor is to move.
# n -		The number of lines to move: 0 for up one line,
#		+2 for down one line.

proc tkTextPlaceHome {w n {ndx insert}} {
    global tkText

    set n [tkBindDefArg ${w} ${n}]
    incr n -1
    set ndx [tkTextPlaceLine ${w} ${n} ${ndx}]
    return [${w} index "${ndx} linestart"]
}

# tkTextPlaceEnd --
# Moves cursor to end of current line and then 'n-1' lines
#
# Arguments:
# w -		The text window in which the cursor is to move.
# n -		The number of lines to move: 0 for up one line,
#		+2 for down one line.

proc tkTextPlaceEnd {w n {ndx insert}} {
    global tkText

    set n [tkBindDefArg ${w} ${n}]
    incr n -1
    set ndx [tkTextPlaceLine ${w} ${n} ${ndx}]
    return [${w} index "${ndx} lineend"]
}

# tkTextPlaceLine --
# Returns the index of the character one line above or below the
# insertion cursor. There are two tricky things here. First,
# we want to maintain the original column across repeated operations,
# even though some lines that will get passed through don't have
# enough characters to cover the original column. Second, don't
# try to scroll past the beginning or end of the text.
#
# Arguments:
# w -		The text window in which the cursor is to move.
# n -		The number of lines to move: -1 for up one line,
#		+1 for down one line.

proc tkTextPlaceLine {w n {ndx insert}} {
    global tkText

    set i [${w} index ${ndx}]
    scan ${i} "%d.%d" line char
    if {[string compare $tkText(${w},prevPos) ${i}] != 0 ||\
      $tkText(${w},prevCmd) != "SetCursor"} {
        set tkText(${w},char) [lindex [${w} bbox ${i}] 0]
    }
    set n [tkBindDefArg ${w} ${n}]
    set new [${w} index [expr ${line} + ${n}].0]
    ${w} see ${new}
    set y [lindex [${w} bbox ${new}] 1]
    if {[catch {set new [${w} index "@$tkText(${w},char),${y}"]}]} {
        set new "insert"
    }
    if {[${w} compare ${new} == end] || [${w} compare ${new} ==\
      "${ndx} linestart"]} {
        set new ${i}
    }
    return ${new}
}

# tkTextPlacePara --
# Returns the index of the beginning of the 'n'th paragraph just
# before or after a given position in the text (the beginning of a
# paragraph is the first non-blank character after a blank line).
#
# Arguments:
# w -		The text window in which the cursor is to move.
# n -		Number of paragraphs to move: -1 for up paragraphs,
#		+1 for down paragrap

proc tkTextPlacePara {w n {ndx insert}} {
    global tkText

    set n [tkBindDefArg ${w} ${n}]
    set ndx [${w} index ${ndx}]
    if {${n} > -1} {
        for {} {${n} > 0} {incr n -1} {
            set ndx [tkTextNextPara ${w} ${ndx}]
        }
    } else {
        for {} {${n} < 0} {incr n} {
            set ndx [tkTextPrevPara ${w} ${ndx}]
        }
    }
    return ${ndx}
}

# tkTextPrevPara --
# Returns the index of the beginning of the paragraph just before a given
# position in the text (the beginning of a paragraph is the first non-blank
# character after a blank line).
#
# Arguments:
# w -		The text window in which the cursor is to move.
# pos -		Position at which to start search.

proc tkTextPrevPara {w pos} {
    set pos [${w} index "${pos} linestart"]
    while 1 {
        if {(([${w} get "${pos} - 1 line"] == "\n") &&([${w} get ${pos}] !=\
          "\n")) ||(${pos} == "1.0")} {
            if [regexp -indices {^[ 	]+(.)} [${w} get ${pos} "${pos} lineend"]\
              dummy index] {
                set pos [${w} index "${pos} + [lindex ${index} 0] chars"]
            }
            if {[${w} compare ${pos} != insert] ||(${pos} == "1.0")} {
                return ${pos}
            }
        }
        set pos [${w} index "${pos} - 1 line"]
    }
}

# tkTextNextPara --
# Returns the index of the beginning of the paragraph just after a given
# position in the text (the beginning of a paragraph is the first non-blank
# character after a blank line).
#
# Arguments:
# w -		The text window in which the cursor is to move.
# start -	Position at which to start search.

proc tkTextNextPara {w start} {
    set pos [${w} index "${start} linestart + 1 line"]
    while {[${w} get ${pos}] != "\n"} {
        if [${w} compare ${pos} == end] {
            return [${w} index "end - 1c"]
        }
        set pos [${w} index "${pos} + 1 line"]
    }
    while {[${w} get ${pos}] == "\n"} {
        set pos [${w} index "${pos} + 1 line"]
        if [${w} compare ${pos} == end] {
            return [${w} index "end - 1c"]
        }
    }
    if [regexp -indices {^[ 	]+(.)} [${w} get ${pos} "${pos} lineend"] dummy\
      index] {
        return [${w} index "${pos} + [lindex ${index} 0] chars"]
    }
    return ${pos}
}

# tkTextScrollPages --
# This is a utility procedure used in bindings for moving up and down
# pages and possibly extending the selection along the way. It scrolls
# the view in the widget by the number of pages, and it returns the
# index of the character that is at the same position in the new view
# as the insertion cursor used to be in the old view.
#
# Arguments:
# w -		The text window in which the cursor is to move.
# count -	Number of pages forward to scroll; may be negative
#		to scroll backwards.

proc tkTextScrollPages {w count} {
    set count [tkBindDefArg ${w} ${count}]
    set bbox [${w} bbox insert]
    ${w} yview scroll ${count} pages
    if {${bbox} == ""} {
        return [${w} index @[expr [winfo height ${w}]/2],0]
    }
    return [${w} index @[lindex ${bbox} 0],[lindex ${bbox} 1]]
}

# tkTextTranspose --
# This procedure implements the "transpose" function for text widgets.
# It tranposes the characters on either side of the insertion cursor,
# unless the cursor is at the end of the line. In this case it
# transposes the two characters to the left of the cursor. In either
# case, the cursor ends up to the right of the transposed characters.
#
# Arguments:
# w -		Text window in which to transpose.

proc tkTextTranspose w {
    global tkText tkBind

    ${w} tag remove sel 1.0 end
    set pos [${w} index insert]
    set cutbuf [tkTextCopyTagBuffer ${w} "insert - 1 c" "insert + 1 c"]

    if [${w} compare ${pos} != "${pos} lineend"] {
        set pos [${w} index "${pos} + 1 char"]
    }
    set new [${w} get "${pos} - 1 char"][${w} get "${pos} - 2 char"]
    if [${w} compare "${pos} - 1 char" == 1.0] {
        return
    }
    ${w} delete "${pos} - 2 char" ${pos}
    ${w} insert insert ${new}
    tkTextUndoPush ${w} ${cutbuf} "${pos} - 2 char" ${pos}
    ${w} see insert

    set tkText(${w},markActive) 0
    set tkBind(${w},arg) {}
    set tkText(${w},prevCmd) Transpose
    set tkBind(${w},mesg) {}
}

proc tkTextEvalSel w {
    global tkText tkBind

    if {[${w} tag nextrange sel 1.0 end] != ""} {
        set txt [uplevel #0 "eval \[${w} get sel.first sel.last\]"]
    } else {
        if [${w} compare emacs < insert] {
            set txt [uplevel #0 "eval \[${w} get emacs insert\]"]
        } else {
            set txt [uplevel #0 "eval \[${w} get insert emacs\]"]
        }
    }
    regsub -all \n ${txt} "^J" mtxt
    set tkBind(${w},mesg) "Eval Result: ${mtxt}"

    set tkText(${w},markActive) 0
    set tkBind(${w},arg) {}
    set tkText(${w},prevCmd) EvalSel
    return ${txt}
}

######################################################################
# EMACS MARK manipulation routines
######################################################################

# tkTextCheckMark --
# Returns 1 if no emacs mark is present in text widget

proc tkTextCheckMark {w {chksel 0}} {
    global tkText tkBind
    if {[catch "${w} index emacs"]} {
        if ${chksel} {
            if {![catch "${w} index sel.first"]} return
        }
        eval $tkBind(bell)
        #		error "No emacs mark present!"
    }
}

# tkTextSetMark --
# Set the emacs mark to the given text index on 0 argument,
# else pop off the given mark in the mark ring
#
# Arguments:
# w -		Text window in which to set mark.
# ndx -		Text index to place mark
# n - 		Index of mark to pop off, if non-zero

proc tkTextSetMark {w {ndx insert} {n 0}} {
    global tkText tkBind

    ${w} mark set emacs ${ndx}
    ${w} mark set anchor ${ndx}
}

# tkTextExchangeMark --
# Exchange index positon of insert cursor and emacs mark
#
# Arguments:
# w -		Text window in which to exchange mark.

proc tkTextExchangeMark {w} {
    global tkText
    tkTextCheckMark ${w}
    set t_m_p [${w} index insert]
    ${w} mark set insert emacs
    tkTextSetMark ${w} ${t_m_p}

    ${w} see insert
    update idletasks
}

proc tkTextGetParaBounds {w {ndx insert}} {
    global tkText tkBind

    set ndx [tkTextNextPara ${w} ${ndx}]
    if {[${w} compare "${ndx} lineend" < end]} {
        set ndx [${w} index "${ndx} -1 line"]
    }
    while {[string trim [${w} get ${ndx} "${ndx} lineend"]] == "" &&\
      [${w} compare ${ndx} > 1.0]} {
        set ndx [${w} index "${ndx} -1 line"]
    }
    set last [${w} index "${ndx} lineend +1c"]
    set first [${w} index "[tkTextPrevPara ${w} ${ndx}] linestart"]
    return [list ${first} ${last}]
}

proc tkTextMarkPara {w {dosel 1}} {
    global tkText tkBind

    #lassign [tkTextGetParaBounds $w] first last
    set bb [tkTextGetParaBounds ${w}]
    set first [lindex ${bb} 0]
    set last [lindex ${bb} 1]

    ${w} mark set insert ${first}
    ${w} mark set emacs ${last}
    ${w} mark set anchor emacs
    if ${dosel} {
        ${w} tag remove sel 1.0 end
        ${w} tag add sel insert emacs
        ${w} tag raise sel
        set tkText(${w},markActive) 1
    }

    ${w} see insert
    set tkBind(${w},arg) {}
    set tkText(${w},prevCmd) MarkPara
    set tkBind(${w},mesg) {}
}

######################################################################
# KILL BUFFER manipulation routines
######################################################################
proc tkTextCopyTagBuffer {w start stop} {
    set tagspecs {}
    set start [${w} index ${start}]
    set stop [${w} index ${stop}]

    return [list [${w} get ${start} ${stop}] ${tagspecs}]
    # Zsolt Koppany

    set ctag [${w} tag names ${start}]
    if {${ctag} == ""} {
        return [list [${w} get ${start} ${stop}] ${tagspecs}]
    }

    if {[lsearch -exact ${ctag} "rem"] != -1} {
        set beg [expr ${start} - 30]
    } else {
        set beg [expr int(${start})].0
    }

    foreach tagname [${w} tag names] {
        if {[lsearch -exact [${w} tag names ${start}] ${tagname}] > -1} {