Examples:<@br> + <@pre class='code'>Serializer all -ignoreVarsRE {::b$} + Do not serialize any instance variable named b (of any object).
+ <@pre class='code'>Serializer all -ignoreVarsRE {^::o1::.*text.*$|^::o2::x$} + Do not serialize any variable of c1 whose name contains + the string "text" and do not serialze the variable x of o2.
+ <@pre class='code'>Serializer all -ignore obj1 obj2 ... + do not serizalze the specified objects + } + return "script" + } + + @ Serializer proc deepSerialize { + objs "Objects to be serialized" + ?-ignoreVarsRE RE? + "provide regular expression; matching vars are ignored" + ?-ignore obj1 obj2 ...? + "provide a list of objects to be omitted" + ?-map list? "translate object names in serialized code" + } { + Description { + Serialize object with all child objects (deep operation) + except the specified omissions. For the description of + <@tt>ignore and <@tt>igonoreVarsRE see + <@tt>Serizalizer all. <@tt>map can be used + in addition to provide pairs of old-string and new-string + (like in the tcl command <@tt>string map). This option + can be used to regenerate the serialized object under a different + object or under an different name, or to translate relative + object names in the serialized code.
+ + Examples: + <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b ::x::y} + Serialize the object <@tt>c which is a child of <@tt>a::b; + the object will be reinitialized as object <@tt>::x::y::c, + all references <@tt>::a::b will be replaced by <@tt>::x::y.
+ + <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b [self]} + The serizalized object can be reinstantiated under some current object, + under which the script is evaluated.
+ + <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b::c ${var}} + The serizalized object will be reinstantiated under a name specified + by the variable <@tt>var<@tt> in the recreation context. + } + return "script" + } + + @ Serializer proc methodSerialize { + object "object or class" + method "name of method" + prefix "either empty or 'inst' (latter for instprocs)" + } { + Description { + Serialize the specified method. In order to serialize + an instproc, <@tt>prefix should be 'inst'; to serialze + procs, it should be empty.
+ + Examples: + <@pre class='code'>Serializer methodSerialize Serializer deepSerialize "" + This command serializes the proc <@tt>deepSerialize + of the Class <@tt>Serializer.
+ + <@pre class='code'>Serializer methodSerialize Serializer serialize inst + This command serializes the instproc <@tt>serialize + of the Class <@tt>Serializer.
+ } + return {Script, which can be used to recreate the specified method} + } + @ Serializer proc exportMethods { + list "list of methods of the form 'object proc|instproc methodname'" + } { + Description { + This method can be used to specify methods that should be + exported in every <@tt>Serializer all<@/tt>. The rationale + behind this is that the serializer does not serialize objects + from the ::xotcl:: namespace, which is used for XOTcl internals + and volatile objects. It is however often useful to define + methods on ::xotcl::Class or ::xotcl::Objects, which should + be exported. One can export procs, instprocs, forward and instforward
+ Example:
+ <@pre class='code'> Serializer exportMethods {
+ ::xotcl::Object instproc __split_arguments
+ ::xotcl::Object instproc __make_doc
+ ::xotcl::Object instproc ad_proc
+ ::xotcl::Class instproc ad_instproc
+ ::xotcl::Object forward expr
+ }<@/pre>
+ }
+ }
+
+
+ @ Serializer instproc serialize {entity "Object or Class"} {
+ Description {
+ Serialize the specified object or class.
+ }
+ return {Object or Class with all currently defined methods,
+ variables, invariants, filters and mixins}
+ }
+
+ ##################################################################################
+ # real clode starts here.....
+ # ################################################################################
+ Class Serializer -parameter {ignoreVarsRE map}
+ namespace export Serializer
+
+ Serializer proc ignore args {
+ my set skip $args
+ }
+ Serializer instproc ignore args {
+ foreach i $args {
+ my set skip($i) 1
+ # skip children of ignored objects as well
+ foreach j [$i info children] {
+ my ignore $j
+ }
+ }
+ }
+ Serializer instproc init {} {
+ my ignore [self]
+ if {[[self class] exists skip]} {
+ eval my ignore [[self class] set skip]
+ }
+ }
+ Serializer instproc method-serialize {o m prefix} {
+ my pcmd [my unescaped-method-serialize $o $m $prefix]
+ }
+ Serializer instproc unescaped-method-serialize {o m prefix} {
+ set arglist [list]
+ foreach v [$o info ${prefix}args $m] {
+ if {[$o info ${prefix}default $m $v x]} {
+ lappend arglist [list $v $x] } {lappend arglist $v}
+ }
+ lappend r ${prefix}proc $m \
+ [concat [$o info ${prefix}nonposargs $m] $arglist] \
+ [$o info ${prefix}body $m]
+ foreach p {pre post} {
+ if {[$o info ${prefix}$p $m]!=""} {lappend r [$o info ${prefix}$p $m]}
+ }
+ return $r
+ }
+ Serializer instproc pcmd list {
+ foreach a $list {
+ if {[regexp -- {^-[[:alpha:]]} $a]} {
+ set mustEscape 1
+ break
+ }
+ }
+ if {[info exists mustEscape]} {
+ return "\[list -$list\]"
+ } else {
+ return -$list
+ }
+ }
+ Serializer instproc Object-serialize o {
+ append cmd [list [$o info class] create [$o self] -noinit] " \\\n"
+ foreach i [$o info procs] {
+ append cmd " " [my method-serialize $o $i ""] " \\\n"
+ }
+ foreach i [$o info forward] {
+ set fwd [concat [list forward $i] [$o info forward -definition $i]]
+ append cmd \t [my pcmd $fwd] " \\\n"
+ }
+ set vset {}
+ set nrVars 0
+ foreach v [$o info vars] {
+ set setcmd [list]
+ if {![my exists ignoreVarsRE] ||
+ ![regexp [my set ignoreVarsRE] ${o}::$v]} {
+ if {[$o array exists $v]} {
+ lappend setcmd array set $v [$o array get $v]
+ } else {
+ lappend setcmd set $v [$o set $v]
+ }
+ incr nrVars
+ append cmd \t [my pcmd $setcmd] " \\\n"
+ }
+ }
+ foreach x {mixin invar} {
+ set v [$o info $x]
+ if {$v ne ""} {my append postcmd [list $o $x set $v] "\n"}
+ }
+ set v [$o info filter -guards]
+ if {$v ne ""} {append cmd [my pcmd [list filter $v]] " \\\n"}
+ return $cmd
+ }
+ Serializer instproc Class-serialize o {
+ set cmd [my Object-serialize $o]
+ set p [$o info parameter]
+ if {$p ne ""} {
+ append cmd " " [my pcmd [list parameter $p]] " \\\n"
+ }
+ foreach i [$o info instprocs] {
+ append cmd " " [my method-serialize $o $i inst] " \\\n"
+ }
+ foreach i [$o info instforward] {
+ set fwd [concat [list instforward $i] [$o info instforward -definition $i]]
+ append cmd \t [my pcmd $fwd] " \\\n"
+ }
+ foreach x {superclass instinvar} {
+ set v [$o info $x]
+ if {$v ne "" && "::xotcl::Object" ne $v } {
+ append cmd " " [my pcmd [list $x $v]] " \\\n"
+ }
+ }
+ foreach x {instmixin} {
+ set v [$o info $x]
+ if {$v ne "" && "::xotcl::Object" ne $v } {
+ my append postcmd [list $o $x set $v] "\n"
+ #append cmd " " [my pcmd [list $x $v]] " \\\n"
+ }
+ }
+ set v [$o info instfilter -guards]
+ if {$v ne ""} {append cmd [my pcmd [list instfilter $v]] " \\\n"}
+ return $cmd\n
+ }
+
+ Serializer instproc args {o prefix m} {
+ foreach v [$o info ${prefix}args $m] {
+ if {[$o info ${prefix}default $m $v x]} {
+ lappend arglist [list $v $x] } {
+ lappend arglist $v }
+ }
+ return $arglist
+ }
+ Serializer instproc category c {
+ if {[$c istype ::xotcl::Class]} {return Class} {return Object}
+ }
+ Serializer instproc allChildren o {
+ set set $o
+ foreach c [$o info children] {
+ eval lappend set [my allChildren $c]
+ }
+ return $set
+ }
+ Serializer instproc allInstances C {
+ set set [$C info instances]
+ foreach sc [$C info subclass] {
+ eval lappend set [my allInstances $sc]
+ }
+ return $set
+ }
+
+ Serializer instproc topoSort {set all} {
+ if {[my array exists s]} {my array unset s}
+ if {[my array exists level]} {my array unset level}
+ foreach c $set {
+ if {!$all &&
+ [string match "::xotcl::*" $c] &&
+ ![[self class] exists exportObjects($c)]} continue
+ if {[my exists skip($c)]} continue
+ my set s($c) 1
+ }
+ set stratum 0
+ while {1} {
+ set set [my array names s]
+ if {[llength $set] == 0} break
+ incr stratum
+ #my warn "$stratum set=$set"
+ my set level($stratum) {}
+ foreach c $set {
+ if {[my [my category $c]-needsNothing $c]} {
+ my lappend level($stratum) $c
+ }
+ }
+ if {[my set level($stratum)] eq ""} {
+ my set level($stratum) $set
+ my warn "Cyclic dependency in $set"
+ }
+ foreach i [my set level($stratum)] {my unset s($i)}
+ }
+ }
+ Serializer instproc warn msg {
+ if {[info command ns_log] ne ""} {
+ ns_log Notice $msg
+ } else {
+ puts stderr "!!! $msg"
+ }
+ }
+
+ Serializer instproc Class-needsNothing x {
+ if {![my Object-needsNothing $x]} {return 0}
+ if {[my needsOneOf [$x info superclass]]} {return 0}
+ #if {[my needsOneOf [$x info instmixin ]]} {return 0}
+ return 1
+ }
+ Serializer instproc Object-needsNothing x {
+ set p [$x info parent]
+ if {$p ne "::" && [my needsOneOf $p]} {return 0}
+ if {[my needsOneOf [$x info class]]} {return 0}
+ #if {[my needsOneOf [$x info mixin ]]} {return 0}
+ return 1
+ }
+ Serializer instproc needsOneOf list {
+ foreach e $list {if {[my exists s($e)]} {return 1}}
+ return 0
+ }
+ Serializer instproc serialize {objectOrClass} {
+ string trimright [my [my category $objectOrClass]-serialize $objectOrClass] "\\\n"
+ }
+ Serializer instproc serialize-objects {list all} {
+ my set postcmd ""
+ my topoSort $list $all
+ #foreach i [lsort [my array names level]] {my warn "$i: [my set level($i)]"}
+ set result ""
+ foreach l [lsort [my array names level]] {
+ foreach i [my set level($l)] {
+ #my warn "serialize $i"
+ append result [my serialize $i] \n
+ }
+ }
+ foreach e $list {
+ set namespace($e) 1
+ set namespace([namespace qualifiers $e]) 1
+ }
+
+ set exports ""
+ set nsdefines ""
+ # delete ::xotcl from the namespace list, if it exists...
+ catch {unset namespace(::xotcl)}
+ foreach ns [array name namespace] {
+ if {![namespace exists $ns]} continue
+ if {![my isobject $ns]} {
+ append nsdefines "namespace eval $ns {}\n"
+ } elseif {$ns ne [namespace origin $ns] } {
+ append nsdefines "namespace eval $ns {}\n"
+ }
+ set exp [namespace eval $ns {namespace export}]
+ if {$exp ne ""} {
+ append exports "namespace eval $ns {namespace export $exp}" \n
+ }
+ }
+ return $nsdefines$result[my set postcmd]$exports
+ }
+ Serializer instproc deepSerialize o {
+ # assumes $o to be fully qualified
+ my serialize-objects [my allChildren $o] 1
+ }
+ Serializer instproc serializeMethod {object kind name} {
+ set code ""
+ switch $kind {
+ proc {
+ if {[$object info procs $name] ne ""} {
+ set code [my method-serialize $object $name ""]
+ }
+ }
+ instproc {
+ if {[$object info instprocs $name] ne ""} {
+ set code [my method-serialize $object $name inst]
+ }
+ }
+ forward - instforward {
+ if {[$object info $kind $name] ne ""} {
+ set fwd [concat [list $kind $name] [$object info $kind -definition $name]]
+ set code [my pcmd $fwd]
+ }
+ }
+ }
+ return $code
+ }
+
+
+ Serializer proc exportMethods list {
+ foreach {o p m} $list {my set exportMethods($o,$p,$m) 1}
+ }
+ Serializer proc exportObjects list {
+ foreach o $list {my set exportObjects($o) 1}
+ }
+
+ Serializer proc serializeExportedMethods {s} {
+ set r ""
+ foreach k [my array names exportMethods] {
+ foreach {o p m} [split $k ,] break
+ #if {$o ne "::xotcl::Object" && $o ne "::xotcl::Class"} {
+ #error "method export only for ::xotcl::Object and\
+ # ::xotcl::Class implemented, not for $o"
+ #}
+ if {![string match "::xotcl::*" $o]} {
+ error "method export is only for ::xotcl::* \
+ object an classes implemented, not for $o"
+ }
+ append methods($o) [$s serializeMethod $o $p $m] " \\\n "
+ }
+ set objects [array names methods]
+ foreach o [list ::xotcl::Object ::xotcl::Class] {
+ set p [lsearch $o $objects]
+ if {$p == -1} continue
+ set objects [lreplace $objects $p $p]
+ }
+ foreach o [concat ::xotcl::Object ::xotcl::Class $objects] {
+ if {![info exists methods($o)]} continue
+ append r \n "$o configure \\\n " \
+ [string trimright $methods($o) "\\\n "]
+ }
+ #puts stderr "... exportedMethods <$r\n>"
+ return "$r\n"
+ }
+
+ Serializer proc all {args} {
+ set filterstate [::xotcl::configure filter off]
+ set s [eval my new -childof [self] -volatile $args]
+ # always export __exitHandler
+ my exportMethods [list ::xotcl::Object proc __exitHandler]
+ set r {set ::xotcl::__filterstate [::xotcl::configure filter off]}
+ append r \n "::xotcl::configure softrecreate [::xotcl::configure softrecreate]"
+ append r \n [my serializeExportedMethods $s]
+ # export the objects and classes
+ #$s warn "export objects = [my array names exportObjects]"
+ #$s warn "export objects = [my array names exportMethods]"
+ append r [$s serialize-objects [$s allInstances ::xotcl::Object] 0]
+ foreach o [list ::xotcl::Object ::xotcl::Class] {
+ foreach x {mixin instmixin invar instinvar} {
+ set v [$o info $x]
+ if {$v ne "" && $v ne "::xotcl::Object"} {
+ append r "$o configure " [$s pcmd [list $x $v]] "\n"
+ }
+ }
+ }
+ append r {
+ ::xotcl::configure filter $::xotcl::__filterstate
+ unset ::xotcl::__filterstate
+ }
+ ::xotcl::configure filter $filterstate
+ return $r
+ }
+ Serializer proc methodSerialize {object method prefix} {
+ set s [my new -childof [self] -volatile]
+ concat $object [$s unescaped-method-serialize $object $method $prefix]
+ }
+ Serializer proc deepSerialize args {
+ set s [my new -childof [self] -volatile]
+ set nr [eval $s configure $args]
+ foreach o [lrange $args 0 [incr nr -1]] {
+ append r [$s deepSerialize [$o]]
+ }
+ if {[$s exists map]} {return [string map [$s map] $r]}
+ return $r
+ }
+
+ Serializer exportObjects [namespace current]::Serializer
+ namespace eval :: "namespace import -force [namespace current]::*"
+
+ #ns_log notice "???? sourceing.....Serializer"
+}
Index: openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl,v
diff -u -r1.4 -r1.5
--- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 26 Jul 2006 21:35:57 -0000 1.4
+++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 17 Aug 2006 01:27:54 -0000 1.5
@@ -1,16 +1,56 @@
-# tell serializer to export methods, allthough these are methods of
+# tell serializer to export methods, although these are methods of
# ::xotcl::Object
+
::Serializer exportMethods {
::xotcl::Object instproc log
::xotcl::Object instproc debug
::xotcl::Object instproc contains
+ ::xotcl::Object instproc serialize
+ ::xotcl::Object instforward db_1row
+ ::xotcl::Object instproc destroy_on_cleanup
+ ::xotcl::nonposArgs proc integer
+ ::xotcl::nonposArgs proc optional
}
::xotcl::Object instproc contains cmds {
my requireNamespace
namespace eval [self] $cmds
}
+::xotcl::Object instforward db_1row -objscope
+::xotcl::Object instproc serialize {} {
+ ::Serializer deepSerialize [self]
+}
+
+
+# Currently, xotcl's serializer does not export ::xotcl::* commands,
+# except methods for ::xotcl::Object and ::xotcl::Core, so we use the
+# mixin instead of te direct defintion... should be changed in the future
+# namespace eval ::xo {
+# Class create ::xo::NonPosArgs \
+# -instproc integer args {
+# if {[llength $args] < 2} return
+# foreach {name value} $args break
+# if {![string is integer $value]} {
+# error "value '$value' of $name not an integer"
+# }
+# } \
+# -instproc optional {name args} {
+# ;
+# }
+# }
+# ::xotcl::nonposArgs proc integer
+# ::xotcl::nonposArgs proc optional
+
+::xotcl::nonposArgs proc integer args {
+ if {[llength $args] < 2} return
+ foreach {name value} $args break
+ if {![string is integer $value]} {error "value '$value' of $name not an integer"}
+}
+::xotcl::nonposArgs proc optional {name args} {
+ ;
+}
+
::xotcl::Object instproc log msg {
set now [ns_time get]
if {[ns_conn isconnected]} {
@@ -28,7 +68,7 @@
} else {
set diff ""
}
- ns_log notice "[self] [self callingclass]->[self callingproc]: $msg (${ms}ms$diff)"
+ ns_log notice "$msg, [self] [self callingclass]->[self callingproc] (${ms}ms$diff)"
set ::__last_timestamp $now
}
@@ -45,6 +85,46 @@
my log "--$string [expr {$now-[my set time]}]ms $rel"
my set ltime $now
}
+
+ proc show_stack {{m 100}} {
+ if {[::info exists ::template::parse_level]} {
+ set parse_level $::template::parse_level
+ } else {
+ set parse_level ""
+ }
+ set msg "### tid=[::thread::id] <$parse_level> connected=[ns_conn isconnected] "
+ if {[ns_conn isconnected]} {
+ append msg "flags=[ad_conn flags] status=[ad_conn status] req=[ad_conn request]"
+ }
+ my log $msg
+ set max [info level]
+ if {$m<$max} {set max $m}
+ my log "### Call Stack (level: command)"
+ for {set i 0} {$i < $max} {incr i} {
+ if {[catch {set s [uplevel $i self]} msg]} {
+ set s ""
+ }
+ my log "### [format %5d -$i]:\t$s [info level [expr {-$i}]]"
+ }
+ }
+
+ #
+ # a simple calback for cleanup of per connection objects
+ # ns_atclose is a little to early for us...
+ #
+ ::xotcl::Object instproc destroy_on_cleanup {} {
+ set ::xotcl_cleanup([self]) 1
+ ::trace add variable ::xotcl_cleanup([self]) unset ::xo::cleanup_callback
+ }
+ proc ::xo::cleanup_callback {var object op} {
+ if {![::xotcl::Object isobject $object]} {
+ #ns_log notice "--D $object already destroyed, nothing to do"
+ $object destroy
+ } else {
+ #ns_log notice "--D $object destroy"
+ $object destroy
+ }
+ }
}
# ::xotcl::Class instproc import {class pattern} {
Index: openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl,v
diff -u -r1.5 -r1.6
--- openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 19 Jan 2006 22:57:37 -0000 1.5
+++ openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 17 Aug 2006 01:27:54 -0000 1.6
@@ -56,7 +56,7 @@
OrderedComposite instproc destroy {} {
# destroy all children of the ordered composite
if {[my exists __children]} {
- #my log "-- destroying children [my set __children]"
+ #my log "--W destroying children [my set __children]"
foreach c [my set __children] { $c destroy }
}
#show_stack;my log "-- children murdered, now next, chlds=[my info children]"
Index: openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl,v
diff -u -r1.8 -r1.9
--- openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 5 Aug 2006 20:38:24 -0000 1.8
+++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 17 Aug 2006 01:27:54 -0000 1.9
@@ -532,3 +532,5 @@
}
return $slave
}
+
+
Index: openacs-4/packages/xotcl-core/tcl/generic-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/generic-procs.tcl,v
diff -u -r1.23 -r1.24
--- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 8 Aug 2006 23:39:51 -0000 1.23
+++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 17 Aug 2006 01:27:54 -0000 1.24
@@ -65,7 +65,7 @@
CrClass set common_query_atts {
item_id revision_id creation_user creation_date last_modified object_type
- creation_user last_modified
+ creation_user last_modified package_id
}
#if {[apm_version_names_compare [ad_acs_version] 5.2] > -1} {
# CrClass lappend common_query_atts object_package_id
@@ -106,22 +106,22 @@
} {
if {$operation ne "register" && $operation ne "unregister"} {
error "[self] operation for folder_type must be '\
- register' or 'unregister'"
+ register' or 'unregister'"
}
my instvar object_type
if {![info exists folder_id]} {
my instvar folder_id
}
db_1row register_type "select content_folder__${operation}_content_type(\
- $folder_id,:object_type,'t')"
+ $folder_id,:object_type,'t')"
}
CrClass ad_instproc create_object_type {} {
Create an oacs object_type and a table for keeping the
additional attributes.
} {
my instvar object_type supertype pretty_name pretty_plural \
- table_name id_column name_method
+ table_name id_column name_method
set supertype [my info superclass]
switch -- $supertype {
@@ -131,22 +131,22 @@
db_transaction {
db_1row create_type {
- select content_type__create_type(
+ select content_type__create_type(
:object_type,:supertype,:pretty_name, :pretty_plural,
- :table_name, :id_column, :name_method
+ :table_name, :id_column, :name_method
)
}
if {[my cr_attributes] ne ""} {
- set o [::xo::OrderedComposite new -volatile -contains [my cr_attributes]]
- foreach att [$o children] {
- $att instvar attribute_name datatype pretty_name
- db_1row create_att {
- select content_type__create_attribute(
+ set o [::xo::OrderedComposite new -volatile -contains [my cr_attributes]]
+ foreach att [$o children] {
+ $att instvar attribute_name datatype pretty_name
+ db_1row create_att {
+ select content_type__create_attribute(
:object_type,:attribute_name,:datatype,
:pretty_name,null,null,null,'text'
)
- }
- }
+ }
+ }
}
my folder_type register
}
@@ -161,7 +161,7 @@
db_transaction {
my folder_type unregister
db_1row drop_type {
- select content_type__drop_type(:object_type,'t','t')
+ select content_type__drop_type(:object_type,'t','t')
}
}
}
@@ -170,7 +170,6 @@
{-parent_id -100}
-package_id
-name
- {-store_folder_id:boolean true}
} {
Get folder_id for a community id or the actual package.
If everything fails, return -100
@@ -184,10 +183,10 @@
set package_id [ad_conn package_id]
set cid ""
if {[info command dotlrn_community::get_community_id_from_url] ne ""} {
- set cid [dotlrn_community::get_community_id_from_url -url [ad_conn url]]
+ set cid [dotlrn_community::get_community_id_from_url -url [ad_conn url]]
}
if {$cid eq ""} {
- set cid $package_id
+ set cid $package_id
}
} else {
set cid -100
@@ -196,21 +195,20 @@
set fullname "$name: $cid"
if {[info command content::item::get_id_by_name] eq ""} {
- set folder_id ""
- db_0or1row get_id_by_name "select item_id as folder_id from cr_items \
- where name = :fullname and parent_id = :parent_id"
+ set folder_id ""
+ db_0or1row get_id_by_name "select item_id as folder_id from cr_items \
+ where name = :fullname and parent_id = :parent_id"
} else {
- set folder_id [content::item::get_id_by_name \
- -name $fullname -parent_id $parent_id]
+ set folder_id [content::item::get_id_by_name \
+ -name $fullname -parent_id $parent_id]
}
if {$folder_id eq ""} {
- set folder_id [content::folder::new -name $fullname -parent_id $parent_id \
- -package_id $package_id -context_id $cid]
+ set folder_id [content::folder::new -name $fullname -parent_id $parent_id \
+ -package_id $package_id -context_id $cid]
}
return $folder_id
}]
- my require_folder_object -folder_id $folder_id -package_id $package_id -store_folder_id $store_folder_id
return $folder_id
}
@@ -226,20 +224,20 @@
if {[info exists data]} {
# new style. does not depend on form variables
if {[$data exists item_id] && [$data set item_id] != 0 && [my exists edit_form]} {
- return [my edit_form]
+ return [my edit_form]
} else {
- return [my form]
+ return [my form]
}
} else {
set nsform [ns_getform]
set item_id [ns_set get $nsform item_id] ;# item_id should be be hardcoded
set new_p [ns_set get $nsform __new_p]
- my log "--F item_id '$item_id', confirmed_p new_p '$new_p' [my set item_id]"
+ #my log "--F item_id '$item_id', confirmed_p new_p '$new_p' [my set item_id]"
if {$item_id ne "" && $new_p ne "1" && [my exists edit_form]} {
- my log "--F use edit_form [my edit_form]"
- return [my edit_form]
+ #my log "--F use edit_form [my edit_form]"
+ return [my edit_form]
} else {
- return [my form]
+ return [my form]
}
}
}
@@ -299,41 +297,39 @@
@return cr item object
} {
- #my log "-- [self args]"
+ my log "-- [self args]"
if {![::xotcl::Object isobject $object]} {
# if the object does not yet exist, we have to create it
my create $object
}
- my instvar table_name
- $object instvar parent_id
set raw_atts [concat [[self class] set common_query_atts] [my edit_atts]]
- set atts [list data]
+ set atts [list]
foreach v $raw_atts {
- catch {$object instvar $v}
switch -- $v {
- name {set fq i.$v}
- creation_date {set fq o.$v}
- default {set fq n.$v}
+ name {set fq i.$v}
+ creation_date {set fq o.$v}
+ package_id {set fq o.$v}
+ text {set fq "n.data as text"}
+ default {set fq n.$v}
}
lappend atts $fq
}
if {$revision_id} {
- db_1row note_select "\
+ $object db_1row note_select "\
select [join $atts ,], i.parent_id \
from [my set table_name]i n, cr_items i,acs_objects o \
- where n.revision_id = :revision_id \
+ where n.revision_id = $revision_id \
and i.item_id = n.item_id \
and o.object_id = i.item_id"
} else {
- db_1row note_select "\
+ $object db_1row note_select "\
select [join $atts ,], i.parent_id \
from [my set table_name]i n, cr_items i, acs_objects o \
- where i.item_id = :item_id \
+ where i.item_id = $item_id \
and n.[my id_column] = i.live_revision \
and o.object_id = i.item_id"
}
- $object set text $data
- $object set item_id $item_id
+ #my log "--AFTER FETCH\n[$object serialize]"
$object initialize_loaded_object
return $object
}
@@ -352,7 +348,7 @@
@param revision_id revision-id of the item to be retrieved.
} {
my fetch_object -object ::[expr {$revision_id ? $revision_id : $item_id}] \
- -item_id $item_id -revision_id $revision_id
+ -item_id $item_id -revision_id $revision_id
}
CrClass ad_instproc delete {
@@ -395,9 +391,9 @@
lappend attributes $a
}
set type_selection [expr {$with_subtypes ?
- "acs_object_types.tree_sortkey between \
+ "acs_object_types.tree_sortkey between \
'$object_type_key' and tree_right('$object_type_key')" :
- "acs_object_types.tree_sortkey = '$object_type_key'"}]
+ "acs_object_types.tree_sortkey = '$object_type_key'"}]
if {$count} {
set attribute_selection "count(*)"
set order_clause "" ;# no need to order when we count
@@ -420,7 +416,7 @@
and acs_object_types.object_type = ci.content_type
and ci.live_revision = cr.revision_id
and parent_id = $folder_id and acs_objects.object_id = cr.revision_id \
- $where_clause $order_clause $pagination"
+ $where_clause $order_clause $pagination"
}
CrClass ad_instproc instantiate_all {
@@ -441,32 +437,59 @@
set __attributes [list]
foreach a [concat [list ci.item_id acs_objects.object_type] \
- $select_attributes] {
+ $select_attributes] {
lappend __attributes [lindex [split $a .] end]
}
db_foreach instance_select \
- [my instance_select_query \
- -folder_id $folder_id \
- -select_attributes $select_attributes \
- -with_subtypes $with_subtypes \
- -where_clause $where_clause \
- -order_clause $order_clause \
- -page_size $page_size -page_number $page_number] {
- set __o [$object_type create ${__result}::$item_id]
- $__result add $__o
- #my log "-- $__result add $__o, $object_type $item_id"
- foreach __a $__attributes {$__o set $__a [set $__a]}
- }
+ [my instance_select_query \
+ -folder_id $folder_id \
+ -select_attributes $select_attributes \
+ -with_subtypes $with_subtypes \
+ -where_clause $where_clause \
+ -order_clause $order_clause \
+ -page_size $page_size -page_number $page_number] {
+ set __o [$object_type create ${__result}::$item_id]
+ $__result add $__o
+ #my log "-- $__result add $__o, $object_type $item_id"
+ foreach __a $__attributes {$__o set $__a [set $__a]}
+ }
return $__result
}
+ CrClass ad_instproc instantiate_objects {
+ {-dbn ""}
+ {-sql ""}
+ {-full_statement_name ""}
+ } {
+ Return a set of instances of folder objects. If the ...
+ } {
+ set __result [::xo::OrderedComposite new]
+ uplevel #1 [list $__result volatile]
+ #$__result proc destroy {} {my log "-- "; next}
+ db_with_handle -dbn $dbn db {
+ set selection [db_exec select $db $full_statement_name $sql]
+ while {1} {
+ set continue [ns_db getrow $db $selection]
+ if {!$continue} break
+ set o [Object new]
+ foreach {att val} [ns_set array $selection] {$o set $att $val}
+
+ if {[$o exists object_type]} {
+ # set the object type if it looks like from xotcl
+ if {[string match "::*" [set ot [$o set object_type]] ]} {
+ $o class $ot
+ }
+ }
+ #my log "--DB more = $continue [$o serialize]"
+ $__result add $o
+ }
+ }
+ return $__result
+ }
+
Class create Attribute -parameter {attribute_name datatype pretty_name}
- # create new objects as child of the callers namespace
- #Attribute proc new args {
- # eval next -childof [uplevel namespace current] $args
- #}
Class create CrItem
CrItem instproc initialize_loaded_object {} {
@@ -482,11 +505,11 @@
@return object containing the attributes of the CrItem
} {
set object_type [ns_cache eval xotcl_object_type_cache \
- [expr {$item_id ? $item_id : $revision_id}] {
+ [expr {$item_id ? $item_id : $revision_id}] {
if {$item_id} {
- db_1row get_class "select content_type as object_type from cr_items where item_id=$item_id"
+ db_1row get_class "select content_type as object_type from cr_items where item_id=$item_id"
} else {
- db_1row get_class "select object_type from acs_objects where object_id=$revision_id"
+ db_1row get_class "select object_type from acs_objects where object_id=$revision_id"
}
return $object_type
}]
@@ -513,7 +536,7 @@
@return item_id or 0 if not successful
} {
if {[db_0or1row entry_exists_select "\
- select item_id from cr_items where name = :name and parent_id = :parent_id" ]} {
+ select item_id from cr_items where name = :name and parent_id = :parent_id" ]} {
#my log "-- found $item_id for $name in folder '$parent_id'"
return $item_id
}
@@ -531,13 +554,13 @@
array unset info
# uncomment the following line, if you want to force db_0or1row for update operations
# (e.g. when useing the provided patch for the content repository in a 5.2 installation)
- #CrItem set insert_view_operation db_0or1row
+ CrItem set insert_view_operation db_0or1row
CrItem instproc update_content_length {storage_type revision_id} {
if {$storage_type eq "file"} {
db_dml update_content_length "update cr_revisions \
- set content_length = [file size [my set import_file]] \
- where revision_id = $revision_id"
+ set content_length = [file size [my set import_file]] \
+ where revision_id = $revision_id"
}
}
@@ -547,9 +570,10 @@
changing the current revision.
} {
set __atts [concat \
- [list item_id revision_id creation_user] \
- [[my info class] edit_atts]]
+ [list item_id revision_id creation_user] \
+ [[my info class] edit_atts]]
# "name" is not part of the *i rule, ignore it for now
+ # TODO: are all atts really useful here? also in save_new
set __p [lsearch $__atts name]
if {$__p > -1} {set __atts [lreplace $__atts $__p $__p]}
@@ -560,12 +584,12 @@
[my info class] instvar storage_type
set revision_id [db_nextval acs_object_id_seq]
if {$storage_type eq "file"} {
- my instvar import_file
- set text [cr_create_content_file $item_id $revision_id $import_file]
+ my instvar import_file
+ set text [cr_create_content_file $item_id $revision_id $import_file]
}
$insert_view_operation revision_add \
- "insert into [[my info class] set table_name]i ([join $__atts ,]) \
- values (:[join $__atts ,:])"
+ "insert into [[my info class] set table_name]i ([join $__atts ,]) \
+ values (:[join $__atts ,:])"
my update_content_length $storage_type $revision_id
db_0or1row make_live {select content_item__set_live_revision(:revision_id)}
}
@@ -584,6 +608,7 @@
my instvar $__var
lappend __atts $__var
if {![info exists $__var]} {set $__var ""}
+ #my log "--V importing var $__var"
}
set creation_user [expr {[ad_conn isconnected] ? [ad_conn user_id] : ""}]
@@ -600,22 +625,24 @@
$__class folder_type -folder_id $parent_id register
db_dml lock_objects "LOCK TABLE acs_objects IN SHARE ROW EXCLUSIVE MODE"
set item_id [db_string insert_item "\
- select content_item__new(:name,$parent_id,null,null,null,:creation_user,null,null,\
- 'content_item',:object_type,null,:description,:mime_type,\
- :nls_language,null,null,null,'f',:storage_type,\
- $package_id)"]
+ select content_item__new(:name,$parent_id,null,null,null,\
+ :creation_user,null,null,\
+ 'content_item',:object_type,null,:description,:mime_type,\
+ :nls_language,null,null,null,'f',:storage_type, $package_id)"]
set revision_id [db_nextval acs_object_id_seq]
if {$storage_type eq "file"} {
- set text [cr_create_content_file $item_id $revision_id $import_file]
+ set text [cr_create_content_file $item_id $revision_id $import_file]
}
+ #my log "--V atts=([join $__atts ,])\nvalues=(:[join $__atts ,:])"
$insert_view_operation revision_add \
- "insert into [$__class set table_name]i ([join $__atts ,]) \
- values (:[join $__atts ,:])"
+ "insert into [$__class set table_name]i ([join $__atts ,]) \
+ values (:[join $__atts ,:])"
my update_content_length $storage_type $revision_id
db_0or1row make_live {select content_item__set_live_revision(:revision_id)}
}
- my set last_modified [db_string get_last_modified {select last_modified from acs_objects where object_id = :revision_id}]
+ my db_1row get_dates {select creation_date, last_modified \
+ from acs_objects where object_id = :revision_id}
return $item_id
}
@@ -630,20 +657,20 @@
::Generic::CrItem instproc revisions {} {
TableWidget t1 -volatile \
- -columns {
- Field version_number -label "" -html {align right}
- ImageField edit -label "" -src /resources/acs-subsite/Zoom16.gif \
- -title "View Item" -alt "view" \
- -width 16 -height 16 -border 0
- 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]
- ImageField live_revision -label [_ xotcl-core.live_revision] \
- -src /resources/acs-subsite/radio.gif \
- -width 16 -height 16 -border 0 -html {align center}
- ImageField_DeleteIcon version_delete -label "" -html {align center}
- }
+ -columns {
+ Field version_number -label "" -html {align right}
+ ImageField edit -label "" -src /resources/acs-subsite/Zoom16.gif \
+ -title "View Item" -alt "view" \
+ -width 16 -height 16 -border 0
+ 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]
+ ImageField live_revision -label [_ xotcl-core.live_revision] \
+ -src /resources/acs-subsite/radio.gif \
+ -width 16 -height 16 -border 0 -html {align center}
+ ImageField_DeleteIcon version_delete -label "" -html {align center}
+ }
set user_id [ad_conn user_id]
set page_id [my set item_id]
@@ -652,57 +679,57 @@
set base [$package_id url]
db_foreach revisions_select \
- "select ci.name, n.revision_id as version_id,
+ "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,
r.content_length,
- content_revision__get_number(n.revision_id) as version_number
+ content_revision__get_number(n.revision_id) as version_number
from cr_revisionsi n, cr_items ci, cr_revisions r
where ci.item_id = n.item_id and ci.item_id = :page_id
and r.revision_id = n.revision_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" {
-
- 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]"
- }
+ order by n.revision_id desc" {
+
+ 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]
+ 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
- }
+ 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}}]
- t1 add \
- -version_number $version_number: \
- -edit.href [export_vars -base $base {{revision_id $version_id}}] \
- -author $author \
- -content_size $content_size_pretty \
- -last_modified_ansi [lc_time_fmt $last_modified_ansi "%x %X"] \
- -description $description \
- -live_revision.src $live_revision_icon \
- -live_revision.title $live_revision \
- -live_revision.href $live_revision_link \
- -version_delete.href [export_vars -base $base \
- {{m delete-revision} {revision_id $version_id}}] \
- -version_delete.title [_ file-storage.Delete_Version]
- }
+ set live_revision_link [export_vars -base $base \
+ {{m make-live-revision} {revision_id $version_id}}]
+ t1 add \
+ -version_number $version_number: \
+ -edit.href [export_vars -base $base {{revision_id $version_id}}] \
+ -author $author \
+ -content_size $content_size_pretty \
+ -last_modified_ansi [lc_time_fmt $last_modified_ansi "%x %X"] \
+ -description $description \
+ -live_revision.src $live_revision_icon \
+ -live_revision.title $live_revision \
+ -live_revision.href $live_revision_link \
+ -version_delete.href [export_vars -base $base \
+ {{m delete-revision} {revision_id $version_id}}] \
+ -version_delete.title [_ file-storage.Delete_Version]
+ }
return [t1 asHTML]
}
@@ -733,7 +760,7 @@
set r [next]
#my log "--CACHE saving [self] in cache"
ns_cache set xotcl_object_cache [self] \
- [::Serializer deepSerialize [self]]
+ [::Serializer deepSerialize [self]]
return $r
}
CrCache::Item instproc save_new args {
@@ -797,10 +824,12 @@
set folder_id [$data set parent_id]
if {![my exists add_page_title]} {
- my set add_page_title [_ xotcl-core.create_new_type [list type [$class pretty_name]]]
+ my set add_page_title [_ xotcl-core.create_new_type \
+ [list type [$class pretty_name]]]
}
if {![my exists edit_page_title]} {
- my set edit_page_title [_ xotcl-core.edit_type [list type [$class pretty_name]]]
+ my set edit_page_title [_ xotcl-core.edit_type \
+ [list type [$class pretty_name]]]
}
# check, if the specified fields are available from the data source
@@ -843,27 +872,34 @@
set old_name [ns_set get [ns_getform] __object_name]
set new_name [$data set name]
if {$old_name ne $new_name} {
- db_dml update_rename "update cr_items set name = :new_name \
- where item_id = [$data set item_id]"
+ db_dml update_rename "update cr_items set name = :new_name \
+ where item_id = [$data set item_id]"
}
}
return [$data set item_id]
}
+
Form instproc request {privilege} {
my instvar edit_form_page_title context
+
+ # TODO: is not needed in the xowiki context with the policy
auth::require_login
- permission::require_permission -object_id [ad_conn package_id] -privilege $privilege
+ permission::require_permission \
+ -object_id [ad_conn package_id] \
+ -privilege $privilege
+
set edit_form_page_title [expr {$privilege eq "create" ?
- [my add_page_title] : [my edit_page_title]}]
+ [my add_page_title] : [my edit_page_title]}]
set context [list $edit_form_page_title]
}
+
Form instproc new_request {} {
my log "--- new_request ---"
my request create
my instvar data
foreach var [[$data info class] edit_atts] {
if {[$data exists $var]} {
- my var $var [list [$data set $var]]
+ my var $var [list [$data set $var]]
}
}
}
@@ -872,7 +908,9 @@
my log "--- edit_request ---"
my request write
foreach var [[$data info class] edit_atts] {
- my var $var [list [$data set $var]]
+ if {[$data exists $var]} {
+ my var $var [list [$data set $var]]
+ }
}
}
@@ -916,12 +954,11 @@
#my log "--e [my name] final fields [my fields]"
set exports [list [list object_type $object_type] \
- [list folder_id $folder_id] \
- [list __object_name $object_name]]
+ [list folder_id $folder_id] \
+ [list __object_name $object_name]]
if {[info exists export]} {foreach pair $export {lappend exports $pair}}
- my log "--F -export $exports -action [my action] -html [my html]"
ad_form -name [my name] -form [my fields] \
- -export $exports -action [my action] -html [my html]
+ -export $exports -action [my action] -html [my html]
set new_data "set item_id \[[self] new_data\]"
set edit_data "set item_id \[[self] edit_data\]"
@@ -934,37 +971,36 @@
if {[my with_categories]} {
set coid [expr {[$data exists item_id] ? [$data set item_id] : ""}]
category::ad_form::add_widgets -form_name [my name] \
- -container_object_id [ad_conn package_id] \
- -categorized_object_id $coid
+ -container_object_id [ad_conn package_id] \
+ -categorized_object_id $coid
append new_data {
- category::map_object -remove_old -object_id $item_id $category_ids
- #ns_log notice "-- new data category::map_object -remove_old -object_id $item_id $category_ids"
- db_dml insert_asc_named_object \
- "insert into acs_named_objects (object_id,object_name,package_id) \
+ category::map_object -remove_old -object_id $item_id $category_ids
+ #ns_log notice "-- new data category::map_object -remove_old -object_id $item_id $category_ids"
+ db_dml insert_asc_named_object \
+ "insert into acs_named_objects (object_id,object_name,package_id) \
values (:item_id, :name, :package_id)"
}
append edit_data {
- db_dml update_asc_named_object \
- "update acs_named_objects set object_name = :name, \
- package_id = :package_id where object_id = :item_id"
- #ns_log notice "-- edit data category::map_object -remove_old -object_id $item_id $category_ids"
- category::map_object -remove_old -object_id $item_id $category_ids
+ db_dml update_asc_named_object \
+ "update acs_named_objects set object_name = :name, \
+ package_id = :package_id where object_id = :item_id"
+ #ns_log notice "-- edit data category::map_object -remove_old -object_id $item_id $category_ids"
+ category::map_object -remove_old -object_id $item_id $category_ids
}
append on_submit {
- set category_ids [category::ad_form::get_categories \
- -container_object_id $package_id]
+ set category_ids [category::ad_form::get_categories \
+ -container_object_id $package_id]
}
}
-
#ns_log notice "-- ad_form new_data=<$new_data> edit_data=<$edit_data> edit_request=<$edit_request>"
-
+
# action blocks must be added last
ad_form -extend -name [my name] \
- -validate [my validate] \
- -new_data $new_data -edit_data $edit_data -on_submit $on_submit \
- -new_request $new_request -edit_request $edit_request \
- -on_validation_error $on_validation_error -after_submit $after_submit
+ -validate [my validate] \
+ -new_data $new_data -edit_data $edit_data -on_submit $on_submit \
+ -new_request $new_request -edit_request $edit_request \
+ -on_validation_error $on_validation_error -after_submit $after_submit
}
#
@@ -1016,9 +1052,9 @@
set actions [list]
foreach object_type $object_types {
lappend actions \
- "Add [$object_type pretty_name]" \
- [export_vars -base [my edit_link] {object_type folder_id}] \
- "Add a new item of kind [$object_type pretty_name]"
+ "Add [$object_type pretty_name]" \
+ [export_vars -base [my edit_link] {object_type folder_id}] \
+ "Add a new item of kind [$object_type pretty_name]"
}
return $actions
}
@@ -1031,42 +1067,42 @@
set elements [list]
foreach {e spec} [my fields] {
switch -exact $e {
- EDIT {
- lappend elements edit {
- link_url_col edit_url
- display_template {
- 
- }
- sub_class narrow
- }
- }
- DELETE {
- lappend elements delete {
- link_url_col delete_url
- display_template {
- 
- }
- sub_class narrow
- }
- }
- VIEW {
- lappend elements view {
- link_url_col view_url
- display_template {
- 
- }
- sub_class narrow
- }
- }
- default {
- lappend elements $e $spec
- }
+ EDIT {
+ lappend elements edit {
+ link_url_col edit_url
+ display_template {
+
+ }
+ sub_class narrow
+ }
+ }
+ DELETE {
+ lappend elements delete {
+ link_url_col delete_url
+ display_template {
+
+ }
+ sub_class narrow
+ }
+ }
+ VIEW {
+ lappend elements view {
+ link_url_col view_url
+ display_template {
+
+ }
+ sub_class narrow
+ }
+ }
+ default {
+ lappend elements $e $spec
+ }
}
}
return $elements
@@ -1094,28 +1130,28 @@
set select_attributes [list]
foreach {e spec} [my fields] {
if {[lsearch -exact {item_id object_type EDIT DELETE VIEW} $e] == -1} {
- lappend select_attributes $e
+ lappend select_attributes $e
}
}
template::list::create \
- -name $template \
- -actions [my actions] \
- -elements [my elements]
+ -name $template \
+ -actions [my actions] \
+ -elements [my elements]
db_multirow \
- -extend {
- edit_url
- delete_url
- view_url
- } $template instance_select [$object_type instance_select_query \
- -folder_id [my folder_id] \
- -select_attributes $select_attributes \
+ -extend {
+ edit_url
+ delete_url
+ view_url
+ } $template instance_select [$object_type instance_select_query \
+ -folder_id [my folder_id] \
+ -select_attributes $select_attributes \
-with_subtypes $with_subtypes \
- -order_clause $order_clause] {
+ -order_clause $order_clause] {
set view_url [export_vars -base [my view_link] {item_id}]
- set edit_url [export_vars -base [my edit_link] {item_id}]
- set delete_url [export_vars -base [my delete_link] {item_id}]
+ set edit_url [export_vars -base [my edit_link] {item_id}]
+ set delete_url [export_vars -base [my delete_link] {item_id}]
}
}
Index: openacs-4/packages/xotcl-core/tcl/object-cache-init.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/object-cache-init.tcl,v
diff -u -r1.3 -r1.4
--- openacs-4/packages/xotcl-core/tcl/object-cache-init.tcl 24 Feb 2006 14:33:58 -0000 1.3
+++ openacs-4/packages/xotcl-core/tcl/object-cache-init.tcl 17 Aug 2006 01:27:54 -0000 1.4
@@ -2,3 +2,4 @@
ns_cache create xotcl_object_cache -size 200000
ns_cache create xotcl_object_type_cache -size 10000
# [ad_parameter -package_id [ad_acs_kernel_id] MaxSize memoize 200000]
+
Index: openacs-4/packages/xotcl-core/www/cache.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/cache.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/www/cache.adp 17 Aug 2006 01:27:54 -0000 1.1
@@ -0,0 +1,13 @@
+@title@
+Memory Caches
+Data for cache_item $item of cache $cache
"
+ append output "
Items in cache $cache ($item_count) with size [ns_cache_size $cache]
- "
+ foreach name [lsort -dictionary $item_list] {
+ append output "
- $name (flush) " + } + append output "