TStcltk 発言

こんにちは、山本です。
大きなメールですけど、Tcl/Tkネタが少ないので(^^;、
汎用的に使えるスクリプトをpostします。

このスクリプトを実行すると、text widgetでundoとredoが
出来るようになります。使い方も簡単です。

source text2.tcl
pack [text .t1] [text .t2]

Windowsでは、Ctrlキー+zでundo、Ctrlキー+Shiftキー+zでredo、
Mac(Classic)では、Commandキー+zでundo、Commandキー+Shiftキー+zでredo、
をbindしています。UNIXではbindしていない上、動作未確認です。

-----[text2.tcl]----------------------------------------------------------------
# // appended bindings /////////////////////////////////////////////////////////
switch $tcl_platform(platform) {
    windows {
        bind Text <Control-z> {tkText2Undo %W}
        bind Text <Control-Z> {tkText2Redo %W}
    }
    macintosh {
        bind Text <Command-z> {tkText2Undo %W}
        bind Text <Command-Z> {tkText2Redo %W}
    }
}

# // text2 procedures //////////////////////////////////////////////////////////
namespace eval tkText2 {
    variable undo
    variable redo
    variable macro
}

proc tkText2Initialize {w} {
    set tkText2::undo($w) {}
    set tkText2::redo($w) {}
}

proc tkText2Insert {w index chars} {
    set index [$w index $index]
    $w insert $index $chars
    lappend tkText2::undo($w) [list I $index $chars]
    set tkText2::redo($w) {}
}

proc tkText2Delete {w anchor start {end {}}} {
    if {$end == ""} {
        set start [$w index $start]
        set chars [$w get $start]
        $w delete $start
    } {
        set start [$w index $start]
        set end [$w index $end]
        set chars [$w get $start $end]
        $w delete $start $end
    }
    lappend tkText2::undo($w) [list $anchor $start $end $chars]
    set tkText2::redo($w) {}
}

proc tkText2Redo {w} {
    if ![info exists tkText2::redo($w)] {return}
    set history [lindex $tkText2::redo($w) end]
    set tkText2::redo($w) [lreplace $tkText2::redo($w) end end]
    if [string equal $history ""] {return}
    switch [lindex $history 0] {
        I {
            set index [lindex $history 1]
            set chars [lindex $history 2]
            $w insert $index $chars
            set index $index+[string length $chars]c
        }
        > -
        < {
            set index [lindex $history 1]
            set end [lindex $history 2]
            set chars [lindex $history 3]
            if [string equal $end ""] {
                $w delete $index
            } {
                $w delete $index $end
            }
        }
    }
    $w mark set insert $index
    $w see insert
    lappend tkText2::undo($w) $history
}

proc tkText2Undo {w} {
    if ![info exists tkText2::undo($w)] {return}
    set history [lindex $tkText2::undo($w) end]
    set tkText2::undo($w) [lreplace $tkText2::undo($w) end end]
    if [string equal $history ""] {return}
    switch [lindex $history 0] {
        I {
            set index [lindex $history 1]
            set chars [lindex $history 2]
            $w delete $index $index+[string length $chars]c
        }
        > -
        < {
            set start [lindex $history 1]
            set index [lindex $history 2]
            set chars [lindex $history 3]
            if [string equal $index ""] {set index $start+1c}
            $w insert $start $chars
            if {[lindex $history 0] == "<"} {
                set index $start
            }
        }
    }
    $w mark set insert $index
    $w see insert
    lappend tkText2::redo($w) $history
}

# // over-ridden procedures ////////////////////////////////////////////////////
bind Text <Delete> {
    if {[string compare [%W tag nextrange sel 1.0 end] ""]} {
    tkText2Delete %W < sel.first sel.last
    } else {
    tkText2Delete %W < insert
    %W see insert
    }
}
bind Text <BackSpace> {
    if {[string compare [%W tag nextrange sel 1.0 end] ""]} {
    tkText2Delete %W > sel.first sel.last
    } elseif {[%W compare insert != 1.0]} {
    tkText2Delete %W > insert-1c
    %W see insert
    }
}

bind Text <<Clear>> {
    catch {tkText2Delete %W > sel.first sel.last}
}
bind Text <Control-d> {
    if {!$tk_strictMotif} {
    tkText2Delete %W < insert
    }
}
bind Text <Control-k> {
    if {!$tk_strictMotif} {
    if {[%W compare insert == {insert lineend}]} {
        tkText2Delete %W < insert
    } else {
        tkText2Delete %W < insert {insert lineend}
    }
    }
}
bind Text <Control-o> {
    if {!$tk_strictMotif} {
    tkText2Insert %W insert \n
    %W mark set insert insert-1c
    }
}

bind Text <Meta-d> {
    if {!$tk_strictMotif} {
    tkText2Delete %W < insert [tkTextNextWord %W insert]
    }
}
bind Text <Meta-BackSpace> {
    if {!$tk_strictMotif} {
    tkText2Delete %W > [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert
    }
}
bind Text <Meta-Delete> {
    if {!$tk_strictMotif} {
    tkText2Delete %W > [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert
    }
}

bind Text <Control-h> {
    if {!$tk_strictMotif} {
    if {[%W compare insert != 1.0]} {
        tkText2Delete %W > insert-1c
        %W see insert
    }
    }
}

proc tkTextPaste {w x y} {
    $w mark set insert [tkTextClosestGap $w $x $y]
    catch {tkText2Insert $w insert [selection get -displayof $w]}
    if {[string equal [$w cget -state] "normal"]} {focus $w}
}

proc tkTextInsert {w s} {
    if {[string equal $s ""] || [string equal [$w cget -state] "disabled"]} {
    return
    }
    catch {
    if {[$w compare sel.first <= insert] \
        && [$w compare sel.last >= insert]} {
        tkText2Delete $w > sel.first sel.last
    }
    }
    tkText2Insert $w insert $s
    $w see insert
}

proc tkTextTranspose w {
    set pos insert
    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
    }
    tkText2Delete $w > "$pos - 2 char" $pos
    tkText2Insert $w insert $new
    $w see insert
}

proc tk_textCut w {
    if {![catch {set data [$w get sel.first sel.last]}]} {
    clipboard clear -displayof $w
    clipboard append -displayof $w $data
    tkText2Delete $w > sel.first sel.last
    }
}

proc tk_textPaste w {
    global tcl_platform
    catch {
    if {[string compare $tcl_platform(platform) "unix"]} {
        catch {
        tkText2Delete $w > sel.first sel.last
        }
    }
    tkText2Insert $w insert [selection get -displayof $w -selection CLIPBOARD]
    }
}

--
Koichi Yamamoto, 
http://www3.ocn.ne.jp/~yamako/