1# $Id$
2# History tool -- allows browsing and searching through Tkabber chat logs.
3
4option add *ChatHistory.geometry          "640x480" widgetDefault
5option add *ChatHistory.oddBackground     ""        widgetDefault
6option add *ChatHistory.evenBackground    ""        widgetDefault
7option add *ChatHistory.headerForeground  blue      widgetDefault
8option add *ChatHistory.bodyForeground    ""        widgetDefault
9option add *ChatHistory.warningForeground red       widgetDefault
10
11event add <<TreeDefaultNodeAction>> <KeyPress-Return>
12event add <<TreeDefaultNodeAction>> <Double-Button-1>
13event add <<TreeStepUp>> <KeyPress-BackSpace>
14
15namespace eval histool {
16    hook::add finload_hook [namespace current]::on_init
17}
18
19proc histool::on_init {} {
20    set m [.mainframe getmenu services]
21    set idx [$m index [::msgcat::mc "Service Discovery"]]
22    $m insert [expr {$idx + 2}] command \
23       -label [::msgcat::mc "Chats history"] \
24       -command [namespace current]::browse
25}
26
27proc histool::browse args {
28    if {[is_unsupported]} {
29	NonmodalMessageDlg [epath] \
30		-aspect 50000 \
31		-icon error \
32		-title [::msgcat::mc "Error"] \
33		-message [::msgcat::mc "Unsupported log dir format"]
34	return
35    }
36
37    set w .histool
38    if {[winfo exists $w]} {
39	focus -force $w
40	return
41    }
42
43    browser_create $w
44}
45
46proc histool::browser_create {w} {
47    variable loghier [get_log_hier]
48
49    add_win $w \
50	    -title [::msgcat::mc "Chats History"] \
51	    -tabtitle [::msgcat::mc "Chats history"] \
52	    -class ChatHistory \
53	    -raise 1
54
55    set nb [NoteBook $w.nb]
56
57    bind $nb <Destroy> +[list [namespace current]::browser_cleanup]
58
59    set p [$nb insert end jidlist \
60	       -text [::msgcat::mc "JID list"] \
61	       -raisecmd [list [namespace current]::jidlist_raise $nb]]
62    jidlist_create $p
63
64    set p [$nb insert end ltree \
65	       -text [::msgcat::mc "Logs"] \
66	       -raisecmd [list [namespace current]::ltree_raise $nb]]
67    ltree_create $p
68
69    set p [$nb insert end ftsearch \
70	       -text [::msgcat::mc "Full-text search"] \
71	       -raisecmd [list [namespace current]::ftsearch_raise $nb]]
72    ftsearch_create $p -mainwindow $w
73
74    pack $nb -fill both -expand true
75
76    $nb raise jidlist
77}
78
79proc histool::browser_cleanup {} {
80    variable loghier
81    unset loghier
82}
83
84################################################################
85
86proc histool::jidlist_create {w} {
87    variable loghier
88
89    grid columnconfigure $w 0 -weight 1
90
91    set sw [ScrolledWindow $w.sw]
92
93    set lbox [listbox $w.lbox -takefocus 1 -exportselection 0]
94    $lbox selection clear 0 end
95    $lbox selection set 0
96    focus $lbox
97
98    # Workaround for a bug in listbox (can't get focus on mouse clicks):
99    bind Listbox <Button-1> {+ if {[winfo exists %W]} {focus %W}}
100
101    bind $lbox <Double-Button-1> [namespace code {
102	jidlist_open_log %W [%W nearest %y]
103    }]
104
105    bind $lbox <Return> [namespace code {
106	jidlist_open_log %W [%W index active]
107    }]
108
109    $sw setwidget $lbox
110    grid $sw -sticky news
111    grid rowconfigure $w 0 -weight 1
112
113    foreach jid [sort_jids [get_jids $loghier] -order {server node resource}] {
114	$lbox insert end $jid
115    }
116
117    # Setup searching:
118
119    set sp [::plugins::search::spanel $w.spanel \
120	    -defaultdirection up \
121	    -searchcommand [list ::plugins::search::listbox::do_search $lbox] \
122	    -closecommand  [list [namespace current]::jidlist_spanel_close $lbox]]
123
124    bind $lbox <<OpenSearchPanel>> \
125	 [double% [list [namespace current]::jidlist_spanel_open $w $sp]]
126}
127
128proc histool::jidlist_open_log {w idx args} {
129    variable loghier
130
131    set jid [$w get $idx]
132    set subdirs [get_subdirs of $loghier for $jid]
133
134    ::logger::show_log $jid -subdirs $subdirs
135}
136
137proc histool::jidlist_spanel_open {w sp} {
138    grid $sp -sticky we
139}
140
141proc histool::jidlist_spanel_close {lbox w} {
142    grid forget $w
143    focus $lbox
144}
145
146################################################################
147
148proc histool::ltree_create {w} {
149    variable loghier
150    variable ::logger::d2m
151
152    set sw [ScrolledWindow $w.sw]
153
154    set t [Tree $w.tree]
155
156    $sw setwidget $t
157    pack $sw -fill both -expand yes
158
159    $t bindText <Double-Button-1> \
160	[list [namespace current]::ltree_node_action [double% $t]]
161
162    # Keyboard bindings don't work in BWidget Tree's bindText;
163    # HACK: Tree.c widget is what receives keyboard events:
164
165    bind $t.c <<TreeDefaultNodeAction>> \
166	 [list [namespace current]::ltree_for_node [double% $t] ltree_node_action]
167    bind $t.c <<TreeStepUp>> \
168	 [list [namespace current]::ltree_for_node [double% $t] ltree_step_up]
169
170    # Install mouse wheel bindings:
171    bindscroll $t.c
172
173    [namespace parent]::search::browser::setup_panel $w $sw $t
174
175    set counter 0
176    foreach LA [lsort -index 0 $loghier] {
177	lassign $LA year months
178	$t insert end root root.$year -text $year
179	foreach LB [lsort -index 0 $months] {
180	    lassign $LB month jids
181	    $t insert end root.$year root.$year.$month -text $d2m($month)
182	    foreach jid [sort_jids $jids -order {server node resource}] {
183		$t insert end root.$year.$month [incr counter] -text $jid
184	    }
185	}
186    }
187}
188
189proc histool::ltree_for_node {t script} {
190    set node [lindex [$t selection get] 0]
191    if {[string equal $node ""]} return
192
193    eval $script $t $node
194}
195
196proc histool::ltree_node_action {t n} {
197    variable loghier
198
199    if {[tree_node_is_leaf $t $n]} {
200	variable ::logger::m2d
201	set mn [$t parent $n]
202	set yn [$t parent $mn]
203	set year [$t itemcget $yn -text]
204	set month $m2d([$t itemcget $mn -text])
205	set jid [$t itemcget $n -text]
206	::logger::show_log $jid -when $year-$month \
207	    -subdirs [get_subdirs of $loghier for $jid]
208    } else {
209	$t toggle $n
210    }
211}
212
213proc histool::tree_node_is_leaf {t n} {
214    string equal [$t nodes $n 0] ""
215}
216
217proc histool::ltree_step_up {t n} {
218    set p [$t parent $n]
219    if {[string equal $p root]} return
220
221    $t toggle $p
222    $t selection set $p
223}
224
225################################################################
226
227proc histool::ftsearch_create {w args} {
228    variable loghier
229    variable ftsearch
230
231    grid columnconfigure $w 0 -weight 1
232
233    set sp $w.spanel
234    ::plugins::search::spanel $sp \
235	-allowclose no \
236	-twoway no \
237	-searchcommand [namespace current]::ftsearch_do_search \
238	-stopcommand   [namespace current]::ftsearch_cancel_search
239    grid $sp -sticky we
240
241    set sw [ScrolledWindow $w.sw]
242    set r [text $w.results -cursor "" -state disabled]
243    $sw setwidget $r
244    grid $sw -sticky news
245    grid rowconfigure $w 1 -weight 1
246
247    set f [frame $w.cf -class Chat]
248    $r tag configure they -foreground [option get $f theyforeground Chat]
249    $r tag configure me -foreground [option get $f meforeground Chat]
250    $r tag configure server_lab \
251	-foreground [option get $f serverlabelforeground Chat]
252    $r tag configure server \
253	-foreground [option get $f serverforeground Chat]
254    destroy $f
255
256    bind $r <Double-Button-1> [namespace code {
257	ftsearch_open_log %W %x %y
258	break
259    }]
260
261    set ix [lsearch $args -mainwindow]
262    if {$ix >= 0} {
263	set mw [lindex $args [incr ix]]
264	if {$mw != ""} {
265	    set val [option get $mw oddBackground ChatHistory]
266	    if {$val != ""} { $r tag configure ODD -background $val }
267	    set val [option get $mw evenBackground ChatHistory]
268	    if {$val != ""} { $r tag configure EVEN -background $val }
269
270	    set val [option get $mw headerForeground ChatHistory]
271	    if {$val != ""} { $r tag configure HEADER -foreground $val }
272	    set val [option get $mw bodyForeground ChatHistory]
273	    if {$val != ""} { $r tag configure BODY -background $val }
274
275	    set val [option get $mw warningForeground ChatHistory]
276	    if {$val != ""} { $r tag configure WARNING -foreground $val }
277	}
278    }
279
280    set ftsearch(last) ""
281    set ftsearch(results) $r
282    set ftsearch(bg) EVEN
283
284    bind $w <Destroy> +[list [namespace current]::ftsearch_cleanup]
285
286    # Set search panel up:
287
288    # TODO remove when fixed elsewhere.
289    # See also [ftsearch_spanel_close]
290    $r mark set sel_start end
291    $r mark set sel_end   1.0
292
293    set asp [::plugins::search::spanel $w.auxspanel \
294	    -defaultdirection up \
295	    -searchcommand [list ::plugins::search::do_text_search $r] \
296	    -closecommand  [list [namespace current]::ftsearch_spanel_close $r $sp.sentry]]
297
298    bind $sp.sentry <<OpenSearchPanel>> \
299	 [list [namespace current]::ftsearch_spanel_open [double% $w] [double% $asp]]
300}
301
302# Schedules an execution of a script produced by concatenating
303# the words of $args using the # [after idle [after 0 [list ...]]]
304# concept presented at http://mini.net/tcl/1526
305# The idea is that some parts of Tk wait for all idle event
306# handlers to complete. So, when executes, our idle event handler
307# installed in [schedule] installs timed event handler that
308# will be executed ASAP, and since it's not an idle event, it
309# allows the event queue to be in a state free of scheduled
310# idle events (thus allowing Tk to do its job, keeping GUI alive).
311proc histool::schedule args {
312    after idle [list after 0 $args]
313}
314
315# Must be used as the (almost) first command inside any procs
316# scheduled as [after ...] callbacks installed in the course
317# of performing full-text search.
318proc histool::ftsearch_can_proceed {} {
319    variable ftsearch_terminate
320
321    if {$ftsearch_terminate} {
322	unset ftsearch_terminate
323	return false
324    } else {
325	return true
326    }
327}
328
329# This proc builds a list of log files to grep and then starts
330# an asynchronous searching through them
331proc histool::ftsearch_do_search {what dir args} {
332    variable loghier
333    variable ftsearch
334    variable ftsearch_terminate false
335
336    # Returning false means we refuse to start searching:
337    if {$what == ""} { return 0 }
338    if {[string equal $ftsearch(last) $what]} { return 0 }
339
340    set ftsearch(now) $what
341    set ftsearch(found) 0
342
343    set r $ftsearch(results)
344    $r configure -state normal
345    $r delete 1.0 end
346    $r configure -state normal
347
348    set slist {}
349    foreach LA [lsort -index 0 $loghier] {
350	lassign $LA year months
351	foreach LB [lsort -index 0 $months] {
352	    lassign $LB month jids
353	    foreach jid $jids {
354		lappend slist [list $year $month $jid]
355	    }
356	}
357    }
358
359    set ix [lsearch $args -completioncommand]
360    if {$ix >= 0} {
361	set ftsearch(compcmd) [lindex $args [incr ix]]
362    } else {
363	set ftsearch(compcmd) ""
364    }
365
366    # will return almost immediately:
367    ftsearch_grep_next of $slist for $what
368
369    return 1 ;# signalize we've started the search process
370}
371
372# Tries to open the last file in the $slist and schedules
373# the execution of a handler that will read that file
374# looking for $what
375proc histool::ftsearch_grep_next {"of" slist "for" what args} {
376    if {![ftsearch_can_proceed]} return
377
378    variable ftsearch
379    variable ::logger::options
380
381    # Some files are unreadable due to some reason, so we loop
382    # over the list of them until opening succeeds or the list
383    # is exhausted:
384    while true {
385	lassign [lindex $slist end] year month jid
386	set fname [file join $options(logdir) \
387	    $year $month [::logger::jid_to_filename $jid]]
388	if {[catch {open $fname} chan]} {
389	    set r $ftsearch(results)
390	    $r configure -state normal
391	    $r insert end [::msgcat::mc "WARNING: %s\n" $chan] WARNING
392	    $r configure -state disabled
393
394	    set slist [lrange $slist 0 end-1]
395	    if {[llength $slist] > 0} {
396		continue
397	    } else {
398		ftsearch_complete_search for $what
399		return
400	    }
401	} else break
402    }
403
404    fconfigure $chan -encoding utf-8
405
406    schedule \
407	[namespace current]::ftsearch_grep_msg of $slist for $what from $chan
408}
409
410# Reads one line from a log file opened as $chan, parses it, looks
411# for $what in the relevant parts of the aqcuired message, renders
412# it if it match.
413# Searching conditions are checked: this proc is either re-schedules
414# its execution (for the next line of the log file) or schedules the
415# reading of the next log file or completes the searching process.
416proc histool::ftsearch_grep_msg {"of" slist "for" what "from" chan} {
417    if {![ftsearch_can_proceed]} return
418
419    variable ftsearch
420
421    set line [gets $chan]
422
423    if {![eof $chan]} {
424	set msg [::logger::log_to_str $line]
425	if {![catch {array set mparts $msg}]} {
426	    foreach part {nick body} {
427		if {[info exists mparts($part)] && \
428			[::plugins::search::match $what $mparts($part)]} {
429		    lassign [lindex $slist end] year month jid
430		    set r $ftsearch(results)
431		    $r configure -state normal
432		    ftsearch_render_msg $r $year $month $jid $msg
433		    $r configure -state disabled
434		    set ftsearch(found) 1
435		    break
436		}
437	    }
438	}
439	schedule \
440	    [namespace current]::ftsearch_grep_msg of $slist for $what from $chan
441    } else {
442	close $chan
443
444	set rem [lrange $slist 0 end-1]
445	if {[llength $rem] > 0} {
446	    schedule \
447		[namespace current]::ftsearch_grep_next of $rem for $what
448	} else {
449	    ftsearch_complete_search for $what
450	}
451    }
452}
453
454proc histool::ftsearch_render_msg {t year month jid msg} {
455    variable ftsearch
456
457    set tags [list $ftsearch(bg) YEAR-$year MONTH-$month JID-$jid]
458
459    set mynick [get_group_nick "" $jid]
460
461    if {[catch {array set mparts $msg}]} return
462
463    set start [$t index {end - 1 char}]
464
465    set header $jid
466
467    if {[info exists mparts(timestamp)] && $mparts(timestamp) != ""} {
468	set ts [::logger::formatxmppts $mparts(timestamp)]
469	append header " \[$ts\]"
470	lappend tags TS-$mparts(timestamp)
471    }
472
473    if {[info exists mparts(jid)] && $mparts(jid) == ""} {
474	append header " " [::msgcat::mc "Client message"]
475    } elseif {[info exists mparts(nick)]} {
476	if {$mparts(nick) == ""} {
477	    append header " " [::msgcat::mc "Server message"]
478	} else {
479	    append header " " [::msgcat::mc "From:"] " " $mparts(nick)
480	}
481    }
482    $t insert end $header\n HEADER
483    $t insert end $mparts(body)\n BODY
484
485    set end [$t index {end - 1 char}]
486
487    foreach tag $tags {
488	$t tag add $tag $start $end
489    }
490
491    if {[string equal $ftsearch(bg) EVEN]} {
492	set ftsearch(bg) ODD
493    } else {
494	set ftsearch(bg) EVEN
495    }
496}
497
498proc histool::ftsearch_complete_search {"for" what} {
499    variable ftsearch
500
501    set ftsearch(now) ""
502    set ftsearch(last) $what
503
504    if {$ftsearch(compcmd) != ""} {
505	eval $ftsearch(compcmd) $ftsearch(found)
506    }
507}
508
509proc histool::ftsearch_cancel_search {args} {
510    variable ftsearch
511    variable ftsearch_terminate true
512
513    set ftsearch(last) $ftsearch(now)
514    set ftsearch(now) ""
515
516    if {$ftsearch(compcmd) != ""} {
517	eval $ftsearch(compcmd) $ftsearch(found)
518    }
519}
520
521proc histool::ftsearch_open_log {t x y} {
522    variable loghier
523
524    set year   ""
525    set month  ""
526    set ts     ""
527    set jid    ""
528
529    foreach tag [$t tag names @$x,$y] {
530	if {[string match YEAR-* $tag]} {
531	    set year [string range $tag 5 end]
532	}
533	if {[string match MONTH-* $tag]} {
534	    set month [string range $tag 6 end]
535	}
536	if {[string match TS-* $tag]} {
537	    set ts [string range $tag 3 end]
538	}
539	if {[string match JID-* $tag]} {
540	    set jid [string range $tag 4 end]
541	}
542    }
543
544    if {$jid == ""} return
545
546    set cmd [list ::logger::show_log $jid]
547
548    if {$year != "" && $month != ""} {
549	lappend cmd -when $year-$month
550	if {$ts != ""} {
551	    lappend cmd -timestamp $ts
552	}
553    }
554
555    lappend cmd -subdirs [get_subdirs of $loghier for $jid]
556
557    eval $cmd
558}
559
560proc histool::ftsearch_spanel_open {w sp} {
561    grid $sp -sticky we
562}
563
564proc histool::ftsearch_spanel_close {t sentry w} {
565    # TODO remove when fixed elsewhere.
566    # See also [ftsearch_create]
567    $t tag remove search_highlight 0.0 end
568    $t mark set sel_start end
569    $t mark set sel_end 0.0
570
571    grid forget $w
572    focus $sentry
573}
574
575# Cleans up relevant variables when the browser form
576# is destroyed. "ftsearch_terminate" variable is
577# unset in the [after ...] event handler, if such
578# handler is installed.
579proc histool::ftsearch_cleanup {} {
580    variable ftsearch
581    array unset ftsearch
582
583    variable ftsearch_terminate
584    if {[info exists ftsearch_terminate]} {
585	set ftsearch_terminate true
586    }
587}
588
589################################################################
590
591proc histool::jidlist_raise {nb} {
592    set lbox [$nb getframe jidlist].lbox
593    if {[winfo exists $lbox]} {
594	focus $lbox
595    }
596}
597
598proc histool::ltree_raise {nb} {
599    set tree [$nb getframe ltree].tree
600    if {[winfo exists $tree]} {
601	focus $tree
602    }
603}
604
605proc histool::ftsearch_raise {nb} {
606}
607
608# Sorts a list of JIDs based on their parts: node, server and resource.
609# The default comparison order is: server, node, resource.
610# Optional argument/value pairs are accepted:
611# -order LIST -- override the default comparison order.
612proc histool::sort_jids {jids args} {
613    set order {server node resource}
614    foreach {opt val} $args {
615	switch -- $opt {
616	    -order { set order $val }
617	    default { error "invalid option: $opt" }
618	}
619    }
620
621    set norder {}
622    foreach part {node server resource} {
623	lappend norder [lsearch $order $part]
624    }
625
626    set items {}
627    foreach jid $jids {
628	::xmpp::jid::split $jid node server resource
629	set parts [list $node $server $resource]
630	set ordered [list \
631	    [lindex $parts [lindex $norder 0]] \
632	    [lindex $parts [lindex $norder 1]] \
633	    [lindex $parts [lindex $norder 2]] \
634	]
635	set pat [join $ordered \u0000]
636	lappend items [list $pat $jid]
637    }
638
639    set sorted {}
640    foreach item [lsort -index 0 -dictionary $items] {
641	lappend sorted [lindex $item 1]
642    }
643
644    set sorted
645}
646
647proc histool::is_unsupported {} {
648    variable ::logger::options
649
650    catch {
651	set fd [open [file join $options(logdir) version]]
652	if {![package vsatisfies [gets $fd] 1.0]} {
653	    close $fd
654	    error "unsupported log dir structure format"
655	}
656	close $fd
657    }
658}
659
660proc histool::get_log_hier {} {
661    variable ::logger::options
662
663    set LA {}
664    foreach dyear [glob -nocomplain -type d -directory $options(logdir) *] {
665	set year [file tail $dyear]
666	if {![regexp {^\d{4}$} $year]} continue
667	set LB {}
668	foreach dmonth [glob -nocomplain -type d -directory $dyear *] {
669	    set month [file tail $dmonth]
670	    if {![regexp {^0[1-9]$|^1[0-2]$} $month]} continue
671	    set LC {}
672	    foreach file [glob -nocomplain -type f -directory $dmonth *] {
673		lappend LC [::logger::filename_to_jid [file tail $file]]
674	    }
675	    lappend LB [list $month $LC]
676	}
677	lappend LA [list $year $LB]
678    }
679
680    set LA
681}
682
683proc histool::get_jids {loghier} {
684    foreach LA $loghier {
685	foreach LB [lindex $LA 1] {
686	    foreach jid [lindex $LB 1] {
687		set jids($jid) ""
688	    }
689	}
690    }
691
692    array names jids
693}
694
695# From the log hierarchy given by $loghier builds a list of
696# YEAR-MONTH entries producing the same structure that
697# is generated by [::logger::get_subdirs].
698# See plugins/chat/logger.tcl
699proc histool::get_subdirs {"of" loghier "for" jid} {
700    set subdirs {}
701
702    foreach LA $loghier {
703	lassign $LA year months
704	foreach LB $months {
705	    lassign $LB month jids
706	    if {[lsearch -exact $jids $jid] >= 0} {
707		lappend subdirs $year-$month
708	    }
709	}
710    }
711
712    set subdirs
713}
714
715# vim:ts=8:sw=4:sts=4:noet
716