# tclchat.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Inject the history from the tclers chat logs into the current chat window.
# This hook only activates if you open a groupchat to a site that
# we know is linked to the tclers chat. ie: tach.tclers.tk or the irc channel.
#
# $Id$

package require msgcat

namespace eval tclchat {
    ::msgcat::mcload [file join [file dirname [info script]] msgs]

    if {![::plugins::is_registered tclchat]} {
	::plugins::register tclchat \
			    -namespace [namespace current] \
			    -source [info script] \
			    -description [::msgcat::mc "Whether the Tclchat plugin is loaded."] \
			    -loadcommand [namespace code load] \
			    -unloadcommand [namespace code unload]
	return
    }

    custom::defgroup Plugins [::msgcat::mc "Plugins options."] \
	-group Tkabber

    custom::defgroup Tclchat [::msgcat::mc "Tclchat plugin options."] \
	-group Plugins

    custom::defvar options(use_tkchat_colors) 1 \
        [::msgcat::mc "Use TkChat embedded colors."] \
        -group Chat -group Tclchat -type boolean
}

# Load in the additional files that are part of the tclchat plugin.
#
source [file join [file dirname [info script]] tclchat_messages.tcl]
source [file join [file dirname [info script]] tclchat_commands.tcl]

package require http 2

proc tclchat::load {} {
    load_commands
    load_messages

    hook::add finload_hook [namespace current]::on_init 30
    hook::add open_chat_post_hook [namespace current]::on_open_chat
    hook::add chat_send_message_xlist_hook [namespace current]::add_color

    on_init
}

proc tclchat::unload {} {
    catch {
	set menu [.mainframe getmenu plugins]
	set idx [$menu index [msgcat::mc "Tkchat colors"]]
	$menu delete $idx
    }

    unload_commands
    unload_messages

    hook::remove finload_hook [namespace current]::on_init 30
    hook::remove open_chat_post_hook [namespace current]::on_open_chat
    hook::remove chat_send_message_xlist_hook [namespace current]::add_color
}

proc tclchat::on_init {} {
    global tcl_platform
    global loginconf
    variable Options
    variable urlid 0

    catch {
	set menu [.mainframe getmenu plugins]
	$menu add checkbutton -label [msgcat::mc "Tkchat colors"] \
	      -underline 0 -variable [namespace current]::options(use_tkchat_colors)
    }

    array set Options {
        HistoryLines  0
        url           "http://tclers.tk/conferences/tcl"
        sel           "/?pattern=*.tcl"
        RE            {<A HREF="([0-9\-%d]+\.tcl)">.*\s([0-9]+) bytes}
    }
}

proc tclchat::on_open_chat {chatid type} {
    variable Options
    if {[string equal $type "groupchat"]} {
        switch -glob -- [set mucjid [chat::get_jid $chatid]] {
            *@tach.tclers.tk {
                set muc [lindex [split $mucjid @] 0]
                set Options(url) "http://tclers.tk/conferences/$muc"
                after 400 [LoadHistory $chatid]
            }
        }
    }
    set W [chat::chat_win $chatid]
    $W tag configure URL -underline 1
    $W tag bind URL <Enter> [list $W configure -cursor hand2]
    $W tag bind URL <Leave> [list $W configure -cursor xterm]
    return
}

# -------------------------------------------------------------------------

# Check the HTTP response for redirecting URLs. - PT
proc tclchat::checkForRedirection {tok} {
    set ncode [::http::ncode $tok]
    if {[expr {$ncode == 302 || $ncode == 301 || $ncode == 307}]} {
        upvar \#0 $tok state
        array set meta $state(meta)
        if {[info exists meta(Location)]} {
            return $meta(Location)
        }
    }
    return {}
}

proc tclchat::FetchHistoryIndex {url} {
    variable Options

    set loglist {}
    set tok [::http::geturl ${url}$Options(sel)]
    switch -- [::http::status $tok] {
        ok {
            if {[::http::ncode $tok] >= 500} {
                debugmsg tclchat "error [::http::code $tok]"
            } elseif {[http::ncode $tok] >= 400} {
                debugmsg tclchat "error [::http::code $tok]"
            } else {
                if {[set _url [checkForRedirection $tok]] != {}} {
                    regsub {/\?M=D} $_url {} $_url
                    set loglist [FetchHistoryIndex $_url]
                } else {
                    foreach line [split [::http::data $tok] \n] {
                        if { [regexp -- $Options(RE) $line -> logname size] } {
                            set logname [string map {"%2d" -} $logname]
                            set size [expr {$size / 1024}]k
                            set loglist [linsert $loglist 0 $logname $size]
                        }
                    }
                }
            }
        }
        reset   { debugmsg tclchat "reset" }
        timeout { debugmsg tclchat "timeout" }
        error   { debugmsg tclchat "error [::http::error $tok]" }
        default { debugmsg tclchat "????? [::http::error $tok]" }
    }
    ::http::cleanup $tok
    return $loglist
}

proc tclchat::ParseHistLog {log {reverse 0}} {
    variable Options

    set retList {}
    set MsgRE {^\s*(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun).+?\[([^\]]+)\]\s+([^:]+):?\s*(.*)$}
    set ircRE {ircbridge: \*\*\* (.+) (.+)$}
    set TimeRE {^(.+?)\s+(.+?)\s+(\d{1,2})\s+(\d\d:\d\d:\d\d)\s+(\d{4})}
    set logtime 0

    # fetch log
    set url "$Options(url)/$log"
    debugmsg tclchat "fetch log \"$url\""
    set tok [::http::geturl $url]

    debugmsg tclchat "status [::http::status $tok] [::http::code $tok]"
    switch -- [::http::status $tok] {
        ok {
            # Tcl Jabber logs
            set I [interp create -safe]
            interp alias $I m {} [namespace current]::ParseLogMsg
            if { $reverse } {
                set histTmp [set [namespace current]::History]
                set Options(History) {}
            }
            $I eval [::http::data $tok]
            if { $reverse } {
                set Options(History) [concat $Options(History) $histTmp]
            }
        }
        reset   { debugmsg tclchat "reset" }
        timeout { debugmsg tclchat "timeout" }
        error   { debugmsg tclchat "error [::http::error $tok]" }
        default { debugmsg tclchat "????? [::http::error $tok]" }
    }
    ::http::cleanup $tok
    return $retList
}

# this called on first logon and after a purge
# so not bothering to backgound it
proc tclchat::LoadHistory {chatid} {
    variable Options

    set FinalList {}
    if {$Options(HistoryLines) == 0} {
	# don't even bother
    } elseif {$Options(HistoryLines) < 0} {
	set loglist [FetchHistoryIndex $Options(url)]
	if {[set len [llength $loglist]] > 0} {
            if {$len > 18} {
                set loglist [lrange $loglist 0 17]
            }

	    # ask user
	    set t [toplevel .histQ -class dialog]
	    wm withdraw $t
	    wm transient $t
	    wm protocol $t WM_DELETE_WINDOW { }
	    wm title $t "Load History From Logs"
	    grid [label $t.lbl \
		    -text "Please select how far back you want to load:"] \
		    -sticky ew -pady 5
	    set i 0
	    variable HistQueryNum [expr {[llength $loglist] / 2}]
            set loglist [lpairreverse $loglist]
	    foreach {l s} $loglist {
		grid [radiobutton $t.rb$i -text "$l $s" \
                          -val $i -var [namespace current]::HistQueryNum] \
                    -sticky w -padx 15 -pady 0
		incr i
	    }
	    grid [radiobutton $t.rb$i -text "None" \
                      -val $i -var [namespace current]::HistQueryNum] \
                -sticky w -padx 15 -pady 0
	    grid [button $t.ok -text Ok -width 8 \
                      -command [list destroy $t] -default active] \
                -sticky e -padx 5 -pady 10
	    grid columnconfigure $t 0 -weight 1
	    bind $t <Return> [list $t.ok invoke]
	    catch {::tk::PlaceWindow $t widget .}
	    wm deiconify $t
	    tkwait visibility $t
            focus $t.ok
	    grab $t
	    tkwait window $t
	    foreach {l s} [lrange $loglist [expr {$HistQueryNum * 2}] end] {
                debugmsg tclchat "loading history \"$l\" (${s}k)"
		if {[catch {ParseHistLog $l} new]} {
		    debugmsg tclchat "ERROR: $new"
                }
            }
	}
    } else {
	set loglist [FetchHistoryIndex $Options(url)]
	# go thru logs in reverse until N lines loaded
        foreach {log size} $loglist {
	    # fetch log
	    if {[catch {ParseHistLog $log} new]} {
		debugmsg tclchat "ERROR: $new"
            }
	    if {[llength $Options(History)] >= $Options(HistoryLines)} {
		break
	    }
	}
    }

    set W [chat::chat_win $chatid]

    # Set a mark for the history insertion point.
    if {[lsearch -exact [$W mark names] HISTORY] == -1} {
        $W config -state normal
        $W insert 0.0 \
            "+++++++++++++++ Loading History +++++++++++++\n"
        $W mark set HISTORY 0.0
        $W config -state disabled
    }

    LoadHistoryLines $chatid

    $W see end
}


proc tclchat::LoadHistoryLines {chatid} {
    variable Options

    set w [chat::chat_win $chatid]
    set state [$w cget -state]
    $w configure -state normal

    if {![info exists Options(History)]} {set Options(History) {}}

    set count 0
    foreach {time nick msg} $Options(History) {
        #$w insert HISTORY "<$nick> $msg\n" [list they NICK-$nick]
        Insert $w $nick $msg $time
        incr count 3
        if {$count > 100} { break }
    }
    $w see end
    set Options(History) [lrange $Options(History) $count end]

    if {$Options(History) == {}} {
        $w configure -state normal
        $w delete "HISTORY + 1 char" "HISTORY + 1 line"
        $w insert "HISTORY + 1 char" \
            "+++++++++++++++ End Of History +++++++++++++\n"
    } else {
        after idle [list [namespace origin LoadHistoryLines] $chatid]
    }

    $w configure -state $state
}

proc tclchat::gotourl {url} {
    debugmsg tclchat "goto url \"$url\""
    browseurl $url
}

proc tclchat::Insert {w nick msg time} {
    variable urlid
    if {[info exists ::plugins::options(delayed_timestamp_format)]} {
        set fmt $::plugins::options(delayed_timestamp_format)
    } else {
        set fmt "\[%m/%d %R\]"
    }

    if {[string equal $nick "ijchain"]} {
        set nick ""
        regexp {^<(\w+)> (.*)$} $msg -> nick msg
    }

    set nk "<$nick>"
    if {[string length $nick] < 1} {set nk "*"}

    $w insert HISTORY \
        [clock format $time -format $fmt] {} \
        "$nk " [list they NICK-$nick]
    while {[regexp -nocase -- {^(.*?)<A.*?HREF="(.+?)".*?>(.*?)</A>(.*?)$} \
                  $msg -> pre url link post]} {
	if {[string length $pre]} {
            $w insert HISTORY $pre [list they NICK-$nick]
	}
        set id URL-[incr urlid]
        $w insert HISTORY $link [list they NICK-$nick URL $id]
        $w tag bind $id <1> [list [namespace origin gotourl] $link]
	set msg $post
    }
    $w insert HISTORY "$msg\n" [list they NICK-$nick]
}

proc tclchat::ParseLogMsg { when nick msg {opts ""} args } {
    variable Options
    set Options(HaveHistory) 1
    set time [clock scan ${when} -gmt 1]
    lappend Options(History) $time $nick $msg
    if {[llength $args] > 0} {
	debugmsg tclchat "WARNING: Log incorrect log format."
    }
    #debugmsg tclchat "[clock format $time] $nick :: $msg $opts $args"
}

proc tclchat::lpairreverse {L} {
    set res {}
    set i [llength $L]
    while {$i} {
        lappend res [lindex $L [incr i -2]] [lindex $L [incr i]]
        incr i -1
    }
    set res
}

proc tclchat::color_to_hex {color} {
    lassign [winfo rgb . $color] r g b
    return [format "%02x%02x%02x" \
                   [expr {$r % 256}] [expr {$g % 256}] [expr {$b % 256}]]
}

# tclchat::add_color --
#
#	In our tclers groupchat window, we want to add additional 'x'
#	elements to add our own color specification.
#
proc tclchat::add_color {varname chatid user id body type} {
    variable options
    upvar 2 $varname var

    set jid [chat::get_jid $chatid]
    if {$options(use_tkchat_colors) && \
            [cequal $type "groupchat"] && \
            [string match "*@tach.tclers.tk" $jid]} {

	set color [plugins::nickcolors::get_color $user]
        if {[string length $color] > 0} {
            lappend var [::xmpp::xml::create x \
				-xmlns urn:tkchat:chat \
                                -attrs [list color [color_to_hex $color]]]
        }
    }
}

# vim:ts=8:sw=4:sts=4:noet
