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

# tkMOO-light is Copyright (c) Andrew Wilson 1994,1995,1996,1997,1998,
#                                            1999,2000
# 
# 	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.

client.register cvw.env start 60
client.register cvw.env client_connected
proc cvw.env.start {} {
    cvw.env.initialise_db
    mcp20.register cvw-env 1.2 cvw-env-changed cvw.env.do_cvw_env_changed
    mcp20.register cvw-env 1.2 cvw-env-contents cvw.env.do_cvw_env_contents
    mcp20.register cvw-env 1.2 cvw-env-inventory cvw.env.do_cvw_env_inventory
    mcp20.register cvw-env 1.2 cvw-env-move-error cvw.env.do_cvw_env_move_error
    cvw.utils.register cvw.env.move-error cvw.env.handle_move_error
    window.menu_tools_add "Toggle CVW Inventory" cvw.env.toggle_inventory
    cvw.utils.register cvw.env.inventory cvw.env.handle_cvw_env_inventory
}
proc cvw.env.client_connected {} {
    cvw.env.initialise_db
    return [modules.module_deferred]
}
proc cvw.env.initialise_db {} {
    global cvw_env_changed_db cvw_env_contents_db cvw_env_inventory_db
    set cvw_env_changed_db(floornum) 0
    set cvw_env_changed_db(newroom) ""
    set cvw_env_changed_db(room_name) ""
    set cvw_env_contents_db(users) {}
    set cvw_env_contents_db(objects) {}
    set cvw_env_contents_db(object_owner_names) {}
    set cvw_env_inventory_db(objects) {}
    set cvw_env_inventory_db(object_owner_names) {}
    set cvw_env_inventory_db(inventory_window) ""
}
proc cvw.env.changed {floornum newroom room_name} {
    global cvw_env_changed_db
    set cvw_env_changed_db(floornum) $floornum
    set cvw_env_changed_db(newroom) $newroom
    set cvw_env_changed_db(room_name) $room_name
    cvw.utils.dispatch cvw.env.changed
}
proc cvw.env.contents {users objects object_owner_names} {
    global cvw_env_contents_db
    set cvw_env_contents_db(users) $users
    set cvw_env_contents_db(objects) $objects
    set cvw_env_contents_db(object_owner_names) $object_owner_names
    cvw.utils.dispatch cvw.env.contents
}
proc cvw.env.inventory {objects object_owner_names} {
    global cvw_env_inventory_db
    set cvw_env_inventory_db(objects) $objects
    set cvw_env_inventory_db(object_owner_names) $object_owner_names
    cvw.utils.dispatch cvw.env.inventory
}

proc cvw.env.get_floornum {} {
    global cvw_env_changed_db
    return $cvw_env_changed_db(floornum)
}
proc cvw.env.get_newroom {} {
    global cvw_env_changed_db
    return $cvw_env_changed_db(newroom)
}
proc cvw.env.get_contents {} {
    global cvw_env_contents_db
    return [list $cvw_env_contents_db(users) $cvw_env_contents_db(objects) $cvw_env_contents_db(object_owner_names)]
}
proc cvw.env.get_inventory {} {
    global cvw_env_inventory_db
    return [list $cvw_env_inventory_db(objects) $cvw_env_inventory_db(object_owner_names)]
}
   

proc cvw.env.do_cvw_env_inventory {} {
    set objects [request.get current objects]
    set object_owner_names [request.get current object-owner-names]
    cvw.env.inventory $objects $object_owner_names
}   
proc cvw.env.do_cvw_env_contents {} {
    set users [request.get current users]
    set objects [request.get current objects]
    set object_owner_names [request.get current object-owner-names]
    cvw.env.contents $users $objects $object_owner_names
}   
 
proc cvw.env.do_cvw_env_changed {} {
    set floornum [request.get current floornum]
    set newroom [request.get current newroom]
    set room_name [request.get current room_name]
    cvw.env.changed $floornum $newroom $room_name
}

proc cvw.env.do_cvw_env_move_error {} {
    set error_msg [request.get current error_msg]
    cvw.utils.dispatch cvw.env.move-error [list error_msg $error_msg] \
	[list keyword value] [list key val]
}

proc cvw.env.handle_move_error args {
    set error_msg [util.assoc [lindex $args 0] error_msg]
    window.displayCR "[lindex $error_msg 1]"
}


proc cvw.env.toggle_inventory {} {
    global cvw_env_inventory_db
    if { [winfo exists $cvw_env_inventory_db(inventory_window)] } {
        cvw.contents.destroy $cvw_env_inventory_db(inventory_window)
    } {
        set w .[util.unique_id inventory_window]
        toplevel $w

        wm title $w "Carrying"
        wm iconname $w "Carrying"

        window.place_nice $w
        set details [cvw.contents.create $w.details]

        cvw.contents.set_headings $w.details [list \
            Name        \
            Type        \
            Modified    \
            By          \
            Created     \
            By]

        cvw.contents.set_tabstrings $w.details [list \
            [string repeat "M" 15]          \
            "Form Folder"                   \
            "00/00/00"                      \
            "Networker"                     \
            "00/00/00"                      \
            "Networker"]

        pack $w.details -fill both -expand 1
        set cvw_env_inventory_db(inventory_window) $w

        cvw.contents.fill_contents $cvw_env_inventory_db(inventory_window).details [lindex [cvw.env.get_inventory] 0]

    }

}

proc cvw.env.handle_cvw_env_inventory args {
    global cvw_env_inventory_db
    if { [winfo exists $cvw_env_inventory_db(inventory_window)] } {
        cvw.contents.fill_contents $cvw_env_inventory_db(inventory_window).details [lindex [cvw.env.get_inventory] 0]
    }

}
proc cvw.utils.register {event callback} {
    global cvw_utils_register_db
    lappend cvw_utils_register_db($event) $callback
}

proc cvw.utils.dispatch {event args} {
    global cvw_utils_register_db
    if { [info exists cvw_utils_register_db($event)] } {
	foreach callback $cvw_utils_register_db($event) {
	    $callback $args
	}
    }
}

proc cvw.utils.split {str delim} {
    set list {}
    set len [string length $delim]
    set str [string range $str $len end]
    while { $str != "" } {
        set psn [string first $delim $str]
        lappend list [string range $str 0 [expr $psn - 1]]
        set str [string range $str [expr $psn + $len] end]
    }   
    return $list
}   










client.register mcp20 start
client.register mcp20 client_connected
client.register mcp20 incoming 40

proc mcp20.start {} {
    global mcp20_authentication_key mcp20_registry_internal \
	mcp20_report_overlap
    set mcp20_authentication_key ""
    set mcp20_registry_internal {}
    set mcp20_report_overlap {}


    if { 0 } {
        foreach {protocol version} {
	    x-mcast-channel	1.0
	    cvw-av		1.3
	    cvw-preferences	1.1
	    cvw-group		1.0
	    cvw-proxy		1.1
	    cvw-whiteboard	1.0
	    cvw-text		1.4
	    cvw-lookup		1.5
	    cvw-user		1.2
	    cvw-modify		1.1
	    cvw-init-id		1.2
	    cvw-document	1.4
	    cvw-move		1.1
	    cvw-system		1.3
	    display-url		1.0
	    cvw-access		1.1
	    cvw-object		1.3
	    cvw-env		1.2
	    cvw-map		1.0
	    x-login-failed	1.0
        } {
	    mcp20.register $protocol $version fake-message not.a_real_callback
        }
    }

    mcp20.register mcp 2.0 mcp mcp20.do_mcp 

    mcp20.register cvw-auth 1.0 cvw-auth-end mcp20.do_cvw_auth_end
    mcp20.register cvw-auth 1.0 cvw-auth-method mcp20.do_cvw_auth_method
    mcp20.register mcp 2.0 protocol mcp20.do_protocol
    mcp20.register mcp 2.0 protocol-end mcp20.do_protocol_end

    mcp20.register_internal cvw.cvw_init_id mcp_negotiate_end

}

proc cvw.cvw_init_id.mcp_negotiate_end {} {
}

proc mcp20.do_cvw_auth_end {} {
    mcp20.server_notify cvw-auth-method [list [list name basic] [list version "1.0"]]
}
proc mcp20.do_cvw_auth_method {} {
    mcp20.server_notify cvw-auth-method-end
    mcp20.negotiate_protocols
}

proc mcp20.register_internal { module event } {
    global mcp20_registry_internal
    lappend mcp20_registry_internal [list $module $event]
}   

proc mcp20.dispatch_internal event {
    global mcp20_registry_internal
    foreach me $mcp20_registry_internal {  
        if { $event == [lindex $me 1] } {
            [lindex $me 0].$event
        }
    }
}   

preferences.register mcp20 {Out of Band} {
    { {directive UseModuleMCP20}
        {type boolean}
        {default Off}
        {display "Use MCP/2.0"} }
}

proc mcp20.client_connected {} {
    global mcp20_use mcp20_active mcp20_server_registry mcp20_report_overlap

    set mcp20_report_overlap {}
    set mcp20_server_registry {}

    set mcp20_use 0
    set use [string tolower [worlds.get_generic Off {} {} UseModuleMCP20]]
    if { $use == "on" } {
        set mcp20_use 1
    } elseif { $use == "off" } {
        set mcp20_use 0
    }

    set mcp20_active 0

    return [modules.module_deferred]
}   

proc mcp20.incoming event {
    global mcp20_use mcp20_active mcp20_authentication_key

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

    set PREFIX {#$}
    set MATCH "$PREFIX*"

    set line [db.get $event line]
    if { [string match $MATCH $line] == 0 } {
        return [modules.module_deferred]
    }

    regexp {^#\$(.)([^ ]+)(.*)} $line all type message rest

    if { $type == "\"" } {
	db.set $event line [string range $line 3 end]
        return [modules.module_deferred]
    }

    if { ($mcp20_active == 0) &&
	 ($message != "mcp") } {
        return [modules.module_deferred]
    }


    request.destroy current

    set rv 1
    if { $message == "*" } {
	regexp {^ ([^ ]*) ([^:]*): (.*)$} $rest all tag field value
	request.set current _data-tag $tag
	request.set current field $field
	request.set current value $value
    } elseif { $message == ":" } {
	regexp {^ ([^ ]*)} $rest all tag
	request.set current _data-tag $tag
    } {
	set rv [mcp20.parse $rest]
    }


    if { ([lsearch -exact {* : mcp} $message] < 0) &&
	 ([request.get current _authentication-key] != $mcp20_authentication_key) } {
        return [modules.module_deferred]
    }

    if { $rv == "multiline" } {
        set tag [request.get current _data-tag]
	request.set current _message $message
        request.duplicate current $tag
    } {
        mcp20.dispatch $message

    }

    return [modules.module_ok]
}

proc mcp20.parse header {
    set first [lindex $header 0]
    set rv 1


    if { [string last ":" $first] < 0 } {
        request.set current _authentication-key $first
        set header [lrange $header 1 end]
    }

    foreach { keyword value } $header {
	regsub ":" $keyword "" keyword
	if { [regexp {(.*)\*} $keyword _ field] } {
	    request.set current $field {}
	    set rv "multiline"
	    set keywords($field) 1
	} {
	    request.set current $keyword $value
	    set keywords($keyword) 1
	}
    }

    if { [info exists keywords] } {
        request.set current _keywords [array names keywords]
    } {
        request.set current _keywords {}
    }

    return $rv
}           


proc mcp20.dispatch message {
    global mcp20_registry
    foreach r $mcp20_registry {
	set msg		[lindex $r 2]
	set callback	[lindex $r 3]

	if { $msg == $message } {
	    $callback
	    return
	}
    }
}

proc mcp20.register {package version message callback} {
    global mcp20_registry
    lappend mcp20_registry [list $package $version $message $callback]
}

proc mcp20.encode str {
    regsub -all {([\\\"])} $str {\\\1} str
    if { [regexp -- {[ :]} $str] } {
        set str "\"$str\""
    }
    if { $str == "" } {
        set str "\"\""    
    }
    return $str
} 

proc mcp20.server_notify {message {keyvals {}}} {
    global mcp20_authentication_key

    if { $mcp20_authentication_key == "" } {
	return
    }

    set multiline 0
    set kvstr ""
    foreach kv $keyvals {
        set k [lindex $kv 0]
        set v [lindex $kv 1]
        set t 0
        if { [llength $kv] == 3 } {
            set t [lindex $kv 2]
        }
        if { $t != 0 } {
            set multiline 1
            append kvstr " $k*: \"\""
            set multiple($k) $v
        } {
            append kvstr " $k: [mcp20.encode $v]"
        }
    }

    if { $multiline == 1 } {
        set tag [util.unique_id d]
        append kvstr " _data-tag: $tag"
    }

    io.outgoing "#$#$message $mcp20_authentication_key$kvstr"

    foreach k [array names multiple] {
        foreach v $multiple($k) {
            io.outgoing "#$#* $tag $k: $v"
        }
    }

    if { $multiline == 1 } {
        io.outgoing "#$#: $tag"
    }
}   


proc mcp20.do_mcp {} {
    global mcp20_active
    global mcp20_authentication_key

    set version [request.get current version]
    set to $version
    catch {
       set to [request.get current to]
    }
    if { $version == "2.0" || $to == "2.0" } {
	set mcp20_active 1
    } {
	return
    }

    io.outgoing "#$#mcp version: 2.0"

    scan [winfo id .] "0x%x" mcp20_authentication_key
    io.outgoing "#$#authentication-key $mcp20_authentication_key"

}

proc mcp20.negotiate_protocols {} {
    foreach r [mcp20.report_packages] {
        set package [lindex $r 0]
        set min     [lindex $r 1]
        set max     [lindex $r 2]
	mcp20.server_notify protocol [list [list name $package] [list from $min] [list to $max]]
    }

    mcp20.server_notify protocol-end
}


proc mcp20.report_packages {} {
    global mcp20_registry
    foreach r $mcp20_registry {
        set package [lindex $r 0]
	if { $package == "mcp" } { continue };
        set version [lindex $r 1]
	if { [info exists min($package)] == 1 } {
	    if { $version > $max($package) } {
		set max($package) $version
	    } elseif { $version < $min($package) } {
		set min($package) $version
	    }
	} {
	    set min($package) $version
	    set max($package) $version
	}
    }
    set report {}
    foreach p [array names min] {
	lappend report [list $p $min($p) $max($p)]
    }
    return $report
}

proc mcp20.report_server_packages {} {
    global mcp20_server_registry
    return $mcp20_server_registry
}

proc mcp20.calculate_overlap {} {
    global mcp20_report_overlap
    set us   [mcp20.report_packages]
    set them [mcp20.report_server_packages]
    set report {}
    foreach p $us {
	set package [lindex $p 0]
	set s [util.assoc $them $package]
	if { $s != {} } {
	    set cmin [lindex $p 1]
	    set cmax [lindex $p 2]
	    set smin [lindex $s 1]
	    set smax [lindex $s 2]
	    if { ($cmax >= $smin) && ($smax >= $cmin) } {
		lappend report [list $package [mcp20.minimum $smax $cmax]]
	    }
	}
    }
    set mcp20_report_overlap $report
}

proc mcp20.report_overlap {} {
    global mcp20_report_overlap
    return $mcp20_report_overlap
}

proc mcp20.minimum { a b } {
    if { $a < $b } {
	return $a
    } {
	return $b
    }
}

proc mcp20.do_protocol {} {
    global mcp20_server_registry
    set name [request.get current name]
    set from [request.get current from]
    set to [request.get current to]
    lappend mcp20_server_registry [list $name $from $to]
}

proc mcp20.do_protocol_end {} {
    mcp20.calculate_overlap
    mcp20.dispatch_internal mcp_negotiate_end
}

proc mcp20.do_mcp_negotiate_can {} {
    global mcp20_server_registry
    set package [request.get current package]
    set min_version [request.get current min-version]
    set max_version [request.get current max-version]
    lappend mcp20_server_registry [list $package $min_version $max_version]
}

proc mcp20.do_mcp_negotiate_end {} {
    mcp20.calculate_overlap
    mcp20.dispatch_internal mcp_negotiate_end
}

proc mcp20.do_* {} {
    set tag [request.get current _data-tag]
    set field [request.get current field]
    set value [request.get current value]
    set new [concat [request.get $tag $field] [list $value]]  
    request.set $tag $field $new
}
proc mcp20.do_: {} {
    set tag [request.get current _data-tag]
    set message [request.get $tag _message]
    mcp20.dispatch $message
    request.destroy $tag
}


proc mcp20.do_mcp_cord_open {} {
    global cord_db
    set id [request.get current _id]
    set type [request.get current _type]
    set cord_db($id:type) $type
}

proc mcp20.do_mcp_cord {} {
    global cord_db
    set id [request.get current _id]
    set message [request.get current _message]
    set msg [request.get current _message]
    set full_message $cord_db($id:type)
    if { $msg != "" } {
	append full_message "-$msg"
    }
    mcp20.dispatch $full_message
}

proc mcp20.do_mcp_cord_closed {} {
    global cord_db
    set id [request.get current _id]
    unset cord_db($id:type)
}
client.register cvw.init_id start 60
client.register cvw.init_id client_connected

proc cvw.init_id.start {} {
    cvw.init_id.initialise_db
    mcp20.register cvw-init-id 1.2 \
	cvw-init-id-server cvw.init_id.do_cvw_init_id_server
    mcp20.register cvw-init-id 1.2 \
	cvw-init-id-user cvw.init_id.do_cvw_init_id_user
    mcp20.register cvw-init-id 1.2 \
	cvw-init-id-client-result cvw.init_id.do_cvw_init_id_client_result
}

proc cvw.init_id.client_connected {} {
    cvw.init_id.initialise_db
    return [modules.module_deferred]
}

proc cvw.init_id.initialise_db {} {
    global cvw_init_id_user_db
    set cvw_init_id_user_db(name) ""
    set cvw_init_id_user_db(object) ""
    set cvw_init_id_user_db(priv) ""
}

proc cvw.init_id.do_cvw_init_id_server {} {
    set name [request.get current name]
    set version [request.get current version]
    set doc_server ""
    catch {
    set doc_server [request.get current doc-server]
    }
    set doc_port ""
    catch {
    set doc_port [request.get current doc-port]
    }
}   

proc cvw.init_id.do_cvw_init_id_user {} {
    set name [request.get current name]
    set object [request.get current object]
    set priv [request.get current priv]
    cvw.init_id.user $name $object $priv
}       

proc cvw.init_id.do_cvw_init_id_client_result {} {
    set error [request.get current name]
    set current_version [request.get current current_version]
    set version [request.get current version]
}       

proc cvw.init_id.user {name object priv} {
    global cvw_init_id_user_db
    set cvw_init_id_user_db(name) $name
    set cvw_init_id_user_db(object) $object
    set cvw_init_id_user_db(priv) $priv
}

proc cvw.init_id.get_user {} {
    global cvw_init_id_user_db
    return $cvw_init_id_user_db(name) 
}

client.register cvw.object start 60
client.register cvw.object client_connected

proc cvw.object.start {} {
    cvw.object.initialise_db
    mcp20.register cvw-object 1.3 cvw-object-info cvw.object.do_cvw_object_info
    mcp20.register cvw-object 1.3 cvw-object-contents cvw.object.do_cvw_object_contents
    mcp20.register cvw-object 1.3 cvw-object-copy-result cvw.object.do_cvw_object_copy_result
    mcp20.register cvw-object 1.3 cvw-object-create-result cvw.object.do_cvw_object_create_result
    mcp20.register cvw-object 1.3 cvw-object-delete-notify cvw.object.do_cvw_object_delete_notify
    mcp20.register cvw-object 1.3 cvw-object-delete-result cvw.object.do_cvw_object_delete_result
    mcp20.register cvw-object 1.3 cvw-object-detail cvw.object.do_cvw_object_detail
    mcp20.register cvw-object 1.3 cvw-object-export-info cvw.object.do_cvw_object_export_info
    mcp20.register cvw-object 1.3 cvw-object-window cvw.object.do_cvw_object_window
    cvw.mime.set Note open skanky.do_note
}
proc cvw.object.client_connected {} {
    cvw.object.initialise_db
    return [modules.module_deferred]
}
proc cvw.object.initialise_db {} {
    global cvw_object_db
    catch { unset cvw_object_db }
}

proc cvw.object.do_cvw_object_contents {} { # do nothing }
proc cvw.object.do_cvw_object_copy_result {} { # do nothing }
proc cvw.object.do_cvw_object_create_result {} { # do nothing }
proc cvw.object.do_cvw_object_delete_notify {} { # do nothing }
proc cvw.object.do_cvw_object_delete_result {} { # do nothing }
proc cvw.object.do_cvw_object_export_info {} { # do nothing }

proc cvw.object.do_cvw_object_window {} {
    set object [request.get current object]
    set rec [cvw.object.get_info $object]
    if { $rec == {} } { return }
    foreach {o name sessile owner icon type location id mod_date mod_by create_date} $rec {break}
    if { [set callback [cvw.mime.get $type Open]] != "" } {
	$callback
    } {
	window.displayCR "Can't handle object of type '$type'."
    }
}

proc cvw.object.do_cvw_object_detail {} {
    set keywords [request.get current _keywords]
    set object [request.get current object]
    foreach keyword $keywords {
	if { $keyword == "object" } { continue }
	if { $keyword == "info_only" } { continue }
	cvw.object.set_field $object $keyword [request.get current $keyword]
    }
}

proc skanky.do_note {} {
    set object [request.get current object]
    set rec [cvw.object.get_info $object]
    foreach {o name sessile owner icon type location id mod_date mod_by create_date} $rec {break}
    set text [request.get current text]
    regsub -all {\\n} $text "\n" text
    set text_lines [split $text "\n"]
    set e [edit.create "Note: $name" $name]
    global skanky
    set skanky($e:object) $object
    edit.SCedit {} $text_lines {} "Note: $name" "$name" $e
    edit.configure_send $e "Send" "skanky.send $e" 1
    edit.configure_send_and_close $e "Send and Close" "skanky.send_and_close $e" 10
    edit.configure_close $e "Close" "skanky.close $e" 0
}

proc cvw.mime.set {type action callback} {
    global cvw_mime_db
    set cvw_mime_db([string tolower $type],[string tolower $action],callback) $callback
}

proc cvw.mime.get {type action} {
    global cvw_mime_db
    if { [info exists cvw_mime_db([string tolower $type],[string tolower $action],callback)] } {
	return $cvw_mime_db([string tolower $type],[string tolower $action],callback)
    }
    return ""
}

proc skanky.send e {
    global skanky
    set object $skanky($e:object)
    set text_list [edit.get_text $e]
    set text [join $text_list "\\n"]
    mcp20.server_notify cvw-modify-text [list [list object $object] [list text $text]]
}

proc skanky.send_and_close e {
    global skanky
    set object $skanky($e:object)
    set content [edit.get_text $e]
    set text_list [edit.get_text $e]
    set text [join $text_list "\\n"]
    mcp20.server_notify cvw-modify-text [list [list object $object] [list text $text]]
    mcp20.server_notify cvw-object-close [list [list object $object]]
    unset skanky($e:object)
    edit.destroy $e
}

proc skanky.close e {
    global skanky
    set object $skanky($e:object)
    mcp20.server_notify cvw-object-close [list [list object $object]]
    unset skanky($e:object)
    edit.destroy $e
}


proc cvw.object.do_cvw_object_info {} {
    set name [request.get current name]
    set object [request.get current object]
    set sessile [request.get current sessile]
    set owner [request.get current owner]
    set icon [request.get current icon]
    set type [request.get current type]
    set location ""
    catch { set location [request.get current location] }
    set id ""
    catch { set id [request.get current id] }
    set mod_date [request.get current mod-date]
    set mod_by [request.get current mod-by]
    set create_date [request.get current create-date]
    cvw.object.info $object $name $sessile $owner $icon $type $location $id $mod_date $mod_by $create_date
}


proc cvw.object.info {object name sessile owner icon type location id mod_date mod_by create_date} {
    global cvw_object_db
    set cvw_object_db($object,_info)	1
    set cvw_object_db($object,name)	$name
    set cvw_object_db($object,sessile)	$sessile
    set cvw_object_db($object,owner)	$owner
    set cvw_object_db($object,icon)	$icon
    set cvw_object_db($object,type)	$type
    set cvw_object_db($object,location)	$location
    set cvw_object_db($object,id)	$id
    set cvw_object_db($object,mod_date)	$mod_date
    set cvw_object_db($object,mod_by)	$mod_by
    set cvw_object_db($object,create_date)	$create_date
    cvw.utils.dispatch cvw.object.info
}

proc cvw.object.get_info object {
    global cvw_object_db
    if { [info exists cvw_object_db($object,_info)] } {
        return [list $object $cvw_object_db($object,name) $cvw_object_db($object,sessile) $cvw_object_db($object,owner) $cvw_object_db($object,icon) $cvw_object_db($object,type) $cvw_object_db($object,location) $cvw_object_db($object,id) $cvw_object_db($object,mod_date) $cvw_object_db($object,mod_by) $cvw_object_db($object,create_date)]
    } {
        return {}
    }
}

proc cvw.object.set_field {object field value} {
    global cvw_object_db
    set cvw_object_db($object,$field) $value
}

proc cvw.object.get_field {object field} {
    global cvw_object_db
    if { [info exists cvw_object_db($object,$field)] } {
	return [list 1 $cvw_object_db($object,$field)]
    } {
	return [list 0 0]
    }
}

client.register cvw.contents start 60
client.register cvw.contents client_connected

proc cvw.contents.start {} {
    cvw.contents.initialise_db
    window.menu_tools_add "Toggle CVW Contents" cvw.contents.toggle_contents
    cvw.utils.register cvw.env.contents cvw.contents.handle_cvw_env_contents
}

proc cvw.env.client_connected {} {
    cvw.env.initialise_db
    return [modules.module_deferred]
}

proc cvw.contents.handle_cvw_env_contents args {
    global cvw_contents_db
    if { [winfo exists $cvw_contents_db(contents_window)] } {
	cvw.contents.fill_contents $cvw_contents_db(contents_window) [lindex [cvw.env.get_contents] 1]
    }
}

proc cvw.contents.initialise_db {} {
    global cvw_contents_db
    set cvw_contents_db(contents_window) ""
}

proc cvw.contents.destroy win {
    global cvw_contents_db
    foreach name [array names cvw_contents_db "$win,*"] {
        unset cvw_contents_db($name)
    }
    destroy $win
}

proc cvw.contents.toggle_contents {} {
    global cvw_contents_db
    if { [winfo exists $cvw_contents_db(contents_window)] } {
	window.remove_statusbar $cvw_contents_db(contents_window)
	window.repack
	cvw.contents.destroy $cvw_contents_db(contents_window)
    } {
	set cvw_contents_db(contents_window) [cvw.contents.create]

        cvw.contents.set_headings $cvw_contents_db(contents_window) [list \
            Name	\
            Type	\
            Modified	\
            By		\
            Created	\
            By]

        cvw.contents.set_tabstrings $cvw_contents_db(contents_window) [list \
            [string repeat "M" 15]          \
            "Form Folder"                   \
            "00/00/00"                      \
            "Networker"                     \
            "00/00/00"                      \
            "Networker"]

	cvw.contents.fill_contents $cvw_contents_db(contents_window) [lindex [cvw.env.get_contents] 1]
        window.add_statusbar $cvw_contents_db(contents_window)
        window.repack
    }
}

proc cvw.contents.fill_contents {win objects} {
    set data {}
    foreach object $objects {
	set rec [cvw.object.get_info $object]
	if { $rec == {} } { continue }
	foreach {_ name _ owner _ type _ _ mdate mby cdate} $rec {break}
	set mbyname $mby
	catch {
	    set mbyname [lindex [cvw.object.get_info $mby] 1]
	}
	set ownername $owner
	catch {
	    set ownername [lindex [cvw.object.get_info $owner] 1]
	}
	set record [list $object $name $type $mdate $mbyname $cdate $ownername]
	lappend data $record
    }
    $win.contents configure -state normal
    $win.contents delete 1.0 end

    foreach tag [$win.contents tag names] {
	if { [string match "doubleclick_*" $tag] } {
	    $win.contents tag delete $tag
	}
    }

    set headings [join [cvw.contents.get_headings $win] "\t"]
    $win.contents insert end " $headings\n" heading
    set CR ""

    foreach {t0 t1 t2 t3 t4 t5} [cvw.contents.get_tabstrings $win] {break}

    foreach record $data {
	foreach {object name type mdate mbyname cdate ownername} $record {break}
	$win.contents insert end "$CR"
	set mdate_str [clock format $mdate -format "%m/%d/%y"]
	set cdate_str [clock format $cdate -format "%m/%d/%y"]
	$win.contents insert end " "
	set name [cvw.contents.crop_string $win.contents $t0 $name]
	if { [cvw.mime.get $type Open] != "" } {
	    set tag [cvw.contents.open_binding $win $object $type]
	    $win.contents insert end "$name" $tag
	} {
	    $win.contents insert end "$name"
	}
	set type [cvw.contents.crop_string $win.contents $t1 $type]
	set mdate_str [cvw.contents.crop_string $win.contents $t2 $mdate_str]
	set mbyname [cvw.contents.crop_string $win.contents $t3 $mbyname]
	set cdate_str [cvw.contents.crop_string $win.contents $t4 $cdate_str]
	set ownername [cvw.contents.crop_string $win.contents $t5 $ownername]
	$win.contents insert end "\t$type\t$mdate_str\t$mbyname\t$cdate_str\t$ownername"
	set CR "\n"
    }
    $win.contents configure -state disabled
}

proc cvw.contents.open_binding {win object type} {
    global cvw_contents_db
    set tag doubleclick_[util.unique_id tag]
    window.hyperlink.link $win.contents $tag cvw.contents.do_double_click
    $win.contents tag bind $tag <Enter> "+
	set cvw_contents_db(double_click_object) $object
	set cvw_contents_db(double_click_type) \"$type\"
    "
    $win.contents tag bind $tag <Leave> "+
	set cvw_contents_db(double_click_object) \"\"
	set cvw_contents_db(double_click_type) \"\"
    "
    return $tag
}

proc cvw.contents.do_double_click {} {
    global cvw_contents_db
    set object $cvw_contents_db(double_click_object)
    mcp20.server_notify "cvw-object-open" [list [list object $object]]
}


proc cvw.contents.set_tabs w {
    global cvw_contents_db

    set font [$w.contents cget -font]
    set pad [font measure $font -displayof $w.contents "M"]

    set tab 0
    set tabs {}
    
    foreach str [cvw.contents.get_tabstrings $w] {
        incr tab [font measure $font -displayof $w.contents $str]
        incr tab $pad
        lappend tabs ${tab}p
    }

    $w.contents configure -tabs $tabs
}

proc cvw.contents.crop_string {w crop string} {
    set font [$w cget -font]
    set length [font measure $font -displayof $w $crop]
    if { [font measure $font -displayof $w $string] > $length } {
        while { [font measure $font -displayof $w "$string..."] > $length } {
	    set string [string range $string 0 end-1]
	    set string [string trim $string]
        }
        return "$string..."
    } {
        return $string
    }
}

proc cvw.contents.create {{w ""}} {
    if { $w == "" } {
	set w .[util.unique_id contents]
    }
    if { [winfo exists $w] } { return }
    frame $w \
	-bd 0 \
	-highlightthickness 0

    text $w.contents \
	-height 5 \
	-wrap none \
	-cursor {} \
	-highlightthickness 0 \
	-xscrollcommand "$w.bottom.hscroll set" \
	-yscrollcommand "$w.vscroll set"


    scrollbar $w.vscroll \
	-highlightthickness 0 \
	-command "$w.contents yview"
    frame $w.bottom \
	-bd 0 \
	-highlightthickness 0

    scrollbar $w.bottom.hscroll \
	-orient horizontal \
	-highlightthickness 0 \
	-command "$w.contents xview"

    window.set_scrollbar_look $w.vscroll
    window.set_scrollbar_look $w.bottom.hscroll

    frame $w.bottom.padding

    pack $w.bottom.padding -side right
    pack $w.bottom.hscroll -side left -fill x -expand 1
    pack $w.bottom -side bottom -fill x
    pack $w.vscroll -side right -fill y
    pack $w.contents -fill both -expand 1

    $w.contents tag configure heading \
	-relief raised \
	-borderwidth 1 \
	-background [$w cget -bg]
    $w.contents configure -state disabled
    after idle "
	$w.bottom.padding configure \
	    -width \[expr \[$w.vscroll cget -width\] + 2\]
    "
    return $w
}

proc cvw.contents.set_tabstrings {w tabstrings} {
    global cvw_contents_db
    set cvw_contents_db($w,tabstrings) $tabstrings
    cvw.contents.set_tabs $w
}
proc cvw.contents.get_tabstrings w {
    global cvw_contents_db
    if { [info exists cvw_contents_db($w,tabstrings)] } {
	return $cvw_contents_db($w,tabstrings)
    } {
	return {}
    }
}

proc cvw.contents.set_headings {w headings} {
    global cvw_contents_db
    set cvw_contents_db($w,headings) $headings
}
proc cvw.contents.get_headings w {
    global cvw_contents_db
    if { [info exists cvw_contents_db($w,headings)] } {
        return $cvw_contents_db($w,headings)
    } {
	return {}
    }
}

client.register cvw.modify start 60

proc cvw.modify.start {} {
    mcp20.register cvw-modify 1.3 cvw-modify-result cvw.modify.do_cvw_modify_result 

}

proc cvw.modify.do_cvw_modify_result {} {
    set error [request.get current error]
    if { $error == 1 } {
        set error_msg [request.get current error_msg]
        window.displayCR "$error_msg"
    }
}   





client.register cvw.system start 60
client.register cvw.system client_connected

proc cvw.system.start {} {
    cvw.system.intitialise_db
    mcp20.register cvw-system 1.3 cvw-system-onusers cvw.system.do_cvw_system_onusers
    mcp20.register cvw-system 1.3 cvw-system-allusers cvw.system.do_cvw_system_allusers
    mcp20.register cvw-system 1.3 cvw-system-list-groups cvw.system.do_cvw_system_list_groups
    mcp20.register cvw-system 1.3 cvw-system-list-users cvw.system.do_cvw_system_list_users
    mcp20.register cvw-system 1.3 cvw-system-motd cvw.system.do_cvw_system_motd
    window.menu_tools_add "Toggle CVW Users" cvw.system.toggle_users
    cvw.utils.register cvw.system.onusers cvw.system.handle_onusers
}

proc cvw.system.do_cvw_system_allusers {} { # do nothing }
proc cvw.system.do_cvw_system_list_groups {} { # do nothing }
proc cvw.system.do_cvw_system_list_users {} { # do nothing }
proc cvw.system.do_cvw_system_motd {} { # do nothing }

proc cvw.system.toggle_users {} {

    global cvw_system_db

    if { [winfo exists $cvw_system_db(users_window)] } {
	cvw.contents.destroy $cvw_system_db(users_window)
        mcp20.server_notify cvw-system-onusers-interest [list [list on 0]]
    } {
        set w .[util.unique_id users_window]
        toplevel $w
    
        wm title $w "Online Users"
        wm iconname $w "Online Users"
    
        window.place_nice $w
        set details [cvw.contents.create $w.details]
    
        cvw.contents.set_headings $w.details [list \
            "User Name"		\
            "Full Name"		\
            Location		\
	    " "			\
            "Idle Time"         \
            "Idle State"]
    
        cvw.contents.set_tabstrings $w.details [list \
            "JoeRandom"		\
            "Joe Random User"	\
            "Some Somewhere"	\
            "*"			\
            "10 hrs 50 mins"	\
            "doing something interesting"]
    
        pack $w.details -fill both -expand 1
        set cvw_system_db(users_window) $w

        cvw.system.fill_contents $cvw_system_db(users_window).details [cvw.system.get_onusers]
        mcp20.server_notify cvw-system-onusers-interest [list [list on 1]]
    }

}

proc cvw.system.client_connected {} {
    cvw.system.intitialise_db
    return [modules.module_deferred]
}

proc cvw.system.intitialise_db {} {
    global cvw_system_db
    set cvw_system_db(users_window) ""
    set cvw_system_db(records) {}
}

proc cvw.system.do_cvw_system_onusers {} {
    set user [request.get current user]
    set location [request.get current location]
    set idle [request.get current idle]
    set busy [request.get current busy]
    set msgs [request.get current msgs]
    set records {}
    foreach u [split $user] \
	    l [split $location] \
	    i [split $idle] \
	    b [split $busy] \
	    m [split [string trim $msgs "|"] "|"] { 
        lappend records [list $u $l $i $b $m]
    }
    cvw.system.cvw_system_onusers $records
}

proc cvw.system.cvw_system_onusers records {
    global cvw_system_db
    set cvw_system_db(records) $records
    cvw.utils.dispatch cvw.system.onusers
}

proc cvw.system.get_onusers {} {
    global cvw_system_db
    return $cvw_system_db(records)
}

proc cvw.system.fill_contents {win records} {
    $win.contents configure -state normal
    $win.contents delete 1.0 end

    set headings [join [cvw.contents.get_headings $win] "\t"]
    $win.contents insert end " $headings\n" heading

    foreach {t0 t1 t2 t3 t4 t5} [cvw.contents.get_tabstrings $win] {break}

    set CR ""
    foreach record $records {
        foreach {u l i b m} $record {break}

        set name "---"
        set v [cvw.object.get_field $u name]
        if { [lindex $v 0] } {
            set name [lindex $v 1]
        }
	set name [cvw.contents.crop_string $win.contents $t0 $name]

        set fullname ""
        set v [cvw.object.get_field $u full_name]
        if { [lindex $v 0] } {
            set fullname [lindex $v 1]
        }
	set fullname [cvw.contents.crop_string $win.contents $t1 $fullname]

        set location ""
        set v [cvw.object.get_field $l name]
        if { [lindex $v 0] } {
            set location [lindex $v 1]
        }
	set location [cvw.contents.crop_string $win.contents $t2 $location]

        set idletime [cvw.system.idle_str $i]

        set idlestate $m
	set idlestate [cvw.contents.crop_string $win.contents $t5 $idlestate]

	if { $b } {
	    set busy "*"
	} {
	    set busy " "
	}

        $win.contents insert end "$CR $name\t$fullname\t$location\t$busy\t$idletime\t$idlestate"
        set CR "\n"
    }

    $win.contents configure -state disabled
}

proc cvw.system.idle_str time {
    if { $time < 60 } {
        return Active
    }
    set hrs [expr $time / 3600]
    set mins [expr ($time / 60) % 60]
    set lstr {}
    if { $hrs } {
	if { $hrs > 1 } {
            lappend lstr "$hrs hrs"
	} {
            lappend lstr "$hrs hr"
	}
    }
    if { $mins } {
	if { $mins > 1 } {
            lappend lstr "$mins mins"
	} {
            lappend lstr "$mins min"
	}
    }
    return [join $lstr " "]
}

proc cvw.system.handle_onusers args {
    global cvw_system_db
    if { [winfo exists $cvw_system_db(users_window)] } {
        cvw.system.fill_contents $cvw_system_db(users_window).details [cvw.system.get_onusers]
    }
}

client.register cvw.map start 60
client.register cvw.map client_connected

proc cvw.map.start {} {
    cvw.map.initialise_db
    cvw.utils.register cvw.env.changed cvw.map.handle_env_changed
    cvw.utils.register cvw.map.info cvw.map.handle_map_info
    mcp20.register cvw-map 1.0 cvw-map-info cvw.map.do_cvw_map_info
    window.menu_tools_add "Toggle CVW Map" cvw.map.toggle
}

proc cvw.map.toggle {} {
    set w .cvwmap
    if { [winfo exists $w] } {
	destroy $w
    } {
	cvw.map.create
    }
}

proc cvw.map.handle_env_changed args {
    set floornum [cvw.env.get_floornum]
    set newroom [cvw.env.get_newroom]
    cvw.map.display $floornum $newroom
}

proc cvw.map.initialise_db {} {
    global cvw_map_info_db
    set cvw_map_info_db(totalfloors) 0
    set cvw_map_info_db(roomobjs) {}
    set cvw_map_info_db(rooms) {}
    set cvw_map_info_db(floorobjs) {}
    set cvw_map_info_db(floors) {}
}

proc cvw.map.client_connected {} {
    global cvw_map_displayed_floor
    set cvw_map_displayed_floor 1
    cvw.map.initialise_db
    return [modules.module_deferred]
}

proc cvw.map.create {} {
    set w .cvwmap
    if { [winfo exists $w] } { return }
    toplevel $w

    wm title $w "CVW Map"
    wm iconname $w "CVW Map"

    window.place_nice $w

    set xoffset 20.0
    set yoffset 20.0
    set scale 40.0


    set coords {
	{0 0 2 1} {2 0 3 1} {3 0 5 1} 
	{0 1 2 2} {2 1 3 2} {3 1 5 2} 
	{0 2 2 3} {2 2 3 3} {3 2 5 3} 
	{0 3                     5 4}
	    {1 4             4 5}
    }

    set height [expr 5*$scale + 2*$yoffset]
    set width  [expr 5*$scale + 2*$xoffset]

    canvas $w.c -height $height -width $width
    pack $w.c -side top

    set psn 0
    foreach room $coords {
	foreach {x1 y1 x2 y2} $room {break};
	$w.c create rectangle [expr $scale*$x1 + $xoffset] [expr $scale*$y1 + $yoffset] \
			      [expr $scale*$x2 + $xoffset] [expr $scale*$y2 + $yoffset] \
			      -tags "room($psn) room"

	$w.c bind room($psn) <1> "cvw.map.do_walkto $psn"
	$w.c bind room($psn) <Enter> "
	    $w.c itemconfigure room($psn) -width 3
	    $w.c raise room($psn)
	    $w.c raise text
	"
	$w.c bind name($psn) <Enter> "
	    $w.c itemconfigure room($psn) -width 3
	    $w.c raise room($psn)
	    $w.c raise text
	"
	$w.c bind room($psn) <Leave> "
	    $w.c itemconfigure room($psn) -width 1
	"
	$w.c bind name($psn) <Leave> "
	    $w.c itemconfigure room($psn) -width 1
	"

	set midx [expr $x1+(($x2-$x1)/2.0)]
	set midy [expr $y1+(($y2-$y1)/2.0)]
	$w.c create text [expr $scale*$midx + $xoffset] [expr $scale*$midy + $yoffset] \
	                 -text "" -justify center -tags "name($psn) text" \
			 -width [expr 2*$scale]
	$w.c bind name($psn) <1> "cvw.map.do_walkto $psn"
	incr psn
    }

    $w.c raise text

    label $w.floor -text "Current Floor: --"
    label $w.total -text "Total Floors: --"

    pack $w.floor -side top -fill x
    pack $w.total -side top -fill x

    set cvw_map_displayed_floor 1
    scale $w.scale -from 1 -to 1 -orient horizontal -command "cvw.map.do_scale" \
	-variable cvw_map_displayed_floor
    pack $w.scale -side top -fill x 
}

proc cvw.map.do_scale floor {
    cvw.map.display $floor [cvw.env.get_newroom]
}

proc cvw.map.do_walkto psn {
    global cvw_map_displayed_floor
    set roomobj [cvw.map.get_room $cvw_map_displayed_floor $psn]
    if { $roomobj == "" } { return }
    mcp20.server_notify cvw-env-move [list [list destination $roomobj]]
}

proc cvw.map.get_room {floor psn} {
    set roomobjs [cvw.map.get_roomobjs]
    if { $roomobjs == {} } { return "" }
    set f 0
    foreach {o(10) o(9) o(6) o(7) o(8) o(3) o(4) o(5) o(0) o(1) o(2)} $roomobjs { 
        incr f
	if { $f == $floor } { break }
    }
    return $o($psn)
}

proc cvw.map.display {floor room} {
    global cvw_map_displayed_floor

    set w .cvwmap

    if { [winfo exists $w] == 0 } { return }

    $w.c itemconfigure room -fill [$w cget -background]

    set totalfloors [cvw.map.get_totalfloors]
    set rooms [cvw.map.get_rooms]
    set roomobjs [cvw.map.get_roomobjs]

    if { $rooms == {} } { return }

    set f 0
    foreach {r10 r9 r6 r7 r8 r3 r4 r5 r0 r1 r2} $rooms \
            {o10 o9 o6 o7 o8 o3 o4 o5 o0 o1 o2} $roomobjs { 
        incr f
	if { $f == $floor } { break }
    }

    set psn 0
    foreach val [list $r0 $r1 $r2 $r3 $r4 $r5 $r6 $r7 $r8 $r9 $r10] \
	    rval     "$o0 $o1 $o2 $o3 $o4 $o5 $o6 $o7 $o8 $o9 $o10" {

	$w.c itemconfigure name($psn) -text $val

	if { $room == $rval } {
	    $w.c itemconfigure room($psn) -fill red
	}
	incr psn
    }

    set floorname [lindex [cvw.map.get_floors] [expr $floor - 1]]

    $w.total configure -text "Total Floors: $totalfloors"
    $w.floor configure -text "Current Floor: $floorname"
    set cvw_map_displayed_floor $floor
    $w.scale configure -from 1 -to $totalfloors
}

proc cvw.map.handle_map_info args {
    set w .cvwmap
    if { [winfo exists $w] == 0 } { return }
    $w.scale configure -from 1 -to [cvw.map.get_totalfloors]
}

proc cvw.map.info {totalfloors roomobjs rooms floorobjs floors} {
    global cvw_map_info_db
    set cvw_map_info_db(totalfloors) $totalfloors
    set cvw_map_info_db(roomobjs) $roomobjs
    set cvw_map_info_db(rooms) $rooms
    set cvw_map_info_db(floorobjs) $floorobjs
    set cvw_map_info_db(floors) $floors
    cvw.utils.dispatch cvw.map.info
}

proc cvw.map.get_totalfloors {} {
    global cvw_map_info_db
    return $cvw_map_info_db(totalfloors)
}
proc cvw.map.get_rooms {} {
    global cvw_map_info_db
    return $cvw_map_info_db(rooms)
}
proc cvw.map.get_roomobjs {} {
    global cvw_map_info_db
    return $cvw_map_info_db(roomobjs)
}
proc cvw.map.get_floors {} {
    global cvw_map_info_db
    return $cvw_map_info_db(floors)
}

proc cvw.map.do_cvw_map_info {} {
    set totalfloors [request.get current totalfloors]
    set roomobjs [request.get current roomobjs]
    set floorobjs [request.get current floorobjs]  
    set rooms [request.get current rooms]
    set floors [request.get current floors]
    cvw.map.info $totalfloors [cvw.utils.split $roomobjs "q|q"] \
                              [cvw.utils.split $rooms "q|q"] \
                              [cvw.utils.split $floorobjs "q|q"] \
                              [cvw.utils.split $floors "q|q"]
}