#
#	cold_text.tcl
#	~/.tkMOO-lite/plugins/cold_text.tcl
#

# tkMOO-light is Copyright (c) Andrew Wilson 1994,1995,1996,1997,1998
#
#       All Rights Reserved
#
# Permission is hereby granted to use this software for private, academic
# and non-commercial use. No commercial or profitable use of this
# software may be made without the prior permission of the author.
#
# THIS SOFTWARE IS PROVIDED BY ANDREW WILSON ``AS IS'' AND ANY
# EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL ANDREW WILSON BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
# OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

# Translate CML derived text into clickable links.  Linked text is
# displayed in blue, and the cursor shape will change when the pointer
# moves over it, at the same time a command to be sent to the server
# is displayed in the client's status-bar message window.  Clicking
# on mouse button 1 will activate the link, sending the command to
# the server.
# 
# Error trapping is minimal, the client does enough to prevent itself
# from being damaged by malformed text.  No error detection is
# performed.  The text is assumed to be perfect when it arrives at
# the client.
#
# Special care needs to be taken when escaping characters for
# display on-screen and also for sending back to the server.  TCL's
# evaluation and dereferencing rules are especially tiresome and
# complicated.

# TODO
# Cold needs to send quoted literals in the { text " ... " } field.
# this means that the literal '"' needs to be escaped.  eg:
#     {link {command "look sign"} {text "a sign reading, \"notice board\""}}
# Clients with triggers configured will see the triggers operating
# on some lines before the cold_text plugin gets a chanse to see
# the data.
# Problem sending (escaped and or unescaped) meta characters back to Cold.
# eg say this is an escaped lbrace ... \{
# result is displayed as
#        this is an escaped lbrace ... \\{
# not sure if it's me or Cold fucking up.  

preferences.register location {Special Forces} {
    { {directive UseColdText}
        {type boolean}
        {default Off}
        {display "Use Cold Text"} }
} 

# cold text is processed after OOB and Trigger stuff
client.register cold_text incoming 60
client.register cold_text client_connected 

proc cold_text.client_connected {} {
    global cold_text_use
    # calculating this variable is costly, do it once on connection
    set use [worlds.get_generic Off {} {} UseColdText]
    set cold_text_use 0
    if { [string tolower $use] == "on" } {
        set cold_text_use 1
    }
    return [modules.module_deferred]
}

proc cold_text.escape str {
    regsub -all {\\\\} $str __ESCAPE__ str
    regsub -all {\\\{} $str __LBRACE__ str
    regsub -all {\\\}} $str __RBRACE__ str
    return $str
}

proc cold_text.unescape str {
    regsub -all __ESCAPE__ $str \\ str
    regsub -all __LBRACE__ $str \{ str
    regsub -all __RBRACE__ $str \} str
    return $str
}

proc cold_text.escape_tcl str {
    regsub -all {\\} $str {\\\\} str
    regsub -all {\$} $str {\\$} str
    regsub -all {\[} $str {\\[} str
    regsub -all {\]} $str {\\]} str
    return $str
}

proc cold_text.incoming event {
    global cold_text_use

    if { $cold_text_use == 0 } {
        return [modules.module_deferred]
    }

    set line [db.get $event line]
    # subs
    set line [cold_text.escape $line]
    # convert
    set converted [cold_text.convert_line $line]
    # unsubs
    cold_text.do.line $converted
    return [modules.module_ok]
}

proc cold_text.matching { begin end str } {
    set psn [string first $begin $str]
    incr psn
    set count 1
    # move from left to right counting start or end characters till
    # the balance == 0 and you're on an end character.
    while { $count > 0 } {
        set mystr [string range $str $psn end]
        set beginner [string first $begin $mystr]
        set ender    [string first $end   $mystr]

        # which is first
        if { $beginner >= 0 } {
            if { $beginner < $ender } {
                set first $begin
            } {
                set first $end
            }
        } {
            set first $end
        }

        if { $first == $begin } {
            incr psn $beginner
            incr psn
            incr count
        } 

        if { $first == $end } {
            incr psn $ender
            incr psn
            incr count -1
        }
           
    }
    return $psn
}

proc cold_text.do.text words {
    set str [lindex $words 0]
    set unescaped [cold_text.unescape $str]
    window.display "$unescaped"
} 

proc cold_text.do.link link {
    while { $link != {} } {
        set head [lindex $link 0]
        set link [lrange $link 1 end] 
        set data([lindex $head 0]) [lrange $head 1 end]
    }
    set tag .[util.unique_id tag]
    set cmd [cold_text.unescape [lindex $data(command) 0]]
    .output tag configure $tag -foreground blue
    # FIXME
    # errors still when cmd contains quotes! 
    # errors still when cmd contains \{  (strewth)
    regsub -all \" $cmd \\\" cmd
#    regsub -all \\ $cmd {\\\\} cmd
    .output tag bind $tag <Button1-ButtonRelease> "client.outgoing \"[cold_text.escape_tcl $cmd]\""
    .output tag bind $tag <Enter> ".output configure -cursor hand2;window.set_status \"[cold_text.escape_tcl $cmd]\""
    .output tag bind $tag <Leave> ".output configure -cursor {}; window.set_status \"\""
    set words [cold_text.unescape [lindex $data(text) 0]]
    window.display $words $tag
}   
    
proc cold_text.do.line line {
    while { $line != {} } {
        set head [lindex $line 0]
        set line [lrange $line 1 end]
        cold_text.do.[lindex $head 0] [lrange $head 1 end]
    }   
    window.displayCR
}


proc cold_text.convert_line str {
    set list {}
    while { $str != {} } {
        if { [regexp -indices -- {^([^\{]*)(\{.*)$} $str ignore pre post] == 1 } {      
           lappend list [list "text" [string range $str [lindex $pre 0] [lindex $pre 1] ]]
           # set str to the rest of the line... including leading whitespace
           set str [string range $str [lindex $post 0] end]

	   # work out the beginning and end of the list fragment
	   set matching [cold_text.matching \{ \} $str]

	   # get a string containing the list
	   set it [string range $str 0 [expr $matching - 1]]

#	   puts "it=>$it<"

	   # convert to a real list and lappend to our converted data
           lappend list [lindex $it 0]
   
           # get the remainder of the string, and keep going
           set str [string range $str $matching end]
        } {
	   # treat is as plain text
           lappend list [list text $str]
           set str {}
        }
    }
    return $list
}