Index: openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 8 Apr 2006 00:05:49 -0000 1.1
@@ -0,0 +1,139 @@
+ad_library {
+
+ Routines for background delivery of files
+
+ @author Gustaf Neumann (neumann@wu-wien.ac.at)
+ @creation-date 19 Nov 2005
+ @cvs-id $Id: bgdelivery-procs.tcl,v 1.1 2006/04/08 00:05:49 gustafn Exp $
+}
+
+::xotcl::THREAD create bgdelivery {
+ ###############
+ # File delivery
+ ###############
+ set ::delivery_count 0
+
+ proc deliver {ch filename context} {
+ set fd [open $filename]
+ fconfigure $fd -translation binary
+ fconfigure $ch -translation binary
+ #ns_log notice "--- start of delivery of $filename (running:[array size ::running])"
+ fcopy $fd $ch -command [list end-delivery $filename $fd $ch]
+ set ::running($ch,$filename) $context
+ incr ::delivery_count
+ }
+
+ proc end-delivery {filename fd ch bytes args} {
+ #ns_log notice "--- end of delivery of $filename, $bytes bytes written $args"
+ if {[catch {close $ch} e]} {ns_log notice "bgdelivery, closing channel for $filename, error: $e"}
+ if {[catch {close $fd} e]} {ns_log notice "bgdelivery, closing file $filename, error: $e"}
+ unset ::running($ch,$filename)
+ }
+
+ ###############
+ # Subscriptions
+ ###############
+ set ::subscription_count 0
+ set ::message_count 0
+
+ ::xotcl::Class Subscriber -parameter {key channel user_id}
+ Subscriber proc current {-key } {
+ my instvar subscriptions
+ set result [list]
+ if {[info exists key]} {
+ if {[info exists subscriptions($key)]} {
+ return [list $key $subscriptions($key)]
+ }
+ } elseif {[info exists subscriptions]} {
+ foreach key [array names subscriptions] {
+ lappend result $key $subscriptions($key)
+ }
+ }
+ }
+ Subscriber proc send {key msg} {
+ my instvar subscriptions
+ ns_log notice "-- [self] send $key $msg subs='[array names subscriptions]' vars=[my info vars]"
+ if {[info exists subscriptions($key)]} {
+ set subs1 [list]
+ foreach s $subscriptions($key) {
+ if {[catch {
+ ns_log notice "-- sending to subscriber for $key $msg ch=[$s channel]"
+ puts [$s channel] $msg
+ flush [$s channel]
+ } errmsg]} {
+ ns_log notice "error in send to subscriber (key=$key): $errmsg"
+ catch {close [$s channel]}
+ $s destroy
+ } else {
+ lappend subs1 $s
+ }
+ }
+ set subscriptions($key) $subs1
+ }
+ incr ::message_count
+ }
+ Subscriber instproc init {} {
+ [my info class] instvar subscriptions
+ lappend subscriptions([my key]) [self]
+ ns_log notice "-- Subscriber init, cl=[my info class], subscriptions([my key]) = $subscriptions([my key])"
+ fconfigure [my channel] -translation binary
+ incr ::subscription_count
+ }
+} -persistent 1
+
+bgdelivery ad_forward running {
+ Interface to the background delivery thread to query the currently running deliveries.
+ @return list of key value pairs of all currently running background processes
+} %self do array get running
+
+
+bgdelivery ad_forward nr_running {
+ Interface to the background delivery thread to query the number of currently running deliveries.
+ @return number of currently running background deliveries
+} %self do array size running
+
+if {[ns_info name] eq "NaviServer"} {
+ bgdelivery forward write_headers ns_headers
+} else {
+ bgdelivery forward write_headers ns_headers DUMMY
+}
+
+
+bgdelivery ad_proc returnfile {statuscode mime_type filename} {
+ Deliver the given file to the requestor in the background. This proc uses the
+ background delivery thread to send the file in an event-driven manner without
+ blocking a request thread. This is especially important when large files are
+ requested over slow (e.g. dial-ip) connections.
+} {
+ #ns_log notice "statuscode = $statuscode, filename=$filename"
+ set size [file size $filename]
+ if {[my write_headers $statuscode $mime_type $size]} {
+ set ch [ns_conn channel]
+ thread::transfer [my get_tid] $ch
+ throttle get_context
+ my do -async deliver $ch $filename \
+ [list [throttle set requestor],[throttle set url] [ns_conn start]]
+ ns_conn contentsentlength $size ;# maybe overly optimistic
+ }
+}
+
+ad_proc -public ad_returnfile_background {statuscode mime_type filename} {
+ Deliver the given file to the requestor in the background. This proc uses the
+ background delivery thread to send the file in an event-driven manner without
+ blocking a request thread. This is especially important when large files are
+ requested over slow (e.g. dial-ip) connections.
+} {
+ bgdelivery returnfile $statuscode $mime_type $filename
+}
+
+#####################################
+bgdelivery proc subscribe {key {initmsg ""}} {
+ my write_headers 200 text/plain 100000
+ ns_write $initmsg
+ set ch [ns_conn channel]
+ thread::transfer [my get_tid] $ch
+ my do -async ::Subscriber new -channel $ch -key $key -user_id [ad_conn user_id]
+}
+bgdelivery proc send_to_subscriber {key msg} {
+ my do -async ::Subscriber send $key $msg
+}
\ No newline at end of file
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 -N -r1.8 -r1.9
--- openacs-4/packages/xotcl-core/tcl/chat-procs.tcl 7 Apr 2006 17:01:18 -0000 1.8
+++ openacs-4/packages/xotcl-core/tcl/chat-procs.tcl 8 Apr 2006 00:05:49 -0000 1.9
@@ -1,15 +1,15 @@
ad_library {
generic chat - chat procs
- @creation-date 2006-02-02
- @author Gustaf Neumann
- @cvs-id $Id$
+ @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 euid emsg
+ -parameter {chat_id user_id session_id
{encoder urlencode} {timewindow 600} {sweepinterval 600}
}
@@ -35,37 +35,32 @@
Chat instproc add_msg {{-get_new:boolean true} -uid msg} {
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 && [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] ;#### PETER?
+ nsv_set $array-seen last [clock seconds]
nsv_set $array-last-activity $user_id $now
- my check_message $user_id $msg
- # ns_log Notice "YY ADDING TO NSV $array $msg_id [list $now [clock seconds] [my euid] [my emsg] [my user_color $user_id]]"
- nsv_set $array $msg_id [list $now [clock seconds] [my euid] [my emsg] [my user_color $user_id]]
+ # 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 {} {
- if { [my exists euid] && [my set euid] == -1 } {
- return 0
- }
- return 1
+ expr { [my exists user_id] && [my set user_id] != -1 }
}
- Chat instproc check_message { user_id msg } {
- set msg [ad_quotehtml $msg]
- my set emsg $msg
- my set euid $user_id
- # if { [regexp {} $msg] } {
- # ns_log Notice "YY Message ($msg) contains html!"
- # my set emsg "[_ xotcl-core.html_is_not_allowed], [my user_name $user_id]"
- # my set euid -1
- # }
- }
-
Chat instproc active_user_list {} {
nsv_array get [my set array]-login
}
@@ -88,6 +83,7 @@
}
return 1
}
+
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}]
@@ -108,6 +104,7 @@
}
my render
}
+
Chat instproc get_all {} {
my instvar array now session_id
foreach {key value} [nsv_array get $array] {
@@ -130,10 +127,10 @@
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 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"
@@ -168,12 +165,12 @@
Chat instproc get_users {} {
set output ""
foreach {user_id timestamp} [my active_user_list] {
- if {$user_id > 0} {
- set diff [clock format [expr {[clock seconds] - $timestamp}] -format "%H:%M:%S" -gmt 1]
- set userlink [my user_link -user_id $user_id]
- append output "| $userlink | $diff |
\n"
- }
- }
+ if {$user_id > 0} {
+ set diff [clock format [expr {[clock seconds] - $timestamp}] -format "%H:%M:%S" -gmt 1]
+ set userlink [my user_link -user_id $user_id]
+ append output "| $userlink | $diff |
\n"
+ }
+ }
return $output
}
@@ -213,14 +210,46 @@
} elseif { $user_id == 0 } {
set creator "Nobody"
} else {
- set creator "System"
+ set creator "System"
}
return [my encode $creator]
}
Chat instproc urlencode {string} {ns_urlencode $string}
Chat instproc noencode {string} {set string}
Chat instproc encode {string} {my [my encoder] $string}
+
+ Chat instproc json_encode {string} {
+ string map [list \n \\n {"} {\"} ' {\'}] $string ;#"
+ }
+
+ Chat instproc json_encode_msg {msg} {
+ set old [my encoder]
+ my encoder noencode ;# just for user_link
+ set userlink [my user_link -user_id [$msg user_id] -color [$msg color]]
+ my encoder $old
+ set timeshort [clock format [$msg time] -format {[%H:%M:%S]}]
+ set text [my json_encode [$msg msg]]
+ foreach var {userlink timeshort} {set $var [my json_encode [set $var]]}
+ return [subst -nocommands {{'messages': [
+ {'user':'$userlink', 'time': '$timeshort', 'msg':'$text'}
+ ]\n}
+ }]
+ }
+
+ Chat instproc broadcast_msg {msg} {
+ bgdelivery send_to_subscriber chat-[my chat_id] [my json_encode_msg $msg]
+ }
+
+ Chat instproc subscribe {-uid} {
+ set user_id [expr {[info exists uid] ? $uid : [my set user_id]}]
+ set color [my user_color $user_id]
+ bgdelivery subscribe chat-[my chat_id] [my json_encode_msg \
+ [Message new -volatile -time [clock seconds] \
+ -user_id $user_id -color $color \
+ -msg [_ xotcl-core.has_entered_the_room] ]]
+ }
+
Chat instproc render {} {
my orderby time
set result ""
@@ -231,6 +260,7 @@
set timelong [clock format [$child time]]
set timeshort [clock format [$child time] -format {[%H:%M:%S]}]
set userlink [my user_link -user_id $user_id -color $color]
+
append result "$timeshort" \
"$userlink:" \
"[my encode $msg]
\n"