Initial Import

COPYRIGHT

+ *  xotcl-core 
+ *
+ *  Copyright (C) 2005 Gustaf Neumann, neumann@wu-wien.ac.at
+ *
+ *  Vienna University of Economics and Business Administration
+ *     Institute of Information Systems and New Media
+ *     A-1090, Augasse 2-6
+ *     Vienna, Austria
+ *
+ *  This is a BSD-Style license applicable for the files in this
+ * directory and below, except when stated explicitly different.
+ *
+ *  Permission to use, copy, modify, distribute, and sell this
+ *  software and its documentation for any purpose is hereby granted
+ *  without fee, provided that the above copyright notice appear in
+ *  all copies and that both that copyright notice and this permission
+ *  notice appear in supporting documentation. We make no
+ *  representations about the suitability of this software for any
+ *  purpose.  It is provided "as is" without express or implied
+ *  warranty.
+ *
+
+

catalog/xotcl-core.de_DE.ISO-8859-1.xml

+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" locale="de_DE" charset="ISO-8859-1">
+
+  <msg key="add">Neu: %type%</msg>
+  <msg key="add_long">Neue Seite vom Type %type% erzeugen</msg>
+  <msg key="edit_item">Editieren</msg>
+  <msg key="has_entered_the_room">has entered the room</msg>
+  <msg key="live_revision">Aktuelle Version</msg>
+  <msg key="permission_denied">Zugriff verweigert</msg>
+  <msg key="policy-error-insufficient_permissions">&lt;blockquote&gt;
+Sie haben keine ausreichende Berechtigung, um die Methode %method% am Objekt %object% auszufhren.
+&lt;/blockquote&gt;</msg>
+  <msg key="revision_title">Versionen des Eintrags</msg>
+  <msg key="revisions">Verlauf</msg>
+</message_catalog>

catalog/xotcl-core.el_GR.utf-8.xml

+<?xml version="1.0" encoding="utf-8"?>
+<message_catalog package_key="xotcl-core" locale="el_GR" charset="utf-8">
+
+  <msg key="add">Προσθήκη %type%</msg>
+  <msg key="add_long">Προσθήκη νέου αντικειμένου του τύπου %type%</msg>
+  <msg key="create_new_type">Δημιουργία νέου %type%</msg>
+  <msg key="edit_item">Επεξεργασία αντικειμένου</msg>
+  <msg key="edit_type">Επεξεργασία %type%</msg>
+  <msg key="has_entered_the_room">μπήκε στο δωμάτιο</msg>
+  <msg key="live_revision">Αναθεώρηση ζωντανά</msg>
+  <msg key="policy-error-insufficient_permissions">&lt;blockquote&gt; Δεν έχετε επαρκείς άδειες για να εφαρμόσετε τη μέθοδο %method% στο αντικείμενο %object%. &lt;/blockquote&gt;</msg>
+  <msg key="revision_title">Αναθεωρήσεις εισόδου</msg>
+  <msg key="revisions">Αναθεωρήσεις </msg>
+</message_catalog>

catalog/xotcl-core.en_US.ISO-8859-1.xml

+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" locale="en_US" charset="ISO-8859-1">
+
+  <msg key="add">Add %type%</msg>
+  <msg key="add_item">Add Item</msg>
+  <msg key="add_long">Add new item of type %type%</msg>
+  <msg key="create_new_type">Create New %type%</msg>
+  <msg key="delete_item">Delete Item</msg>
+  <msg key="edit_item">Edit Item</msg>
+  <msg key="edit_type">Edit %type%</msg>
+  <msg key="has_entered_the_room">has entered the room</msg>
+  <msg key="live_revision">Live Revision</msg>
+  <msg key="permission_denied">Permission Denied</msg>
+  <msg key="policy-error-insufficient_permissions">&lt;blockquote&gt;
+You don't have sufficient permissions for performing method %method% on object %object%.
+&lt;/blockquote&gt;</msg>
+  <msg key="revision_title">Revisions of Entry</msg>
+  <msg key="revisions">Revisions</msg>
+  <msg key="view_item">View Item</msg>
+</message_catalog>

catalog/xotcl-core.es_ES.ISO-8859-1.xml

+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" locale="es_ES" charset="ISO-8859-1">
+
+  <msg key="add">Aadir %type%</msg>
+  <msg key="add_item">Aadir elemento</msg>
+  <msg key="add_long">Aadir un nuevo tem del tipo %type%</msg>
+  <msg key="create_new_type">Crear Nuevo %type%</msg>
+  <msg key="delete_item">Borrar elemento</msg>
+  <msg key="edit_item">Editar tem</msg>
+  <msg key="edit_type">Editar %type%</msg>
+  <msg key="has_entered_the_room">ha entrado en la sala</msg>
+  <msg key="live_revision">Revisin Viva</msg>
+  <msg key="policy-error-insufficient_permissions">&lt;blockquote&gt;
+Usted no tiene permisos suficientes para realizar mtodo %method% en objeto %object%.
+&lt;/blockquote&gt;</msg>
+  <msg key="revision_title">Revisiones de la Entrada</msg>
+  <msg key="revisions">Revisiones</msg>
+  <msg key="view_item">Ver elemento</msg>
+</message_catalog>

catalog/xotcl-core.nl_ZA.ISO-8859-1.xml

+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" package_version="0.38" locale="nl_ZA" charset="ISO-8859-1">
+
+  <msg key="live_revision">Aktieve revisie</msg>
+  <msg key="revision_title">Revisies van lid</msg>
+  <msg key="revisions">Revisies</msg>
+</message_catalog>

catalog/xotcl-core.pt_BR.ISO-8859-1.xml

+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" locale="pt_BR" charset="ISO-8859-1">
+
+  <msg key="add">Adicionar %type%</msg>
+  <msg key="add_long">Adicionar novo item tipo %type%</msg>
+  <msg key="create_new_type">Criar novo %type%</msg>
+  <msg key="edit_item">Editar Item</msg>
+  <msg key="edit_type">Editar %type%</msg>
+  <msg key="has_entered_the_room">Entrou na sala</msg>
+  <msg key="live_revision">Reviso Ativa</msg>
+  <msg key="policy-error-insufficient_permissions">&lt;blockquote&gt;
+Voc no tem permisses suficientes para executar mtodo %method% sobre objeto %object%.
+&lt;/blockquote&gt;</msg>
+  <msg key="revision_title">Revises da Entrada</msg>
+  <msg key="revisions">Revises</msg>
+</message_catalog>

lib/revisions-postgresql.xql

+<?xml version="1.0"?>
+
+<queryset>
+  <rdbms><type>postgresql</type><version>7.1</version></rdbms>
+
+  <fullquery name="revisions_info">      
+    <querytext>
+    select  ci.name, n.revision_id as version_id,
+      person__name(n.creation_user) as author,
+      n.creation_user as author_id,
+      to_char(n.last_modified,'YYYY-MM-DD HH24:MI:SS') as last_modified_ansi,
+      n.description,
+      acs_permission__permission_p(n.revision_id,:user_id,'admin') as admin_p,
+      acs_permission__permission_p(n.revision_id,:user_id,'delete') as delete_p,
+      char_length(n.data) as content_size,
+      content_revision__get_number(n.revision_id) as version_number	
+    from cr_revisionsi n, cr_items ci
+    where ci.item_id = n.item_id and ci.item_id = :page_id
+          and exists (select 1 from acs_object_party_privilege_map m
+                      where m.object_id = n.revision_id
+                        and m.party_id = :user_id
+                        and m.privilege = 'read')
+	order by n.revision_id desc
+    </querytext>
+  </fullquery> 
+</queryset>
+
+

lib/revisions.adp

+<listtemplate name="revisions"></listtemplate>

lib/revisions.tcl

+ad_page_contract {
+  display information about revisions of content items
+
+  @author Gustaf Neumann (gustaf.neumann@wu-wien.ac.at)
+  @creation-date Oct 23, 2005
+  @cvs-id $Id$
+} {
+  page_id:integer,notnull
+  {name ""}
+} -properties {
+  name:onevalue
+  context:onevalue
+  page_id:onevalue
+  revisions:multirow
+  gc_comments:onevalue
+}
+
+# check they have read permission on content item
+permission::require_permission -object_id $page_id -privilege read
+
+set user_id [ad_conn user_id]
+set live_revision_id [content::item::get_live_revision -item_id $page_id]
+
+template::list::create \
+    -name revisions \
+    -no_data [_ file-storage.lt_There_are_no_versions] \
+    -multirow revisions \
+    -elements {
+      version_number {label "" html {align right}}
+      name { label ""
+	display_template {
+	  <img src='/resources/acs-subsite/Zoom16.gif' \
+	      title='View Item' alt='view' \
+	      width="16" height="16" border="0">
+	}
+	sub_class narrow
+	link_url_col version_link
+      }
+      author { label #file-storage.Author#
+	display_template {@revisions.author_link;noquote@}
+      }
+      content_size { label #file-storage.Size# html {align right}
+	display_col content_size_pretty
+      }
+      last_modified_ansi { label #file-storage.Last_Modified#
+	display_col last_modified_pretty
+      }
+      description { label #file-storage.Version_Notes#}
+      live_revision { label #xotcl-core.live_revision#
+	display_template {
+	  <a href='@revisions.live_revision_link@'> \
+	  <img src='@revisions.live_revision_icon@' \
+	      title='@revisions.live_revision@' alt='@revisions.live_revision@' \
+	      width="16" height="16" border="0"></a>
+	}
+	html {align center}
+	sub_class narrow
+      }
+      version_delete { label "" link_url_col version_delete_link
+	display_template {
+	  <img src='/resources/acs-subsite/Delete16.gif' \
+	      title='Delete Revision' alt='delete' \
+	      width="16" height="16" border="0">
+	}
+	html {align center}
+      }
+    }
+
+db_multirow -unclobber -extend { 
+  author_link last_modified_pretty 
+  content_size_pretty version_link version_delete version_delete_link 
+  live_revision live_revision_icon live_revision_link
+} revisions revisions_info {} {
+  set version_number $version_number:
+  set last_modified_ansi   [lc_time_system_to_conn $last_modified_ansi]
+  set last_modified_pretty [lc_time_fmt $last_modified_ansi "%x %X"]
+  if {$content_size < 1024} {
+    set content_size_pretty "[lc_numeric $content_size] [_ file-storage.bytes]"
+  } else {
+    set content_size_pretty "[lc_numeric [format %.2f [expr {$content_size/1024.0}]]] [_ file-storage.kb]"
+  }
+  
+  if {$name eq ""} {set name [_ file-storage.untitled]}
+  set live_revision_link [export_vars -base make-live-revision \
+			      {page_id name {revision_id $version_id}}]
+  set version_delete_link [export_vars -base delete-revision \
+			       {page_id name {revision_id $version_id}}]
+  set version_link [export_vars -base view {{revision_id $version_id} {item_id $page_id}}]
+  if {$version_id != $live_revision_id} {
+    set live_revision "Make this Revision Current"
+    set live_revision_icon /resources/acs-subsite/radio.gif
+  } else {
+    set live_revision "Current Live Revision"
+    set live_revision_icon /resources/acs-subsite/radiochecked.gif
+  }
+  set version_delete [_ file-storage.Delete_Version]
+  set author_link [acs_community_member_link -user_id $author_id -label $author]
+}
+

tcl/00-serializer-procs.tcl

+# $Id$
+if {![info exists ::xotcl::version]} {
+  ns_log notice "**********************************************************"
+  ns_log notice "OOPS, apparenty you have no XOTcl installed on your aolserver."
+  ns_log notice "Please install XOTcl on your system(see http://openacs.org/xowiki/xotcl-core)"
+  ns_log notice "**********************************************************"
+  return
+}
+if {$::xotcl::version < 1.5} {
+  ns_log notice "**********************************************************"
+  ns_log notice "This version of xotcl-core requires at least XOTcl 1.5.0."
+  ns_log notice "The installed version ($::xotcl::version$::xotcl::patchlevel appears to be older."
+  ns_log notice "Please updgrade to a new version (see http://openacs.org/xowiki/xotcl-core)"
+  ns_log notice "**********************************************************"
+}

tcl/04-library-procs.tcl

+ad_library {
+  XOTcl API for library file management (handling file-level dependencies)
+
+  @author Gustaf Neumann
+  @creation-date 2007-10-11
+  @cvs-id $Id$
+}
+
+#
+# Support for loading files of a package in a non-alphabetical order
+#
+# Usage:
+# Top of file:
+#
+#     ::xo::library doc {
+#         .....your comment goes here .... 
+#     }
+#
+# Load a required file:
+#
+#   Source a file, which is requred by the current file
+#   Filename is without path and .tcl
+#
+#     ::xo::library require filename
+#
+#   The library to be loaded must be defined with a 
+#   ::xo::library doc {...}
+#
+# Source files extending classes of the current file.
+#
+#    When classes are defined in the current file and (some) of their methods
+#    are defined in other files, one has to load the methods of the
+#    other files after the classes are recreated in the current file
+#    (recreation of classes deletes the old methods).
+#
+#     ::xo::library source_dependent
+#
+
+namespace eval ::xo {
+  Object library
+
+  library proc doc {comment} {
+    ad_library $comment
+    nsv_set [self]-loaded [info script] 1
+    #my log "--loaded nsv_set [self]-loaded [info script] 1"
+  }
+
+  library ad_proc require {{-package ""} filename} {
+
+    Use this method to indicate when some other files (from the same
+    package) are needed to be sourced before the current file.  This
+    method is useful in cases where the alphabetical loading order is
+    a problem.
+
+    A typical use-case is a file defining a subclass of another
+    class. In this case, the file defining the subclass will require
+    the definition of the base class.
+
+    @param filename filename without path and .tcl suffix
+  } {
+    #my log "--loaded nsv_set [self]-loaded [info script] 1"
+    nsv_set [self]-loaded [info script] 1
+    set myfile [file tail [info script]]
+    set dirname [file dirname [info script]]
+    if {$package eq ""} {
+      set otherfile $dirname/$filename.tcl
+    } else {
+      set otherfile [acs_root_dir]/packages/$package/tcl/$filename.tcl
+    }
+    set vn [self]
+    #my log "--exists otherfile $otherfile => [nsv_exists $vn $otherfile]"
+    if {[nsv_exists $vn $otherfile]} {
+      nsv_set $vn $otherfile [lsort -unique [concat [nsv_get $vn $otherfile] [info script]]]
+      #my log "--setting nsv_set $vn $otherfile [lsort -unique [concat [nsv_get $vn $otherfile] $myfile]]"
+    } else {
+      nsv_set $vn $otherfile [info script]
+      #my log "--setting nsv_set $vn $otherfile $myfile"
+    }
+    #my log "--source when not loaded [self]-loaded $otherfile: [nsv_exists [self]-loaded $otherfile]"
+    #my log "--loaded = [lsort [nsv_array names [self]-loaded]]"
+
+    if {![nsv_exists [self]-loaded $otherfile]} {
+      my log "--sourcing $otherfile"
+      apm_source $otherfile
+    }
+  }
+
+  library ad_proc source_dependent {} {
+    Source files extending classes of the current file.
+
+    When classes are defined in this file and (some) of their methods
+    are defined in other files, we have to load the methods of the
+    other files after the classes are recreated in this file
+    (recreation of classes deletes the old methods).
+
+    Use "::xo::library source_dependent" at the end of a file
+    when the classes are defined.
+
+  } {
+    set myfile [file tail [info script]]
+    set dirname [file dirname [info script]]
+    set vn [self]
+    #my log "--check nsv_exists $vn $dirname/$myfile [nsv_exists $vn $dirname/$myfile]"
+    if {[nsv_exists $vn $dirname/$myfile]} {
+      foreach file [nsv_get $vn $dirname/$myfile] {
+        #my log "--sourcing dependent $dirname/$file"
+        #apm_source $dirname/$file
+        #my log "--sourcing dependent $file"
+        apm_source $file
+      }
+    }
+  }
+}

tcl/10-recreation-procs.tcl

+ad_library {
+  Support for the recreation of classes objects without
+  destroying foreign references. Normally, when a class
+  definition is reloaded, the class is destroyed and created
+  again with the same name. During the destruction of a class
+  several references to this class are removed (e.g. in a
+  class hierarchy, the relation from instances to this class, etc.).
+  XOTcl provides support for altering this behavior through 
+  the recreate method.
+
+  @author Gustaf Neumann (neumann@wu-wien.ac.at)
+  @creation-date 2005-05-13
+  @cvs-id $Id$
+}
+
+if {![::xotcl::Object isclass ::xotcl::RecreationClass]} {
+  ::xotcl::Class create ::xotcl::RecreationClass -ad_doc {
+    <p>This meta-class controlls the behavior of classes (and optionally
+    their instances), when the classes (or their instances) are	
+    overwritten by same named new objects; we call this situation
+    a recreate of an object.</p>
+					     
+    <p>Normally, when files with e.g. class definitions are sourced,
+    the classes and objects are newly defined. When e.g. class 
+    definitions exists already in this file, these classes are 
+    deleted first before they are newly created. When a class is 
+    deleted, the instances of this class are changed into 
+    instances of class ::xotcl::Object. </p>
+
+    <p>This can be a problem when the class instances are not 
+    reloaded and when they should survife the redefintion with the
+    same class relationships. Therefore we define a 
+    meta class RecreationClass, which can be used to parameterize 
+    the behavior on redefinitions. Alternatively, Classes or objects
+    could provide their own recreate methods.</p>
+
+    <p>Per default, this meta-class handles only the class redefintion
+    case and does only a reconfigure on the class object (in order
+    to get e.g. ad_doc updated).</p>
+    The following parameters are defined:
+    <ul>
+    <li><b>reconfigure:</b> reconfigure class (default 1)
+    <li><b>reinit:</b> run init after configure for this class (default unset)
+    <li><b>instrecreate:</b> handle recreate of class instances (default unset)
+      When this flag is set to 0, instreconfigure and instreinit are ignored.
+    <li><b>instreconfigure:</b> reconfigure instances of this class (default 1)
+    <li><b>instreinit:</b> re-init instances of this class (default unset)
+    </ul>
+  } -parameter {
+    {reconfigure 1}
+    {reinit}
+    {instrecreate}
+    {instreconfigure 1}
+    {instreinit}
+  } -superclass ::xotcl::Class \
+      -instproc recreate {obj args} {
+	#my log "### recreateclass instproc $obj <$args>"
+	# the minimal reconfiguration is to set the class and remove methods
+	$obj class [self]
+	foreach p [$obj info procs] {$obj proc $p {} {}}
+	if {![my exists instrecreate]} {
+	  #my log "### no instrecreate for $obj <$args>"
+	  next
+	  return
+	}
+	if {[my exists instreconfigure]} {
+	  # before we set defaults, we must unset vars
+	  foreach var [$obj info vars] {$obj unset $var}
+	  # set defaults and run configure
+          $obj set_instance_vars_defaults
+	  eval $obj configure $args
+	  #my log "### instproc recreate $obj + configure $args ..."
+	}
+	if {[my exists instreinit]} {
+	  #my log "### instreinit for $obj <$args>"
+	  eval $obj init 
+	  #my log "### instproc recreate $obj + init ..."
+	}
+      } -proc recreate {obj args} {
+	#my log "### recreateclass proc $obj <$args>"
+	# the minimal reconfiguration is to set the class and remove methods
+	$obj class [self]
+	foreach p [$obj info instprocs] {$obj instproc $p {} {}}
+	if {[my exists reconfigure]} {
+	  # before we set defaults, we must unset vars
+	  foreach var [$obj info vars] {$obj unset $var}
+	  # set defaults and run configure
+          $obj set_instance_vars_defaults
+	  eval $obj configure $args
+	}
+	if {[my exists reinit]} {
+	  eval $obj init 
+	}
+      }
+
+  ::Serializer exportObjects {
+    ::xotcl::RecreationClass 
+  }
+}
+
+set version [package require XOTcl]
+if {[string match "1.3.*" $version]} {
+  Class ad_proc recreate {obj args} { 
+    The re-definition of recreate makes reloading of class definitions via 
+    apm possible, since the foreign keys of the class relations 
+    to these classes survive these calls. One can define specialized
+    versions of this for certain classes or use ::xotcl::RecreationClass.
+
+    Class proc recreate is called on the class level, while 
+    Class instproc recreate is called on the instance level.
+
+    @param obj name of the object to be recreated
+    @param args arguments passed to recreate (might contain parameters)
+  } {
+    # clean on the class level
+    #my log "proc recreate $obj $args"
+    foreach p [$obj info instprocs] {$obj instproc $p {} {}}
+    $obj instmixin set {}
+    $obj instfilter set {}
+    next ; # clean next on object level
+  }
+  Class ad_instproc recreate {obj args} { 
+    The re-definition of recreate makes reloading of class definitions via 
+    apm possible, since the foreign keys of the class relations 
+    to these classes survive these calls. One can define specialized
+    versions of this for certain classes or use ::xotcl::RecreationClass.
+
+    Class proc recreate is called on the class level, while 
+    Class instproc recreate is called on the instance level.
+
+    @param obj name of the object to be recreated
+    @param args arguments passed to recreate (might contain parameters)
+  } {
+    # clean on the object level
+    #my log "+++ instproc recreate $obj <$args> old class = [$obj info class], new class = [self]"
+    $obj filter set {}
+    $obj mixin set {}
+    set cl [self] 
+    foreach p [$obj info commands] {$obj proc $p {} {}}
+    foreach c [$obj info children] {
+      my log "recreate destroy <$c destroy"
+      $c destroy
+    }
+    foreach var [$obj info vars] {
+      $obj unset $var
+    }
+    # set p new values
+    $obj class $cl 
+    $obj set_instance_vars_defaults
+
+    # we use uplevel to handle -volatile correctly
+    set pos [my uplevel $obj configure $args]
+    if {[lsearch -exact $args -init] == -1} {
+      incr pos -1
+      eval $obj init [lrange $args 0 $pos]
+    }
+  }
+
+  #::xotcl::Object instforward unset -objscope 
+  #  ::xotcl::Object instforward unset
+  ::Serializer exportMethods {
+    ::xotcl::Class instproc recreate
+    ::xotcl::Class proc recreate
+    ::xotcl::Object instforward unset
+  }
+} else {
+  ns_log notice "-- softrecreate"
+  ::xotcl::configure softrecreate true
+
+  Class RR -instproc recreate args { 
+    my log "-- [self args]"; next
+  } -instproc create args { 
+    my log "-- [self args]"; next
+  }
+  #::xotcl::Class instmixin RR
+}
\ No newline at end of file

tcl/20-Ordered-Composite-procs.tcl

+ad_library {
+  ::xo::OrderedComposite to create tree structures with aggregated
+  objects. This is similar to object aggregations, but
+  preserves the order. The OrderedComposite supports
+  hierarchical sorting.
+
+  @author Gustaf Neumann (neumann@wu-wien.ac.at)
+  @creation-date 2005-11-26
+  @cvs-id $Id$
+}
+
+namespace eval ::xo {
+  Class OrderedComposite 
+
+  OrderedComposite instproc show {} {
+    next
+    foreach child [my children] {
+      $child show
+    }
+  }
+
+  OrderedComposite instproc orderby {{-order "increasing"} variable} {
+    my set __order $order
+    my set __orderby $variable
+  }
+
+  OrderedComposite instproc __compare {a b} {
+    set by [my set __orderby]
+    set x [$a set $by]
+    set y [$b set $by]
+    if {$x < $y} {
+      return -1
+    } elseif {$x > $y} {
+      return 1
+    } else {
+      return 0
+    }
+  }
+
+  OrderedComposite instproc children {} {
+    set children [expr {[my exists __children] ? [my set __children] : ""}]
+    if {[my exists __orderby]} {
+      set order [expr {[my exists __order] ? [my set __order] : "increasing"}]
+      return [lsort -command [list my __compare] -$order $children]
+    } else {
+      return $children
+    }
+  }
+  OrderedComposite instproc add obj {
+    my lappend __children $obj
+    $obj set __parent [self]
+    #my log "-- adding __parent [self] to $obj -- calling after_insert"
+    #$obj __after_insert
+  }
+  OrderedComposite instproc delete obj {
+    my instvar __children
+    set p [lsearch -exact $__children $obj]
+    if {$p == -1} {error "can't delete '$obj' from $__children"}
+    set __children [lreplace $__children $p $p]
+    $obj destroy
+  }
+  
+  OrderedComposite instproc last_child {} {
+    lindex [my set __children] end
+  }
+
+  OrderedComposite instproc destroy {} {
+    # destroy all children of the ordered composite
+    if {[my exists __children]} {
+      #my log "--W destroying children [my set __children]"
+      foreach c [my set __children] { 
+	if {[my isobject $c]} {$c destroy}
+      }
+    }
+    #show_stack;my log "--W children murdered, now next, chlds=[my info children]"
+    #namespace eval [self] {namespace forget *}  ;# for pre 1.4.0 versions
+    next
+  }
+
+  OrderedComposite instproc contains cmds {
+    my requireNamespace ;# legacy for older xotcl versions
+    set m [Object info instmixin]
+    if {[lsearch $m [self class]::ChildManager] == -1} {
+      set insert 1
+      Object instmixin add [self class]::ChildManager
+    } else { 
+      set insert 0
+    }
+    set errorOccurred [catch {namespace eval [self] $cmds} errorMsg]
+    if {$insert} {
+      Object instmixin delete [self class]::ChildManager
+    }
+    if {$errorOccurred} {error $errorMsg}
+  }
+  Class OrderedComposite::ChildManager -instproc init args {
+    set r [next]
+    set parent [self callingobject] ;# not a true calling object (ns-eval), but XOTcl 1 honors it
+    #set parent [my info parent] ;# is ok in XOTcl 2, since the namespace is honored correctly
+    #set parent [uplevel 2 self] ;# should work everywhere
+    #puts stderr "-- CONTAINS p=$parent, co=[self callingobject] n=[uplevel 2 self]"
+    $parent lappend __children [self]
+    my set __parent $parent
+    #my __after_insert
+    #my log "-- adding __parent  $parent to [self]"
+    return $r
+  }
+
+  Class OrderedComposite::Child -instproc __after_insert {} {;}
+
+  Class OrderedComposite::IndexCompare
+  OrderedComposite::IndexCompare instproc __compare {a b} {
+    set by [my set __orderby]
+    set x [$a set $by]
+    set y [$b set $by]
+    #my log "--value compare  $x $y] => [my __value_compare $x $y 0]"
+    return [my __value_compare $x $y 0]
+  }
+  OrderedComposite::IndexCompare instproc __value_compare {x y def} {
+    set xp [string first . $x]
+    set yp [string first . $y]
+    if {$xp == -1 && $yp == -1} {
+      if {$x < $y} {
+	return -1
+      } elseif {$x > $y} {
+	return 1
+      } else {
+	return $def
+      }
+    } elseif {$xp == -1} {
+      set yh [string range $y 0 [expr {$yp-1}]]
+      return [my __value_compare $x $yh -1]
+    } elseif {$yp == -1} {
+      set xh [string range $x 0 [expr {$xp-1}]]
+      return [my __value_compare $xh $y 1]
+    } else {
+      set xh [string range $x 0 $xp]
+      set yh [string range $y 0 $yp]
+      #puts "xh=$xh yh=$yh"
+      if {$xh < $yh} {
+	return -1
+      } elseif {$xh > $yh} {
+	return 1
+      } else {
+	incr xp 
+	incr yp
+	#puts "rest [string range $x $xp end] [string range $y $yp end]"
+	return [my __value_compare [string range $x $xp end] [string range $y $yp end] $def]
+      }
+    }
+  }
+
+  Class OrderedComposite::MethodCompare
+  OrderedComposite::MethodCompare instproc __compare {a b} {
+    set by [my set __orderby]
+    set x [$a $by]
+    set y [$b $by]
+    if {$x < $y} {
+      return -1
+    } elseif {$x > $y} {
+      return 1
+    } else {
+      return 0
+    }
+  }
+}
+

tcl/40-thread-mod-procs.tcl

+ad_library {
+  Tcl API for Thread management provides some support for threads
+   under the AOL-server and XOTcl. It contains
+   essentially two classes THREAD and Proxy.
+  <p>
+   The class THREAD is used to create, initialize
+   and destroy threads and to pass commands to these 
+   threads. It is designed in a way to create threads
+   lazyly such that thread definitions can be included
+   in the modules directory of the aolserver and 
+   therefore be part of the aolserver blueprints.
+   When an instance of THREAD is created (e.g. t1), 
+   an init-command is provided. e.g.:
+  <pre>
+    ::xotcl::THREAD create t1 {
+      Class Counter -parameter {{value 1}}
+      Counter instproc ++ {} {my incr value}
+      Counter c1
+      Counter c2
+    }
+  </pre>
+   Commands are sent to the thread via the
+   "do" method, which returns the result of the
+   command evaluated in the specified thread. 
+   When the first command is sent to a 
+   non-initialized thread, such as
+  <pre>
+    set x [t1 do c1 ++]
+  </pre> 
+   the actual thread is created and the thread 
+   ID is remembered in a tsv array. When a
+   THREAD object is destroyed, the associated
+   thread is terminated as well. 
+  
+   Notice that according to the aol-server behavior it
+   is possible to create **persistent threads**
+   (when the thread object is created during
+   startup and provided to all request threads
+   through the blueprint, or to create **volatile
+   threads** that are created during a request
+   and which are deleted when the thread cleanup
+   is called after some timeout. Volatile threads can 
+   shared as well (when different request-threads
+   create the same-named thread objects) and can 
+   be used for caching proposes. Flushing the cache
+   can be done in the thread's exitHandler.
+  
+   The Proxy class can be used to simplify
+   the interaction with a thread and to 
+   hide the fact, that certain classes/objects
+   are part of a thread. The following command
+   creates a Proxy for an object c1 in thread t1.
+   After this, c1 can be used like an local object.
+  <pre>
+    ::xotcl::THREAD::Proxy c1 -attach t1
+    set x [c1 ++]
+  </pre>
+  The Proxy forwards all commands to the 
+  attached thread except the methods attatch, filter, 
+  detachAll and destroy. The attach method can be used 
+  to reattach a proxy instance to a different thread, such as 
+  <pre>  
+    c1 attach t2
+  </pre>
+   A proxy can be (temporarily) detachted from a thread via
+  <pre>
+    c1 filter ""
+  </pre>
+  Later forwarding to the thread can be re-enabled via 
+  <pre>
+    c1 filter forward
+  </pre>
+  When a proxy is attached to a thread and 
+  receives a destroy command, both the proxy
+  and the corresponding object in the thread 
+  are deleted. If only the proxy object is to be
+  destroyed, the proxy must be detachted at first.
+  The class method detatchAll is provided to detach 
+  all proxies from their objects.
+
+  @author Gustaf Neumann
+  @creation-date 2005-05-13
+  @cvs-id $Id$
+}
+
+::xotcl::Object setExitHandler {
+  #my log "EXITHANDLER of request thread [pid]"
+  #if {[catch {::xotcl::THREAD::Proxy detachAll} m]} {
+  #  #my log "EXITHANDLER error in detachAll $m"
+  #}
+}
+
+::Serializer exportObjects {
+  ::xotcl::THREAD
+  ::xotcl::THREAD::Client
+  ::xotcl::THREAD::Proxy
+}
+
+################## main thread support ##################
+Class create ::xotcl::THREAD \
+    -parameter {{persistent 0} {lightweight 0}}
+
+::xotcl::THREAD instproc check_blueprint {} {
+  if {![[self class] exists __blueprint_checked]} {
+    if {[string first ::xotcl::THREAD [ns_ictl get]] == -1} {
+      _ns_savenamespaces
+    }
+    [self class] set __blueprint_checked 1
+  }
+}
+
+::xotcl::THREAD instproc init cmd {
+  if {$cmd eq "-noinit"} {return}
+  my instvar initcmd 
+  #ns_log notice "+++ THREAD cmd='$cmd', epoch=[ns_ictl epoch]"
+  if {![ns_ictl epoch]} {
+    #ns_log notice "--THREAD init [self] no epoch"
+
+    # We are during initialization. For some unknown reasons, XOTcl 
+    # is not available in newly created threads, so we have to care for it.
+    # We need only a partial initialization, to allow the exit handler 
+    # to be defined.
+    set initcmd {
+      package req XOTcl
+      namespace import -force ::xotcl::*
+    }
+  }
+  append initcmd {
+    ns_thread name SELF
+    ::xotcl::Object setExitHandler {
+      #my log "EXITHANDLER of slave thread SELF [pid]"
+    }
+  }
+  regsub -all SELF $initcmd [self] initcmd
+  append initcmd \n\
+      [list set ::xotcl::currentScript [info script]] \n\
+      [list set ::xotcl::currentThread [self]] \n\
+      $cmd 
+  my set mutex [thread::mutex create]
+  ns_log notice "mutex [my set mutex] created"
+  next
+}
+
+::xotcl::THREAD ad_proc -private recreate {obj args} {
+  this method catches recreation of THREADs in worker threads 
+  it reinitializes the thread according to the new definition.
+} {
+  my log "recreating [self] $obj, tid [$obj exists tid]"
+  if {![string match "::*" $obj]} { set obj ::$obj }
+  $obj set recreate 1
+  next
+  $obj init [lindex $args 0]
+  if {[nsv_exists [self] $obj]} {
+    set tid [nsv_get [self] $obj]
+    ::thread::send $tid [$obj set initcmd]
+    $obj set tid $tid
+    my log "+++ content of thread $obj ($tid) redefined"
+  }
+}
+
+::xotcl::THREAD instproc destroy {} {
+  my log "destroy called"
+  if {![my persistent] && 
+      [nsv_exists [self class] [self]]} {
+    set tid [nsv_get [self class] [self]]
+    set refcount [::thread::release $tid]
+    my log "destroying thread object tid=$tid cnt=$refcount"
+    if {$refcount == 0} {
+      my log "thread terminated"
+      nsv_unset [self class] [self]
+      thread::mutex destroy [my set mutex]
+      my log "+++ mutex [my set mutex] destroyed"
+    }
+  }
+  next
+}
+
+::xotcl::THREAD instproc get_tid {} {
+  if {[nsv_exists [self class] [self]]} {
+    # the thread was already started
+    return [nsv_get [self class] [self]]
+  }
+  # start a small command in the thread
+  my do info exists x
+  # now we have the thread and can return the tid
+  return [my set tid]
+}
+
+::xotcl::THREAD instproc do {-async:switch args} {
+  if {![nsv_exists [self class] [self]]} {
+    # lazy creation of a new slave thread
+
+    thread::mutex lock [my set mutex]
+    #my check_blueprint
+    #my log "after lock"
+    if {![nsv_exists [self class] [self]]} {
+      if {[my lightweight]} {
+        my log "CREATE lightweight thread"
+        set tid [::thread::create -thin]
+      } else {
+        set tid [::thread::create]
+      }
+      nsv_set [self class] [self] $tid
+      if {[my persistent]} {
+	my log "--created new persistent [self class] as $tid pid=[pid]"
+      } else {
+	my log "--created new [self class] as $tid pid=[pid]"
+      }
+      #my log "--THREAD DO send [self] epoch = [ns_ictl epoch]"
+      if {[my lightweight]} {
+      } elseif {![ns_ictl epoch]} {
+	#ns_log notice "--THREAD send [self] no epoch"
+	# We are during initialization. For some unknown reasons, XOTcl 
+	# is not available in newly created threads, so we have to care 
+	# for full initialization, including xotcl blueprint.
+	_ns_savenamespaces
+	set initcmd [ns_ictl get]
+      }
+      append initcmd [my set initcmd]
+      #ns_log notice "INIT $initcmd"
+      ::thread::send $tid $initcmd
+    } else {
+      set tid [nsv_get [self class] [self]]
+    }
+    #my log "doing unlock"
+    thread::mutex unlock [my set mutex]
+  } else {
+    # target thread is already up and running
+    set tid [nsv_get [self class] [self]]
+  }
+  if {![my exists tid]} {
+    # this is the first call 
+    if {![my persistent] && ![my exists recreate]} {
+      # for a shared thread, we do ref-counting through preseve
+      my log "must preserve for sharing request-thread [pid]"
+      set tid [nsv_get [self class] [self]]
+      ::thread::preserve $tid
+    }
+    my set tid $tid
+  }
+  #my log "calling [self class] ($tid, [pid]) $args"
+  if {$async} {
+    return [thread::send -async $tid $args]
+  } else {
+    return [thread::send $tid $args]
+  }
+}
+
+# create a sample persistent thread that can be acessed 
+# via request threads
+#::xotcl::THREAD create t0 {
+#  Class Counter -parameter {{value 1}}
+#  Counter instproc ++ {} {my incr value}
+#  
+#  Counter c1
+#  Counter c2
+#} -persistent 1
+#
+
+################## forwarding  proxy ##################
+# Class ::xotcl::THREAD::Proxy -parameter {attach} 
+# ::xotcl::THREAD::Proxy configure \
+#     -instproc forward args {
+#       set cp [self calledproc]
+#       if { [string equal $cp "attach"] 
+# 	   || $cp eq "filter" 
+# 	   || $cp eq "detachAll"} {
+# 	next
+#       } elseif {$cp eq "destroy"} {
+# 	eval [my attach] do [self] $cp $args
+# 	my log "destroy"
+# 	next
+#       } else {
+# 	my log "forwarding [my attach] do [self] $cp $args"
+# 	eval [my attach] do [self] $cp $args
+#       }
+#     } -instproc init args {
+#       my filter forward
+#     } -proc detachAll {} {
+#       foreach i [my info instances] {$i filter ""}
+#     }
+
+
+# sample Thread client routine, calls a same named object in the server thread
+# a thread client should be created in an connection thread dynamically to 
+# avoid name clashes in the blueprint.
+ 
+Class create ::xotcl::THREAD::Client -parameter {server {serverobj [self]}}
+::xotcl::THREAD::Client instproc do args {
+  eval [my server] do [my serverobj] $args
+}
+

tcl/50-protocol-handler-procs.tcl

+namespace eval ::xo {
+  Class create ProtocolHandler -parameter {
+    {url}
+    {package}
+  }
+
+  ProtocolHandler ad_instproc unknown {method args} {
+    Return connection information similar to ad_conn
+  } {
+    my log "--[self class] unknown called with '$method' <$args>"
+    switch -- [llength $args] {
+      0 {if {[my exists $method]} {return [my set method]}
+        return [ad_conn $method]
+      }
+      1 {my set method $args}
+      default {my log "--[self class] ignoring <$method> <$args>"}
+    }
+  }
+
+  ProtocolHandler ad_instproc set_user_id {} {
+    Set user_id based on authentication header
+  } {
+    set ah [ns_set get [ns_conn headers] Authorization]
+    if {$ah ne ""} {
+      # should be something like "Basic 29234k3j49a"
+      my debug "auth_check authentication info $ah"
+      # get the second bit, the base64 encoded bit
+      set up [lindex [split $ah " "] 1]
+      # after decoding, it should be user:password; get the username
+      set user [lindex [split [ns_uudecode $up] ":"] 0]
+      set password [lindex [split [ns_uudecode $up] ":"] 1]
+      array set auth [auth::authenticate \
+                          -username $user \
+                          -authority_id [::auth::get_register_authority] \
+                          -password $password]
+      my debug "auth $user $password returned [array get auth]"
+      if {$auth(auth_status) ne "ok"} {
+        array set auth [auth::authenticate \
+                            -email $user \
+                            -password $password]
+        if {$auth(auth_status) ne "ok"} {
+          my debug "auth status $auth(auth_status)"
+          ns_returnunauthorized
+          my set user_id 0
+          return 0
+        }
+      }
+      my debug "auth_check user_id='$auth(user_id)'"
+      ad_conn -set user_id $auth(user_id)
+      
+    } else {
+      # no authenticate header, anonymous visitor
+      ad_conn -set user_id 0
+      ad_conn -set untrusted_user_id 0
+    }
+    my set user_id [ad_conn user_id]
+  }
+
+  ProtocolHandler ad_instproc initialize {} {
+    Setup connection object and authenticate user
+  } {
+    my instvar uri method urlv destination
+    ad_conn -reset
+    set uri [ns_urldecode [ns_conn url]]
+    set url_regexp "^[my url]"
+    #my log "--conn_setup: uri '$uri' my url='[my url]' con='[ns_conn url]'"
+    regsub $url_regexp $uri {} uri
+    if {![regexp {^[./]} $uri]} {set uri /$uri}
+    my set_user_id
+
+    set method [string toupper [ns_conn method]]
+    #my log "--conn_setup: uri '$uri' method $method"
+    set urlv [split [string trimright $uri "/"] "/"]
+    set destination [ns_urldecode [ns_set iget [ns_conn headers] Destination]]
+    if {$destination ne ""} {
+      regsub {https?://[^/]+/} $destination {/} dest
+      regsub $url_regexp $dest {} destination
+      if {![regexp {^[./]} $destination]} {set destination /$destination}
+    }
+    #my log "--conn_setup: method $method destination '$destination' uri '$uri'"
+  }
+
+  ProtocolHandler ad_instproc preauth { args } {
+    Handle authorization. This method is called via ns_filter.
+  } {
+    #my log "--preauth args=<$args>"
+    my instvar user_id 
+    
+    # Restrict to SSL if required
+    if { [security::RestrictLoginToSSLP]  && ![security::secure_conn_p] } {
+      ns_returnunauthorized
+      return filter_return
+    }
+  
+    # set common data for all kind of requests 
+    my initialize
+
+    # for now, require for every user authentification
+    if {$user_id == 0} {
+      ns_returnunauthorized
+      return filter_return
+    }
+    
+    #my log "--preauth filter_ok"
+    return filter_ok    
+  }
+
+  ProtocolHandler ad_instproc register { } {
+    Register the the aolserver filter and traces.
+    This method is typically called via *-init.tcl.
+
+    Note, that the specified url must not have an entry
+    in the site-nodes, otherwise the openacs request 
+    processor performs always the cockie-based authorization.
+
+    To change that, it would be necessary to register the
+    filter before the request processor (currently, there
+    are no hooks for that).
+  } {
+    set filter_url [my url]*
+    set url [my url]/*
+    foreach method {
+      GET HEAD PUT POST MKCOL COPY MOVE PROPFIND PROPPATCH
+      DELETE LOCK UNLOCK OPTIONS
+    } {
+      ns_register_filter preauth $method $filter_url  [self]
+      ns_register_proc $method $url [self] handle_request
+      #my log "--ns_register_filter preauth $method $filter_url  [self]"
+      #my log "--ns_register_proc $method $url [self] handle_request"
+    }
+  }
+
+  ProtocolHandler ad_instproc get_package_id {} {
+    Initialize the given package and return the package_id
+    @return package_id 
+  } {
+    my instvar uri package
+    $package initialize -url $uri
+    #my log "--[my package] initialize -url $uri"
+    return $package_id
+  }
+
+  ProtocolHandler ad_instproc handle_request { args } {
+    Process the incoming HTTP request. This method
+    could be overloaded by the application and
+    dispatches the HTTP requests.
+  } {
+    my instvar uri method user_id
+  
+    #my log "--handle_request method=$method uri=$uri\
+    # 	userid=$user_id -ns_conn query '[ns_conn query]'"
+    if {[my exists package]} {
+      my set package_id [my get_package_id]
+    }
+    if {[my procsearch $method] ne ""} {
+      my $method
+    } else {
+      ns_return 404 text/plain "not implemented"
+    }
+  }
+
+  #
+  # Some dummy HTTP methods
+  #
+  ProtocolHandler instproc GET {} {
+    my log "--GET method"
+    ns_return 200 text/plain GET-[my uri]
+  }
+  ProtocolHandler instproc PUT {} {
+    my log "--PUT method [ns_conn content]"
+    ns_return 201 text/plain "received put with content-length [string length [ns_conn content]]"
+  }
+  ProtocolHandler instproc PROPFIND {} {
+    my log "--PROPFIND [ns_conn content]"
+    ns_return 204 text/xml {<?xml version="1.0" encoding="utf-8" ?>}
+  }
+}
\ No newline at end of file

tcl/cluster-init.tcl

+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 [parameter::get -package_id [ad_acs_kernel_id] -parameter ClusterAuthorizedIP] {
+    if {[string first * $ip] > -1} {
+      ::xo::Cluster lappend allowed_host_patterns $ip
+    } else {
+      ::xo::Cluster set allowed_host($ip) 1
+    }
+  }
+  
+  set url [::xo::Cluster set url]
+
+  # Check, if the filter url mirrors a site node. If so,
+  # the cluster mechanism will not work, if the site node
+  # requires a login. Clustering will only work if the
+  # root node is freely accessible.
+
+  array set node [site_node::get -url $url] 
+  if {$node(url) ne "/"} {
+    ns_log notice "***\n*** WARNING: there appears a package mounted on\
+	$url\n***Cluster configuration will not work\
+	since there is a conflict with the aolserver filter with the same name!\n"
+  }
+  
+  #ns_register_filter trace GET $url ::xo::Cluster
+  ns_register_filter preauth GET $url ::xo::Cluster 
+  #ad_register_filter -priority 900 preauth GET $url ::xo::Cluster
+}

tcl/cluster-procs.tcl

+ad_library {
+  XOTcl cluster support
+
+  @author Gustaf Neumann
+  @creation-date 2007-07-19
+  @cvs-id $Id$
+}
+
+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
+  }
+
+  proc cache_flush_all {cache pattern} {
+    # Provide means to perform a wildcard-based cache flushing on
+    # (cluster) machines.
+    foreach n [ns_cache names $cache $pattern] {ns_cache flush $cache $n}
+  }
+
+  Class Cluster -parameter {host {port 80}}
+  Cluster set allowed_host_patterns [list]
+  Cluster set url /xotcl-cluster-do 
+  Cluster array set allowed_host {
+    "127.0.0.1" 1
+  }
+  # 
+  # The allowed commands are of the form 
+  #   - command names followed by 
+  #   - optional "except patterns"
+  #
+  Cluster array set allowed_command {
+    set "" 
+    unset "" 
+    nsv_set "" 
+    nsv_unset ""
+    nsv_incr ""
+    bgdelivery ""
+    ns_cache "^ns_cache\s+eval"
+    xo::cache_flush_all ""
+  }
+  #
+  # 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 [Cluster set url]?cmd=[ns_urlencode $args]]
+#     return [$r set data]
+
+    set r [::xo::AsyncHttpRequest new -volatile \
+	       -host [my host] -port [my port] \
+	       -path [Cluster set url]?cmd=[ns_urlencode $args]]
+  
+#     ::bgdelivery do ::xo::AsyncHttpRequest new \
+# 	-host [my host] -port [my port] \
+#         -path [Cluster set url]?cmd=[ns_urlencode $args] \
+# 	-mixin ::xo::AsyncHttpRequest::SimpleListener \
+# 	-proc finalize {obj status value} { my destroy }
+
+  }
+}
\ No newline at end of file

tcl/install-check-procs.tcl

+namespace eval ::xotcl-core {
+
+  ad_proc ::xotcl-core::before_install_callback {} {
+  
+    Callback for checking whether xotcl is installed for OpenACS
+    
+    @author Gustaf Neumann (neumann@wu-wien.ac.at)
+  } {
+    ns_log notice "-- before-install callback"
+    if {[info command ::xotcl::Class] eq ""} {
+      error " XOTcl does not appear to be installed on your system!\n\
+     Please follow the install instructions on http://www.openacs.org/xowiki/xotcl-core"
+    } elseif {$::xotcl::version < 1.5} {
+      error " XOTcl 1.5 or newer required. You are using $::xotcl::version$::xotcl::patchlevel.\n\
+	Please install a new version of XOTcl (see http://www.openacs.org/xowiki/xotcl-core)"
+    } else {
+      ns_log notice "XOTcl $::xotcl::version$::xotcl::patchlevel is installed on your system."
+    }
+  }
+  
+  ad_proc ::xotcl-core::after_upgrade_callback {
+    {-from_version_name:required}
+    {-to_version_name:required}
+  } {
+    
+    Callback for upgrading
+    
+    @author Gustaf Neumann (neumann@wu-wien.ac.at)
+  } {
+    ns_log notice "-- UPGRADE $from_version_name -> $to_version_name"
+    set v 0.88
+    if {[apm_version_names_compare $from_version_name $v] == -1 &&
+        [apm_version_names_compare $to_version_name $v] > -1} {
+      ns_log notice "-- upgrading to $v"
+      set dir [acs_package_root_dir xotcl-core]
+      foreach file {
+        tcl/05-doc-procs.tcl 
+        tcl/10-recreation-procs.tcl-old
+        tcl/thread_mod-procs.tcl 
+      } {
+        if {[file exists $dir/$file]} {
+          ns_log notice "Deleting obsolete file $dir/$file"
+          file delete $dir/$file
+        }
+      }
+    }
+  }
+
+}
\ No newline at end of file

tcl/object-cache-init.tcl

+# The following two commands to setup the cache were moved to
+# generic-procs due to problems with install.xml
+#
+#
+# ns_cache create xotcl_object_cache -size 200000
+# ns_cache create xotcl_object_type_cache -size 10000
+
+#ns_cache create xotcl_object_cache -size 200000
+#ns_cache create xotcl_object_type_cache -size 10000
+
+# should provide parameter at some time...
+
+#    [parameter::get -package_id [ad_acs_kernel_id] -parameter MaxSize -default 200000]
+