[Tkabber-dev] r67 - throwaway/ctcomp2

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Wed Oct 3 21:52:39 MSD 2007


Author: kostix
Date: 2007-10-03 21:52:38 +0400 (Wed, 03 Oct 2007)
New Revision: 67

Added:
   throwaway/ctcomp2/ctcomp.tcl
Log:
Imported testbed with ctcomp remake.
Bindtags approach sort of works.


Added: throwaway/ctcomp2/ctcomp.tcl
===================================================================
--- throwaway/ctcomp2/ctcomp.tcl	                        (rev 0)
+++ throwaway/ctcomp2/ctcomp.tcl	2007-10-03 17:52:38 UTC (rev 67)
@@ -0,0 +1,429 @@
+# $Id$
+# "ctcomp" Tkabber plugin -- "Chat text completion".
+# Written by Konstantin Khomoutov <flatworm at users.sourceforge.net>
+# See "lisence.terms" for distribution details.
+# Consult README for the information and usage guidelines.
+
+namespace eval ctcomp {
+	variable options
+
+	set options(pattern) {\m%s\w*\M}
+
+	event add <<ChatTextCompNext>>   <Control-n>
+	event add <<ChatTextCompPrev>>   <Control-p>
+	event add <<ChatTextCompCancel>> <Escape>
+
+	bind ChatTextCompInactive <<ChatTextCompNext>> [namespace code {
+		activate %W
+		offer_next %W
+	}]
+	bind ChatTextCompInactive <<ChatTextCompPrev>> [namespace code {
+		activate %W
+		offer_prev %W
+	}]
+
+	bind ChatTextCompActive <<ChatTextCompNext>> [namespace code {
+		offer_next %W
+	}]
+	bind ChatTextCompActive <<ChatTextCompPrev>> [namespace code {
+		offer_prev %W
+	}]
+	bind ChatTextCompActive <<ChatTextCompCancel>> [namespace code {
+		_cancel %W
+		deactivate %W
+	}]
+	bind ChatTextCompActive <Key> [namespace code {
+		deactivate %W
+	}]
+}
+
+# TODO remove in production:
+namespace eval chat {
+	proc input_win chatid { return .iw }
+	proc chat_win  chatid { return .cw }
+}
+
+#### New code:
+
+proc ctcomp::btags {w op args} {
+	switch -- $op {
+		insert {
+			eval [list BindtagsInsert $w] $args
+		}
+		delete {
+			if {[llength $args] != 1]} {
+				return -code error "Wrong # args: should be\
+					\"btags window delete tag\""
+			}
+			set btags [bindtags $w]
+			set ix [lsearch -exact $btags [lindex $args 0]]
+			if {$ix >= 0} {
+				bindtags $win [lreplace $btags $ix $ix]
+			}
+			bindtags $win
+		}
+		replace {
+		}
+		default {
+			return -code error "Bad operation \"$op\":\
+				must be insert or delete"
+		}
+	}
+}
+
+proc ctcomp::BindtagsInsert {win tag args} {
+	set ix -1
+
+	foreach {opt val} $args {
+		switch -- $opt {
+			-before {
+				set ix [lsearch -exact [bindtags $win] $val]
+				incr ix -1
+			}
+			-after {
+				set ix [lsearch -exact [bindtags $win] $val]
+				incr ix 1
+			}
+			-at {
+				set ix $val
+			}
+			default {
+				return -code error "Bad option \"$opt\":\
+					must be one of -before, -after or -at"
+			}
+		}
+	}
+}
+
+proc ctcomp::initialize iw {
+	bindtags $iw [linsert [bindtags $iw] 0 ChatTextCompInactive]
+}
+
+proc ctcomp::activate iw {
+	set btags [bindtags $iw]
+	set ix [lsearch -exact $btags ChatTextCompInactive]
+	bindtags $iw [lreplace $btags $ix $ix ChatTextCompActive]
+}
+
+proc ctcomp::deactivate iw {
+	set btags [bindtags $iw]
+	set ix [lsearch -exact $btags ChatTextCompActive]
+	bindtags $iw [lreplace $btags $ix $ix ChatTextCompInactive]
+}
+
+proc ctcomp::offer_next w {
+	puts [info level 0]
+}
+
+proc ctcomp::offer_prev w {
+	puts [info level 0]
+}
+
+proc ctcomp::_cancel w {
+	puts [info level 0]
+}
+
+#### Legacy code:
+
+proc ctcomp::prepare {chatid type} {
+	variable options
+	set token [namespace current]::state$chatid
+	variable $token
+	upvar 0 $token state
+
+	array set state [list chatid $chatid]
+
+	set iw [chat::input_win $chatid]
+	set cw [chat::chat_win $chatid]
+
+	set btoken [string map {% %%} $token] ;# % is special in bindings
+
+	bind $iw $options(next_match) \
+		[namespace code [list match next for $btoken]]
+
+	bind $iw $options(prev_match) \
+		[namespace code [list match prev for $btoken]]
+
+	bind $iw $options(cancel_match) \
+		[namespace code [list cancel $btoken]]
+
+	set prev [bind $iw <Key>]
+	bind $iw <Key> \
+		[namespace code [list keypress_any $btoken]]
+	bind $iw <Key> \
+		+$prev
+
+	bind $iw <space> \
+		[namespace code [list keypress_space $btoken]]
+
+	set prev [bind $iw <Return>]
+	bind $iw <Return> \
+		[namespace code [list keypress_return $btoken]]
+	bind $iw <Return> \
+		+$prev
+
+	# Set initial state -- inactive:
+	reset_state $token
+
+	# Kind of destructor for per-chat state:
+	bind $iw <Destroy> \
+		+[namespace code [list array unset $btoken]]
+
+	# TODO the color must be tweakable via option DB:
+	$iw tag configure ctcomp/submatch -background pink
+}
+
+proc ctcomp::pattern what {
+	variable options
+	# TODO must escape RE magic chars after [format]ting:
+	format $options(pattern) $what
+}
+
+proc ctcomp::yield {"from" t} {
+	set from [tk::TextPrevPos $t insert tcl_startOfPreviousWord]
+	$t get $from insert
+}
+
+proc ctcomp::get_matches {"for" what "in" token} {
+	variable $token
+	upvar 0 $token state
+
+	set t [chat::chat_win $state(chatid)]
+	set pos 1.0
+
+	while 1 {
+		set at [$t search -count len -regexp [pattern $what] $pos end]
+		if {$at == {}} break
+
+		set match [$t get $at "$at + $len chars"]
+		set seen($match) {}
+
+		set pos [$t index "$at + 1 char"]
+	}
+
+	lsort -dictionary [array names seen]
+}
+
+proc ctcomp::wraparound {"in" token} {
+	show info $token "Wrapped around"
+}
+
+proc ctcomp::advance {"to" where "in" token} {
+	variable $token
+	upvar 0 $token state
+	upvar 0 state(last) last
+
+	switch -- $where {
+		next {
+			incr last
+			if {$last > [llength $state(matches)]} {
+				set last 0
+				wraparound in $token
+			}
+		}
+		prev {
+			incr last -1
+			if {$last < 0} {
+				set last [expr {[llength $state(matches)] - 1}]
+				wraparound in $token
+			}
+		}
+		default {
+			error "bad match: $match; should be \"next\" or \"prev\""
+		}
+	}
+}
+
+proc ctcomp::match {where "for" token} {
+	variable $token
+	upvar 0 $token state
+	upvar 0 state(chatid)  chatid
+	upvar 0 state(what)    what
+	upvar 0 state(matches) matches
+	upvar 0 state(last)    last
+
+	set iw [chat::input_win $chatid]
+	set cw [chat::chat_win  $chatid]
+
+	if {!$state(active)} {
+		set what [yield from $iw]
+		if {[string length $what] == 0} return
+
+		set state(matches) [get_matches for $what in $token]
+		if {[llength $matches] == 0} {
+			show info $token "No match for $what"
+			return
+		}
+
+		set last 0
+	} else {
+		advance to $where in $token
+	}
+
+	set match [lindex $matches $last]
+	set submatch [string range $match [string length $what] end]
+
+	if {$state(active)} {
+		$iw delete comp_start comp_end
+	} else {
+		$iw mark set comp_start insert
+		$iw mark gravity comp_start left
+	}
+	$iw insert comp_start $submatch ctcomp/submatch
+	$iw mark set comp_end insert
+	$iw mark gravity comp_end right
+
+	set state(active) 1
+
+	return -code break ;# prevent further keypress processing
+}
+
+proc ctcomp::cancel {token} {
+	variable $token
+	upvar 0 $token state
+
+	if {!$state(active)} return
+
+	set iw [chat::input_win $state(chatid)]
+
+	$iw delete comp_start comp_end
+	$iw mark unset comp_start
+	$iw mark unset comp_end
+
+	reset_state $token
+}
+
+proc ctcomp::reset_state {token} {
+	variable $token
+	upvar 0 $token state
+
+	set state(active) 0
+	set state(matches) {}
+	set state(last) ""
+	set state(what) ""
+}
+
+proc ctcomp::commit token {
+	variable $token
+	upvar 0 $token state
+	
+	#if {!$state(active)} return
+	if {!$state(active)} { return -code continue }
+
+	set iw [chat::input_win $state(chatid)]
+
+	$iw tag remove ctcomp/submatch comp_start comp_end
+	$iw mark unset comp_start
+	$iw mark unset comp_end
+
+	reset_state $token
+}
+
+proc ctcomp::keypress_any token {
+	variable $token
+	upvar 0 $token state
+	
+	if {!$state(active)} return
+
+	cancel $token
+}
+
+proc ctcomp::keypress_space token {
+	variable options
+	variable $token
+	upvar 0 $token state
+	
+	if {!$state(active)} return
+
+	if {$options(space_cancels_completion)} {
+		cancel $token
+	} else {
+		commit $token
+	}
+}
+
+proc ctcomp::keypress_return token {
+	variable $token
+	upvar 0 $token state
+	
+	if {!$state(active)} return
+
+	commit $token
+
+	return -code break
+}
+
+# $type should be either "info" or "error"
+proc ctcomp::show {type token msg} {
+	variable $token
+	upvar 0 ${token}(chatid) chatid
+
+	set jid [chat::get_jid $chatid]
+	set cw [chat::chat_win $chatid]
+
+	chat::add_message $chatid $jid $type $msg {}
+}
+
+proc ctcomp::on_event_spec_changed {where what op} {
+	return
+
+	variable $where
+	upvar 0 ${where}($what) this
+	upvar 0 ${where}(prev_$what) prev
+	if {![info exists prev]} { set prev "" }
+
+	if {$this == $prev} return ;# no change
+
+	if {$this == ""} { # empty value => remove binding
+		event delete $event $prev
+		set prev ""
+		return
+	}
+
+	if {[is_valid_event_spec $this]} {
+		event delete $event $prev
+		event add $event $this
+		set prev $this
+	} else {
+		set this $prev
+	}
+}
+
+proc ctcomp::is_valid_event_spec spec {
+	set f [frame .testframemustnotexist]
+
+	set ok [catch {bind $f $spec bogus}]
+
+	if {!$ok} {
+		global errorInfo
+		set errorInfo [::msgcat::mc "...testing event valididy..."]
+		bgerror [::msgcat::mc "Bad event: $options(binding)"]
+	}
+
+	destroy $f
+	return $ok
+}
+
+#### Action:
+
+wm geometry . 417x180
+
+text .cw -state disabled
+text .iw -height 3
+
+grid .cw -column 0 -row 0 -sticky news
+grid .iw -column 0 -row 1 -sticky news
+
+grid rowconfigure . 0 -weight 1
+grid rowconfigure . 1 -weight 0
+grid columnconfigure . 0 -weight 1
+
+if {[string equal $tcl_platform(platform) windows]} {
+console eval { wm protocol . WM_DELETE_WINDOW exit }
+console show
+}
+
+ctcomp::initialize .iw
+
+focus -force .iw
+


Property changes on: throwaway/ctcomp2/ctcomp.tcl
___________________________________________________________________
Name: svn:keywords
   + Id
Name: svn:eol-style
   + native



More information about the Tkabber-dev mailing list