Index: openacs-4/packages/chat/tcl/chat-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/chat/tcl/chat-procs.tcl,v diff -u -r1.25 -r1.26 --- openacs-4/packages/chat/tcl/chat-procs.tcl 6 Dec 2018 17:08:15 -0000 1.25 +++ openacs-4/packages/chat/tcl/chat-procs.tcl 3 Sep 2024 15:37:36 -0000 1.26 @@ -1,269 +1,45 @@ -# /chat/tcl/chat-procs.tcl ad_library { - TCL Library for the chat system v.4 + TCL Library for the chat system v.6 + These procs serve now only as a backward compatibility layer, as + all the relevant logic is implemented in xotcl-chat-procs. These + procs will soon be deprecated. + @author David Dao (ddao@arsdigita.com) @creation-date November 17, 2000 @cvs-id $Id$ } -# All the remaining Java-related code is being faded out, as its -# status is unknown (as in not working) and we won't be allowed to -# have binaries into the core by distros. - -# ad_proc -private chat_start_server { -# } { -# Start Java chat server. -# } { - -# if {[nsv_get chat server_started]} { -# return -# } -# ns_log notice "chat_start_server: Starting chat server" -# set port [parameter::get -parameter ServerPort] -# set path "ns/server/[ns_info server]/module/nssock" -# set host_location "[ns_config $path Address]" - -# exec java -classpath [acs_root_dir]/packages/chat/java adChatServer start $port & - -# set done 0 - -# # Wait until chat server started before spawning new threads connecting to the server. -# while { $done == 0} { -# if {[catch {set fds [ns_sockopen -nonblock $host_location $port]} errmsg]} { -# set done 0 -# } else { -# set done 1 -# } -# } - -# # Free up resources. -# lassign $fds r w - -# close $r -# close $w -# ns_thread begindetached "chat_broadcast_to_applets $host_location $port" -# ns_thread begindetached "chat_receive_from_server $host_location $port" - -# ns_log notice "chat_start_server: Chat server started." -# nsv_set chat server_started 1 -# } - -# ad_proc -private chat_broadcast_to_applets { -# host -# port -# } { -# Broadcast chat message from HTML client to Java server. -# } { - -# # Chat server must already started otherwise error will occur. -# set fds [ns_sockopen -nonblock $host $port] - -# lassign $fds r w - -# ns_log Notice "chat_broadcast_to_applets: Ready to broadcast message to applets." -# ns_log Notice $host -# ns_log Notice $port - -# # Register to java chat server. -# puts $w "-1AOL_WRITERT-1" -# flush $w - -# while { 1 } { -# # Wait until there is new message in queue. -# ns_mutex lock [nsv_get chat new_message] -# if {[nsv_exists chat html_message]} { -# # Get message from queue. -# puts $w [nsv_get chat html_message] -# flush $w -# } -# } -# } - -# ad_proc -private chat_receive_from_server { -# host -# port -# } { -# Receive messages from Java clients. -# } { - -# set fds [ns_sockopen -nonblock $host $port] - -# lassign $fds r w -# set r_fd [list $r] - -# ns_log Notice "chat_receive_from_server: Listening for messages from applets." - -# puts $w " -# -# -1 -# AOL_READER -# T -# -1 -# " -# flush $w - -# set running 1 - -# while { $running } { -# set sel [ns_sockselect $r_fd {} {}] -# set rfds [lindex $sel 0] - -# foreach r $rfds { - -# if {[ns_sockcheck $r] && [set line [string trim [gets $r]]] != ""} { - -# regexp "(.*)" $line match room_id -# regexp "(.*)" $line match screen_name -# regexp "(.*)" $line match msg -# regexp "(.*)" $line match user_id -# if {![nsv_exists chat_room $room_id]} { -# nsv_set chat_room $room_id {} -# } - -# ::chat::Chat c1 -volatile -chat_id $room_id -user_id $user_id -session_id 0 -# switch $msg { -# "/enter" { -# c1 login -# } -# "/leave" { -# c1 logout -# } -# default { -# c1 add_msg -uid $user_id $msg -# } -# } - -# chat_room_get -room_id $room_id -array room_info -# if { $room_info(archive_p) == "t" } { -# if {[catch { -# chat_post_message_to_db \ -# -creation_user $user_id $room_id $msg -# } errmsg]} { -# ad_log error "chat_post_message_to_db: error: $errmsg" -# } -# } - -# nsv_lappend chat_room $room_id $line - -# } else { -# set running 0 -# } -# } -# } -# } - - -# ad_proc -public chat_moderate_message_post { -# room_id -# user_id -# message -# } { -# Post moderate message to the chat room and broadcast to all applet clients. Only use by HTML client. -# } { -# set chat_msg " -# -# [chat_user_name $user_id] -# $user_id -# $room_id -# $message -# pending -# " - -# # Add message to queue. Notify thread responsible for broadcast message to applets. -# nsv_set chat html_message $chat_msg -# ns_mutex unlock [nsv_get chat new_message] -# } - -# ad_proc -public chat_message_retrieve { -# msgs -# room_id -# user_id -# } { -# Retrieve all messages from the chat room starting from -# first_msg_id. Return messages are store in multirow format. -# } { -# ns_log debug "chat_message_retrieve: starting message retrieve" - -# # The first time html client enter chat room, chat_room variable -# # is not initialize correctly. Therefore I just hard code the -# # variable. -# if {![nsv_exists chat_room $room_id]} { -# nsv_set chat_room $room_id {} -# } - -# set user_name [chat_user_name $user_id] - -# upvar "$msgs:rowcount" counter - -# set chat_messages [nsv_get chat_room $room_id] - -# set count [llength $chat_messages] - -# set cnt $count -# set counter 0 - -# #foreach msg $chat_messages -# for { set i [expr {$cnt - 1}] } { $i >= 0 } { incr i -1 } { -# set msg [lindex $chat_messages $i] -# regexp "(.*)" $msg match screen_name -# regexp "(.*)" $msg match chat_msg -# regexp "(.*)" $msg match status - -# if {$status in {"pending" "rejected"}} { -# continue -# } - -# upvar "$msgs:[expr {$counter + 1}]" array_val - -# set array_val(screen_name) $screen_name -# set array_val(chat_msg) $chat_msg -# incr counter -# set array_val(rownum) $counter - -# if {$screen_name == $user_name && $chat_msg eq "has entered the room."} { -# return -# } -# } -# } - -ad_proc -private chat_post_message_to_db { - {-creation_user ""} - {-creation_ip ""} - room_id - msg -} { - Log chat message to the database. -} { - db_string post_message {} -} - -ad_proc -public chat_room_get { +ad_proc -deprecated -public chat_room_get { {-room_id {}} {-array:required} } { Get all the information about a chat room into an array + + @see ::xo::db::chat_room } { upvar $array row array set row [ns_cache eval chat_room_cache $room_id { chat_room_get_not_cached $room_id }] + #array set row [chat_room_get_not_cached $room_id] } -ad_proc -private chat_room_get_not_cached { +ad_proc -deprecated -private chat_room_get_not_cached { room_id } { - if {![db_0or1row select_room_info { - select * from chat_rooms - where room_id = :room_id - } -column_array row]} { - set msg "Cannot find data for chatroom $room_id" - ad_log error $msg - error $msg + @see ::xo::db::chat_room +} { + set r [::xo::db::Class get_instance_from_db -id $room_id] + foreach var [$r info vars] { + set row($var) [$r set $var] } + # todo: extend oo machinery so these attributes are also returned + # by get_instance_from_db acs_object::get \ -object_id $room_id \ -array obj + set row(object_id) $obj(object_id) set row(context_id) $obj(context_id) set row(creation_user) $obj(creation_user) set row(creation_date) $obj(creation_date_ansi) @@ -274,7 +50,7 @@ return [array get row] } -ad_proc -public chat_room_new { +ad_proc -deprecated -public chat_room_new { {-description ""} {-moderated_p f} {-active_p t} @@ -287,69 +63,43 @@ {-context_id ""} {-creation_user ""} {-creation_ip ""} + {-avatar_p t} pretty_name } { Create new chat room. Return room_id if successful else raise error. -} { - if {[ad_conn isconnected] && $creation_user eq ""} { - set creation_user [ad_conn user_id] - } - db_transaction { - set room_id [::xo::db::sql::acs_object new \ - -object_type "chat_room" \ - -creation_user $creation_user \ - -creation_ip $creation_ip \ - -context_id $context_id] - - db_dml insert_room {} - - if {$creation_user ne ""} { - foreach privilege {edit view delete} { - permission::grant \ - -party_id $creation_user \ - -object_id $room_id \ - -privilege chat_room_${privilege} - } - permission::grant \ - -party_id $creation_user \ - -object_id $room_id \ - -privilege chat_transcript_create - } - } - - return $room_id + @see ::xo::db::chat_room +} { + set r [::xo::db::chat_room new \ + -description $description \ + -active_p $active_p \ + -archive_p $archive_p \ + -auto_flush_p $auto_flush_p \ + -auto_transcript_p $auto_transcript_p \ + -login_messages_p $login_messages_p \ + -logout_messages_p $logout_messages_p \ + -messages_time_window $messages_time_window \ + -avatar_p $avatar_p \ + -pretty_name $pretty_name] + $r set context_id $context_id + $r set creation_user $creation_user + $r set creation_ip $creation_ip + return [$r save_new] } -ad_proc -public chat_room_exists_p { +ad_proc -deprecated -public chat_room_exists_p { room_id } { Return whether a chat room exists @return a boolean + + @see ::xo::db::chat_room } { - if {[ns_cache names chat_room_cache $room_id] ne ""} { - # chat room is in cache: it exists "for sure" - return 1 - } elseif {[info exists ::chat_room_deleted_p($room_id)]} { - # chat room deletion has been recorded in threaded cache: as - # object id comes from a sequence, unless somebody puts an id - # by hand, the same will never be used again system wide, so - # it is safe to cache this - return 0 - } elseif {[db_0or1row room_exists { - select 1 from chat_rooms - where room_id = :room_id}]} { - # chat room existence has been confirmed by query - return 1 - } else { - # chat room is not there: take note of this in threaded cache - set ::chat_room_deleted_p($room_id) 1 - return 0 - } + return [::xo::db::Class exists_in_db -id $room_id] } -ad_proc -public chat_room_edit { +ad_proc -deprecated -public chat_room_edit { room_id pretty_name description @@ -361,200 +111,213 @@ login_messages_p logout_messages_p messages_time_window + avatar_p } { Edit information on chat room. All information require. + + @see ::xo::db::chat_room } { - db_dml update_room {} - ns_cache flush chat_room_cache $room_id + set r [::xo::db::Class get_instance_from_db -id $room_id] + foreach var { + pretty_name + description + active_p + archive_p + auto_flush_p + auto_transcript_p + login_messages_p + logout_messages_p + messages_time_window + avatar_p + } { + $r set $var [set $var] + } + $r save + ns_cache flush -- chat_room_cache $room_id } -ad_proc -public chat_room_delete { +ad_proc -deprecated -public chat_room_delete { room_id } { Delete chat room. + + @see ::xo::db::chat_room } { - db_string delete_room {} + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r delete ns_cache flush -- chat_room_cache $room_id } -ad_proc -public chat_room_message_delete { +ad_proc -deprecated -public chat_room_message_delete { room_id } { Delete all message in the room. + + @see ::xo::db::chat_room } { - db_string delete_message {} + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r delete_messages } -ad_proc -public chat_message_count { +ad_proc -deprecated -public chat_message_count { room_id } { Get message count in the room. + + @see ::xo::db::chat_room } { - return [db_string message_count {} -default 0] + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r count_messages } -ad_proc -public room_active_status { +ad_proc -deprecated -public room_active_status { room_id } { Get room active status. + + @see ::xo::db::chat_room } { - if {[chat_room_exists_p $room_id]} { - chat_room_get -room_id $room_id -array c - return [expr {$c(active_p) ne "" ? $c(active_p) : "f"}] + if {[::xo::db::Class exists_in_db -id $room_id]} { + set r [::xo::db::Class get_instance_from_db -id $room_id] + return [string is true -strict [$r set active_p]] } else { - return "f" + return false } } -ad_proc -public chat_room_name { +ad_proc -deprecated -public chat_room_name { room_id } { Get chat room name. + + @see ::xo::db::chat_room } { - chat_room_get -room_id $room_id -array c - return $c(pretty_name) + set r [::xo::db::Class get_instance_from_db -id $room_id] + return [$r set pretty_name] } -ad_proc -public chat_moderator_grant { +ad_proc -deprecated -public chat_moderator_grant { room_id party_id } { Grant party a chat moderate privilege to this chat room. + + @see ::xo::db::chat_room } { - permission::grant \ - -party_id $party_id \ - -object_id $room_id \ - -privilege "chat_room_moderate" + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r grant_moderator -party_id $party_id } -ad_proc -public chat_moderator_revoke { +ad_proc -deprecated -public chat_moderator_revoke { room_id party_id } { Revoke party a chat moderate privilege to this chat room. + + @see ::xo::db::chat_room } { - permission::revoke \ - -party_id $party_id \ - -object_id $room_id \ - -privilege "chat_room_moderate" + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r revoke_moderator -party_id $party_id } -ad_proc -public chat_user_grant { +ad_proc -deprecated -public chat_user_grant { room_id party_id } { Grant party a chat privilege to this chat room. + + @see ::xo::db::chat_room } { - db_transaction { - foreach privilege {read write} { - permission::grant \ - -party_id $party_id \ - -object_id $room_id \ - -privilege chat_${privilege} - } - } + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r grant_user -party_id $party_id } -ad_proc -public chat_user_revoke { +ad_proc -deprecated -public chat_user_revoke { room_id party_id } { Revoke party a chat privilege to this chat room. + + @see ::xo::db::chat_room } { - db_transaction { - foreach privilege {read write} { - permission::revoke \ - -party_id $party_id \ - -object_id $room_id \ - -privilege chat_${privilege} - } - } + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r revoke_user -party_id $party_id } -ad_proc -public chat_user_ban { +ad_proc -deprecated -public chat_user_ban { room_id party_id } { Explicit ban user from this chat room. + + @see ::xo::db::chat_room } { - permission::grant \ - -party_id $party_id \ - -object_id $room_id \ - -privilege "chat_ban" + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r ban_user -party_id $party_id } -ad_proc -public chat_user_unban { +ad_proc -deprecated -public chat_user_unban { room_id party_id } { unban user from this chat room. + + @see ::xo::db::chat_room } { - permission::revoke \ - -party_id $party_id \ - -object_id $room_id \ - -privilege "chat_ban" + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r unban_user -party_id $party_id } -ad_proc -public chat_revoke_moderators { +ad_proc -deprecated -public chat_revoke_moderators { room_id revoke_list } { Revoke a list of parties of a moderate privilege from this room. + + @see ::xo::db::chat_room } { - foreach party_id $revoke_list { - permission::revoke \ - -party_id $party_id \ - -object_id $room_id \ - -privilege "chat_moderate_room" - } + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r revoke_moderator -party_id $revoke_list } -ad_proc -public chat_room_moderate_p { +ad_proc -deprecated -public chat_room_moderate_p { room_id } { Return the moderate status of this chat room. + + Note that the moderated_p flag is not part of the current + datamodel anymore. + + @see ::xo::db::chat_room } { - chat_room_get -room_id $room_id -array c - return $c(moderated_p) + return false } -ad_proc -public chat_user_name { +ad_proc -deprecated -public chat_user_name { user_id } { Return display name of this user to use in chat. + + @see ::chat::Package } { - set name [acs_user::get_user_info -user_id $user_id -element screen_name] - if {$name eq ""} { - set name [person::name -person_id $user_id] - } - return $name + return [::chat::Package get_user_name -user_id $user_id] } -ad_proc -public chat_message_post { +ad_proc -deprecated -public chat_message_post { room_id user_id message moderator_p } { Post message to the chat room and broadcast to all applet clients. Used by ajax + html. -} { - if {$moderator_p == 1} { - set status "approved" - } else { - set status "pending" - } - # do not write messages to the database if the room should not be archived - chat_room_get -room_id $room_id -array room_info - if { $room_info(archive_p) == "f" } { return } - - # write message to the database - if {[catch {chat_post_message_to_db -creation_user $user_id $room_id $message} errmsg]} { - ns_log error "chat_post_message_to_db: error: $errmsg" - } + @see ::xo::db::chat_room +} { + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r post_message -msg $message -creation_user $user_id } -ad_proc -public chat_transcript_new { +ad_proc -deprecated -public chat_transcript_new { {-description ""} {-context_id ""} {-creation_user ""} @@ -564,86 +327,69 @@ room_id } { Create chat transcript. -} { - if {[ad_conn isconnected] && $creation_user eq ""} { - set creation_user [ad_conn user_id] - } - db_transaction { - set transcript_id [::xo::db::sql::acs_object new \ - -object_type "chat_transcript" \ - -creation_user $creation_user \ - -creation_ip $creation_ip \ - -context_id $context_id] - - db_dml insert_transcript {} - - foreach privilege {edit view delete} { - permission::grant \ - -party_id $creation_user \ - -object_id $transcript_id \ - -privilege chat_transcript_${privilege} - } - } - - return $transcript_id + @see ::xo::db::chat_transcript +} { + set t [::xo::db::chat_transcript new \ + -description $description \ + -pretty_name $pretty_name \ + -contents $contents \ + -room_id $room_id] + $t set context_id $context_id + $t set creation_user $creation_user + $t set creation_ip $creation_ip + return [$t save_new] } -ad_proc -public chat_transcript_delete { +ad_proc -deprecated -public chat_transcript_delete { transcript_id } { Delete chat transcript. + + @see ::xo::db::chat_transcript } { - db_string delete_transcript {} + ::acs::dc call acs_object delete \ + -object_id $transcript_id } -ad_proc -public chat_transcript_edit { +ad_proc -deprecated -public chat_transcript_edit { transcript_id pretty_name description contents } { Edit chat transcript. + + @see ::xo::db::chat_transcript } { - db_dml update_transcript {} + set t [::xo::db::Class get_instance_from_db -id $transcript_id] + foreach var { + pretty_name + description + contents + } { + $t set $var [set $var] + } + $t save } ad_proc -private chat_flush_rooms {} { Flush the messages in all of the chat rooms + + @see ::chat::Package } { - set room_ids [db_list get_rooms *SQL*] - foreach room_id $room_ids { - chat_room_flush $room_id - } + ::chat::Package flush_rooms } ad_proc -private chat_room_flush { room_id } { Flush the messages a single chat room + + @see ::xo::db::chat_room } { - db_transaction { - chat_room_get -room_id $room_id -array room_info - # do we have to create a transcript for the room - if { $room_info(auto_transcript_p) == "t" } { - # build a list of all messages - set contents [list] - foreach message [db_list_of_lists get_archives_messages {}] { - lassign $message msg creation_user creation_date - set user_name [expr {$creation_user > 0 ? [chat_user_name $creation_user] : "system"}] - lappend contents "\[$creation_date\] ${user_name}: $msg" - } - if { $contents ne "" } { - set today [clock format [clock seconds] -format "%d.%m.%Y"] - chat_transcript_new \ - -description "#chat.automatically_created_transcript#" \ - "#chat.transcript_of_date# $today" \ - [join $contents "
\n"] $room_id - } - } - # clear all the messages in the room - chat_room_message_delete $room_id - } + set r [::xo::db::Class get_instance_from_db -id $room_id] + $r flush } # Local variables: