[Tkabber-dev] r1007 - in trunk/tkabber: . plugins/chat

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sun Mar 4 20:12:22 MSK 2007


Author: sergei
Date: 2007-03-04 20:12:19 +0300 (Sun, 04 Mar 2007)
New Revision: 1007

Added:
   trunk/tkabber/plugins/chat/histool.tcl
Modified:
   trunk/tkabber/ChangeLog
Log:
	* plugins/chat/histool.tcl: Added Chats history tool plugin (thanks
	  to Konstantiin Khomoutov).


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2007-03-04 16:14:29 UTC (rev 1006)
+++ trunk/tkabber/ChangeLog	2007-03-04 17:12:19 UTC (rev 1007)
@@ -23,6 +23,9 @@
 	* plugins/search/search.tcl: Added functions to search in listboxes
 	  (thanks to Konstantin Khomoutov).
 
+	* plugins/chat/histool.tcl: Added Chats history tool plugin (thanks
+	  to Konstantiin Khomoutov).
+
 2007-03-03  Sergei Golovan  <sgolovan at nes.ru>
 
 	* plugins/general/headlines.tcl: Bugfix. Removed trailing linefeed

Added: trunk/tkabber/plugins/chat/histool.tcl
===================================================================
--- trunk/tkabber/plugins/chat/histool.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/chat/histool.tcl	2007-03-04 17:12:19 UTC (rev 1007)
@@ -0,0 +1,264 @@
+# $Id$
+# "histool" -- "A History Tool" Tkabber plugin.
+# Offers additional possiblities to dig the available chat history.
+#
+# Written by Konstantin Khomoutov <flatworm at users.sourceforge.net>
+# See README for details.
+# See licence.terms for the terms of distribution.
+
+option add Tkabber.histool.geometry "640x480" widgetDefault
+
+event add <<TreeDefaultNodeAction>> <KeyPress-Return>
+event add <<TreeDefaultNodeAction>> <Double-Button-1>
+event add <<TreeStepUp>> <KeyPress-BackSpace>
+
+namespace eval histool {
+    hook::add finload_hook [namespace current]::on_init
+}
+
+proc histool::on_init {} {
+    set m [.mainframe getmenu services]
+    set idx [$m index [::msgcat::mc "Service Discovery"]]
+    $m insert [expr {$idx + 2}] command \
+       -label [::msgcat::mc "Chats history"] \
+       -command [namespace current]::browse
+}
+
+proc histool::browse args {
+    if {[is_unsupported]} {
+	tk_messageBox -message [::msgcat::mc "Unsupported log dir format"]
+	return
+    }
+
+    set w .histool
+    if {[winfo exists $w]} {
+	focus -force $w
+	return
+    }
+
+    browser_create $w
+}
+
+proc histool::browser_create {w} {
+    global font tk_relief tk_borderwidth
+
+    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]
+
+    set nb [NoteBook $w.nb]
+
+    set p [$nb insert end jidlist \
+	       -text [::msgcat::mc "JIDs"] \
+	       -raisecmd [list [namespace current]::jidlist_raise $nb]]
+    jidlist_create $p $loghier
+
+    set p [$nb insert end ltree \
+	       -text [::msgcat::mc "Logs"] \
+	       -raisecmd [list [namespace current]::ltree_raise $nb]]
+    ltree_create $p $loghier
+
+#    set p [$nb insert end ftsearch \
+#	       -text [::msgcat::mc "Full-text search"] \
+#	       -raisecmd [list [namespace current]::ftsearch_raise $nb]]
+#    ftsearch_create $p $loghier
+
+    pack $nb -fill both -expand true
+
+    $nb raise jidlist
+}
+
+proc histool::jidlist_create {w loghier} {
+    set sw [ScrolledWindow $w.sw]
+
+    set lbox [listbox $w.lbox -takefocus 1]
+    $lbox selection clear 0 end
+    $lbox selection set 0
+    focus $lbox
+
+    # 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]]
+    }
+
+    $sw setwidget $lbox
+    pack $sw -fill both -expand yes
+
+    foreach jid [sort_jids [get_jids $loghier] -order {server node resource}] {
+	$lbox insert end $jid
+    }
+
+    # Setup searching:
+
+    set sp [::plugins::search::spanel $w.spanel \
+		-searchcommand [list ::plugins::search::listbox::do_search $lbox] \
+		-closecommand  [list [namespace current]::jidlist_spanel_close $lbox]]
+
+    bind $lbox <<OpenSearchPanel>> \
+	 [list [namespace current]::jidlist_spanel_open $w $sp]
+}
+
+proc histool::jidlist_spanel_open {w sp} {
+    pack $sp -in $w -side bottom -fill x
+}
+
+proc histool::jidlist_spanel_close {lbox w} {
+    pack forget $w
+    focus $lbox
+}
+
+proc histool::ltree_create {w loghier} {
+    upvar 1 ::logger::d2m d2m
+
+    set sw [ScrolledWindow $w.sw]
+
+    set t [Tree $w.tree]
+
+    $sw setwidget $t
+    pack $sw -fill both -expand yes
+
+    $t bindText <Double-Button-1> \
+	[list [namespace current]::ltree_node_action $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]
+    bind $t.c <<TreeStepUp>> \
+	 [list [namespace current]::ltree_for_node $t ltree_step_up]
+
+    [namespace parent]::search::browser::setup_panel $w $sw $t
+
+    foreach LA [lsort -index 0 $loghier] {
+	lassign $LA year months
+	$t insert end root root.$year -text $year
+	foreach LB [lsort -index 0 $months] {
+	    lassign $LB month jids
+	    $t insert end root.$year root.$year.$month -text $d2m($month)
+	    foreach {jid fname} [sort_jids $jids -order {server node resource}] {
+		$t insert end root.$year.$month root.$year.$month.$jid -text $jid
+	    }
+	}
+    }
+}
+
+proc histool::ftsearch_create {w loghier} {
+    pack [label $w.tobedone -anchor w -text [::msgcat::mc "To be done..."]] -fill x
+}
+
+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
+    }
+}
+
+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]
+    $t toggle $p
+    $t selection set $p
+}
+
+proc histool::jidlist_raise {nb} {
+    set lbox [$nb getframe jidlist].lbox
+    if {[winfo exists $lbox]} {
+	focus $lbox
+    }
+}
+
+proc histool::ltree_raise {nb} {
+    set tree [$nb getframe ltree].tree
+    if {[winfo exists $tree]} {
+	focus $tree
+    }
+}
+
+proc histool::ftsearch_raise {nb} {
+}
+
+proc histool::sort_jids {jids args} {
+    set cmd [concat [namespace current]::compare_jids $args]
+
+    lsort -command $cmd $jids
+}
+
+proc histool::compare_jids {"-order" order a b} {
+    foreach f $order {
+	set res [string compare [${f}_from_jid $a] [${f}_from_jid $b]]
+	if {$res != 0} break
+    }
+
+    return $res
+}
+
+proc histool::is_unsupported {} {
+    upvar 1 ::logger::options(logdir) logdir
+
+    catch {
+	set fd [open [file join $logdir version]]
+	if {![package vsatisfies [gets $fd] 1.0]} {
+	    close $fd
+	    error "unsupported log dir structure format"
+	}
+	close $fd
+    }
+}
+
+proc histool::get_log_hier {} {
+    upvar 1 ::logger::options(logdir) logdir
+
+    set LA {}
+    foreach dyear [glob -nocomplain -type d -directory $logdir *] {
+	set LB {}
+	foreach dmonth [glob -nocomplain -type d -directory $dyear *] {
+	    set LC {}
+	    foreach file [glob -nocomplain -type f -directory $dmonth *] {
+		lappend LC [::logger::filename_to_jid [file tail $file]]
+	    }
+	    set month [lindex [file split $dmonth] end]
+	    lappend LB [list $month $LC]
+	}
+	set year [lindex [file split $dyear] end]
+	lappend LA [list $year $LB]
+    }
+
+    set LA
+}
+
+proc histool::get_jids {loghier} {
+    foreach LA $loghier {
+	foreach LB [lindex $LA 1] {
+	    foreach {jid fname} [lindex $LB 1] {
+		set jids($jid) ""
+	    }
+	}
+    }
+
+    array names jids
+}
+


Property changes on: trunk/tkabber/plugins/chat/histool.tcl
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native



More information about the Tkabber-dev mailing list