Index: openacs-4/packages/xotcl-core/tcl/chat-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/chat-procs.tcl,v diff -u -r1.12 -r1.13 --- openacs-4/packages/xotcl-core/tcl/chat-procs.tcl 7 Jun 2007 09:19:51 -0000 1.12 +++ openacs-4/packages/xotcl-core/tcl/chat-procs.tcl 7 Jun 2007 11:55:47 -0000 1.13 @@ -1,24 +1,21 @@ ad_library { generic chat - chat procs - - @author Gustaf Neumann and Pablo Mu�oz(pablomp@tid.es) - + + @creation-date 2006-02-02 + @author Gustaf Neumann + @cvs-id $Id$ } namespace eval ::xo { Class Message -parameter {time user_id msg color} Class Chat -superclass ::xo::OrderedComposite \ -parameter {chat_id user_id session_id {mode default} {encoder urlencode} {timewindow 600} {sweepinterval 600} - } - + } - Chat instproc init {} { - + Chat instproc init {} { my instvar array - # my log "-- " - my set now [clock clicks -milliseconds] if {![my exists user_id]} {my set user_id [ad_conn user_id]} if {![my exists session_id]} {my set session_id [ad_conn session_id]} @@ -34,81 +31,32 @@ if {![nsv_exists $array-color idx]} {nsv_set $array-color idx 0} my init_user_color } - - Chat instproc add_msg {{-get_new:boolean true} -uid msg} { - - my instvar array now user_id chat_id + my instvar array now + set user_id [expr {[info exists uid] ? $uid : [my set user_id]}] + set color [my user_color $user_id] + set msg [ad_quotehtml $msg] + my log "-- msg=$msg" - if { $get_new eq "true" } { - - db_1row room_info { - select count(cr.room_id) as count - from chat_room_user_id as cr - where cr.room_id = :chat_id - and cr.user_id = :user_id - } - - if { $count == 1 || [permission::permission_p -party_id $user_id -object_id [dotlrn::get_package_id] -privilege admin]} { - set user_id [expr {[info exists uid] ? $uid : [my set user_id]}] - set color [my user_color $user_id] - - set msg $msg - my log "-- msg=$msg" - - if {$get_new && [info command ::thread::mutex] ne ""} { - # we could use the streaming interface - my broadcast_msg [Message new -volatile -time [clock seconds] \ + if {$get_new && [info command ::thread::mutex] ne ""} { + # we could use the streaming interface + my broadcast_msg [Message new -volatile -time [clock seconds] \ -user_id $user_id -msg $msg -color $color] - - } + } - set msg_id $now.$user_id - if { ![nsv_exists $array-login $user_id] } { - nsv_set $array-login $user_id [clock seconds] - } - - nsv_set $array $msg_id [list $now [clock seconds] $user_id $msg $color] - nsv_set $array-seen newest $now - nsv_set $array-seen last [clock seconds] - nsv_set $array-last-activity $user_id $now + set msg_id $now.$user_id + if { ![nsv_exists $array-login $user_id] } { + nsv_set $array-login $user_id [clock seconds] + } + nsv_set $array $msg_id [list $now [clock seconds] $user_id $msg $color] + nsv_set $array-seen newest $now + nsv_set $array-seen last [clock seconds] + nsv_set $array-last-activity $user_id $now # this in any case a valid result, but only needed for the polling interface - if {$get_new} {my get_new} - } - - - } else { - - set user_id [expr {[info exists uid] ? $uid : [my set user_id]}] - set color [my user_color $user_id] - - set msg $msg - my log "-- msg=$msg" - - if {$get_new && [info command ::thread::mutex] ne ""} { - # we could use the streaming interface - my broadcast_msg [Message new -volatile -time [clock seconds] \ - -user_id $user_id -msg $msg -color $color] - - } + if {$get_new} {my get_new} + } - set msg_id $now.$user_id - if { ![nsv_exists $array-login $user_id] } { - nsv_set $array-login $user_id [clock seconds] - } - nsv_set $array $msg_id [list $now [clock seconds] $user_id $msg $color] - nsv_set $array-seen newest $now - nsv_set $array-seen last [clock seconds] - nsv_set $array-last-activity $user_id $now - # this in any case a valid result, but only needed for the polling interface - if {$get_new} {my get_new} - } - - } - - - Chat instproc current_message_valid {} { expr { [my exists user_id] && [my set user_id] != -1 } } @@ -136,9 +84,8 @@ return 1 } - Chat instproc get_new {} { - my instvar array now session_id chat_id - + Chat instproc get_new {} { + my instvar array now session_id set last [expr {[nsv_exists $array-seen $session_id] ? [nsv_get $array-seen $session_id] : 0}] if {[nsv_get $array-seen newest]>$last} { #my log "--c must check $session_id: [nsv_get $array-seen newest] > $last" @@ -154,53 +101,45 @@ #my log "--c setting session_id $session_id: $now" } else { #my log "--c nothing new for $session_id" - } - my render2 -chat_id $chat_id + } + my render } - Chat instproc get_all {} { - my instvar array now session_id chat_id - + Chat instproc get_all {} { + my instvar array now session_id foreach {key value} [nsv_array get $array] { - foreach {timestamp secs user msg color} $value break if {[my check_age $key [expr {($now - $timestamp) / 1000}]]} { my add [Message new -time $secs -user_id $user -msg $msg -color $color] } - } - #my log "--c setting session_id $session_id: $now" + } + #my log "--c setting session_id $session_id: $now" nsv_set $array-seen $session_id $now - my render2 -chat_id $chat_id + my render } - Chat instproc sweeper2 {} { - my instvar array now chat_id - my log "-- starting" - - foreach {user timestamp} [nsv_array get $array-last-activity] { - set ago [expr {($now - $timestamp) / 1000}] - # was 1200 - if {$ago > 1000} { - my add_msg -get_new false -uid $user "auto logout" - db_dml insert_users {delete from chat_room_user_id where room_id = :chat_id and user_id = :user;} - nsv_unset $array-last-activity $user - nsv_unset $array-color $user - nsv_unset $array-login $user - + Chat instproc sweeper {} { + my instvar array now + my log "-- starting" + foreach {user timestamp} [nsv_array get $array-last-activity] { + ns_log Notice "YY at user $user with $timestamp" + set ago [expr {($now - $timestamp) / 1000}] + ns_log Notice "YY Checking: now=$now, timestamp=$timestamp, ago=$ago" + # was 1200 + if {$ago > 300} { + my add_msg -get_new false -uid $user "auto logout" + nsv_unset $array-last-activity $user + nsv_unset $array-login $user + nsv_unset $array-color $user } - } - my log "-- ending" } - Chat instproc logout {} { - my instvar array user_id chat_id - + Chat instproc logout {} { + my instvar array user_id + ns_log Notice "YY User $user_id logging out of chat" my add_msg -get_new false [_ chat.has_left_the_room]. - - db_dml insert_users {delete from chat_room_user_id where room_id = :chat_id and user_id = :user_id;} - catch { # do not try to clear nsvs, if they are not available # this situation could occur after a server restart, after which the user tries to leave the room @@ -211,233 +150,39 @@ } Chat instproc init_user_color {} { - my instvar array user_id if { [nsv_exists $array-color $user_id] } { return } else { - set colors [parameter::get -parameter UserColors -default [[my info class] set colors]] + set colors [parameter::get -parameter UserColors -default [[my info class] set colors]] + # ns_log notice "getting colors of [my info class] = [info exists colors]" set color [lindex $colors [expr { [nsv_get $array-color idx] % [llength $colors] }]] nsv_set $array-color $user_id $color nsv_incr $array-color idx } } - Chat instproc init_user_color {} { - - my instvar array user_id - if { [nsv_exists $array-color $user_id] } { - return - } else { - set colors [parameter::get -parameter UserColors -default [[my info class] set colors]] - set color [lindex $colors [expr { [nsv_get $array-color idx] % [llength $colors] }]] - nsv_set $array-color $user_id $color - nsv_incr $array-color idx - } - } - - - Chat instproc get_users {} { - my instvar chat_id set output "" - set count 0 - - - foreach {user_id timestamp} [my active_user_list] { - - set count [expr $count+1] + foreach {user_id timestamp} [my active_user_list] { if {$user_id > 0} { - db_1row room_info { - select count(1) as info - from chat_registered_users - where room_id = :chat_id - and user_id = :user_id - } - if { $info > 0 } { - db_1row room_info { - select alias as alias - from chat_registered_users - where room_id = :chat_id - and user_id = :user_id - } - - set pp [my sweeper2] - - set color [my user_color $user_id] - set diff [clock format [expr {[clock seconds] - $timestamp}] -format "%H:%M:%S" -gmt 1] - set package_id [ad_conn package_id] - db_1row url { - select site_node__url(node_id) as url - from site_nodes - where object_id=:package_id - } - - set userlink [my user_link2 -user_id $user_id -alias $alias] - set user_id2 [ad_conn user_id] - set url2 "private-room?room_id=$chat_id&user_id1=$user_id&user_id2=$user_id2" - append link $url $url2 - set address [my encode $link] - set narrow [dt_right_arrow] - - append output "
$userlink:" \ "
\n" - } - return $result - } - - #pablomp - - Chat instproc render2 {-chat_id } { - my instvar array - my orderby time - set result "" - set msg_true "f" - - - db_1row room_info { - select room.maximal_participants as maxp - from chat_rooms as room - where room.room_id = :chat_id - } - - #[nsv_get $array $msg] - foreach aux [my array] { - - set msg [$array msg] - set msg_all "" - - for {set i 0} {$i < [llength $msg]} {incr i 1} { - set word [lindex $msg $i] - - - for {set j 0} {$j < [llength $word]} {incr j 1} { - if { [string range $word $j $j] eq "h" } { - set aux [expr $j+1] - if { [string range $word $aux [expr $aux+5] ] eq "ttp://" } { - set url [lindex $msg $i] - lappend msg_all $i - set msg_true "t" - - } - } else { - if { [string range $word $j $j] eq "w" } { - set aux [expr $j+1] - if { [string range $word $aux [expr $aux+1] ] eq "ww" } { - set url [lindex $msg $i] - lappend msg_all $i - set msg_true "t" - - } - } - } - } - } - - set user_id [$child user_id] - set color [$child color] - - - set timelong [clock format [$child time]] - set timeshort [clock format [$child time] -format {[%H:%M:%S]}] - set timeshort2 [clock format [$child time] -format {[%D]}] - - db_1row room_info { - select count(1) as info - from chat_registered_users - where room_id = :chat_id - and user_id = :user_id - } - - - - if { $info > 0 } { - db_1row room_info { - select alias as alias - from chat_registered_users - where room_id = :chat_id - and user_id = :user_id - } - set userlink [my user_link2 -user_id $user_id -color $color -alias $alias] - - if {$msg_true eq "t"} { - - append result " " \ "$userlink:" - - append result "
\n" - } else { - append result " " \ - "$userlink:" \ - "
\n" - } - } - - if {$info eq 0} { - set userlink [my user_link -user_id $user_id -color $color] - - if {$msg_true eq "t"} { - - append result " " \ - "$userlink:" - - append result "
\n" - } else { - - append result " " \ - "$userlink:" \ - "
\n" - } - } - } - return $result } + - - - ############################################################################ # Chat meta class, since we need to define general class-specific methods ############################################################################ Class create ChatClass -superclass ::xotcl::Class ChatClass method sweep_all_chats {} { - my log "-- starting----------swee_all_chats" + my log "-- starting" foreach nsv [nsv_names "[self]-*-seen"] { if { [regexp "[self]-(\[0-9\]+)-seen" $nsv _ chat_id] } { - my log "--Chat_id $chat_id" - my new -volatile -chat_id $chat_id -user_id 0 -session_id 0 -init -sweeper2 + my log "--Chat_id $chat_id" + my new -volatile -chat_id $chat_id -user_id 0 -session_id 0 -init -sweeper } } my log "-- ending" " \ - "