Index: openacs-4/packages/xotcl-core/COPYRIGHT =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/COPYRIGHT,v diff -u -N -r1.1 -r1.2 --- openacs-4/packages/xotcl-core/COPYRIGHT 30 Dec 2005 00:04:44 -0000 1.1 +++ openacs-4/packages/xotcl-core/COPYRIGHT 26 Jun 2018 10:24:24 -0000 1.2 @@ -1,23 +1,24 @@ - * 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. - * +# +# xotcl-core +# +# Copyright (C) 2005-2018 Gustaf Neumann, neumann@wu-wien.ac.at +# +# Vienna University of Economics and Business +# Institute of Information Systems and New Media +# A-1020, Welthandelsplatz 1 +# 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. +# Index: openacs-4/packages/xotcl-core/xotcl-core.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v diff -u -N -r1.101 -r1.102 --- openacs-4/packages/xotcl-core/xotcl-core.info 22 Jun 2018 20:11:55 -0000 1.101 +++ openacs-4/packages/xotcl-core/xotcl-core.info 26 Jun 2018 10:24:24 -0000 1.102 @@ -10,7 +10,7 @@ t xotcl - + Gustaf Neumann XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes) 2017-08-06 @@ -43,12 +43,12 @@ BSD-Style 2 - + - + Index: openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl,v diff -u -N -r1.132 -r1.133 --- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 25 Jun 2018 17:20:48 -0000 1.132 +++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 26 Jun 2018 10:24:24 -0000 1.133 @@ -722,173 +722,6 @@ ########################################################################## # - # Generic Cache class - # - ########################################################################## - - nx::Class create ::xo::Cache { - # - # Provide a simple class to generalize cache management to extend - # cache primitiva (in the future, e.g. for cache partitioning). - # - :property parameter:required - :property package_key:required - :property maxentry:integer - :property {default_size:integer 10000} - - :method cache_name {key} { - # - # More or less dummy function, can be refined, completely - # ignores "key". - # - return ${:name} - } - - :method get_size {} { - # - # Determine the cache size depending on configuration variables. - # - return [::parameter::get_from_package_key \ - -package_key ${:package_key} \ - -parameter "${:parameter}Size" \ - -default ${:default_size}] - } - - :public method flush {{-tree_key} key} { - if {![info exists tree_key]} {set tree_key $key} - ::xo::clusterwide ns_cache flush [:cache_name $tree_key] $key - } - - if {[info commands ns_cache_eval] ne ""} { - # - # NaviServer variant - # - :public method eval {{-tree_key} key body} { - if {![info exists tree_key]} {set tree_key $key} - try { - :uplevel [list ns_cache_eval -- [:cache_name $tree_key] $key $body] - } on break {r} { - #ns_log notice "====================== [self] $key -> break -> <$r>" - return 0 - } on ok {r} { - return $r - } - } - :public method set {key value} { - if {![info exists tree_key]} {set tree_key $key} - :uplevel [list ns_cache_eval -force -- [:cache_name $tree_key] $key [list set _ $value]] - } - :public method flush_pattern {{-tree_key ""} pattern} { - return [ns_cache_flush -glob [:cache_name $tree_key] $pattern] - } - :method cache_create {name size} { - ns_cache_create \ - {*}[expr {[info exists :maxentry] ? "-maxentry ${:maxentry}" : ""}] \ - $name $size - } - - } else { - # - # AOLserver variant - # - :public method eval {{-tree_key} key body} { - if {![info exists tree_key]} {set tree_key $key} - try { - :uplevel [list ns_cache eval [:cache_name $tree_key] $key $body] - } on break {r} { - return 0 - } on ok {r} { - return $r - } - } - :public method set {{-tree_key} key value} { - if {![info exists tree_key]} {set tree_key $key} - :uplevel [list ns_cache set [:cache_name $tree_key] $key $value] - } - :public method flush_pattern {{-tree_key ""} pattern} { - foreach name [ns_cache names [:cache_name $tree_key] $pattern] { - :flush -tree_key $tree_key $name - } - } - :method cache_create {name size} { - ns_cache create $name -size $size - } - } - - :public method init {} { - set :name [namespace tail [current]] - :cache_create ${:name} [:get_size] - } - } - - ########################################################################## - # - # Simple Partitioned Cache class - # - # Partitioning is based on a modulo function based on the key, which - # has to be numeric. So far, no partitioning-spanning methods are - # provided. - # - ########################################################################## - - nx::Class create ::xo::PartitionedCache -superclasses ::xo::Cache { - :property {partitions:integer 1} - - :protected method cache_name {key:integer} { - return ${:name}-[expr {$key % ${:partitions}}] - } - - :public method init {} { - set :name [namespace tail [current]] - set partitions [::parameter::get_from_package_key \ - -package_key ${:package_key} \ - -parameter "${:parameter}Partitions" \ - -default ${:partitions}] - # - # Create multiple separate caches depending on the - # partitions. This requires to have a partitioning function that - # determines the partition number from the key. - # - set size [expr {[:get_size] / ${:partitions}}] - for {set i 0} {$i < ${:partitions}} {incr i} { - :cache_create ${:name}-$i $size - } - } - } - - - ########################################################################## - # - # Tree Partitioned Cache class - # - # Tree Partitioning is based on a modulo function using a special - # tree_key, which has to be numeric. So far, no - # partitioning-spanning methods are provided. - # - ########################################################################## - - nx::Class create ::xo::TreePartitionedCache -superclasses ::xo::PartitionedCache { - :property {partitions:integer 1} - - :public method flush_pattern {{-tree_key:integer,required} pattern} { - # - # flush just in the determined partition - # - next - } - - :public method flush {{-tree_key:integer,required} key} { - next - } - - :public method set {{-tree_key:integer,required} key value} { - next - } - } - - - ########################################################################## - # # The ns_caches below should exist, before any cached objects are # created. Under most conditions, it is sufficient to do this in # object-cache-init.tcl, which is performed after xotcl-core procs @@ -897,8 +730,7 @@ # xotcl-core are not executed (probably a bug). Without the # ns_cache, creating objects fails with an error. So, we moved the # cache creation here and create caches, when they do not exist - # already. This change makes the object-cache-init.tcl - # obsolete. + # already. # # Unfortunately, AOLserver's ns_cache has no command to check, whether # a cache exists, so we use the little catch below to check. @@ -908,28 +740,31 @@ } on error {errorMsg} { ns_log notice "xotcl-core: creating xotcl-object caches" - ::xo::PartitionedCache create ::xo::xotcl_object_cache \ + ::acs::PartitionedCache create ::xo::xotcl_object_cache \ -maxentry 200000 \ -package_key xotcl-core \ -parameter XOTclObjectCache \ -default_size 400000 \ -partitions 2 ns_log notice "... created ::xo::xotcl_object_cache" - ::xo::TreePartitionedCache create ::xo::xotcl_object_type_cache \ + ::acs::TreePartitionedCache create ::xo::xotcl_object_type_cache \ -package_key xotcl-core \ -parameter XOTclObjectTypeCache \ -default_size 50000 ns_log notice "... created ::xo::xotcl_object_type_cache" - ::xo::Cache create ::xo::xotcl_package_cache \ + ::acs::Cache create ::xo::xotcl_package_cache \ -package_key xotcl-core \ -parameter XOTclPackageCache \ -default_size 10000 ns_log notice "... created ::xo::xotcl_package_cache" } - + ########################################################################## + # + # Deprecated functions, obsolted by xo::dc + # ad_proc -deprecated has_ltree {} { Check, whether ltree is available (postgres only) @see ::xo::dc has_ltree @@ -944,7 +779,11 @@ ::xo::dc has_hstore } - + ########################################################################## + # + # Support for requiring database artifacts + # + ########################################################################## ::xotcl::Object create require require proc exists_table {name} { @@ -1221,7 +1060,7 @@ @return object_type, typically an XOTcl class } { - xo::xotcl_object_type_cache eval -tree_key $id $id { + xo::xotcl_object_type_cache eval -partition_key $id $id { ::xo::dc 1row get_class "select object_type from acs_objects where object_id=:id" return $object_type } 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.69 -r1.70 --- openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 25 Jun 2018 15:03:02 -0000 1.69 +++ openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 26 Jun 2018 10:24:24 -0000 1.70 @@ -65,7 +65,7 @@ return [set $key] } set entry_key [expr {$item_id ? $item_id : $revision_id}] - set $key [xo::xotcl_object_type_cache eval -tree_key $entry_key $entry_key { + set $key [xo::xotcl_object_type_cache eval -partition_key $entry_key $entry_key { if {$item_id} { ::xo::dc 1row -prepare integer get_class_from_item_id \ "select content_type as object_type from cr_items where item_id=:item_id" @@ -1639,7 +1639,7 @@ # In order to cache fails as well, we would have to flush the fail # on new added items and renames. while {1} { - set item_id [xo::xotcl_object_type_cache eval -tree_key $parent_id $parent_id-$name { + set item_id [xo::xotcl_object_type_cache eval -partition_key $parent_id $parent_id-$name { set item_id [next] if {$item_id == 0} { #ns_log notice ".... lookup $parent_id-$name => 0 -> break and don't cache" @@ -1753,19 +1753,27 @@ return $item_id } CrCache::Item instproc delete args { + # + # Not all cr_items are cached. Some of the bulk creation commands + # create autonamed items, which have non-numeric object names. So + # the flush on these will fail anyhow, since these were never + # added to the cache. + # set key [string trimleft [self] :] - # Do not try to flush autnamed entries if {[string is integer $key] } { ::xo::xotcl_object_cache flush $key } - xo::xotcl_object_type_cache flush -tree_key ${:parent_id} ${:parent_id}-[:name] + xo::xotcl_object_type_cache flush -partition_key ${:parent_id} ${:parent_id}-[:name] next } CrCache::Item instproc rename {-old_name:required -new_name:required} { - ::xo::xotcl_object_type_cache flush -tree_key ${:parent_id} ${:parent_id}-$old_name + ::xo::xotcl_object_type_cache flush -partition_key ${:parent_id} ${:parent_id}-$old_name next } + # + # Register the caching mixins + # CrClass instmixin CrCache CrClass mixin CrCache::Class CrItem instmixin CrCache::Item