[Tkabber-dev] r1084 - in trunk/tkabber: . msgs plugins/chat plugins/search

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sun Apr 8 15:06:32 MSD 2007


Author: sergei
Date: 2007-04-08 15:06:32 +0400 (Sun, 08 Apr 2007)
New Revision: 1084

Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/msgs/de.msg
   trunk/tkabber/plugins/chat/histool.tcl
   trunk/tkabber/plugins/chat/logger.tcl
   trunk/tkabber/plugins/search/spanel.tcl
Log:
	* plugins/chat/logger.tcl: Accept subdirs list when creating chatlog
	  window to prevent extra directory tree scanning (thanks to
	  Konstantin Khomoutov).

	* plugins/search/spanel.tcl: Removed checking for existence of search
	  form. It should be done in search routines. Also added 'Stop' button
	  and stop search callback (thanks to Konstantin Khomoutov).

	* plugins/chat/histool.tcl: Redone full-text search to use stop search
	  callback and to avoid [update] calls.

	* msgs/de.msg: Updated German translation (thanks to Roger
	  Sondermann).


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2007-04-08 07:50:54 UTC (rev 1083)
+++ trunk/tkabber/ChangeLog	2007-04-08 11:06:32 UTC (rev 1084)
@@ -1,3 +1,19 @@
+2007-04-08  Sergei Golovan  <sgolovan at nes.ru>
+
+	* plugins/chat/logger.tcl: Accept subdirs list when creating chatlog
+	  window to prevent extra directory tree scanning (thanks to
+	  Konstantin Khomoutov).
+
+	* plugins/search/spanel.tcl: Removed checking for existence of search
+	  form. It should be done in search routines. Also added 'Stop' button
+	  and stop search callback (thanks to Konstantin Khomoutov).
+
+	* plugins/chat/histool.tcl: Redone full-text search to use stop search
+	  callback and to avoid [update] calls.
+
+	* msgs/de.msg: Updated German translation (thanks to Roger
+	  Sondermann).
+
 2007-04-02  Sergei Golovan  <sgolovan at nes.ru>
 
 	* msgs/de.msg: Updated German translation (thanks to Roger

Modified: trunk/tkabber/msgs/de.msg
===================================================================
--- trunk/tkabber/msgs/de.msg	2007-04-08 07:50:54 UTC (rev 1083)
+++ trunk/tkabber/msgs/de.msg	2007-04-08 11:06:32 UTC (rev 1084)
@@ -1,6 +1,6 @@
 
 # German messages file
-# Roger Sondermann 02.04.2007
+# Roger Sondermann 07.04.2007
 
 # .../browser.tcl
 ::msgcat::mcset de "Add conference..."                                      "Konferenz hinzufügen..."
@@ -245,7 +245,7 @@
 ::msgcat::mcset de "Accept messages from roster users only"                 "Nur Nachrichten von Benutzern im Roster akzeptieren"
 ::msgcat::mcset de "Activate lists at startup"                              "Listen beim Start aktivieren"
 ::msgcat::mcset de "Activate search panel"                                  "Such-Leiste aktivieren"
-::msgcat::mcset de "Add group by regexp on JIDs..."                         "Gruppe unter Verwendung Regulärer Ausdrücke auf JIDs hinzufügen..."
+::msgcat::mcset de "Add group by regexp on JIDs..."                         "Gruppe mit RegEx auf JIDs hinzufügen..."
 ::msgcat::mcset de "Add new user..."                                        "Einen neuen Benutzer hinzufügen..."
 ::msgcat::mcset de "Add user to roster..."                                  "Benutzer zum Roster hinzufügen..."
 ::msgcat::mcset de "Admin tools"                                            "Administrator-Werkzeuge"
@@ -279,7 +279,7 @@
 ::msgcat::mcset de "Extended away"                                          "Länger abwesend"
 ::msgcat::mcset de "Font to use in roster, chat windows etc."               "Schriftart/-größe für Roster, Chat-Fenster, etc."
 ::msgcat::mcset de "Free to chat"                                           "Frei zum Chatten"
-::msgcat::mcset de "Generate enter/exit messages"                           "Eingangs-/Ausgangs-Nachrichten erstellen"
+::msgcat::mcset de "Generate enter/exit messages"                           "Betreten-/Verlassen-Nachrichten erstellen"
 ::msgcat::mcset de "Hide/Show roster"                                       "Roster verbergen/zeigen"
 ::msgcat::mcset de "Iconize"                                                "Ikonifizieren"
 ::msgcat::mcset de "Import roster..."                                       "Roster importieren"
@@ -377,14 +377,14 @@
 
 # .../ifacetk/iroster.tcl
 ::msgcat::mcset de "Add chats group in roster."                             "Chats-Gruppe zu Roster hinzufügen."
-::msgcat::mcset de "Add roster group by JID regexp"                         "Roster-Gruppe unter Verwendung Regulärer Ausdrücke auf JIDs hinzufügen..."
+::msgcat::mcset de "Add roster group by JID regexp"                         "Gruppe mit RegEx auf JIDs hinzufügen"
 ::msgcat::mcset de "Are you sure to remove %s from roster?"                 "Soll %s wirklich vom Roster entfernt werden?"
 ::msgcat::mcset de "Are you sure to remove all users in group '%s' from roster? \n(Users which are in another groups too, will not be removed from the roster.)" "Sollen wirklich alle Benutzer in Gruppe '%s' vom Roster entfernt werden?\n(Benutzer, die gleichzeitig in einer anderen Gruppe sind, werden nicht entfernt.)"
 ::msgcat::mcset de "Are you sure to remove group '%s' from roster? \n(Users which are in this group only, will be in undefined group.)" "Soll die Gruppe '%s' wirklich vom Roster entfernt werden?\n(Benutzer, die nur in dieser Gruppe sind, werden in die Gruppe 'Undefiniert' verschoben.)"
 ::msgcat::mcset de "Ask:"                                                   "Frage:"
 ::msgcat::mcset de "Default nested roster group delimiter."                 "Voreingestelltes Trennzeichen für verschachtelte Roster-Gruppen."
 ::msgcat::mcset de "Enable nested roster groups."                           "Verschachtelte Roster-Gruppen aktivieren."
-::msgcat::mcset de "JID regexp:"                                            "Reguläre Ausdrücke auf JIDs:"
+::msgcat::mcset de "JID regexp:"                                            "Regulärer Ausdruck:"
 ::msgcat::mcset de "New group name:"                                        "Neuer Gruppen-Name:"
 ::msgcat::mcset de "Remove all users in group..."                           "Alle Benutzer in Gruppe entfernen..."
 ::msgcat::mcset de "Remove from roster..."                                  "Vom Roster entfernen..."

Modified: trunk/tkabber/plugins/chat/histool.tcl
===================================================================
--- trunk/tkabber/plugins/chat/histool.tcl	2007-04-08 07:50:54 UTC (rev 1083)
+++ trunk/tkabber/plugins/chat/histool.tcl	2007-04-08 11:06:32 UTC (rev 1084)
@@ -3,10 +3,10 @@
 
 option add *ChatHistory.geometry          "640x480" widgetDefault
 option add *ChatHistory.oddBackground     ""        widgetDefault
-option add *ChatHistory.evenBackground    ""     widgetDefault
+option add *ChatHistory.evenBackground    ""        widgetDefault
 option add *ChatHistory.headerForeground  blue      widgetDefault
 option add *ChatHistory.bodyForeground    ""        widgetDefault
- 
+option add *ChatHistory.warningForeground red       widgetDefault
 
 event add <<TreeDefaultNodeAction>> <KeyPress-Return>
 event add <<TreeDefaultNodeAction>> <Double-Button-1>
@@ -42,37 +42,51 @@
 proc histool::browser_create {w} {
     global font tk_relief tk_borderwidth
 
+    variable loghier [get_log_hier]
+
     add_win $w \
 	    -title [::msgcat::mc "Chats History"] \
 	    -tabtitle [::msgcat::mc "Chats history"] \
 	    -class ChatHistory
-    #wm geometry $w [option get $w geometry Geometry]
 
-    set loghier [get_log_hier]
+    bind $w <Destroy> +[list [namespace current]::browser_cleanup [double% $w] %W]
 
     set nb [NoteBook $w.nb]
 
     set p [$nb insert end jidlist \
 	       -text [::msgcat::mc "JID list"] \
 	       -raisecmd [list [namespace current]::jidlist_raise $nb]]
-    jidlist_create $p $loghier
+    jidlist_create $p
 
     set p [$nb insert end ltree \
 	       -text [::msgcat::mc "Logs"] \
 	       -raisecmd [list [namespace current]::ltree_raise $nb]]
-    ltree_create $p $loghier
+    ltree_create $p
 
     set p [$nb insert end ftsearch \
 	       -text [::msgcat::mc "Full-text search"] \
 	       -raisecmd [list [namespace current]::ftsearch_raise $nb]]
-    ftsearch_create $p $loghier -mainwindow $w
+    ftsearch_create $p -mainwindow $w
 
     pack $nb -fill both -expand true
 
     $nb raise jidlist
 }
 
-proc histool::jidlist_create {w loghier} {
+proc histool::browser_cleanup {w1 w2} {
+    if {![string equal $w1 $w2]} return
+
+    variable loghier
+    unset loghier
+}
+
+################################################################
+
+proc histool::jidlist_create {w} {
+    variable loghier
+
+    grid columnconfigure $w 0 -weight 1
+
     set sw [ScrolledWindow $w.sw]
 
     set lbox [listbox $w.lbox -takefocus 1 -exportselection 0]
@@ -83,16 +97,17 @@
     # Workaround for a bug in listbox (can't get focus on mouse clicks):
     bind Listbox <Button-1> {+ if {[winfo exists %W]} {focus %W}}
 
-    bind $lbox <Double-Button-1> {
-	::logger::show_log [%W get [%W nearest %y]]
-    }
+    bind $lbox <Double-Button-1> [namespace code {
+	jidlist_open_log %W [%W nearest %y]
+    }]
 
-    bind $lbox <Return> {
-	::logger::show_log [%W get [%W index active]]
-    }
+    bind $lbox <Return> [namespace code {
+	jidlist_open_log %W [%W index active]
+    }]
 
     $sw setwidget $lbox
-    pack $sw -fill both -expand yes
+    grid $sw -sticky news
+    grid rowconfigure $w 0 -weight 1
 
     foreach jid [sort_jids [get_jids $loghier] -order {server node resource}] {
 	$lbox insert end $jid
@@ -109,18 +124,30 @@
 	 [list [namespace current]::jidlist_spanel_open $w $sp]
 }
 
+proc histool::jidlist_open_log {w idx args} {
+    variable loghier
+
+    set jid [$w get $idx]
+    set subdirs [get_subdirs of $loghier for $jid]
+
+    ::logger::show_log $jid -subdirs $subdirs
+}
+
 proc histool::jidlist_spanel_open {w sp} {
-    pack $sp -in $w -side bottom -fill x
+    grid $sp -sticky we
 }
 
 proc histool::jidlist_spanel_close {lbox w} {
-    pack forget $w
+    grid forget $w
     focus $lbox
 }
 
-proc histool::ltree_create {w loghier} {
-    upvar 1 ::logger::d2m d2m
+################################################################
 
+proc histool::ltree_create {w} {
+    variable loghier
+    variable ::logger::d2m
+
     set sw [ScrolledWindow $w.sw]
 
     set t [Tree $w.tree]
@@ -129,15 +156,17 @@
     pack $sw -fill both -expand yes
 
     $t bindText <Double-Button-1> \
-	[list [namespace current]::ltree_node_action $t]
+	[list [namespace current]::ltree_node_action [double% $t]]
 
     # Keyboard bindings don't work in BWidget Tree's bindText;
     # HACK: Tree.c widget is what receives keyboard events:
 
     bind $t.c <<TreeDefaultNodeAction>> \
-	 [list [namespace current]::ltree_for_node $t ltree_node_action]
+	 [list [namespace current]::ltree_for_node [double% $t] ltree_node_action]
     bind $t.c <<TreeStepUp>> \
-	 [list [namespace current]::ltree_for_node $t ltree_step_up]
+	 [list [namespace current]::ltree_for_node [double% $t] ltree_step_up]
+
+    # Install mouse wheel bindings:
     bindscroll $t.c
 
     [namespace parent]::search::browser::setup_panel $w $sw $t
@@ -155,21 +184,63 @@
     }
 }
 
-proc histool::ftsearch_create {w lh args} {
-    variable loghier $lh
+proc histool::ltree_for_node {t script} {
+    set node [lindex [$t selection get] 0]
+    if {[string equal $node ""]} return
+
+    eval $script $t $node
+}
+
+proc histool::ltree_node_action {t n} {
+    variable loghier
+
+    if {[tree_node_is_leaf $t $n]} {
+	variable ::logger::m2d
+	set mn [$t parent $n]
+	set yn [$t parent $mn]
+	set year [$t itemcget $yn -text]
+	set month $m2d([$t itemcget $mn -text])
+	set jid [$t itemcget $n -text]
+	::logger::show_log $jid -when $year-$month \
+	    -subdirs [get_subdirs of $loghier for $jid]
+    } else {
+	$t toggle $n
+    }
+}
+
+proc histool::tree_node_is_leaf {t n} {
+    string equal [$t nodes $n 0] ""
+}
+
+proc histool::ltree_step_up {t n} {
+    set p [$t parent $n]
+    if {[string equal $p root]} return
+
+    $t toggle $p
+    $t selection set $p
+}
+
+################################################################
+
+proc histool::ftsearch_create {w args} {
+    variable loghier
     variable ftsearch
 
+    grid columnconfigure $w 0 -weight 1
+
     set sp $w.spanel
     ::plugins::search::spanel $sp \
 	-allowclose no \
 	-twoway no \
-	-searchcommand [namespace current]::ftsearch_do_search
-    pack $sp -fill x
+	-searchcommand [namespace current]::ftsearch_do_search \
+	-stopcommand   [namespace current]::ftsearch_cancel_search
+    grid $sp -sticky we
 
     set sw [ScrolledWindow $w.sw]
     set r [text $w.results -cursor "" -state disabled]
     $sw setwidget $r
-    pack $sw -fill both -expand yes
+    grid $sw -sticky news
+    grid rowconfigure $w 1 -weight 1
 
     set f [frame $w.cf -class Chat]
     $r tag configure they -foreground [option get $f theyforeground Chat]
@@ -194,10 +265,13 @@
 	    set val [option get $mw evenBackground ChatHistory]
 	    if {$val != ""} { $r tag configure EVEN -background $val }
 	    
-	    $r tag configure HEADER -foreground \
-		[option get $mw headerForeground ChatHistory]
+	    set val [option get $mw headerForeground ChatHistory]
+	    if {$val != ""} { $r tag configure HEADER -foreground $val }
 	    set val [option get $mw bodyForeground ChatHistory]
 	    if {$val != ""} { $r tag configure BODY -background $val }
+
+	    set val [option get $mw warningForeground ChatHistory]
+	    if {$val != ""} { $r tag configure WARNING -foreground $val }
 	}
     }
 
@@ -205,7 +279,7 @@
     set ftsearch(results) $r
     set ftsearch(bg) EVEN
 
-    bind $w <Destroy> +[list [namespace current]::ftsearch_cleanup $w %W]
+    bind $w <Destroy> +[list [namespace current]::ftsearch_cleanup [double% $w] %W]
 
     # Set search panel up:
 
@@ -220,62 +294,160 @@
 	    -closecommand  [list [namespace current]::ftsearch_spanel_close $r $sp.sentry]]
 
     bind $sp.sentry <<OpenSearchPanel>> \
-	 [list [namespace current]::ftsearch_spanel_open $w $asp]
+	 [list [namespace current]::ftsearch_spanel_open [double% $w] [double% $asp]]
 }
 
-proc histool::ftsearch_do_search {what dir} {
+# Schedules an execution of a script produced by concatenating
+# the words of $args using the # [after idle [after 0 [list ...]]]
+# concept presented at http://mini.net/tcl/1526
+# The idea is that some parts of Tk wait for all idle event
+# handlers to complete. So, when executes, our idle event handler
+# installed in [schedule] installs timed event handler that
+# will be executed ASAP, and since it's not an idle event, it
+# allows the event queue to be in a state free of scheduled
+# idle events (thus allowing Tk to do its job, keeping GUI alive).
+proc histool::schedule args {
+    after idle [list after 0 $args]
+}
+
+# Must be used as the (almost) first command inside any procs
+# scheduled as [after ...] callbacks installed in the course
+# of performing full-text search.
+proc histool::ftsearch_can_proceed {} {
+    variable ftsearch_terminate
+
+    if {$ftsearch_terminate} {
+	unset ftsearch_terminate
+	return false
+    } else {
+	return true
+    }
+}
+
+# This proc builds a list of log files to grep and then starts
+# an asynchronous searching through them
+proc histool::ftsearch_do_search {what dir args} {
     variable loghier
     variable ftsearch
+    variable ftsearch_terminate false
 
+    # Returning false means we refuse to start searching:
     if {$what == ""} { return 0 }
-    if {[string equal $ftsearch(last) $what]} { return 1 }
+    if {[string equal $ftsearch(last) $what]} { return 0 }
 
+    set ftsearch(now) $what
+    set ftsearch(found) 0
+
     set r $ftsearch(results)
+    $r configure -state normal
     $r delete 1.0 end
+    $r configure -state normal
 
-    set found 0
-
+    set slist {}
     foreach LA [lsort -index 0 $loghier] {
 	lassign $LA year months
 	foreach LB [lsort -index 0 $months] {
 	    lassign $LB month jids
 	    foreach jid $jids {
-		set fname [::logger::jid_to_filename $jid]
-		foreach msg [ftsearch_grep $what in $fname on $year-$month] {
-		    set found 1
-		    if {![winfo exists $r]} {
-			# User closed histool window
-			return $found
-		    }
-		    $r configure -state normal
-		    ftsearch_render_msg $r $year $month $jid $msg
-		    $r configure -state disabled
-		}
+		lappend slist [list $year $month $jid]
 	    }
 	}
     }
 
-    set ftsearch(last) $what
+    set ix [lsearch $args -completioncommand]
+    if {$ix >= 0} {
+	set ftsearch(compcmd) [lindex $args [incr ix]]
+    } else {
+	set ftsearch(compcmd) ""
+    }
 
-    return $found
+    # will return almost immediately:
+    ftsearch_grep_next of $slist for $what
+
+    return 1 ;# signalize we've started the search process
 }
 
-proc histool::ftsearch_grep {what "in" where "on" month} {
-    set out {}
+# Tries to open the last file in the $slist and schedules
+# the execution of a handler that will read that file
+# looking for $what
+proc histool::ftsearch_grep_next {"of" slist "for" what args} {
+    if {![ftsearch_can_proceed]} return
 
-    foreach msg [::logger::read_hist_from_file $where $month] {
-	lassign $msg & mts & mjid & mnick & mbody
-	if {[::plugins::search::match $what $mbody]} {
-	    lappend out $msg
-	} elseif {[::plugins::search::match $what $mnick]} {
-	    lappend out $msg
-	}
-	update
+    variable ftsearch
+    variable ::logger::options
+
+    # Some files are unreadable due to some reason, so we loop
+    # over the list of them until opening succeeds or the list
+    # is exhausted:
+    while true {
+	lassign [lindex $slist end] year month jid
+	set fname [file join $options(logdir) \
+	    $year $month [::logger::jid_to_filename $jid]]
+	if {[catch {open $fname} chan]} {
+	    set r $ftsearch(results)
+	    $r configure -state normal
+	    $r insert end [::msgcat::mc "WARNING: %s\n" $chan] WARNING
+	    $r configure -state disabled
+
+	    set slist [lrange $slist 0 end-1]
+	    if {[llength $slist] > 0} {
+		continue
+	    } else {
+		ftsearch_complete_search for $what
+		return
+	    }
+	} else break
     }
 
-    set out
+    fconfigure $chan -encoding utf-8
+
+    schedule \
+	[namespace current]::ftsearch_grep_msg of $slist for $what from $chan
 }
 
+# Reads one line from a log file opened as $chan, parses it, looks
+# for $what in the relevant parts of the aqcuired message, renders
+# it if it match.
+# Searching conditions are checked: this proc is either re-schedules
+# its execution (for the next line of the log file) or schedules the
+# reading of the next log file or completes the searching process.
+proc histool::ftsearch_grep_msg {"of" slist "for" what "from" chan} {
+    if {![ftsearch_can_proceed]} return
+
+    variable ftsearch
+
+    set line [gets $chan]
+
+    if {![eof $chan]} {
+	set msg [::logger::log_to_str $line]
+	array set mparts $msg
+	foreach part {nick body} {
+	    if {[info exists mparts($part)]
+	    && [::plugins::search::match $what $mparts($part)]} {
+		lassign [lindex $slist end] year month jid
+		set r $ftsearch(results)
+		$r configure -state normal
+		ftsearch_render_msg $r $year $month $jid $msg
+		$r configure -state disabled
+		set ftsearch(found) 1
+		break
+	    }
+	}
+	schedule \
+	    [namespace current]::ftsearch_grep_msg of $slist for $what from $chan
+    } else {
+	close $chan
+
+	set rem [lrange $slist 0 end-1]
+	if {[llength $rem] > 0} {
+	    schedule \
+		[namespace current]::ftsearch_grep_next of $rem for $what
+	} else {
+	    ftsearch_complete_search for $what
+	}
+    }
+}
+
 proc histool::ftsearch_render_msg {t year month jid msg} {
     variable ftsearch
 
@@ -320,7 +492,32 @@
     }
 }
 
+proc histool::ftsearch_complete_search {"for" what} {
+    variable ftsearch
+
+    set ftsearch(now) ""
+    set ftsearch(last) $what
+
+    if {$ftsearch(compcmd) != ""} {
+	eval $ftsearch(compcmd) $ftsearch(found)
+    }
+}
+
+proc histool::ftsearch_cancel_search {args} {
+    variable ftsearch
+    variable ftsearch_terminate true
+
+    set ftsearch(last) $ftsearch(now)
+    set ftsearch(now) ""
+
+    if {$ftsearch(compcmd) != ""} {
+	eval $ftsearch(compcmd) $ftsearch(found)
+    }
+}
+
 proc histool::ftsearch_open_log {t x y} {
+    variable loghier
+
     set year   ""
     set month  ""
     set ts     ""
@@ -352,11 +549,13 @@
 	}
     }
 
+    lappend cmd -subdirs [get_subdirs of $loghier for $jid]
+
     eval $cmd
 }
 
 proc histool::ftsearch_spanel_open {w sp} {
-    pack $sp -in $w -side bottom -fill x
+    grid $sp -sticky we
 }
 
 proc histool::ftsearch_spanel_close {t sentry w} {
@@ -366,53 +565,28 @@
     $t mark set sel_start end                                               
     $t mark set sel_end 0.0                                                 
     
-    pack forget $w
+    grid forget $w
     focus $sentry
 }
 
+# Cleans up relevant variables when the browser form
+# is destroyed. "ftsearch_terminate" variable is
+# unset in the [after ...] event handler, if such
+# handler is installed.
 proc histool::ftsearch_cleanup {w1 w2} {
     if {![string equal $w1 $w2]} return
 
     variable ftsearch
-    variable loghier
-
     array unset ftsearch
-    unset loghier
-}
 
-proc histool::ltree_for_node {t script} {
-    set node [lindex [$t selection get] 0]
-    if {[string equal $node ""]} return
-
-    eval $script $t $node
-}
-
-proc histool::ltree_node_action {t n} {
-    if {[tree_node_is_leaf $t $n]} {
-	upvar 1 ::logger::m2d m2d
-	set mn [$t parent $n]
-	set yn [$t parent $mn]
-	set year [$t itemcget $yn -text]
-	set month $m2d([$t itemcget $mn -text])
-	set jid [$t itemcget $n -text]
-	::logger::show_log $jid -when $year-$month
-    } else {
-	$t toggle $n
+    variable ftsearch_terminate
+    if {[info exists ftsearch_terminate]} {
+	set ftsearch_terminate true
     }
 }
 
-proc histool::tree_node_is_leaf {t n} {
-    string equal [$t nodes $n 0] ""
-}
+################################################################
 
-proc histool::ltree_step_up {t n} {
-    set p [$t parent $n]
-    if {[string equal $p root]} return
-
-    $t toggle $p
-    $t selection set $p
-}
-
 proc histool::jidlist_raise {nb} {
     set lbox [$nb getframe jidlist].lbox
     if {[winfo exists $lbox]} {
@@ -473,10 +647,10 @@
 }
 
 proc histool::is_unsupported {} {
-    upvar 1 ::logger::options(logdir) logdir
+    variable ::logger::options
 
     catch {
-	set fd [open [file join $logdir version]]
+	set fd [open [file join $options(logdir) version]]
 	if {![package vsatisfies [gets $fd] 1.0]} {
 	    close $fd
 	    error "unsupported log dir structure format"
@@ -486,10 +660,10 @@
 }
 
 proc histool::get_log_hier {} {
-    upvar 1 ::logger::options(logdir) logdir
+    variable ::logger::options
 
     set LA {}
-    foreach dyear [glob -nocomplain -type d -directory $logdir *] {
+    foreach dyear [glob -nocomplain -type d -directory $options(logdir) *] {
 	set LB {}
 	foreach dmonth [glob -nocomplain -type d -directory $dyear *] {
 	    set LC {}
@@ -518,4 +692,24 @@
     array names jids
 }
 
+# From the log hierarchy given by $loghier builds a list of
+# YEAR-MONTH entries producing the same structure that
+# is generated by [::logger::get_subdirs].
+# See plugins/chat/logger.tcl
+proc histool::get_subdirs {"of" loghier "for" jid} {
+    set subdirs {}
+
+    foreach LA $loghier {
+	lassign $LA year months
+	foreach LB $months {
+	    lassign $LB month jids
+	    if {[lsearch -exact $jids $jid] >= 0} {
+		lappend subdirs $year-$month
+	    }
+	}
+    }
+
+    set subdirs
+}
+
 # vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/plugins/chat/logger.tcl
===================================================================
--- trunk/tkabber/plugins/chat/logger.tcl	2007-04-08 07:50:54 UTC (rev 1083)
+++ trunk/tkabber/plugins/chat/logger.tcl	2007-04-08 11:06:32 UTC (rev 1084)
@@ -247,6 +247,7 @@
     foreach {key val} $args {
 	switch -- $key {
 	    -connection { set connid $val }
+	    -subdirs { set subdirs $val }
 	}
     }
     if {![info exists connid]} {
@@ -293,17 +294,21 @@
 
     $l configure -state disabled
 
-    set subdirs {}
-    foreach sd [lsort -decreasing [get_subdirs $logfile]] {
-	lappend subdirs [describe_month $sd]
+    if {![info exists subdirs]} {
+	set subdirs [get_subdirs $logfile]
     }
-    lappend subdirs [::msgcat::mc "All"]
 
+    set ympairs {}
+    foreach sd [lsort -decreasing $subdirs] {
+	lappend ympairs [describe_month $sd]
+    }
+    lappend ympairs [::msgcat::mc "All"]
+
     set mcombo [ComboBox $mf.mcombo \
 			 -editable no \
 			 -exportselection no \
-			 -values $subdirs \
-			 -text [lindex $subdirs 0] \
+			 -values $ympairs \
+			 -text [lindex $ympairs 0] \
 			 -modifycmd [list \
 			    [namespace current]::change_month \
 					  $mf.mcombo $logfile $l $mynick]]
@@ -324,7 +329,7 @@
     upvar 1 $lw state
 
     if {![winfo exists $lw]} {
-	create_log_viewer $lw $jid $args
+	eval [list create_log_viewer $lw $jid] $args
     } else {
 	focus -force $lw
     }
@@ -342,14 +347,14 @@
     set log $lw.log
     set cbox $lw.mf.mcombo
 
-    set subdirs [$cbox cget -values]
+    set ympairs [$cbox cget -values]
     if {[info exists when]} {
 	set text [describe_month $when]
-	if {[lsearch -exact $subdirs $text] < 0} {
+	if {[lsearch -exact $ympairs $text] < 0} {
 	    error "no log entries for: $when"
 	}
     } else {
-	set text [lindex $subdirs 0]
+	set text [lindex $ympairs 0]
     }
 
     $cbox configure -text $text

Modified: trunk/tkabber/plugins/search/spanel.tcl
===================================================================
--- trunk/tkabber/plugins/search/spanel.tcl	2007-04-08 07:50:54 UTC (rev 1083)
+++ trunk/tkabber/plugins/search/spanel.tcl	2007-04-08 11:06:32 UTC (rev 1084)
@@ -25,9 +25,11 @@
 proc search::spanel {w args} {
     set opencmd   ""
     set closecmd  ""
+    set stopcmd   ""
     set canclose  1
     set twoway    1
-    set primary   0
+    set defbutton 0
+    set async     0
     foreach {key val} $args {
 	switch -- $key {
 	    -searchcommand {
@@ -47,11 +49,16 @@
 	    }
 	    -defaultdirection {
 		switch -- $val {
-		    up   { set primary 0 }
-		    down { set primary 1 }
+		    up   { set defbutton 0 }
+		    down { set defbutton 1 }
 		    default { error "Invaild default search direcrion: $val" }
 		}
 	    }
+	    -stopcommand {
+		set async 1
+		set stopcmd $val
+	    }
+	    default { error "invalid option: $key" }
 	}
     }
 
@@ -78,13 +85,25 @@
 	set lbl [::msgcat::mc "Search"]
     }
     $sbox add -text $lbl \
-	      -command [namespace code [list spanel_search $w $searchcmd up $bg]]
+	      -command [namespace code [list spanel_search $w $async \
+					     $searchcmd up $bg]]
     if {$twoway} {
 	$sbox add -text [::msgcat::mc "Search down"] \
-	      -command [namespace code [list spanel_search $w $searchcmd down $bg]]
+	      -command [namespace code [list spanel_search $w $async \
+					     $searchcmd down $bg]]
     }
     pack $sbox -side left -padx 1m
 
+    set xbox [ButtonBox $w.xbox -spacing 0]
+    $xbox add -text [::msgcat::mc "Cancel"] \
+	-command [namespace code [list spanel_cancel $w $stopcmd]]
+    if {$async} {
+	bind $sentry <Control-KeyPress-c> [namespace code [list spanel_cancel \
+								[double% $w] \
+								[double% $stopcmd]]]
+	pack $xbox -side left -padx 1m
+    }
+
     set cbox [ButtonBox $w.cbox -spacing 0]
     $cbox add -text [::msgcat::mc "Close"] \
 	      -command [namespace code [list spanel_close $w $closecmd]]
@@ -92,42 +111,74 @@
 	pack $cbox -side right -padx 1m
     }
 
-    bind $sentry <Key-Return> [double% [list $sbox invoke $primary]]
-    bind $sentry <Shift-Key-Return> [double% [list $sbox invoke [expr {!$primary}]]]
+    bind $sentry <Key-Return> [double% [list $sbox invoke $defbutton]]
+    bind $sentry <Shift-Key-Return> [double% [list $sbox invoke [expr {!$defbutton}]]]
 
     if {$canclose} {
 	bind $sentry <Escape> [double% [list $cbox invoke 0]]
 	bind $sentry <Escape> +break ;# prevent forwarding upstream
     }
 
+    spanel_state $w inactive
+
     set w
 }
 
-proc search::spanel_search {w searchcmd dir dbg} {
+# In async mode, the result of eval'ing of $searchcmd
+# is treated specially:
+# * true ("found") means the client code has started the search process;
+# * false ("not found") means it refused to search for some reason.
+proc search::spanel_search {w async searchcmd dir dbg} {
     set sentry $w.sentry
-    set sbox   $w.sbox
-    set cbox   $w.cbox
 
-    $sentry configure -state disabled
-    $sbox   configure -state disabled
-    $cbox   configure -state disabled
-    update idletasks
+    spanel_state $w active
 
-    set failed [catch {eval $searchcmd [list [$sentry get] $dir]} found]
+    set cmd $searchcmd
+    lappend cmd [$sentry get] $dir
+    if {$async} {
+	lappend cmd -completioncommand [list \
+	    [namespace current]::spanel_on_completed $w $dbg]
+    }
 
-    # Search command may take much time to process, so it may
-    # destroy search panel (user interrupted search by closing the window)
-    if {![winfo exists $sentry]} return
+    set failed [catch { eval $cmd } found]
 
-    $sentry configure -state normal
-    $sbox   configure -state normal
-    $cbox   configure -state normal
-    update idletasks
-
     if {$failed} {
+	spanel_state $w inactive
 	return -code error $found
     }
 
+    if {$async && $found} return
+
+    spanel_state $w inactive
+
+    spanel_signalize_result $w $dbg $found
+}
+
+proc search::spanel_state {w state} {
+    set sentry $w.sentry
+    set sbox   $w.sbox
+    set xbox   $w.xbox
+    set cbox   $w.cbox
+
+    if {[string equal $state active]} {
+	set a disabled
+	set b normal
+    } else {
+	set a normal
+	set b disabled
+    }
+
+    $sentry configure -state $a
+    $sbox   configure -state $a
+    $xbox   configure -state $b
+    $cbox   configure -state $a
+
+    update idletasks
+}
+
+proc search::spanel_signalize_result {w dbg found} {
+    set sentry $w.sentry
+
     if {$found} {
 	set bg $dbg
     } else {
@@ -153,4 +204,15 @@
     }
 }
 
+proc search::spanel_cancel {w stopcmd} {
+    if {$stopcmd != ""} {
+	eval $stopcmd [list $w]
+    }
+}
+
+proc search::spanel_on_completed {w dbg found} {
+    spanel_state $w inactive
+    spanel_signalize_result $w $dbg $found
+}
+
 # vim:ts=8:sw=4:sts=4:noet



More information about the Tkabber-dev mailing list