#
#    Copyright (C) 2010 Alexandros Stergiakis <alsterg@gmail.com>
#
#    This program is free software: you can redistribute it and/or modify
#    it under the terms of the GNU Affero General Public License as
#    published by the Free Software Foundation, either version 3 of the
#    License, or (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU Affero General Public License for more details.
#
#    You should have received a copy of the GNU Affero General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.
#

#//#
# A library of useful procedures for the Master and Sesssion interpreters.
#//#

################################
# Useful procedures
################################

# Equivalent the the C language's ? construct.
# If bool is true, then $true is returned, otherwise $false is returned.
#
# @param bool An expression that must be evaluated to either true or false.
# @param true Any string or list.
# @param false Any string or list.
# @return Either $true or $false.
proc ? {bool true {false {}}} {
    if {[expr {$bool}]} {
        return $true
    } else {
        return $false
    }
}

# Remove an item from a list. Item specified by value.
#
# @param listName A list name
# @param item The name/value of the item to remove
proc lremove {listName item} {
    upvar $listName lst
    if {[set pos [lsearch -exact $lst $item]] == -1} {
        return
    }
    set lst [lreplace $lst $pos $pos]
}

# Test if a string is empty.
#
# @param listValue A list name
# @return true if empty, otherwise false
proc lempty {listValue} {
    expr {$listValue eq {}}
}

# Return the input text with extra formating based on ANSI escape codes.
# If ANSI escape codes are disabled for a session, then only the -underline
# parameter is supported (using special marking). The rest are ignored.
#
# @todo Support background color and the other ANSI codes.
# @param sid Session ID.
# @param args -bold <bool> -underline <bool> -crossed <bool> -italic <bool> -blinkslow <bool> -blinkrapid <bool> -franktur <bool> -color <color> -- <text>
# @return The input text formatted.
proc ansi {sid args} {
    Session $sid ANSI
    
    if {! $ANSI} {
        # We only support -underline, using special marking.
        set txt [lindex $args end]
        if {"-underline" in [lrange $args 0 end-1]} {
            set txt ">>> $txt <<<"
        }
        return $txt
    }
    
    set ESC "\033"
    set color {}
    set type {}
    set suffix {}
    
    for {set i 0} {$i < [llength $args]} {incr i} {
        set arg [lindex $args $i]
        
        switch -exact -- $arg {
            "-bold" {
                set type 1
                append suffix "${ESC}\[22m"
            }
            "-underline" {
                set type 4
                append suffix "${ESC}\[24m"
            }
            "-crossed" {
                set type 9
                append suffix "${ESC}\[29m"
            }
            "-italic" {
                set type 3
                append suffix "${ESC}\[23m"
            }
            "-blinkslow" {
                set type 5
                append suffix "${ESC}\[25m"
            }
            "-blinkrapid" {
                set type 6
                append suffix "${ESC}\[25m"
            }
            "-franktur" {
                set type 20
                append suffix "${ESC}\[23m"
            }
            "-color" {
                switch -exact -- [lindex $args [incr i]] {
                    "black" { set color {;30}}
                    "red" { set color {;31}}
                    "green" { set color {;32}}
                    "yellow" { set color {;33}}
                    "blue" { set color {;34}}
                    "magenta" { set color {;35}}
                    "cyan" { set color {;36}}
                    "white" { set color {;37}}
                    default { error "unrecognized color" }
                }
                append suffix "${ESC}\[;37m"
            }
            "--" { # skip }
            default {
                set txt $arg
            }
        }
    }
    return "${ESC}\[${type}${color}m$txt${suffix}"
}

################################
# Shared memory access
################################

# Update the value of shared memory variable, when the corresponding local changes.
#
# @param name The name of the local/shared variable.
# @param args Rest of standard variable trace arguments.
proc Global_update_write {name args} {
    upvar $name var
    tsv::set conf $name $var
}

# This procedure makes it easy to access module shared memory parameters among threads
# by mapping a local variable to a shared memory variable, and optionally keeping them
# synchronized as the local variable changes. However, if the session variable changes
# the local will not be updated. Review the code where this proc is used
# to investigate whether this could happen and whether it poses a problem.
# A read trace would solve this, but adds significant extra overhead.
#
# @param args List of shared memory variable names to bind local variables to.
# @error
proc Global {args} {
    set sync 0 ;# default is "ro"
    switch -exact -- [lindex $args 0] {
        "-rw" { set sync 1; set args [lrange $args 1 end] }
        "-ro" { set args [lrange $args 1 end] }
    }

    foreach var $args {
        if {! [tsv::exists conf $var]} {
            error "Global configuration variable \"$var\" is not defined"
        }
        
        uplevel 1 [list set $var [tsv::get conf $var]]
        
        if {$sync} {
            uplevel 1 [list trace add variable $var write ::Global_update_write]
        }
    }
}

# Update the value of shared memory variable, when the corresponding local changes.
#
# @param name The name of the local/shared variable.
# @param args Rest of standard variable trace arguments.
proc Session_update_write {name args} {
    upvar $name var __sid__ sid
    tsv::set $sid $name $var
}

# This procedure makes it easy to access shared memory session parameters,
# by mapping a local variable to a shared memory variable, and keeping them
# synchronized. However, if the session variable changes
# the local will not be updated. Review the code where this proc is used
# to investigate whether this could happen and whether it poses a problem.
# A read trace would solve this, but adds significant extra overhead.
#
# @param args [-rw|-ro] <sid> var1 [var2 ...]
proc Session {args} {
    set sync 0 ;# default is "ro"
    switch -exact -- [lindex $args 0] {
        "-rw" { set sync 1; set args [lrange $args 1 end] }
        "-ro" { set args [lrange $args 1 end] }
    }
    
    set sid [lindex $args 0]
    set args [lrange $args 1 end]
    
    foreach var $args {
        if {! [tsv::exists $sid $var]} {
            error "Session configuration variable \"$var\" is not defined"
        }
        uplevel 1 [list set $var [tsv::get $sid $var]]
        
        if {$sync} {
            uplevel 1 [list set __sid__ $sid]
            uplevel 1 [list trace add variable $var write Session_update_write]
        }
    }
}

# Update the value of shared memory variable, when the corresponding local changes.
#
# @param name The name of the local/shared variable.
# @param args Rest of standard variable trace arguments.
proc Module_update_write {name args} {
    upvar $name var __mod__ mod
    tsv::set $mod $name $var
}

# This procedure makes it easy to access global shared memory parameters
# by mapping a local variable to a shared memory variable, and keeping them
# synchronized.However, if the session variable changes
# the local will not be updated. Review the code where this proc is used
# to investigate whether this could happen and whether it poses a problem.
# A read trace would solve this, but adds significant extra overhead.
#
# @param args [-rw|-ro] <mod> var1 [var2 ...]
proc Module {args} {
    set sync 0 ;# default is "ro"
    switch -exact -- [lindex $args 0] {
        "-rw" { set sync 1; set args [lrange $args 1 end] }
        "-ro" { set args [lrange $args 1 end] }
    }
    
    set mod [lindex $args 0]
    set args [lrange $args 1 end]
    
    foreach var $args {
        if {! [tsv::exists $mod $var]} {
            error "Session configuration variable \"$var\" is not defined"
        }
        uplevel 1 [list set $var [tsv::get $mod $var]]
        
        if {$sync} {
            uplevel 1 [list set __mod__ $mod]
            uplevel 1 [list trace add variable $var write Module_update_write]
        }
    }
}

################################
# Non-blocking thread::send
################################

namespace eval Thread {

# When bgsend is invoked, it waits on a variable (result_$counter) to be set. This variable
# is set by the executed script when its evaluation completes. Since it is possible
# that the script being evaluated uses bgsend again in the other direction,
# and following that more bgsends in both directions can be opened (waiting for
# their variable to be set), for this reason we can not use the same variable for
# all parallel bgsend sessions. We use a different namespace variable for each.
# The 'counter' variable is used to generate unique names, for each session-
# specific variable.
variable counter 0

# A procedure executed when a bgsend job timeouts.
#
# @param counter The unique number associated with this bgsend job.
# @param tid Thread Id of thread script is sent to.
proc bgsend_timeout {counter tid} {
    if {[interp exists $tid]} {
        interp cancel $tid "Timeout waiting"
    }
    set ::Thread::result_${counter} [list 1 {Timeout waiting} {-code 1 -level 0 -errorcode NONE -errorinfo {Timeout waiting}}]
}
    
# A version of thread::send with asynchronous execution, that waits until command
# is evaluated (without blocking), propagates errors back, and returns the result of
# the evaluation. In addition it supports the folling option(s):
#   -timeout <val> : Wait up to <val> ms for the script to return. If it doesn't return by
#                               that time, generate an error back to the caller.
#                               Warning: Although the procedure 'bgsend' returns, the script
#                               might still be executed when it gets its turn in the event loop
#                               at some unknown time in the future. Result in this case will
#                               be lost. Errors will be captured by 'bgerror'.
#
# @param tid Thread Id to evaluate script into.
# @param script Tcl script to evaluate.
# @param args Optional parameters.
# @return The return value of the evaluation.
# @error
proc bgsend {tid script args} {
    variable counter  

    for {set i 0} {$i < [llength $args]} {incr i} {
        switch -exact -- [lindex $args $i] {
            "-timeout" {
                set timeout [lindex $args [incr i]]
            }
            default {
                error "Unrecognized option"
            }
        }
    }

    incr counter
    
    set script [format {
        set _err [catch { %s } _res _opt]
        thread::send -async %s [list set ::Thread::result_%d [list $_err $_res $_opt]]
    } $script [thread::id] $counter]

    if {[info exists timeout]} {
        after $timeout [list ::Thread::bgsend_timeout $counter $tid]
    }
    
    set ::Thread::result_${counter} {}    
    thread::send -async $tid $script
    
    vwait ::Thread::result_${counter}
    
    if {! [info exists ::Thread::result_${counter}]} { return } ;# XXX
    
    lassign [set ::Thread::result_${counter}] err res opt 
    unset ::Thread::result_${counter}

    if {$err} { ;# An error occured.
        return -options $opt $res
    }
    
    return $res
}

} ;# namespace