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 -r1.10 -r1.11
--- openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl	24 Jul 2007 20:52:16 -0000	1.10
+++ openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl	20 Sep 2007 11:57:04 -0000	1.11
@@ -237,8 +237,7 @@
   ns_write "HTTP/1.0 200 OK\r\nContent-type: $content_type\r\n\r\n[string repeat { } 1024]"
   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] -mode $mode
-  my send_to_subscriber $key $initmsg
+  my do ::Subscriber new -channel $ch -key $key -user_id [ad_conn user_id] -mode $mode
 }
 
 bgdelivery proc send_to_subscriber {key msg} {
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.14 -r1.15
--- openacs-4/packages/xotcl-core/tcl/chat-procs.tcl	18 Jun 2007 16:19:49 -0000	1.14
+++ openacs-4/packages/xotcl-core/tcl/chat-procs.tcl	20 Sep 2007 11:57:04 -0000	1.15
@@ -24,15 +24,29 @@
     if {![nsv_exists $cls initialized]} {
       my log "-- initialize $cls"
       $cls initialize_nsvs
-      nsv_set $cls initialized \
+      ::xo::clusterwide nsv_set $cls initialized \
 	  [ad_schedule_proc -thread "t" [my sweepinterval] $cls sweep_all_chats]
     }
-    if {![nsv_exists $array-seen newest]} {nsv_set $array-seen newest 0}
-    if {![nsv_exists $array-color idx]}   {nsv_set $array-color idx 0}
+    if {![nsv_exists $array-seen newest]} {::xo::clusterwide nsv_set $array-seen newest 0}
+    if {![nsv_exists $array-color idx]}   {::xo::clusterwide nsv_set $array-color idx 0}
     my init_user_color
   }
 
+
+
+  Chat instproc register_nsvs {msg_id user_id msg color secs} {
+    my instvar array now
+    if { ![nsv_exists $array-login $user_id] } {
+      ::xo::clusterwide nsv_set $array-login $user_id $secs
+    }
+    ::xo::clusterwide nsv_set $array $msg_id [list $now $secs $user_id $msg $color]
+    ::xo::clusterwide nsv_set $array-seen newest $now
+    ::xo::clusterwide nsv_set $array-seen last $secs
+    ::xo::clusterwide nsv_set $array-last-activity $user_id $now
+  }
+
   Chat instproc add_msg {{-get_new:boolean true} -uid msg} {
+    my log "--chat adding $msg"
     my instvar array now
     set user_id [expr {[info exists uid] ? $uid : [my set user_id]}]
     set color   [my user_color $user_id]
@@ -46,15 +60,7 @@
       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
+    my register_nsvs $now.$user_id $user_id $msg $color [clock seconds]
     # this in any case a valid result, but only needed for the polling interface
     if {$get_new} {my get_new}
   }
@@ -79,7 +85,7 @@
   Chat instproc check_age {key ago} {
     my instvar array timewindow
     if {$ago > $timewindow} {
-      nsv_unset $array $key
+      ::xo::clusterwide nsv_unset $array $key
       #my log "--c unsetting $key"
       return 0
     }
@@ -99,7 +105,7 @@
 	  my check_age $key [expr {($now - $timestamp) / 1000}]
 	}
       }
-      nsv_set $array-seen $session_id $now
+      ::xo::clusterwide nsv_set $array-seen $session_id $now
       #my log "--c setting session_id $session_id: $now"
     } else {
       #my log "--c nothing new for $session_id"
@@ -116,7 +122,7 @@
       }
     }
     #my log "--c setting session_id $session_id: $now"
-    nsv_set $array-seen $session_id $now
+    ::xo::clusterwide nsv_set $array-seen $session_id $now
     my render
   }
 
@@ -143,11 +149,11 @@
     ns_log Notice "YY User $user_id logging out of chat"
     my add_msg -get_new false [_ chat.has_left_the_room].
     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
-        nsv_unset $array-last-activity $user_id
-        nsv_unset $array-login $user_id
-        nsv_unset $array-color $user_id
+      # 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
+      ::xo::clusterwide nsv_unset $array-last-activity $user_id
+      ::xo::clusterwide nsv_unset $array-login $user_id
+      ::xo::clusterwide nsv_unset $array-color $user_id
     }
   }
 
@@ -159,8 +165,8 @@
       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
+      ::xo::clusterwide nsv_set $array-color $user_id $color
+      ::xo::clusterwide nsv_incr $array-color idx
     }
   }
   
@@ -177,10 +183,12 @@
   }
   
   Chat instproc login {} {
+    my log "--chat login"
     my instvar array user_id now
     # was the user already active?
+    my log "--chat login already avtive? [nsv_exists $array-last-activity $user_id]"
     if {![nsv_exists $array-last-activity $user_id]} {
-        my add_msg -get_new false [_ xotcl-core.has_entered_the_room]
+      my add_msg -get_new false [_ xotcl-core.has_entered_the_room]
     }
     my encoder noencode
     #my log "--c setting session_id [my set session_id]: $now"
@@ -217,10 +225,9 @@
     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 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 ;#"
   }
@@ -248,16 +255,18 @@
   }
 
   Chat instproc broadcast_msg {msg} {
-    bgdelivery send_to_subscriber chat-[my chat_id] [my json_encode_msg $msg]
+    my log "--chat broadcast_msg $msg"
+    ::xo::clusterwide \
+        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] ]] [my mode]
+    bgdelivery subscribe chat-[my chat_id] "" [my mode] 
+    my broadcast_msg [Message new -volatile -time [clock seconds] \
+                          -user_id $user_id -color $color \
+                          -msg [_ xotcl-core.has_entered_the_room] ]
   }
 
   Chat instproc render {} {
@@ -299,15 +308,15 @@
     db_foreach get_rooms {
       select room_id, to_char(max(creation_date),'HH24:MI:SS YYYY-MM-DD') as last_activity 
       from chat_msgs group by room_id} {
-	nsv_set [self]-$room_id-seen last [clock scan $last_activity]
+	::xo::clusterwide nsv_set [self]-$room_id-seen last [clock scan $last_activity]
       }
   }
 
   ChatClass method flush_messages {-chat_id:required} {
     set array "[self]-$chat_id"
-    nsv_unset $array
-    nsv_unset $array-seen
-    nsv_unset $array-last-activity
+    ::xo::clusterwide nsv_unset $array
+    ::xo::clusterwide nsv_unset $array-seen
+    ::xo::clusterwide nsv_unset $array-last-activity
   }
 
   ChatClass method init {} {
Index: openacs-4/packages/xotcl-core/tcl/cluster-init.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/cluster-init.tcl,v
diff -u -N
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/cluster-init.tcl	20 Sep 2007 11:57:04 -0000	1.1
@@ -0,0 +1,22 @@
+if {[server_cluster_enabled_p]} {
+  set my_ip   [ns_config ns/server/[ns_info server]/module/nssock Address]
+  set my_port [ns_config ns/server/[ns_info server]/module/nssock port]
+  
+  foreach host [server_cluster_all_hosts] {
+    set port 80
+    regexp {^(.*):(.*)} $host _ host port
+    if {"$host-$port" eq "$my_ip-$my_port"}  continue
+    ::xo::Cluster create CS_${host}_$port -host $host -port $port
+  }
+  
+  foreach ip [ad_parameter -package_id [ad_acs_kernel_id] ClusterAuthorizedIP server-cluster] {
+    if {[string first * $ip] > -1} {
+      ::xo::Cluster lappend allowed_host_patterns $ip
+    } else {
+      ::xo::Cluster set allowed_host($ip) 1
+    }
+  }
+  
+  ns_register_filter trace GET /xotcl/do ::xo::Cluster
+  ad_register_filter -priority 900 preauth GET /xotcl/do ::xo::Cluster
+}
Index: openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl,v
diff -u -N
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl	20 Sep 2007 11:57:04 -0000	1.1
@@ -0,0 +1,115 @@
+ad_library {
+  XOTcl cluster support
+
+  @author Gustaf Neumann
+  @creation-date 2007-07-19
+  @cvs-id $Id: cluster-procs.tcl,v 1.1 2007/09/20 11:57:04 gustafn Exp $
+}
+
+namespace eval ::xo {
+
+  proc clusterwide args {
+    # first, excute the command on the local server
+    eval $args
+    # then, distribute the command in the cluster
+    eval ::xo::Cluster broadcast $args
+  }
+
+  Class Cluster -parameter {host {port 80}}
+  Cluster set allowed_host_patterns [list]
+  Cluster array set allowed_host {
+    "127.0.0.1" 1
+  }
+  Cluster array set allowed_command {
+    set "" 
+    unset "" 
+    nsv_set "" 
+    nsv_unset ""
+    nsv_incr ""
+    bgdelivery ""
+    ns_cache "^ns_cache\s+eval"
+  }
+  #
+  # Prevent unwanted object generations for unknown 
+  # arguments of ::xo::Cluster.
+  #
+  Cluster proc unknown args {
+    error "[self] received unknown method $args"
+  }
+  #
+  # handling the ns_filter methods
+  #
+  Cluster proc trace args {
+    my log ""
+    return filter_return
+  }
+  Cluster proc preauth args {
+    my log ""
+    my incoming_request
+    return filter_return
+  }
+  Cluster proc postauth args {
+    my log ""
+    return filter_return
+  }
+  #
+  # handle incoming request issues
+  #
+  Cluster proc incoming_request {} {
+    set cmd [ns_queryget cmd]
+    set addr [lindex [ns_set iget [ns_conn headers] x-forwarded-for] end]
+    if {$addr eq ""} {set addr [ns_conn peeraddr]}
+    ns_log notice "--cluster got cmd='$cmd' from $addr"
+    if {[catch {set result [::xo::Cluster execute [ns_conn peeraddr] $cmd]} errorMsg]} {
+      ns_log notice "--cluster error: $errorMsg"
+      ns_return 417 text/plain $errorMsg
+    } else {
+      #ns_log notice "--cluster success $result"
+      ns_return 200 text/plain $result
+    }
+  }
+
+  Cluster proc execute {host cmd} {
+    if {![my exists allowed_host($host)]} {
+      set ok 0
+      foreach g [my set allowed_host_patterns] {
+        if {[string match $g $host]} {
+          set ok 1
+          break
+        }
+      }
+      if {!$ok} {
+        error "refuse to execute commands from $host (command: '$cmd')"
+      }
+    }
+    set cmd_name [lindex $cmd 0]
+    set key allowed_command($cmd_name)
+    #ns_log notice "--cluster $key exists ? [my exists $key]"
+    if {[my exists $key]} {
+      set except_RE [my set $key]
+      #ns_log notice "--cluster [list regexp $except_RE $cmd] -> [regexp $except_RE $cmd]"
+      if {$except_RE eq "" || ![regexp $except_RE $cmd]} {
+        ns_log notice "--cluster executes command '$cmd' from host $host"
+        return [eval $cmd]
+      }
+    }
+    error "command '$cmd' from host $host not allowed"
+  }
+  #
+  # handline outgoing request issues
+  #
+  Cluster proc broadcast args {
+    foreach server [my info instances] {
+      eval $server message $args
+    }
+  }
+  Cluster instproc message args {
+    my log "--cluster outgoing request to [my host]:[my port] // $args" 
+    set r [::xo::HttpRequest new -volatile \
+               -host [my host] -port [my port] \
+               -path /xotcl/do?cmd=[ns_urlencode $args]]
+    return [$r set data]
+  }
+
+
+}
\ No newline at end of file
Index: openacs-4/packages/xotcl-core/tcl/cr-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/cr-procs.tcl,v
diff -u -N -r1.4 -r1.5
--- openacs-4/packages/xotcl-core/tcl/cr-procs.tcl	19 Sep 2007 13:56:47 -0000	1.4
+++ openacs-4/packages/xotcl-core/tcl/cr-procs.tcl	20 Sep 2007 11:57:04 -0000	1.5
@@ -1183,7 +1183,7 @@
   }
   CrCache instproc delete {-item_id} {
     next
-    ns_cache flush xotcl_object_cache ::$item_id
+    ::xo::clusterwide ns_cache flush xotcl_object_cache ::$item_id
     # we should probably flush as well cached revisions
   }
 
@@ -1192,10 +1192,11 @@
   CrCache::Item instproc save args {
     set r [next]
     # cache only names with IDs
-    if {[regexp [[self class] set name_pattern] [self]]} {
-      #my log "--CACHE saving [self] in cache"
-      ns_cache set xotcl_object_cache [self] \
-	  [::Serializer deepSerialize [self]]
+    set obj [self]
+    if {[regexp [[self class] set name_pattern] $obj]} {
+      #my log "--CACHE saving $obj in cache"
+      ::xo::clusterwide ns_cache flush xotcl_object_cache $obj
+      ns_cache set xotcl_object_cache $obj [$obj serialize]
     }
     return $r
   }
@@ -1207,7 +1208,7 @@
     return $item_id
   }
   CrCache::Item instproc delete args {
-    ns_cache flush xotcl_object_cache [self]
+    ::xo::clusterwide ns_cache flush xotcl_object_cache [self]
     next
   }