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