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.100 -r1.101 --- openacs-4/packages/xotcl-core/xotcl-core.info 22 Jun 2018 11:56:11 -0000 1.100 +++ openacs-4/packages/xotcl-core/xotcl-core.info 22 Jun 2018 20:11:55 -0000 1.101 @@ -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,7 +43,7 @@ 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.128 -r1.129 --- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 22 Jun 2018 13:55:40 -0000 1.128 +++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 22 Jun 2018 20:11:55 -0000 1.129 @@ -110,15 +110,15 @@ } ::xo::db::postgresql instproc has_ltree {} { - ::xo::xotcl_object_type_cache eval [self]::has_ltree { + ::xo::xotcl_package_cache eval [self]::has_ltree { if {[:get_value check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"] > 0} { return 1 } return 0 } } ::xo::db::postgresql instproc has_hstore {} { - ::xo::xotcl_object_type_cache eval [self]::has_hstore { + ::xo::xotcl_package_cache eval [self]::has_hstore { if {[:get_value check_ltree "select count(*) from pg_proc where proname = 'hstore_in'"] > 0} { return 1 } @@ -738,7 +738,8 @@ :method cache_name {key} { # - # more or less dummy function, can be refined. + # More or less dummy function, can be refined, completely + # ignores "key". # return ${:name} } @@ -753,20 +754,33 @@ -default ${:default_size}] } - :public method flush {key} { - ::xo::clusterwide ns_cache flush [:cache_name $key] $key + :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 {key body} { - :uplevel [list ns_cache_eval -- [:cache_name $key] $key $body] + :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} { - :uplevel [list ns_cache_eval -force -- [:cache_name $key] $key [list set _ $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}" : ""}] \ @@ -777,12 +791,25 @@ # # AOLserver variant # - :public method eval {key body} { - :uplevel [list ns_cache eval [:cache_name $key] $key $body] + :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 {key value} { - :uplevel [list ns_cache set [:cache_name $key] $key $value] + :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 } @@ -798,9 +825,9 @@ # # Simple Partitioned Cache class # - # Parititioning is based on a modulo function based onm the key, - # which has to be numeric. So far, no partitioning spanning methods - # are provided. + # Partitioning is based on a modulo function based on the key, which + # has to be numeric. So far, no partitioning-spanning methods are + # provided. # ########################################################################## @@ -819,8 +846,8 @@ -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. + # 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} { @@ -832,6 +859,36 @@ ########################################################################## # + # 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::Cache { + :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 @@ -859,7 +916,7 @@ -partitions 2 ns_log notice "... created ::xo::xotcl_object_cache" - ::xo::Cache create ::xo::xotcl_object_type_cache \ + ::xo::TreePartitionedCache create ::xo::xotcl_object_type_cache \ -package_key xotcl-core \ -parameter XOTclObjectTypeCache \ -default_size 50000 @@ -1164,7 +1221,7 @@ @return object_type, typically an XOTcl class } { - xo::xotcl_object_type_cache eval $id { + xo::xotcl_object_type_cache eval -tree_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/06-package-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl,v diff -u -N -r1.40 -r1.41 --- openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 21 Jun 2018 07:23:56 -0000 1.40 +++ openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 22 Jun 2018 20:11:55 -0000 1.41 @@ -336,7 +336,7 @@ @return folder_id } { - set folder_id [ns_cache eval xotcl_package_cache root_folder-${:id} { + set folder_id [::xo::xotcl_package_cache eval root_folder-${:id} { set folder_id [::xo::db::CrClass lookup -name $name -parent_id $parent_id] if {$folder_id == 0} { Index: openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl,v diff -u -N -r1.23 -r1.24 --- openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 20 May 2018 11:23:00 -0000 1.23 +++ openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 22 Jun 2018 20:11:55 -0000 1.24 @@ -159,13 +159,11 @@ # # Methods on the parameter class object # - parameter proc get_package_key_from_id { - -package_id:required - } { + parameter proc get_package_key_from_id {-package_id:required} { return [apm_package_key_from_id $package_id] } parameter proc get_package_id_from_package_key {-package_key:required} { - return [ns_cache eval xotcl_object_type_cache package_id-$package_key { + return [ns_cache eval xotcl_package_cache package_id-$package_key { ::xo::dc get_value get_package_id \ [::xo::dc select -vars package_id -from apm_packages \ -where "package_key = :package_key" -limit 1] 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.67 -r1.68 --- openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 22 Jun 2018 11:56:11 -0000 1.67 +++ openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 22 Jun 2018 20:11:55 -0000 1.68 @@ -1,5 +1,5 @@ ::xo::library doc { - XOTcl for the Content Repository + XOTcl for the Content Repository @author Gustaf Neumann @creation-date 2007-08-13 @@ -19,28 +19,28 @@ {folder_id -100} {non_cached_instance_var_patterns {__*}} } -ad_doc { -

The meta class CrClass serves for a class of applications that mostly - store information in the content repository and that use a few - attributes adjoining this information. The class handles the open - acs object_type creation and the automatic creation of the +

The meta class CrClass serves for a class of applications that mostly + store information in the content repository and that use a few + attributes adjoining this information. The class handles the open + acs object_type creation and the automatic creation of the necessary tables based on instances of this meta-class.

- -

The definition of new types is handled in the constructor of - CrType through the method - create_object_type, + +

The definition of new types is handled in the constructor of + CrType through the method + create_object_type, the removal of the - object type is handled through the method + object type is handled through the method drop_object_type - (requires that + (requires that all instances of this type are deleted).

-

Each content item can be retrieved either through the - general method +

Each content item can be retrieved either through the + general method - CrClass get_instance_from_db or through the "get_instance_from_db" method of + CrClass get_instance_from_db or through the "get_instance_from_db" method of every subclass of CrItem. -

This Class is a meta-class providing methods for Classes +

This Class is a meta-class providing methods for Classes managing CrItems.

} @@ -57,37 +57,37 @@ @return object_type typically an XOTcl class } { # - # Use a request-spanning cache. When the type whould changes, we - # would require xo::broadcast or server restart. + # Use a request-spanning cache. When the object_type would change, + # we require xo::broadcast or server restart. # set key ::xo::object_type($item_id,$revision_id) if {[info exists $key]} { return [set $key] } - set $key [ns_cache eval xotcl_object_type_cache \ - [expr {$item_id ? $item_id : $revision_id}] { - 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" - } else { - ::xo::dc 1row -prepare integer get_class_from_revision_id \ - "select object_type from acs_objects where object_id=:revision_id" - } - return $object_type - }] + set entry_key [expr {$item_id ? $item_id : $revision_id}] + set $key [xo::xotcl_object_type_cache eval -tree_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" + } else { + ::xo::dc 1row -prepare integer get_class_from_revision_id \ + "select object_type from acs_objects where object_id=:revision_id" + } + return $object_type + }] } CrClass ad_proc get_instance_from_db { {-item_id:integer 0} {-revision_id:integer 0} {-initialize:boolean true} } { - Instantiate the live revision or the specified revision of an - CrItem. The XOTcl object is destroyed automatically on cleanup + Instantiate the live revision or the specified revision of an + CrItem. The XOTcl object is destroyed automatically on cleanup (end of a connection request). @return fully qualified object containing the attributes of the CrItem - } { + } { set object_type [:get_object_type -item_id $item_id -revision_id $revision_id] set class [::xo::db::Class object_type_to_class $object_type] return [$class get_instance_from_db -item_id $item_id -revision_id $revision_id -initialize $initialize] @@ -97,11 +97,11 @@ -item_id:required } { Get the parent_id of a content item either from an already instantiated - object or from the database without instantiating it. If item_id is not + object or from the database without instantiating it. If item_id is not a valid item_id, we throw an error. @return parent_id - } { + } { # TODO: the following line is deactivated, until we get rid of the "folder object" in xowiki #if {[:isobject ::$item_id]} {return [::$item_id parent_id]} ::xo::dc 1row -prepare integer get_parent "select parent_id from cr_items where item_id = :item_id" @@ -111,12 +111,12 @@ CrClass ad_proc get_name { -item_id:required } { - Get the name of a content item either from an already instantiated object - or from the database without instantiating it. If item_id is not a valid + Get the name of a content item either from an already instantiated object + or from the database without instantiating it. If item_id is not a valid item_id, we throw an error. @return parent_id - } { + } { # TODO: the following line is deactivated, until we get rid of the "folder object" in xowiki #if {[:isobject ::$item_id]} {return [::$item_id parent_id]} ::xo::dc 1row -prepare integer get_name "select name from cr_items where item_id = :item_id" @@ -126,8 +126,8 @@ CrClass ad_proc get_child_item_ids { -item_id:required } { - Return a list of content items having the provided item_id as - direct or indirect parent. The method returns recursively all + Return a list of content items having the provided item_id as + direct or indirect parent. The method returns recursively all item_ids. @return list of item_ids @@ -151,15 +151,15 @@ @return item_id } { return [::xo::dc get_value entry_exists_select { - select item_id from cr_items + select item_id from cr_items where name = :name and parent_id = :parent_id and content_type like :content_type } 0] } - + CrClass ad_proc delete { - -item_id + -item_id } { Delete a CrItem in the database } { @@ -176,14 +176,14 @@ # # Deal with locking requirements - # + # if {[db_driverkey ""] eq "postgresql"} { # # PostgreSQL # set pg_version [::xo::dc get_value get_version { select substring(version() from 'PostgreSQL #"[0-9]+.[0-9]+#"%' for '#') }] - ns_log notice "--Postgres Version $pg_version" + ns_log notice "--Postgres Version $pg_version" if {$pg_version < 8.2} { ns_log notice "--Postgres Version $pg_version older than 8.2, use locks" # @@ -225,17 +225,17 @@ } } } - + # # database version (Oracle/PG) independent code # CrClass set common_query_atts { - object_type + object_type creation_user creation_date - publish_status last_modified + publish_status last_modified } if {[apm_version_names_compare [ad_acs_version] 5.2] > -1} { CrClass lappend common_query_atts package_id @@ -251,12 +251,12 @@ } { Unregister the object type from all folders on the system - @param include_subtypes Boolean value (t/f) to flag whether the + @param include_subtypes Boolean value (t/f) to flag whether the operation should be applied on subtypes as well } { set object_type ${:object_type} - xo::dc foreach all_folders { - select folder_id from cr_folder_type_map + xo::dc foreach all_folders { + select folder_id from cr_folder_type_map where content_type = :object_type } { ::xo::db::sql::content_folder unregister_content_type \ @@ -271,10 +271,10 @@ -folder_id operation } { - register the current object type for folder_id. If folder_id + register the current object type for folder_id. If folder_id is not specified, use the instvar of the class instead. - @param include_subtypes Boolean value (t/f) to flag whether the + @param include_subtypes Boolean value (t/f) to flag whether the operation should be applied on subtypes as well } { if {$operation ne "register" && $operation ne "unregister"} { @@ -311,7 +311,7 @@ -table_name ${:table_name} \ -id_column ${:id_column} \ -name_method ${:name_method} - + :folder_type register } } @@ -335,7 +335,7 @@ CrClass ad_proc require_folder_object { -folder_id - -package_id + -package_id } { Dummy stub; let specializations define it } { @@ -406,13 +406,13 @@ } } :remember_long_text_slots - + if {![::xo::db::Class object_type_exists_in_db -object_type ${:object_type}]} { :create_object_type } } - + CrClass ad_instproc fetch_object { -item_id:required {-revision_id 0} @@ -463,7 +463,7 @@ #ns_log notice [$slot serialize] lappend atts "n.data as text" } - + ::xo::db::CrItem::slot::name { lappend atts i.[$slot column_name] } @@ -482,7 +482,7 @@ where n.revision_id = :revision_id \ and i.item_id = n.item_id \ and o.object_id = n.revision_id"] - + set selection [db_exec 1row $db dbqd..cr-procs-fetch_object-from-revision_id $sql] } $object mset [ns_set array $selection] @@ -494,9 +494,9 @@ # case of troubles, comment next line out. # lappend atts "n.creation_user as modifying_user" - + $object set item_id $item_id - + $object db_1row [:qn fetch_from_view_item_id] "\ select [join $atts ,], i.parent_id \ from ${:table_name}i n, cr_items i, acs_objects o \ @@ -526,7 +526,7 @@ {-item_id 0} {-revision_id 0} {-initialize:boolean true} - } { + } { Retrieve either the live revision or a specified revision of a content item with all attributes into a newly created object. The retrieved attributes are stored in the instance variables in @@ -549,7 +549,7 @@ CrClass ad_instproc new_persistent_object {-package_id -creation_user -creation_ip args} { Create a new content item of the actual class, - configure it with the given arguments and + configure it with the given arguments and insert it into the database. The XOTcl object is destroyed automatically on cleanup (end of a connection request). @@ -574,7 +574,7 @@ CrClass ad_instproc delete { -item_id:required - } { + } { Delete a content item from the content repository. @param item_id id of the item to be deleted } { @@ -599,7 +599,7 @@ } { returns the SQL-query to select the CrItems of the specified object_type @param select_attributes attributes for the sql query to be retrieved, in addition - to item_id, name, publish_status, object_type, and package_id + to item_id, name, publish_status, object_type, and package_id which are always returned @param orderby for ordering the solution set @param where_clause clause for restricting the answer set @@ -615,9 +615,9 @@ if {![info exists parent_id]} {set parent_id $folder_id} if {$base_table eq "cr_revisions"} { - set attributes [list ci.item_id ci.name ci.publish_status acs_objects.object_type acs_objects.package_id] + set attributes [list ci.item_id ci.name ci.publish_status acs_objects.object_type acs_objects.package_id] } else { - set attributes [list bt.item_id ci.name ci.publish_status bt.object_type "bt.object_package_id as package_id"] + set attributes [list bt.item_id ci.name ci.publish_status bt.object_type "bt.object_package_id as package_id"] } foreach a $select_attributes { if {$a eq "title"} {set a bt.title} @@ -632,7 +632,7 @@ } else { set attribute_selection [join $attributes ,] } - + set cond [list] if {$type_selection_clause ne ""} {lappend cond $type_selection_clause} if {$where_clause ne ""} {lappend cond $where_clause} @@ -685,9 +685,9 @@ {-base_table "cr_revisions"} {-initialize true} } { - Returns a set (ordered composite) of the answer tuples of + Returns a set (ordered composite) of the answer tuples of an 'instance_select_query' with the same attributes. - The tuples are instances of the class, on which the + The tuples are instances of the class, on which the method was called. } { set s [:instantiate_objects -sql \ @@ -751,7 +751,7 @@ -create_acs_attribute false } \ -parameter { - package_id + package_id {parent_id -100} {publish_status ready} } @@ -765,7 +765,7 @@ if {[db_driverkey ""] eq "postgresql"} { # # PostgreSQL - # + # # # INSERT statements differ between PostgreSQL and Oracle @@ -777,7 +777,7 @@ } CrItem instproc fix_content {revision_id content} { - [:info class] instvar storage_type + [:info class] instvar storage_type # :my msg "--long_text_slots: [[:info class] array get long_text_slots]" # foreach {slot_name slot} [[:info class] array get long_text_slots] { # set cls [$slot domain] @@ -793,11 +793,11 @@ CrItem instproc update_content {revision_id content} { # - # This method can be use to update the content field (only this) of + # This method can be use to update the content field (only this) of # an content item without creating a new revision. This works # currently only for storage_type == "text". # - [:info class] instvar storage_type + [:info class] instvar storage_type if {$storage_type eq "file"} { :log "--update_content not implemented for type file" } else { @@ -832,7 +832,7 @@ foreach a $atts v $vars { # - # "text" and long_text_slots are handled in Oracle + # "text" and long_text_slots are handled in Oracle # via separate update statement. # if {$a eq "text" || [info exists :long_text_slots($a)]} continue @@ -864,7 +864,7 @@ CrItem instproc update_content {revision_id content} { # - # This method can be used to update the content field (only this) of + # This method can be used to update the content field (only this) of # an content item without creating a new revision. This works # currently only for storage_type == "text". # @@ -893,29 +893,29 @@ } } } - + CrItem instproc update_revision {{-quoted false} revision_id attribute value} { # - # This method can be use to update arbitrary fields of + # This method can be use to update arbitrary fields of # an revision. # if {$quoted} {set val $value} {set val :value} ::xo::dc dml update_content "update cr_revisions set $attribute = $val \ where revision_id = :revision_id" } - + CrItem instproc current_user_id {} { if {[:isobject ::xo::cc]} {return [::xo::cc user_id]} if {[ad_conn isconnected]} {return [ad_conn user_id]} return "" } CrItem ad_instproc save { - -modifying_user - {-live_p:boolean true} + -modifying_user + {-live_p:boolean true} {-use_given_publish_date:boolean false} } { - Updates an item in the content repository. We insert a new revision instead of + Updates an item in the content repository. We insert a new revision instead of changing the current revision. @param modifying_user @param live_p make this revision the live revision @@ -959,7 +959,7 @@ } else { set publish_date_flag "" } - + ::xo::dc transaction { [:info class] instvar storage_type set revision_id [xo::dc nextval acs_object_id_seq] @@ -1029,11 +1029,11 @@ } { next } - + CrItem ad_instproc save_new { - -package_id - -creation_user - -creation_ip + -package_id + -creation_user + -creation_ip {-live_p:boolean true} {-use_given_publish_date:boolean false} } { @@ -1042,9 +1042,9 @@ @param creation_user user_id if the creating user @param live_p make this revision the live revision } { - + set __class [:info class] - + if {![info exists package_id] && [info exists :package_id]} { set package_id ${:package_id} } @@ -1066,7 +1066,7 @@ lappend __atts [$__slot column_name] lappend __vars $__slot_name } - + if {$use_given_publish_date} { if {"publish_date" ni $__atts} { set publish_date ${:publish_date} @@ -1086,11 +1086,11 @@ if {![info exists :name] || ${:name} eq ""} { # we have an autonamed item, use a unique value for the name - set :name [expr {[info exists :__autoname_prefix] ? + set :name [expr {[info exists :__autoname_prefix] ? "${:__autoname_prefix}$revision_id" : $revision_id}] } if {$title eq ""} { - set title [expr {[info exists :__title_prefix] ? + set title [expr {[info exists :__title_prefix] ? "${:__title_prefix} (${:name})" : ${:name}}] } @@ -1104,7 +1104,7 @@ -filename ${:name} \ -file ${:import_file}] } - + set :item_id [::xo::db::sql::content_item new \ -name ${:name} \ -parent_id ${:parent_id} \ @@ -1119,7 +1119,7 @@ -storage_type $storage_type \ -package_id $package_id \ -with_child_rels f] - + if {$storage_type eq "file"} { set text [cr_create_content_file ${:item_id} $revision_id ${:import_file}] } @@ -1143,23 +1143,23 @@ } :db_1row [:qn get_dates] { - select creation_date, last_modified + select creation_date, last_modified from acs_objects where object_id = :revision_id } set :object_id ${:item_id} return ${:item_id} } CrItem ad_instproc delete {} { - Delete the item from the content repository with the item_id taken from the + Delete the item from the content repository with the item_id taken from the instance variable. } { # delegate deletion to the class [:info class] delete -item_id ${:item_id} } CrItem ad_instproc rename {-old_name:required -new_name:required} { - Rename a content item + Rename a content item } { set item_id ${:item_id} ::xo::dc dml update_rename \ @@ -1193,7 +1193,7 @@ AnchorField author -label [_ file-storage.Author] Field content_size -label [_ file-storage.Size] -html {align right} Field last_modified_ansi -label [_ file-storage.Last_Modified] - Field description -label [_ file-storage.Version_Notes] + Field description -label [_ file-storage.Version_Notes] if {[acs_user::site_wide_admin_p]} {AnchorField show -label ""} ImageAnchorField live_revision -label [_ xotcl-core.live_revision] \ -src /resources/acs-subsite/radio.gif \ @@ -1218,28 +1218,28 @@ r.content_length,\ content_revision__get_number(r.revision_id) as version_number " \ -from "cr_items ci, cr_revisions r, acs_objects o" \ - -where "ci.item_id = :page_id and r.item_id = ci.item_id and o.object_id = r.revision_id + -where "ci.item_id = :page_id and r.item_id = ci.item_id and o.object_id = r.revision_id and acs_permission__permission_p(r.revision_id, :user_id, 'read')" \ -orderby "r.revision_id desc"] - + ::xo::dc foreach revisions_select $sql { if {$content_length < 1024} { if {$content_length eq ""} {set content_length 0} set content_size_pretty "[lc_numeric $content_length] [_ file-storage.bytes]" } else { set content_size_pretty "[lc_numeric [format %.2f [expr {$content_length/1024.0}]]] [_ file-storage.kb]" } - + set last_modified_ansi [lc_time_system_to_conn $last_modified_ansi] - + 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 live_revision_link [export_vars -base $base \ {{m make-live-revision} {revision_id $version_id}}] @@ -1256,7 +1256,7 @@ -version_delete.href [export_vars -base $base \ {{m delete-revision} {revision_id $version_id}}] \ -version_delete.title [_ file-storage.Delete_Version] - + [t1 last_child] set payload(revision_id) $version_id if {$isAdmin} { @@ -1267,7 +1267,7 @@ } } - + # providing diff links to the prevision versions. This can't be done in # the first loop, since we have not yet the revision id of entry in the next line. set lines [t1 children] @@ -1360,7 +1360,7 @@ # # a) specifying richt-text properties for an instance # b) provide a title for the instance - # + # # We should provide either a minimal parameter page for this # purposes, or - more conservative - provide simply package # parameters for this. The only thing we are losing are "computed @@ -1400,9 +1400,9 @@ if {![info exists parent_id]} {set parent_id $folder_id} if {$base_table eq "cr_folders"} { - set attributes [list ci.item_id ci.name ci.publish_status acs_objects.object_type] + set attributes [list ci.item_id ci.name ci.publish_status acs_objects.object_type] } else { - set attributes [list bt.item_id ci.name ci.publish_status bt.object_type] + set attributes [list bt.item_id ci.name ci.publish_status bt.object_type] } foreach a $select_attributes { # if {$a eq "title"} {set a bt.title} @@ -1513,7 +1513,7 @@ if {![::xotcl::Object isobject $object]} { :create $object } - + $object db_1row [:qn fetch_folder] " SELECT * FROM cr_folders JOIN cr_items on cr_folders.folder_id = cr_items.item_id @@ -1570,31 +1570,31 @@ ::xo::db::CrFolder instproc is_package_root_folder {} { return [expr {${:folder_id} eq [::${:package_id} folder_id]} ? true : false] } - + ::xo::db::CrFolder instproc delete {} { if {[:is_package_root_folder]} { ad_return_error "Removal denied" "Dont delete the package root folder, delete the package" return } ::xo::db::sql::content_folder del -folder_id ${:folder_id} -cascade_p t } - + # # Caching interface # # CrClass is a mixin class for caching the CrItems in ns_cache. # - - ::xotcl::Class create CrCache + + ::xotcl::Class create CrCache CrCache instproc fetch_object { -item_id:required {-revision_id 0} -object:required {-initialize:boolean true} } { set serialized_object [::xo::xotcl_object_cache eval [string trimleft $object :] { - # :log "--CACHE true fetch [self args], call shadowed method [self next]" + # :log "--CACHE true fetch [self args], call shadowed method [self next]" set loaded_from_db 1 # Call the showdowed method with initializing turned off. We # want to store object before the after-load initialize in the @@ -1613,7 +1613,7 @@ # or create it. if {[:isobject $object]} { # There would have been no need to call this method. We could - # raise an error here. + # raise an error here. # :log "--!! $object exists already" } else { # Create the object from the serialization and initialize it @@ -1639,12 +1639,15 @@ # 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 [ns_cache eval xotcl_object_type_cache $parent_id-$name { + set item_id [xo::xotcl_object_type_cache eval -tree_key $parent_id $parent_id-$name { set item_id [next] - if {$item_id == 0} break ;# don't cache + if {$item_id == 0} { + #ns_log notice ".... lookup $parent_id-$name => 0 -> break and don't cache" + break + } return $item_id }] - + break } # :msg "lookup $parent_id-$name -> item_id=$item_id" @@ -1653,7 +1656,7 @@ ::xotcl::Class create CrCache::Item CrCache::Item set name_pattern {^::[0-9]+$} - + CrCache::Item instproc remove_non_persistent_vars {} { # # Do not save __db__artefacts in the cache. @@ -1674,7 +1677,7 @@ foreach pattern [[:info class] non_cached_instance_var_patterns] { lappend non_cached_vars {*}[info vars :$pattern] } - + #puts stderr "pattern [[:info class] non_cached_instance_var_patterns], non_cached_vars=$non_cached_vars" foreach x $non_cached_vars { if {[array exists :$x]} { @@ -1687,7 +1690,7 @@ } return [list $arrays $scalars] } - + CrCache::Item instproc set_non_persistent_vars {vars} { lassign $vars arrays scalars foreach {var value} $arrays {my array set $var $value} @@ -1704,7 +1707,7 @@ # The object name is eq to the item_id; we assume, this is a # fully loaded object, containing all relevant instance # variables. We can restore it. After the flash - # + # # We do not want to cache per object mixins for the # time being (some classes might be volatile). So save # mixin-list, cache and resore them later for the current @@ -1751,22 +1754,20 @@ } CrCache::Item instproc delete args { ::xo::xotcl_object_cache flush [string trimleft [self] :] - # :msg "delete flush xotcl_object_type_cache ${:parent_id}-[:name]" - ::xo::clusterwide ns_cache flush xotcl_object_type_cache ${:parent_id}-[:name] + xo::xotcl_object_type_cache flush -tree_key ${:parent_id} ${:parent_id}-[:name] next } CrCache::Item instproc rename {-old_name:required -new_name:required} { - # :msg "rename flush xotcl_object_type_cache ${:parent_id}-$old_name" - ::xo::clusterwide ns_cache flush xotcl_object_type_cache ${:parent_id}-$old_name + ::xo::xotcl_object_type_cache flush -tree_key ${:parent_id} ${:parent_id}-$old_name next } - + CrClass instmixin CrCache CrClass mixin CrCache::Class CrItem instmixin CrCache::Item -} +} -#::xo::library source_dependent +#::xo::library source_dependent # Index: openacs-4/packages/xowiki/xowiki.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/xowiki.info,v diff -u -N -r1.166 -r1.167 --- openacs-4/packages/xowiki/xowiki.info 22 Jun 2018 11:56:11 -0000 1.166 +++ openacs-4/packages/xowiki/xowiki.info 22 Jun 2018 20:11:55 -0000 1.167 @@ -10,7 +10,7 @@ t xowiki - + Gustaf Neumann A xotcl-based enterprise wiki system with multiple object types 2017-08-06 @@ -55,8 +55,9 @@ BSD-Style 2 - - + + + @@ -65,7 +66,6 @@ - Index: openacs-4/packages/xowiki/tcl/package-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/package-procs.tcl,v diff -u -N -r1.321 -r1.322 --- openacs-4/packages/xowiki/tcl/package-procs.tcl 22 Jun 2018 11:56:11 -0000 1.321 +++ openacs-4/packages/xowiki/tcl/package-procs.tcl 22 Jun 2018 20:11:55 -0000 1.322 @@ -1985,7 +1985,7 @@ @return folder_id } { - set folder_id [ns_cache eval xotcl_package_cache root_folder-${:id} { + set folder_id [xo::xotcl_package_cache eval root_folder-${:id} { set folder_id [::xo::db::CrClass lookup -name $name -parent_id $parent_id] if {$folder_id == 0} { @@ -2413,7 +2413,7 @@ # Different machines in the cluster might have different entries in their caches. # Since we use wild-cards to find these, it has to be done on every machine ::xo::clusterwide xo::cache_flush_all xowiki_cache link-*-$name-$parent_id - ::xo::clusterwide ns_cache flush xotcl_object_type_cache $parent_id-$name + ::xo::xotcl_object_type_cache flush -tree_key $parent_id $parent_id-$name } Package instproc delete_revision {-revision_id:required -item_id:required} { Index: openacs-4/packages/xowiki/tcl/xowiki-callback-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/xowiki-callback-procs.tcl,v diff -u -N -r1.76 -r1.77 --- openacs-4/packages/xowiki/tcl/xowiki-callback-procs.tcl 21 Jun 2018 07:23:56 -0000 1.76 +++ openacs-4/packages/xowiki/tcl/xowiki-callback-procs.tcl 22 Jun 2018 20:11:55 -0000 1.77 @@ -51,10 +51,10 @@ set instance_name [apm_instance_name_from_id $package_id] - ::xo::clusterwide ns_cache flush xotcl_object_type_cache package_id-$instance_name - ::xo::clusterwide ns_cache flush xotcl_object_type_cache -100-$instance_name - ::xo::clusterwide ns_cache flush xotcl_object_type_cache package_key-$package_id - ::xo::clusterwide ns_cache flush xotcl_package_cache root_folder-$package_id + ::xo::xotcl_package_cache flush package_id-$instance_name + ::xo::xotcl_package_cache flush package_key-$package_id + ::xo::xotcl_package_cache flush root_folder-$package_id + ::xo::xotcl_object_type_cache flush -tree_key -100 -100-$instance_name ns_log notice "before-uninstantiate DONE" } Index: openacs-4/packages/xowiki/tcl/xowiki-utility-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/xowiki-utility-procs.tcl,v diff -u -N -r1.52 -r1.53 --- openacs-4/packages/xowiki/tcl/xowiki-utility-procs.tcl 22 Jun 2018 11:56:11 -0000 1.52 +++ openacs-4/packages/xowiki/tcl/xowiki-utility-procs.tcl 22 Jun 2018 20:11:55 -0000 1.53 @@ -431,7 +431,7 @@ proc ::xowiki::page_order_uses_ltree {} { if {[::xo::dc has_ltree]} { - ::xo::xotcl_object_type_cache eval ::xowiki::page_order_uses_ltree { + ::xo::xotcl_package_cache eval ::xowiki::page_order_uses_ltree { return [::xo::dc get_value check_po_ltree { select count(*) from pg_attribute a, pg_type t, pg_class c where attname = 'page_order' and a.atttypid = t.oid and c.oid = a.attrelid @@ -459,7 +459,7 @@ select item_id from cr_items where name = :name and parent_id = -100 }] } - ::xo::clusterwide ns_cache flush xotcl_object_type_cache $item_id + xo::xotcl_object_type_cache flush -tree_key $item_id $item_id set form_id [::xowiki::Weblog instantiate_forms -forms en:folder.form -package_id $package_id] if {[::xo::dc 0or1row check { @@ -487,9 +487,10 @@ ::xo::xotcl_object_cache flush $package_id ::xo::xotcl_object_cache flush $item_id ::xo::xotcl_object_cache flush $revision_id - ::xo::clusterwide ns_cache flush xotcl_object_type_cache root-folder-$package_id - ::xo::clusterwide ns_cache flush xotcl_object_type_cache $item_id - ::xo::clusterwide ns_cache flush xotcl_object_type_cache $revision_id + ::xo::xotcl_object_type_cache flush + ::xo::xotcl_package_cache flush root-folder-$package_id + ::xo::xotcl_object_type_cache flush -tree_key $item_id $item_id + ::xo::xotcl_object_type_cache flush -tree_key $revision_id $revision_id } proc ::xowiki::refresh_id_column_fk_constraints {} { Index: openacs-4/packages/xowiki/www/admin/test.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/www/admin/Attic/test.tcl,v diff -u -N -r1.43 -r1.44 --- openacs-4/packages/xowiki/www/admin/test.tcl 9 Apr 2018 08:11:05 -0000 1.43 +++ openacs-4/packages/xowiki/www/admin/test.tcl 22 Jun 2018 20:11:55 -0000 1.44 @@ -140,11 +140,6 @@ ? {expr {$info(package_id) ne ""}} 1 "package is mounted, package_id provided: $info(package_id)" -# Make sure to delete the name entry in the cache in case, the instance was deleted -# via low-level API -#::xo::clusterwide ns_cache flush xotcl_object_type_cache package_id-xowiki -#::xo::clusterwide ns_cache flush xotcl_object_type_cache -100-$instance_name - ############################################################# test subsection "Basic Setup: Package, url= /$instance_name/" #############################################################