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 -r1.1 -r1.2
--- openacs-4/packages/xotcl-core/xotcl-core.info 11 Oct 2005 08:41:17 -0000 1.1
+++ openacs-4/packages/xotcl-core/xotcl-core.info 14 Dec 2005 15:55:28 -0000 1.2
@@ -8,10 +8,10 @@
<singleton-p>t</singleton-p>
<auto-mount>xotcl</auto-mount>
- <version name="0.15" url="http://media.wu-wien.ac.at/download/xotcl-core-0.15.apm">
+ <version name="0.27" url="http://media.wu-wien.ac.at/download/xotcl-core-0.27.apm">
<owner url="mailto:neumann@wu-wien.ac.at">Gustaf Neumann</owner>
- <summary>XOTcl library functionality (e.g. thread handling, online documentation)</summary>
- <release-date>2005-10-07</release-date>
+ <summary>XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)</summary>
+ <release-date>2005-12-08</release-date>
<description format="text/html">This component contains some core functionality for OACS
applications using XOTcl. It includes
XOTcl thread handling for OACS (supporting persistent and
@@ -22,9 +22,10 @@
and ad_instproc. This component provides as
well an XOTcl Object and Class browser, as well as
means to control the recreation of objects and classes
-when components are reloaded.</description>
+when components are reloaded. 0.23 contains a major overhaul of the Generic classes. Object preliminary object layer for content repository, oo templating.</description>
+ <maturity>0</maturity>
- <provides url="xotcl-core" version="0.15"/>
+ <provides url="xotcl-core" version="0.27"/>
<callbacks>
</callbacks>
Index: openacs-4/packages/xotcl-core/catalog/xotcl-core.de_DE.ISO-8859-1.xml
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/catalog/xotcl-core.de_DE.ISO-8859-1.xml,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/catalog/xotcl-core.de_DE.ISO-8859-1.xml 14 Dec 2005 15:57:52 -0000 1.1
@@ -0,0 +1,7 @@
+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" package_version="0.18" locale="de_DE" charset="ISO-8859-1">
+
+ <msg key="live_revision">Aktuelle Version</msg>
+ <msg key="revision_title">Versionen des Eintrags</msg>
+ <msg key="revisions">Verlauf</msg>
+</message_catalog>
Index: openacs-4/packages/xotcl-core/catalog/xotcl-core.de_DE.ISO-8859-1.xml.orig
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/catalog/Attic/xotcl-core.de_DE.ISO-8859-1.xml.orig,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/catalog/xotcl-core.de_DE.ISO-8859-1.xml.orig 14 Dec 2005 15:57:52 -0000 1.1
@@ -0,0 +1,7 @@
+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" package_version="0.18" locale="de_DE" charset="ISO-8859-1">
+
+ <msg key="live_revision">Aktuelle Version</msg>
+ <msg key="revision_title">Versionen des Eintrags</msg>
+ <msg key="revisions">Verlauf</msg>
+</message_catalog>
Index: openacs-4/packages/xotcl-core/catalog/xotcl-core.en_US.ISO-8859-1.xml
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/catalog/xotcl-core.en_US.ISO-8859-1.xml,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/catalog/xotcl-core.en_US.ISO-8859-1.xml 14 Dec 2005 15:57:52 -0000 1.1
@@ -0,0 +1,7 @@
+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" package_version="0.17" locale="en_US" charset="ISO-8859-1">
+
+ <msg key="live_revision">Live Revision</msg>
+ <msg key="revision_title">Revisions of Entry</msg>
+ <msg key="revisions">Revisions</msg>
+</message_catalog>
Index: openacs-4/packages/xotcl-core/lib/revisions-postgresql.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/lib/revisions-postgresql.xql,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/lib/revisions-postgresql.xql 14 Dec 2005 15:57:53 -0000 1.1
@@ -0,0 +1,28 @@
+<?xml version="1.0"?>
+
+<queryset>
+ <rdbms><type>postgresql</type><version>7.1</version></rdbms>
+
+ <fullquery name="revisions_info">
+ <querytext>
+ select n.title, n.revision_id as version_id,
+ person__name(n.creation_user) as author,
+ n.creation_user as author_id,
+ to_char(n.last_modified,'YYYY-MM-DD HH24:MI:SS') as last_modified_ansi,
+ n.description,
+ acs_permission__permission_p(n.revision_id,:user_id,'admin') as admin_p,
+ acs_permission__permission_p(n.revision_id,:user_id,'delete') as delete_p,
+ char_length(n.data) as content_size,
+ content_revision__get_number(n.revision_id) as version_number
+ from cr_revisionsi n, cr_items ci
+ where ci.item_id = n.item_id and ci.item_id = :page_id
+ and exists (select 1 from acs_object_party_privilege_map m
+ where m.object_id = n.revision_id
+ and m.party_id = :user_id
+ and m.privilege = 'read')
+ order by n.revision_id desc
+ </querytext>
+ </fullquery>
+</queryset>
+
+
Index: openacs-4/packages/xotcl-core/lib/revisions.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/lib/revisions.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/lib/revisions.adp 14 Dec 2005 15:57:53 -0000 1.1
@@ -0,0 +1 @@
+<listtemplate name="revisions"></listtemplate>
Index: openacs-4/packages/xotcl-core/lib/revisions.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/lib/revisions.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/lib/revisions.tcl 14 Dec 2005 15:57:53 -0000 1.1
@@ -0,0 +1,99 @@
+ad_page_contract {
+ display information about revisions of content items
+
+ @author Gustaf Neumann (gustaf.neumann@wu-wien.ac.at)
+ @creation-date Oct 23, 2005
+ @cvs-id $Id: revisions.tcl,v 1.1 2005/12/14 15:57:53 maltes Exp $
+} {
+ page_id:integer,notnull
+ {title ""}
+} -properties {
+ title:onevalue
+ context:onevalue
+ page_id:onevalue
+ revisions:multirow
+ gc_comments:onevalue
+}
+
+# check they have read permission on content item
+permission::require_permission -object_id $page_id -privilege read
+
+set user_id [ad_conn user_id]
+set live_revision_id [content::item::get_live_revision -item_id $page_id]
+
+template::list::create \
+ -name revisions \
+ -no_data [_ file-storage.lt_There_are_no_versions] \
+ -multirow revisions \
+ -elements {
+ version_number {label "" html {align right}}
+ title { label ""
+ display_template {
+ <img src='/resources/acs-subsite/Zoom16.gif' \
+ title='View Item' alt='view' \
+ width="16" height="16" border="0">
+ }
+ sub_class narrow
+ link_url_col version_link
+ }
+ author { label #file-storage.Author#
+ display_template {@revisions.author_link;noquote@}
+ }
+ content_size { label #file-storage.Size# html {align right}
+ display_col content_size_pretty
+ }
+ last_modified_ansi { label #file-storage.Last_Modified#
+ display_col last_modified_pretty
+ }
+ description { label #file-storage.Version_Notes#}
+ live_revision { label #xotcl-core.live_revision#
+ display_template {
+ <a href='@revisions.live_revision_link@'> \
+ <img src='@revisions.live_revision_icon@' \
+ title='@revisions.live_revision@' alt='@revisions.live_revision@' \
+ width="16" height="16" border="0"></a>
+ }
+ html {align center}
+ sub_class narrow
+ }
+ version_delete { label "" link_url_col version_delete_link
+ display_template {
+ <img src='/resources/acs-subsite/Delete16.gif' \
+ title='Delete Revision' alt='delete' \
+ width="16" height="16" border="0">
+ }
+ html {align center}
+ }
+ }
+
+db_multirow -unclobber -extend {
+ author_link last_modified_pretty
+ content_size_pretty version_link version_delete version_delete_link
+ live_revision live_revision_icon live_revision_link
+} revisions revisions_info {} {
+ set version_number $version_number:
+ set last_modified_ansi [lc_time_system_to_conn $last_modified_ansi]
+ set last_modified_pretty [lc_time_fmt $last_modified_ansi "%x %X"]
+ if {$content_size < 1024} {
+ set content_size_pretty "[lc_numeric $content_size] [_ file-storage.bytes]"
+ } else {
+ set content_size_pretty "[lc_numeric [format %.2f [expr {$content_size/1024.0}]]] [_ file-storage.kb]"
+ }
+
+ if {$title eq ""} {set title [_ file-storage.untitled]}
+ set live_revision_link [export_vars -base make-live-revision \
+ {page_id title {revision_id $version_id}}]
+ set version_delete_link [export_vars -base delete-revision \
+ {page_id title {revision_id $version_id}}]
+ set version_link [export_vars -base view {{revision_id $version_id} {item_id $page_id}}]
+ if {$version_id != $live_revision_id} {
+ set live_revision "Make this Revision Current"
+ set live_revision_icon /resources/acs-subsite/radio.gif
+ } else {
+ set live_revision "Current Live Revision"
+ set live_revision_icon /resources/acs-subsite/radiochecked.gif
+ }
+ set version_delete [_ file-storage.Delete_Version]
+ set author_link [acs_community_member_link -user_id $author_id -label $author]
+}
+
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.1 -r1.2
--- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1
+++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 14 Dec 2005 15:55:29 -0000 1.2
@@ -2,11 +2,17 @@
::Serializer exportMethods {
::xotcl::Object instproc log
::xotcl::Object instproc debug
+ ::xotcl::Object instproc contains
}
+::xotcl::Object instproc contains cmds {
+ my requireNamespace
+ namespace eval [self] $cmds
+}
+
::xotcl::Object instproc log msg {
- ns_log notice "[self] $msg"
+ ns_log notice "[self] [self callingclass]->[self callingproc]: $msg"
}
::xotcl::Object instproc debug msg {
- ns_log debug "[self] $msg"
+ ns_log debug "[self] [self callingclass]->[self callingproc]: $msg"
}
\ No newline at end of file
Index: openacs-4/packages/xotcl-core/tcl/05-doc-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/05-doc-procs.tcl,v
diff -u -r1.1 -r1.2
--- openacs-4/packages/xotcl-core/tcl/05-doc-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1
+++ openacs-4/packages/xotcl-core/tcl/05-doc-procs.tcl 14 Dec 2005 15:55:29 -0000 1.2
@@ -20,21 +20,14 @@
::xotcl::Class instproc ad_instproc
::xotcl::Object instproc ad_doc
::xotcl::Object instproc __api_make_doc
+ ::xotcl::Object instproc __api_make_forward_doc
}
::Serializer exportObjects {
::xotcl::api
}
::xotcl::Object create ::xotcl::api \
- -proc split_arguments {} {
- my upvar args args arguments arguments doc doc body body
- if {[llength $args]==3} {
- foreach {arguments doc body} $args break
- } else {
- error "wrong number of arguments provided to ad_proc or ad_instproc"
- }
-
- } -proc isclass {scope obj} {
+ -proc isclass {scope obj} {
if {$scope eq ""} {
set isclass [::xotcl::Object isclass $obj]
} else {
@@ -59,7 +52,7 @@
return $scope
} -proc inscope {scope args} {
- expr {$scope eq "" ? [eval $args] : [$scope do $args]}
+ expr {$scope eq "" ? [eval $args] : [eval $scope do $args]}
} -proc script_name {scope} {
#set kind [expr {[my istype ::xotcl::Class] ? "Class" : "Object"}]
@@ -180,28 +173,78 @@
nsv_set api_proc_doc $proc_index [array get doc_elements]
}
-::xotcl::Object instproc ad_proc {
- {-private:switch false}
- {-deprecated:switch false}
- {-warn:switch false}
- {-debug:switch false}
-} {proc_name args} {
- ::xotcl::api split_arguments
- uplevel [list [self] proc $proc_name $arguments $body]
- my __api_make_doc "" $proc_name
+::xotcl::Object instproc __api_make_forward_doc {inst method_name} {
+ upvar doc doc private private public public deprecated deprecated
+ if {$doc eq ""} {
+ set doc_elements(main) ""
+ } else {
+ ad_parse_documentation_string $doc doc_elements
+ #my log "doc_elements=[array get doc_elements]"
+ }
+ set defaults [list]
+ set public [expr {$private ? false : true}]
+ set doc_elements(public_p) $public
+ set doc_elements(private_p) $private
+ set doc_elements(deprecated_p) $deprecated
+ set doc_elements(varargs_p) false
+ set doc_elements(flags) [list]
+ set doc_elements(switches) [list]
+ set doc_elements(default_values) [list]
+ set doc_elements(positionals) [list]
+ # argument documentation finished
+ set scope [::xotcl::api scope]
+ set doc_elements(script) [::xotcl::api script_name $scope]
+ set proc_index [::xotcl::api proc_index $scope [self] ${inst}forward $method_name]
+ if {![nsv_exists api_proc_doc $proc_index]} {
+ nsv_lappend api_proc_doc_scripts $doc_elements(script) $proc_index
+ }
+ my log "doc_elements=[array get doc_elements]"
+ my log "SETTING api_proc_doc '$proc_index'"
+ nsv_set api_proc_doc $proc_index [array get doc_elements]
}
+::xotcl::Object instproc ad_proc {
+ {-private:switch false}
+ {-deprecated:switch false}
+ {-warn:switch false}
+ {-debug:switch false}
+ proc_name arguments doc body} {
+ uplevel [list [self] proc $proc_name $arguments $body]
+ my __api_make_doc "" $proc_name
+ }
+
+::xotcl::Object instproc ad_forward {
+ {-private:switch false}
+ {-deprecated:switch false}
+ {-warn:switch false}
+ {-debug:switch false}
+ method_name doc args} {
+ uplevel [self] forward $method_name $args
+ my __api_make_forward_doc "" $method_name
+ }
+
::xotcl::Class instproc ad_instproc {
{-private:switch false}
{-deprecated:switch false}
{-warn:switch false}
{-debug:switch false}
-} {proc_name args} {
- ::xotcl::api split_arguments
- uplevel [list [self] instproc $proc_name $arguments $body]
- my __api_make_doc inst $proc_name
-}
+ proc_name arguments doc body} {
+ uplevel [list [self] instproc $proc_name $arguments $body]
+ my __api_make_doc inst $proc_name
+ }
+::xotcl::Object instproc ad_instforward {
+ {-private:switch false}
+ {-deprecated:switch false}
+ {-warn:switch false}
+ {-debug:switch false}
+ method_name doc args} {
+ uplevel [self] instforward $method_name $args
+ my __api_make_forward_doc inst $method_name
+ }
+
+
+
::xotcl::Object instproc ad_doc {doc_string} {
ad_parse_documentation_string $doc_string doc_elements
set scope [::xotcl::api scope]
Index: openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl,v
diff -u -r1.1 -r1.2
--- openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1
+++ openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 14 Dec 2005 15:55:29 -0000 1.2
@@ -8,7 +8,7 @@
XOTcl provides support for altering this behavior through
the recreate method.
- @author Gustaf Neumann
+ @author Gustaf Neumann (neumann@wu-wien.ac.at)
@creation-date 2005-05-13
@cvs-id $Id$
}
@@ -54,7 +54,7 @@
{instreinit}
} -superclass ::xotcl::Class \
-instproc recreate {obj args} {
- my log "### recreateclass instproc $obj <$args>"
+ #my log "### recreateclass instproc $obj <$args>"
# the minimal reconfiguration is to set the class and remove methods
$obj class [self]
foreach p [$obj info procs] {$obj proc $p {} {}}
@@ -133,19 +133,27 @@
} {
# clean on the object level
my log "+++ instproc recreate $obj <$args> old class = [$obj info class], new class = [self]"
+ $obj filter set {}
+ $obj mixin set {}
set cl [self]
- $obj class $cl
- foreach p [$obj info procs] {$obj proc $p {} {}}
+ foreach p [$obj info commands] {$obj proc $p {} {}}
foreach c [$obj info children] {
my log "recreate destroy <$c destroy"
$c destroy
}
- foreach var [$obj info vars] {$obj unset $var}
- $obj mixin set {}
- $obj filter set {}
+ #my log "+++ $obj recreate unset vars"
+ #my log "+++ $obj vars = {[$obj info vars]}"
+ foreach var [$obj info vars] {
+ #my log "$obj unset $var"
+ $obj unset $var
+ }
+ #my log "+++ $obj recreate unset vars done"
+ # set p new values
+ $obj class $cl
set pcl [$cl info parameterclass]
+ #my log "+++ $obj recreate calling searchDefaults"
$pcl searchDefaults $obj
- #my log "+++ recreate calling $obj configure $args"
+ #my log "+++ $obj recreate calling $obj configure $args"
set pos [eval $obj configure $args]
#my log "+++ recreate instproc configure returns $pos"
if {[lsearch -exact $args -init] == -1} {
@@ -155,7 +163,10 @@
}
}
+#::xotcl::Object instforward unset -objscope
+# ::xotcl::Object instforward unset
::Serializer exportMethods {
::xotcl::Class instproc recreate
::xotcl::Class proc recreate
+ ::xotcl::Object instforward unset
}
\ No newline at end of file
Index: openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl-old
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/10-recreation-procs.tcl-old,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl-old 14 Dec 2005 15:57:53 -0000 1.1
@@ -0,0 +1,161 @@
+ad_library {
+ Support for the recreation of classes objects without
+ destroying foreign references. Normally, when a class
+ definition is reloaded, the class is destroyed and created
+ again with the same name. During the destruction of a class
+ several references to this class are removed (e.g. in a
+ class hierarchy, the relation from instances to this class, etc.).
+ XOTcl provides support for altering this behavior through
+ the recreate method.
+
+ @author Gustaf Neumann
+ @creation-date 2005-05-13
+ @cvs-id $Id: 10-recreation-procs.tcl-old,v 1.1 2005/12/14 15:57:53 maltes Exp $
+}
+
+if {![::xotcl::Object isclass ::xotcl::RecreationClass]} {
+ ::xotcl::Class create ::xotcl::RecreationClass -ad_doc {
+ <p>This meta-class controlls the behavior of classes (and optionally
+ their instances), when the classes (or their instances) are
+ overwritten by same named new objects; we call this situation
+ a recreate of an object.</p>
+
+ <p>Normally, when files with e.g. class definitions are sourced,
+ the classes and objects are newly defined. When e.g. class
+ definitions exists already in this file, these classes are
+ deleted first before they are newly created. When a class is
+ deleted, the instances of this class are changed into
+ instances of class ::xotcl::Object. </p>
+
+ <p>This can be a problem when the class instances are not
+ reloaded and when they should survife the redefintion with the
+ same class relationships. Therefore we define a
+ meta class RecreationClass, which can be used to parameterize
+ the behavior on redefinitions. Alternatively, Classes or objects
+ could provide their own recreate methods.</p>
+
+ <p>Per default, this meta-class handles only the class redefintion
+ case and does only a reconfigure on the class object (in order
+ to get e.g. ad_doc updated).</p>
+ The following parameters are defined:
+ <ul>
+ <li><b>reconfigure:</b> reconfigure class (default 1)
+ <li><b>reinit:</b> run init after configure for this class (default unset)
+ <li><b>instrecreate:</b> handle recreate of class instances (default unset)
+ When this flag is set to 0, instreconfigure and instreinit are ignored.
+ <li><b>instreconfigure:</b> reconfigure instances of this class (default 1)
+ <li><b>instreinit:</b> re-init instances of this class (default unset)
+ </ul>
+ } -parameter {
+ {reconfigure 1}
+ {reinit}
+ {instrecreate}
+ {instreconfigure 1}
+ {instreinit}
+ } -superclass ::xotcl::Class \
+ -instproc recreate {obj args} {
+ my log "### recreateclass instproc $obj <$args>"
+ # the minimal reconfiguration is to set the class and remove methods
+ $obj class [self]
+ foreach p [$obj info procs] {$obj proc $p {} {}}
+ if {![my exists instrecreate]} {
+ #my log "### no instrecreate for $obj <$args>"
+ next
+ return
+ }
+ if {[my exists instreconfigure]} {
+ # before we set defaults, we must unset vars
+ foreach var [$obj info vars] {$obj unset $var}
+ set pcl [my info parameterclass]
+ # set defaults and run configure
+ $pcl searchDefaults $obj
+ eval $obj configure $args
+ #my log "### instproc recreate $obj + configure $args ..."
+ }
+ if {[my exists instreinit]} {
+ #my log "### instreinit for $obj <$args>"
+ eval $obj init
+ #my log "### instproc recreate $obj + init ..."
+ }
+ } -proc recreate {obj args} {
+ my log "### recreateclass proc $obj <$args>"
+ # the minimal reconfiguration is to set the class and remove methods
+ $obj class [self]
+ foreach p [$obj info instprocs] {$obj instproc $p {} {}}
+ if {[my exists reconfigure]} {
+ # before we set defaults, we must unset vars
+ foreach var [$obj info vars] {$obj unset $var}
+ set pcl [my info parameterclass]
+ $pcl searchDefaults $obj
+ # set defaults and run configure
+ eval $obj configure $args
+ }
+ if {[my exists reinit]} {
+ eval $obj init
+ }
+ }
+
+ ::Serializer exportObjects {
+ ::xotcl::RecreationClass
+ }
+}
+
+Class ad_proc recreate {obj args} {
+ The re-definition of recreate makes reloading of class definitions via
+ apm possible, since the foreign keys of the class relations
+ to these classes survive these calls. One can define specialized
+ versions of this for certain classes or use ::xotcl::RecreationClass.
+
+ Class proc recreate is called on the class level, while
+ Class instproc recreate is called on the instance level.
+
+ @param obj name of the object to be recreated
+ @param args arguments passed to recreate (might contain parameters)
+} {
+ # clean on the class level
+ #my log "proc recreate $obj $args"
+ foreach p [$obj info instprocs] {$obj instproc $p {} {}}
+ $obj instmixin set {}
+ $obj instfilter set {}
+ next ; # clean next on object level
+}
+Class ad_instproc recreate {obj args} {
+ The re-definition of recreate makes reloading of class definitions via
+ apm possible, since the foreign keys of the class relations
+ to these classes survive these calls. One can define specialized
+ versions of this for certain classes or use ::xotcl::RecreationClass.
+
+ Class proc recreate is called on the class level, while
+ Class instproc recreate is called on the instance level.
+
+ @param obj name of the object to be recreated
+ @param args arguments passed to recreate (might contain parameters)
+} {
+ # clean on the object level
+ my log "+++ instproc recreate $obj <$args> old class = [$obj info class], new class = [self]"
+ set cl [self]
+ $obj class $cl
+ foreach p [$obj info procs] {$obj proc $p {} {}}
+ foreach c [$obj info children] {
+ my log "recreate destroy <$c destroy"
+ $c destroy
+ }
+ foreach var [$obj info vars] {$obj unset $var}
+ $obj mixin set {}
+ $obj filter set {}
+ set pcl [$cl info parameterclass]
+ $pcl searchDefaults $obj
+ #my log "+++ recreate calling $obj configure $args"
+ set pos [eval $obj configure $args]
+ #my log "+++ recreate instproc configure returns $pos"
+ if {[lsearch -exact $args -init] == -1} {
+ incr pos -1
+ #my log "+++ $obj init [lrange $args 0 $pos]"
+ eval $obj init [lrange $args 0 $pos]
+ }
+}
+
+::Serializer exportMethods {
+ ::xotcl::Class instproc recreate
+ ::xotcl::Class proc recreate
+}
\ No newline at end of file
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
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 14 Dec 2005 15:57:53 -0000 1.1
@@ -0,0 +1,88 @@
+ad_library {
+ ::xo::OrderedComposite to create tree structures with aggregated
+ objects. This is similar to object aggregations, but
+ preserves the order. The OrderedComposite supports
+ hierarchical sorting.
+
+ @author Gustaf Neumann (neumann@wu-wien.ac.at)
+ @creation-date 2005-11-26
+ @cvs-id $Id: 20-Ordered-Composite-procs.tcl,v 1.1 2005/12/14 15:57:53 maltes Exp $
+}
+
+namespace eval ::xo {
+ Class OrderedComposite
+
+ OrderedComposite instproc show {} {
+ next
+ foreach child [my children] {
+ $child show
+ }
+ }
+
+ OrderedComposite instproc orderby {{-order "increasing"} variable} {
+ my set __order $order
+ my set __orderby $variable
+ }
+
+ OrderedComposite instproc __compare {a b} {
+ set by [my set __orderby]
+ set x [$a set $by]
+ set y [$b set $by]
+ if {$x < $y} {
+ return -1
+ } elseif {$x > $y} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+
+ OrderedComposite instproc children {} {
+ set children [expr {[my exists __children] ? [my set __children] : ""}]
+ if {[my exists __orderby]} {
+ set order [expr {[my exists __order] ? [my set __order] : "increasing"}]
+ return [lsort -command [list my __compare] -$order $children]
+ } else {
+ return $children
+ }
+ }
+ OrderedComposite instproc add obj {
+ my lappend __children $obj
+ $obj set __parent [self]
+ #my log "-- adding __parent [self] to $obj -- calling after_insert"
+ #$obj __after_insert
+ }
+
+ OrderedComposite instproc destroy {} {
+ # destroy all children of the ordered composite
+ foreach c [my set __children] { $c destroy }
+ next
+ }
+
+ OrderedComposite instproc contains cmds {
+ my requireNamespace ;# legacy for older xotcl versions
+ set m [Object info instmixin]
+ if {[lsearch $m [self class]::ChildManager] == -1} {
+ set insert 1
+ Object instmixin add [self class]::ChildManager
+ } else {
+ set insert 0
+ }
+ set errorOccurred [catch {namespace eval [self] $cmds} errorMsg]
+ if {$insert} {
+ Object instmixin delete [self class]::ChildManager
+ }
+ if {$errorOccurred} {error $errorMsg}
+ }
+ Class OrderedComposite::ChildManager -instproc init args {
+ set r [next]
+ [self callingobject] lappend __children [self]
+ my set __parent [self callingobject]
+ #my __after_insert
+ #my log "-- adding __parent [self callingobject] to [self]"
+ return $r
+ }
+
+ Class OrderedComposite::Child -instproc __after_insert {} {;}
+
+}
\ No newline at end of file
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
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 14 Dec 2005 15:57:53 -0000 1.1
@@ -0,0 +1,319 @@
+ad_library {
+ XOTcl HTML Widget Classes based on tdom
+
+ @author Gustaf Neumann (neumann@wu-wien.ac.at)
+ @author Neophytos Demetriou (k2pts@phigita.net)
+ @creation-date 2005-11-26
+ @cvs-id $Id: 30-widget-procs.tcl,v 1.1 2005/12/14 15:57:53 maltes Exp $
+}
+
+::Serializer exportMethods {
+ ::xotcl::Object instproc asHTML
+}
+
+Object instproc asHTML {{-master defaultMaster} -page:switch} {
+ require_html_procs
+ dom createDocument html doc
+ set root [$doc documentElement]
+ if {!$page} {
+ $root appendFromScript {my render}
+ return [[$root childNode] asHTML]
+ } else {
+ set slave [$master decorate $root]
+ $slave appendFromScript {my render}
+ ns_return 200 text/html [$root asHTML]
+ }
+}
+
+#
+# Define Widget classes
+#
+# ::xo::Table, somewhat similar to the classical multirow
+
+namespace eval ::xo {
+ Class Table -superclass OrderedComposite \
+ -parameter {{no_data "No Data"} {renderer TABLE2}}
+
+ Table instproc actions {cmd} {
+ set M [OrderedComposite create [self]::__actions]
+ namespace eval $M {namespace import -force [self class]::*}
+ $M contains $cmd
+ }
+ Table instproc columns {cmd} {
+ set M [OrderedComposite create [self]::__columns]
+ namespace eval $M {namespace import -force [self class]::*}
+ $M contains $cmd
+ set slots [list]
+ foreach c [$M children] {
+ eval lappend slots [$c get-slots]
+ }
+ my proc add $slots {
+ set __self [Object new]
+ foreach __v [info vars] {$__self set $__v [set $__v]}
+ next $__self
+ }
+ }
+
+ Table instproc render_with {renderer} {
+ #my log "--"
+ set cl [self class]
+ [self] mixin ${cl}::$renderer
+ foreach child [$cl info classchildren] {
+ #my log "-- $child heritage [$child info heritage]"
+ if {[$child info heritage ::xo::OrderedComposite::Child] eq ""} continue
+ $child instmixin ${cl}::${renderer}::[namespace tail $child]
+ #my log "-- $child instmixin ${cl}::${renderer}::[namespace tail $child]"
+ }
+ my init_renderer
+ }
+
+ Table instproc write_csv {} {
+ set output ""
+ set line [list]
+ foreach column [[self]::__columns children] {
+ set value [string map {\" \\\"} [$column name]]
+ lappend line \"$value\"
+ }
+ append output [join $line ,] \n
+ foreach row [my children] {
+ set line [list]
+ foreach column [[self]::__columns children] {
+ set value [string map {\" \\\"} [$row set [$column name]]]
+ lappend line \"$value\"
+ }
+ append output [join $line ,] \n
+ }
+ ns_return 200 text/csv $output
+ }
+
+ #
+ # Define elements of a Table
+ #
+ namespace eval ::xo::Table {
+ Class Action \
+ -superclass ::xo::OrderedComposite::Child \
+ -parameter {label url {tooltip {}}}
+
+ Class Field \
+ -superclass ::xo::OrderedComposite::Child \
+ -parameter {label {html {}} {orderby ""} name} \
+ -instproc init {} {
+ my set name [namespace tail [self]]
+ } \
+ -instproc get-slots {} {
+ return -[my name]
+ }
+
+ Class AnchorField \
+ -superclass ::xo::Table::Field \
+ -instproc get-slots {} {
+ set slots [list -[my name]]
+ foreach subfield {href text} {
+ lappend slots [list -[my name].$subfield ""]
+ }
+ return $slots
+ }
+
+ # export table elements
+ namespace export Field AnchorField Action
+ }
+}
+
+
+namespace eval ::xo::Table {
+ #
+ # Class for rendering ::xo::Table as the html TABLE
+ #
+ Class TABLE \
+ -instproc init_renderer {} {
+ #my log "--"
+ my set __rowcount 0
+ }
+
+ TABLE instproc render-actions {} {
+ html::tr -class list-button-bar {
+ set cols [llength [[self]::__columns children]]
+ html::td -colspan $cols -class list-button-bar {
+ set children [[self]::__actions children]
+ set last [lindex $children end]
+ foreach o $children {
+ $o render
+ if {$o ne $last} {
+ html::t -disableOutputEscaping "·"
+ }
+ }
+ }
+ }
+ }
+
+ TABLE instproc render-body {} {
+ html::tr -class list-header {
+ foreach o [[self]::__columns children] {
+ $o render
+ }
+ }
+ set children [my children]
+ if {[llength $children] == 0} {
+ html::tr {html::td { html::t [my set no_data]}}
+ } else {
+ foreach line [my children] {
+ html::tr -class [expr {[my incr __rowcount]%2 ? "list-odd" : "list-even" }] {
+ foreach field [[self]::__columns children] {
+ html::td [concat [list class list] [$field html]] {
+ $field render-data $line
+ }
+ }
+ }
+ }
+ }
+ }
+
+ TABLE instproc render {} {
+ if {![my isobject [self]::__actions]} {my actions {}}
+ html::table -class list {
+ my render-actions
+ my render-body
+ }
+ }
+
+ #
+ # Define renderer for elements of a Table
+ #
+ # ::xo:Table requires the elements to have the methods render and render-data
+ #
+
+ Class create TABLE::Action -instproc render {} {
+ html::a -class button -title [my tooltip] -href [my url] { html::t [my label] }
+ }
+
+ Class create TABLE::Field
+ TABLE::Field instproc render-data {line} {
+ html::t [$line set [my name]]
+ }
+
+ TABLE::Field instproc render {} {
+ html::th [concat [list class list] [my html]] {
+ if {[my set orderby] eq ""} {
+ html::t [my set label]
+ } else {
+ my renderSortLabels
+ }
+ }
+ }
+
+ TABLE::Field instproc renderSortLabels {} {
+ set field [my set orderby]
+ upvar #[template::adp_level] orderby orderby
+ if {![info exists orderby]} {set orderby ""}
+ set new_orderby $orderby
+ if {$orderby eq "$field,desc"} {
+ set new_orderby $field,asc
+ set title "Sort by this column ascending"
+ set img /resources/acs-templating/sort-ascending.png
+ } elseif {$orderby eq "$field,asc"} {
+ set new_orderby $field,desc
+ set title "Sort by this column descending"
+ set img /resources/acs-templating/sort-descending.png
+ } else {
+ set new_orderby $field,asc
+ set title "Sort by this column"
+ set img /resources/acs-templating/sort-neither.png
+ }
+ set query [list [list orderby $new_orderby]]
+ foreach pair [split [ns_conn query] &] {
+ foreach {key value} [split $pair =] break
+ if {$key eq "orderby"} continue
+ lappend query [list [ns_urldecode $key] [ns_urldecode $value]]
+ }
+ set href [export_vars -base [ad_conn url] $query]
+ html::a -href $href -title $title {
+ html::t [my set label]
+ html::img -src $img -alt ""
+ }
+ }
+
+ Class create TABLE::AnchorField \
+ -superclass TABLE::Field \
+ -instproc render-data {line} {
+ if {[$line exists [my name].href] &&
+ [set href [$line set [my name].href]] ne ""} {
+ html::a -href $href {
+ return [next]
+ }
+ }
+ next
+ }
+
+
+ Class TABLE2 \
+ -superclass TABLE \
+ -instproc render-actions {} {
+ html::div -id "actions" -style "float: left" {
+ html::ul -style "list-style:none; padding: 10px;" {
+ foreach o [[self]::__actions children] {
+ html::li -class "button" {$o render}
+ }
+ }
+ }
+ } \
+ -instproc render {} {
+ if {![my isobject [self]::__actions]} {my actions {}}
+ html::div {
+ my render-actions
+ html::div -class table {
+ html::table -class list {my render-body}
+ }
+ }
+ }
+
+ Class create TABLE2::Action -superclass TABLE::Action
+ Class create TABLE2::Field -superclass TABLE::Field
+ Class create TABLE2::AnchorField -superclass TABLE::AnchorField
+
+}
+
+Class TableWidget \
+ -superclass ::xo::Table \
+ -instproc init {} {
+ my render_with [my renderer]
+ next
+ }
+
+
+
+#
+# Pure List widget
+#
+
+Class ListWidget -superclass ::xo::OrderedComposite -instproc render {} {
+ html::ul {
+ foreach o [my children] {
+ html::li {
+ $o render
+ }
+ }
+ }
+}
+
+
+#
+# Define two Master templates, an empty one and one page master
+#
+
+Object defaultMaster -proc decorate {node} {
+ $node appendFromScript {
+ set slave [tmpl::div]
+ }
+ return $slave
+}
+
+Object pageMaster -proc decorate {node} {
+ $node appendFromScript {
+ html::div -class defaultMasterClass {
+ html::t "hello header"
+ set slave [tmpl::body]
+ html::t "hello footer"
+ }
+ }
+ 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.1 -r1.2
--- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1
+++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 14 Dec 2005 15:55:29 -0000 1.2
@@ -8,25 +8,24 @@
namespace eval ::Generic {
- # We do not want to re-source all of the user-data-models,
- # when small things in the definition of the CrClass change. Normally,
- # sourcing of this file causes CrClass do be destroyed with
- # the consequence, that instances of CrClass loose their
- # class-releationship.
-
Class CrClass -superclass Class -parameter {
pretty_name
pretty_plural
{supertype content_revision}
table_name
id_column
- sql_attributes
+ {cr_attributes {}}
+ {sql_attribute_names {}}
+ form
+ edit_form
{name_method ""}
- {description ""}
+ {description " "}
{mime_type text/plain}
{nls_language ""}
- {text ""}
+ {text " "}
{storage_type "text"}
+ {folder_id -100}
+ {object_type [self]}
} -ad_doc {
<p>The meta class CrClass serves for a class of applications that mostly
store information in the content repository and that use a few
@@ -43,30 +42,31 @@
(requires that
all instances of this type are deleted).</p>
- <p>Each content item is retrieved though the method
- <a href='#instproc-get'>get</a>,
- added through the method
- <a href='#instproc-add'>add</a>,
- edited (updated) throught the
- method
- <a href='#instproc-edit'>edit</a>,
- and deleted though the the method
- <a href='#instproc-delete'>delete</a>. </p>
+ <p>Each content item can be retrieved either through the
+ general method
+ <a href='proc-view?proc=%3a%3aGeneric%3a%3aCrItem+proc+instantiate'>
+ CrItem instantiate</a> or through the "instantiate" method of
+ every subclass of CrItem.
- <p>This Class provides generic methods for these purposes. For more
- complex applications, these methods will be most probably overwritten
- by defining subclasses with (some of) these methods or by object
- specific methods.</p>
+ <p>This Class is a meta-class providing methods for Classes
+ manageing CrItems.</p>
}
+ proc package_id_from_package_key { key } {
+ set id [apm_version_id_from_package_key $key]
+ set mount_url [site_node::get_children -all -package_key $key -node_id $id]
+ array set site_node [site_node::get -url $mount_url]
+ return $site_node(package_id)
+ }
+
CrClass instproc unknown { obj args } {
my log "unknown called with $obj $args"
}
- CrClass set query_atts {
+ CrClass set common_query_atts {
item_id creation_user creation_date last_modified object_type
}
- CrClass set insert_atts {title description mime_type nls_language text}
+ CrClass set common_insert_atts {title description mime_type nls_language text}
CrClass instproc object_types {
{-subtypes_first:boolean false}
@@ -79,20 +79,10 @@
$order_clause
"]
}
-
+
CrClass instproc edit_atts {} {
- concat [[self class] set insert_atts] [my atts]
+ concat [[self class] set common_insert_atts] [my sql_attribute_names]
}
- CrClass instproc atts {} {
- set atts [list [my id_column]]
- if {[my exists sql_attributes]} {
- foreach att [my sql_attributes] {
- lappend atts [lindex $att 0]
- }
- }
- return $atts
- }
-
CrClass instproc object_type_exists {} {
my instvar object_type
@@ -101,39 +91,65 @@
object_type = :object_type
}]}
}
-
+
+ CrClass ad_instproc folder_type {
+ -folder_id
+ operation
+ } {
+ register the current object type for folder_id. If folder_id
+ is not specified, use the instvar of the class instead.
+ } {
+ if {$operation ne "register" && $operation ne "unregister"} {
+ error "[self] operation for folder_type must be '\
+ 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')"
+ }
+
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
- my log "[self proc] $object_type"
- set st [my info superclass]
- if {$st ne "::xotcl::Object"} {
- set supertype [string trimleft $st :]
+ set supertype [my info superclass]
+ switch -- $supertype {
+ ::xotcl::Object -
+ ::Generic::CrItem {set supertype content_revision}
}
+ my log "--supertype = $supertype"
+
db_transaction {
- if {[my exists sql_attributes]} {
- set sql_atts [list]
- lappend sql_atts "$id_column integer primary key \
- references cr_revisions(revision_id)"
- foreach {att spec} [my sql_attributes] {
- lappend sql_atts "$att $spec"
- }
-
- db_dml table_add "create table $table_name (\n[join $sql_atts ,\n])"
- my log "adding table explicitely"
- }
db_1row create_type {
- select content_type__create_type(:object_type,:supertype,
- :pretty_name, :pretty_plural,
- :table_name, :id_column, :name_method)
+ select content_type__create_type(
+ :object_type,:supertype,:pretty_name, :pretty_plural,
+ :table_name, :id_column, :name_method
+ )
}
- db_1row register_type {
- select content_folder__register_content_type(-100,:object_type,'t')
+ if {[my cr_attributes] ne ""} {
+ set o [Object new -volatile -contains [my cr_attributes]]
+ foreach att [$o info 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'
+ )
+ }
+ #content::type::attribute::new \
+ -content_type $object_type \
+ -attribute_name [$att attribute_name] \
+ -datatype [$att datatype] \
+ -pretty_name [$att pretty_name]
+ }
}
+ my folder_type register
}
}
@@ -144,156 +160,162 @@
} {
my instvar object_type table_name
db_transaction {
- db_1row unregister_type {
- select content_folder__unregister_content_type(-100,:object_type,'t')
- }
+ my folder_type unregister
db_1row drop_type {
select content_type__drop_type(:object_type,'t','t')
}
}
}
+ CrClass ad_instproc require_folder {
+ {-parent_id -100}
+ -package_id
+ -name
+ } {
+ Get folder_id for a community id or the actual package.
+ If everything fails, return -100
+
+ @return folder_id
+ } {
+ my instvar object_type table_name
+ if {[info exists package_id]} {
+ set cid $package_id
+ } elseif {[ad_conn isconnected]} {
+ 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]]
+ }
+ if {$cid eq ""} {
+ set cid [ad_conn package_id]
+ }
+ } else {
+ set cid -100
+ }
+ 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"
+ } else {
+ 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]
+ }
+ return $folder_id
+ }
+
+ CrClass instproc getFormClass {} {
+ set nsform [ns_getform]
+ set item_id [ns_set get $nsform item_id] ;# item_id should be be hardcoded
+ set confirmed_p [ns_set get $nsform __confirmed_p]
+ set new_p [ns_set get $nsform __new_p]
+ my log "-- item_id '$item_id', confirmed_p '$confirmed_p', new_p '$new_p'"
+ if {$item_id ne "" && $new_p ne "1" && [my exists edit_form]} {
+ return [my edit_form]
+ } else {
+ return [my form]
+ }
+ }
+
CrClass instproc init {} {
- my instvar object_type
- set object_type [string trimleft [self] :]
- if {[my info superclass] ne "::xotcl::Object"} {
+ my log "-- "
+ my instvar object_type sql_attribute_names
+ if {[my info superclass] ne "::Generic::CrItem"} {
my set superclass [[my info superclass] set object_type]
}
+ set sql_attribute_names [list]
+ set o [Object new -volatile -contains [my cr_attributes]]
+ foreach att [$o info children] {
+ lappend sql_attribute_names [$att attribute_name]
+ }
+ my log "-- attribute_names <$sql_attribute_names> [$o info children]"
+
if {![my object_type_exists]} {
my create_object_type
}
my set object_type_key [db_list get_tree_sortkey {
select tree_sortkey from acs_object_types
where object_type = :object_type
}]
+ my log "-- type key = [my set object_type_key]"
next
}
- CrClass ad_instproc get {
- -item_id:required
- } {
- Retrieve the live revision of a content item with all attributes.
- The retrieved attributes are strored in the instance variables in
- class representing the object_type.
+ CrClass ad_instproc lookup {
+ -title:required
+ -parent_id:required
+ } {
+ Check, whether an content item with the given title exists.
+ If not, return 0.
- @param item_id id of the item to be retreived.
+ @return item_id
} {
- my instvar title table_name
- set raw_atts [concat [[self class] set query_atts] [my edit_atts]]
- set atts [list data]
- foreach v $raw_atts {
- catch {my instvar $v}
- lappend atts n.$v
+ my instvar table_name
+
+ if {[db_0or1row entry_exists_select "
+ select n.item_id from cr_items ci, ${table_name}i n
+ where n.title = :title and
+ n.[my id_column] = ci.live_revision and ci.parent_id = :parent_id"]} {
+ return $item_id
}
-
- db_1row note_select "
- select [join $atts ,] from cr_items ci, ${table_name}i n
- where ci.item_id = :item_id
- and n.[my id_column] = ci.live_revision
- "
- my set text $data
- my set item_id $item_id
+ return 0
}
-
- CrClass ad_instproc add {
- form
- } {
- Insert a new item to the content repository and makes
- it the live revision. This method obtains the values of
- the new content item from the specified form.
- @param form form-object (instance of <a href='/xotcl/show-object?object=::Generic::Form'>::Generic::Form</a>) from where the values are obtained
- @return item_id of the new note.
+ CrClass ad_instproc fetch_object {
+ -item_id:required
+ {-revision_id 0}
+ -object:required
} {
- my instvar object_type table_name storage_type
+ Load a content item into the specified object. If revision_id is
+ provided, the specified revision is returned, otherwise the live
+ revision of the item_id.
- set atts [list item_id revision_id]
- foreach v [[self class] set insert_atts] {
- my instvar $v
- lappend atts $v
+ @return cr item object
+ } {
+ #my log "-- [self args]"
+ 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]
+ foreach v $raw_atts {
+ catch {$object instvar $v}
+ lappend atts n.$v
}
-
- set form_vars [list]
- foreach var [$form form_vars] {lappend form_vars $var [uplevel set $var]}
- foreach var [$form form_vars] {set $var [uplevel set $var]}
-
- db_transaction {
- set item_id [db_exec_plsql note_insert {
- select content_item__new(:title,-100,null,null,null,null,null,null,
- 'content_item',:object_type,:title,
- :description,:mime_type,
- :nls_language,:text,:storage_type)
- }]
-
- set revision_id [db_nextval acs_object_id_seq]
-
- db_dml revision_add "
- insert into ${table_name}i ([join $atts ,])
- values (:[join $atts ,:])"
-
- my update_main_table -revision_id $revision_id -form_vars $form_vars
-
- db_exec_plsql make_live {
- select content_item__set_live_revision(:revision_id)
- }
+ if {$revision_id} {
+ db_1row note_select "
+ select [join $atts ,], i.parent_id from [my set table_name]i n, cr_items i
+ where n.revision_id = :revision_id and i.item_id = :item_id"
+ } else {
+ db_1row note_select "
+ select [join $atts ,], i.parent_id from cr_items i, [my set table_name]i n
+ where i.item_id = :item_id
+ and n.[my id_column] = i.live_revision"
}
- return $item_id
+ $object set text $data
+ $object set item_id $item_id
+ return $object
}
-
- CrClass instproc update_main_table {
- -revision_id
- -form_vars
- } {
- my instvar table_name
- if {[llength [my atts]]>1} {
- set vars [list]
- foreach a [lrange [my atts] 1 end] {lappend vars $a}
- catch {my instvar $vars}
- foreach {att val} $form_vars {set $att $val}
- if {[llength $vars]>1} {
- db_dml main_table_update "
- update $table_name set ([join $vars ,]) = (:[join $vars ,:])
- where [my id_column] = :revision_id"
- } else {
- db_dml main_table_update "
- update $table_name set $vars = :$vars
- where [my id_column] = :revision_id"
- }
- }
- }
- CrClass ad_instproc edit {
- form
+
+ CrClass ad_instproc instantiate {
+ -item_id
+ {-revision_id 0}
} {
- Updates an item in the content repository and makes
- it the live revision. We insert a new revision instead of
- changing the current revision.
+ Retrieve either the live revision or a specified revision
+ of a content item with all attributes.
+ The retrieved attributes are strored in the instance variables in
+ class representing the object_type.
- @param form form-object (instance of <a href='/xotcl/show-object?object=::Generic::Form'>::Generic::Form</a>) from where the values are obtained
+ @param item_id id of the item to be retrieved.
+ @param revision_id revision-id of the item to be retrieved.
} {
- my instvar table_name item_id
-
- set atts [concat [list item_id revision_id] [[self class] set insert_atts]]
- catch {eval my instvar $atts}
-
- set form_vars [list]
- foreach var [$form form_vars] {lappend form_vars $var [uplevel set $var]}
- foreach var [$form form_vars] {set $var [uplevel set $var]}
-
- db_transaction {
- set revision_id [db_nextval acs_object_id_seq]
-
- db_dml revision_add "
- insert into ${table_name}i ([join $atts ,])
- values (:[join $atts ,:])"
-
- db_exec_plsql make_live {
- select content_item__set_live_revision(:revision_id)
- }
- my update_main_table -revision_id $revision_id -form_vars $form_vars
- }
+ set o [my create ::[expr {$revision_id ? $revision_id : $item_id}]]
+ my fetch_object -object $o -item_id $item_id -revision_id $revision_id
}
-
+
CrClass ad_instproc delete {
-item_id:required
} {
@@ -308,16 +330,24 @@
CrClass ad_instproc instance_select_query {
{-select_attributes ""}
{-order_clause ""}
+ {-where_clause ""}
{-with_subtypes:boolean true}
{-count:boolean false}
+ {-folder_id}
} {
returns the SQL-query to select the CrItems of the specified object_type
@select_attributes attributes for the sql query to be retrieved, in addion
- to ci.item_id acs_objects.object_type
+ to ci.item_id acs_objects.object_type, which are always returned
@param order_clause clause for ordering the solution set
+ @param where_clause clause for restricting the answer set
+ @param with_subtypes return subtypes as well
+ @param count return the query for counting the solutions
+ @param folder_id parent_id
@return sql query
} {
my instvar object_type_key
+ if {![info exists folder_id]} {my instvar folder_id}
+
set attributes [list ci.item_id acs_objects.object_type]
foreach a $select_attributes {
if {$a eq "title"} {set a cr.title}
@@ -328,61 +358,233 @@
'$object_type_key' and tree_right('$object_type_key')" :
"acs_object_types.tree_sortkey = '$object_type_key'"}]
set attribute_selection [expr {$count ? "count(*)" : [join $attributes ,]}]
+ if {$where_clause ne ""} {
+ set where_clause "and $where_clause"
+ }
return "select $attribute_selection
from acs_object_types, acs_objects, cr_items ci, cr_revisions cr
where $type_selection
and acs_object_types.object_type = ci.content_type
- and ci.live_revision = cr.revision_id and
- acs_objects.object_id = cr.revision_id $order_clause"
+ and ci.live_revision = cr.revision_id
+ and parent_id = $folder_id
+ and acs_objects.object_id = cr.revision_id $where_clause $order_clause"
}
+ CrClass ad_instproc instantiate_all {
+ {-select_attributes ""}
+ {-order_clause ""}
+ {-where_clause ""}
+ {-with_subtypes:boolean true}
+ {-folder_id}
+ } {
+ Return all instances of an content type class matching the
+ specified clauses.
+ } {
+ set __result [::xo::OrderedComposite new]
+ uplevel #1 [list $__result volatile]
+ $__result proc destroy {} {my log "-- "; next}
+
+ set __attributes [list]
+ foreach a [concat [list ci.item_id acs_objects.object_type] \
+ $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] {
+ 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
+ }
+
+
+ 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 ad_proc instantiate {
+ -item_id
+ {-revision_id 0}
+ } {
+ Instantiate the live revision or the specified revision of an
+ CrItem.
+ @return object containing the attributes of the CrItem
+ } {
+ db_1row get_class "select content_type as object_type from cr_items \
+ where item_id=$item_id"
+ if {![string match ::* $object_type]} {set object_type ::$object_type}
+ set o [$object_type create ::[expr {$revision_id ? $revision_id : $item_id}]]
+ $object_type fetch_object \
+ -item_id $item_id -revision_id $revision_id -object $o
+ #my log "-- fetched $o of type $object_type"
+ return $o
+ }
+
+
+ CrItem ad_proc delete {
+ -item_id
+ } {
+ Delete a CrItem in the database
+ } {
+ db_1row get_class_and_folder \
+ "select content_type as object_type from cr_items where item_id = $item_id"
+ $object_type delete -item_id $item_id
+ }
+
+ CrItem ad_proc lookup {
+ -title:required
+ -parent_id:required
+ } {
+ Lookup CR item from title and folder (parent_id)
+ @return item_id or 0 if not successful
+ } {
+ if {[db_0or1row entry_exists_select "
+ select i.item_id from cr_revisions r, cr_items i
+ where revision_id = i.live_revision and r.title = :title
+ and i.parent_id = :parent_id" ]} {
+ #my log "-- found $item_id for $title in folder '$parent_id'"
+ return $item_id
+ }
+ #my log "-- nothing found for $title in folder '$parent_id'"
+ return 0
+ }
+
+ CrItem ad_instproc save {} {
+ Updates an item in the content repository and makes
+ it the live revision. We insert a new revision instead of
+ changing the current revision.
+ } {
+ set __atts [concat [list item_id revision_id] [[my info class] edit_atts]]
+ eval my instvar $__atts
+
+ db_transaction {
+ set revision_id [db_nextval acs_object_id_seq]
+
+ db_dml revision_add "
+ insert into [[my info class] set table_name]i ([join $__atts ,])
+ values (:[join $__atts ,:])"
+
+ db_exec_plsql make_live {
+ select content_item__set_live_revision(:revision_id)
+ }
+ }
+ return $item_id
+ }
+
+ CrItem ad_instproc save_new {} {
+ Insert a new item to the content repository and make
+ it the live revision.
+ } {
+ set __class [my info class]
+ my instvar parent_id item_id
+
+ set __atts [list item_id revision_id]
+ foreach __var [$__class edit_atts] {
+ my instvar $__var
+ lappend __atts $__var
+ if {![info exists $__var]} {set $__var ""}
+ }
+
+ db_transaction {
+ $__class instvar mime_type storage_type object_type
+ $__class folder_type -folder_id $parent_id register
+ set item_id [db_exec_plsql note_insert "
+ select content_item__new(:title,$parent_id,null,null,null,null,null,null,
+ 'content_item',:object_type,:title,
+ :description,:mime_type,
+ :nls_language,:text,:storage_type)"]
+
+ set revision_id [db_nextval acs_object_id_seq]
+ my log "-- NEW item_id = $item_id, revision_id = $revision_id"
+ db_dml revision_add "
+ insert into [$__class set table_name]i ([join $__atts ,])
+ values (:[join $__atts ,:])"
+
+ db_exec_plsql make_live {
+ select content_item__set_live_revision(:revision_id)
+ }
+ my log "-- end object_type == $object_type"
+ }
+ return $item_id
+ }
+
+ CrItem ad_instproc delete {} {
+ Delete the item from the content repositiory with the item_id taken from the
+ instance variable.
+ } {
+ # delegate deletion to the class
+ [my info class] delete [my set instance_id]
+ }
+
#
# Form template class
#
Class Form -parameter {
fields
- object_type
+ data
+ {folder_id -100}
{name {[namespace tail [self]]}}
add_page_title
edit_page_title
+ {validate ""}
{with_categories false}
+ {submit_link "."}
} -ad_doc {
Class for the simplified generation of forms. This class was designed
together with the content repository class
<a href='/xotcl/show-object?object=::Generic::CrClass'>::Generic::CrClass</a>.
- This class can be parameterized with
+
<ul>
<li><b>fields:</b> form elements as described in
<a href='/api-doc/proc-view?proc=ad_form'>ad_form</a>.
- <li><b>object_type:</b> instance of
- <a href='/xotcl/show-object?object=::Generic::CrClass'>::Generic::CrClass</a>,
- used as a data source for this form
+ <li><b>data:</b> data object (e.g. instance if CrItem)
+ <li><b>folder_id:</b> associated folder id
<li><b>name:</b> of this form, used for naming the template,
defaults to the object name
<li><b>add_page_title:</b> page title when adding content items
<li><b>edit_page_title:</b> page title when editing content items
+ <li><b>with_categories:</b> display form with categories (default false)
+ <li><b>submit_link:</b> link for page after submit
</ul>
}
Form instproc init {} {
+ set level [template::adp_level]
+ my forward var uplevel #$level set
+
+ my instvar data folder_id
+ set class [$data info class]
+ set folder_id [$data set parent_id]
+
if {![my exists add_page_title]} {
- my set add_page_title "Add [[my object_type] pretty_name]"
+ my set add_page_title "New [$class pretty_name]"
}
if {![my exists edit_page_title]} {
- my set edit_page_title "Edit [[my object_type] pretty_name]"
+ my set edit_page_title "Edit [$class pretty_name]"
}
+
# check, if the specified fields are available from the data source
# and ignore the unavailable entries
set checked_fields [list]
- set available_atts [[my object_type] edit_atts]
- lappend available_atts [[my object_type] id_column] item_id
- foreach varspec [my fields] {
- set var [lindex [split [lindex $varspec 0] :] 0]
- if {[lsearch -exact $available_atts $var] == -1} continue
- lappend checked_fields $varspec
- }
- my fields $checked_fields
+ set available_atts [$class edit_atts]
+ #my log "-- available atts <$available_atts>"
+ lappend available_atts [$class id_column] item_id
+
+ if {![my exists fields]} {my mkFields}
+ #my log --fields=[my fields]
}
Form instproc form_vars {} {
@@ -392,13 +594,62 @@
}
return $vars
}
- Form instproc get_vars {object_type} {
- foreach var [my form_vars] {
- uplevel [list set $var [$object_type set $var]]
+ Form instproc new_data {} {
+ my instvar data
+ my log "--- new_data ---"
+ foreach __var [my form_vars] {
+ $data set $__var [my var $__var]
}
+ $data save_new
+ return [$data set item_id]
}
+ Form instproc edit_data {} {
+ my log "--- edit_data ---"
+ my instvar data
+ foreach __var [my form_vars] {
+ $data set $__var [my var $__var]
+ }
+ $data save
+ return [$data set item_id]
+ }
+ Form instproc request {privelege} {
+ my instvar page_title context
+ auth::require_login
+ permission::require_permission -object_id [ad_conn package_id] -privilege $privelege
+ set page_title [my add_page_title]
+ set context [list $page_title]
+ }
+ Form instproc new_request {} {
+ my log "--- new_request ---"
+ my request create
+ }
+ Form instproc edit_request {item_id} {
+ my instvar data
+ my log "--- edit_request ---"
+ my request write
+ foreach var [[$data info class] edit_atts] {
+ my var $var [list [$data set $var]]
+ }
+ }
-
+ Form instproc on_validation_error {} {
+ my instvar page_title context
+ my log "-- "
+ set page_title [my edit_page_title]
+ set context [list $page_title]
+ }
+ Form instproc after_submit {item_id} {
+ my instvar data
+ my log "-- item_id=$item_id [$data set item_id]"
+ set link [my submit_link]
+ if {$link ne "." && ![string match {*[?]*} $link]} {
+ set link [export_vars -base $link {item_id}]
+ }
+ ns_log notice "-- redirect to $link // [string match *\?* $link]"
+ ad_returnredirect $link
+ ad_script_abort
+ }
+
Form ad_instproc generate {
{-template "formTemplate"}
} {
@@ -409,21 +660,31 @@
} {
# set form name for adp file
uplevel set $template [my name]
-
- ad_form -name [my name] -form [my fields] \
- -export [list [list object_type [my object_type]]]
+ my instvar data folder_id
+ set object_type [[$data info class] object_type]
+ my log "-- $data, cl=[$data info class] [[$data info class] object_type]"
- set new_data [subst -novariables {[my object_type] add [self]}]
- set edit_data [subst -novariables {[my object_type] edit [self]}]
+ #my log "--final fields [my fields]"
+ ad_form -name [my name] -form [my fields] \
+ -export [list [list object_type $object_type] [list folder_id $folder_id]]
+
+ set new_data "set item_id \[[self] new_data\]"
+ set edit_data "set item_id \[[self] edit_data\]"
+ set new_request "[self] new_request"
+ set edit_request "[self] edit_request \$item_id"
+ set after_submit "[self] after_submit \$item_id"
+ set on_validation_error "[self] on_validation_error"
set on_submit {}
if {[my with_categories]} {
- upvar item_id item_id
+ 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 [value_if_exists item_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) \
values (:item_id, :title, :package_id)"
@@ -432,6 +693,7 @@
db_dml update_asc_named_object \
"update acs_named_objects set object_name = :title, \
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 {
@@ -440,30 +702,14 @@
}
}
+ ns_log notice "-- ad_form new_data=<$new_data> edit_data=<$edit_data>"
+
# 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 [subst -novariables {
- auth::require_login
- permission::require_permission \
- -object_id [ad_conn package_id] \
- -privilege create
- set page_title "[my add_page_title]"
- set context \[list $page_title\]
- }] -edit_request [subst -novariables {
- auth::require_login
- permission::require_write_permission -object_id $item_id
- [my object_type] get -item_id $item_id
- my get_vars [my object_type]
- set page_title "[my edit_page_title]"
- set context \[list $page_title\]
- }] -on_validation_error [subst -novariables {
- set page_title "[my edit_page_title]"
- set context \[list $page_title\]
- }] -after_submit {
- ad_returnredirect "."
- ad_script_abort
- }
+ -new_request $new_request -edit_request $edit_request \
+ -on_validation_error $on_validation_error -after_submit $after_submit
}
#
@@ -477,7 +723,9 @@
{with_subtypes true}
{name {[namespace tail [self]]}}
{edit_link edit}
+ {view_link view}
{delete_link delete}
+ {folder_id -100}
} -ad_doc {
Class for the simplified generation of lists. This class was designed
together with the content repository class
@@ -500,10 +748,10 @@
defaults to the object name
<li><b>edit_link:</b> link to edit content item (default: edit)
<li><b>delete_link:</b> link to delete content item (default: delete)
+ <li><b>view_link:</b> link to view content item (default: view)
</ul>
}
-
List ad_instproc actions {} {
actions is a method to compute the actions of the list
depending on the object types. It can be easily overwritten
@@ -514,7 +762,7 @@
foreach object_type $object_types {
lappend actions \
"Add [$object_type pretty_name]" \
- [export_vars -base [my edit_link] {object_type}] \
+ [export_vars -base [my edit_link] {object_type folder_id}] \
"Add a new item of kind [$object_type pretty_name]"
}
return $actions
@@ -550,6 +798,17 @@
sub_class narrow
}
}
+ VIEW {
+ lappend elements view {
+ link_url_col view_url
+ display_template {
+ <img src='/resources/acs-subsite/Zoom16.gif' \
+ title='View Item' alt='view' \
+ width="16" height="16" border="0">
+ }
+ sub_class narrow
+ }
+ }
default {
lappend elements $e $spec
}
@@ -579,7 +838,7 @@
set select_attributes [list]
foreach {e spec} [my fields] {
- if {[lsearch -exact {item_id object_type EDIT DELETE} $e] == -1} {
+ if {[lsearch -exact {item_id object_type EDIT DELETE VIEW} $e] == -1} {
lappend select_attributes $e
}
}
@@ -593,12 +852,18 @@
-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] {
- set edit_url [export_vars -base [my edit_link] {item_id object_type}]
- set delete_url [export_vars -base [my delete_link] {item_id object_type}]
+ 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}]
}
}
+
+ namespace export CrItem
}
+namespace import -force ::Generic::*
Index: openacs-4/packages/xotcl-core/tcl/html-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/html-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/html-procs.tcl 14 Dec 2005 15:57:53 -0000 1.1
@@ -0,0 +1,138 @@
+package require tdom
+
+proc require_html_procs {} {
+ if {[info command ::html::a] eq ""} {
+ namespace eval ::html {
+
+ # Declare Tcl commands for building HTML elements. This is an complete
+ # set taken from W3C on http://www.w3.org/TR/html4/index/elements.html
+ #
+
+ #
+ # Miscelaneous commands. Not part of html specs
+ # but needed for generation of special dom nodes.
+ #
+
+ dom createNodeCmd cdataNode cdata
+ dom createNodeCmd textNode t
+ dom createNodeCmd commentNode c
+ dom createNodeCmd parserNode x
+ dom createNodeCmd piNode runtime
+
+ #
+ # Command generating HTML tags. All these commands have
+ # following sytax: <cmd> ?-option value ...? ?script?
+ #
+ # -option name of HTML attribute
+ # value attribute value
+ # script tcl script to run in command's context.
+ #
+ # Example: table -border 1 {...}
+ #
+
+ dom createNodeCmd elementNode a
+ dom createNodeCmd elementNode abbr
+ dom createNodeCmd elementNode acronym
+ dom createNodeCmd elementNode address
+ dom createNodeCmd elementNode applet
+ dom createNodeCmd elementNode area
+ dom createNodeCmd elementNode b
+ dom createNodeCmd elementNode base
+ dom createNodeCmd elementNode basefont
+ dom createNodeCmd elementNode bdo
+ dom createNodeCmd elementNode big
+ dom createNodeCmd elementNode blockquote
+ dom createNodeCmd elementNode body
+ dom createNodeCmd elementNode br
+ dom createNodeCmd elementNode button
+ dom createNodeCmd elementNode caption
+ dom createNodeCmd elementNode center
+ dom createNodeCmd elementNode cite
+ dom createNodeCmd elementNode code
+ dom createNodeCmd elementNode col
+ dom createNodeCmd elementNode colgroup
+ dom createNodeCmd elementNode dd
+ dom createNodeCmd elementNode del
+ dom createNodeCmd elementNode dfn
+ dom createNodeCmd elementNode dir
+ dom createNodeCmd elementNode div
+ dom createNodeCmd elementNode dl
+ dom createNodeCmd elementNode dt
+ dom createNodeCmd elementNode em
+ dom createNodeCmd elementNode fieldset
+ dom createNodeCmd elementNode font
+ dom createNodeCmd elementNode form
+ dom createNodeCmd elementNode frame
+ dom createNodeCmd elementNode frameset
+ dom createNodeCmd elementNode h1
+ dom createNodeCmd elementNode h2
+ dom createNodeCmd elementNode h3
+ dom createNodeCmd elementNode h4
+ dom createNodeCmd elementNode h5
+ dom createNodeCmd elementNode h6
+ dom createNodeCmd elementNode head
+ dom createNodeCmd elementNode hr
+ dom createNodeCmd elementNode html
+ dom createNodeCmd elementNode i
+ dom createNodeCmd elementNode iframe
+ dom createNodeCmd elementNode img
+ dom createNodeCmd elementNode input
+ dom createNodeCmd elementNode ins
+ dom createNodeCmd elementNode isindex
+ dom createNodeCmd elementNode kbd
+ dom createNodeCmd elementNode label
+ dom createNodeCmd elementNode legend
+ dom createNodeCmd elementNode li
+ dom createNodeCmd elementNode link
+ dom createNodeCmd elementNode map
+ dom createNodeCmd elementNode menu
+ dom createNodeCmd elementNode meta
+ dom createNodeCmd elementNode noframes
+ dom createNodeCmd elementNode noscript
+ dom createNodeCmd elementNode object
+ dom createNodeCmd elementNode ol
+ dom createNodeCmd elementNode optgroup
+ dom createNodeCmd elementNode option
+ dom createNodeCmd elementNode p
+ dom createNodeCmd elementNode param
+ dom createNodeCmd elementNode pre
+ dom createNodeCmd elementNode q
+ dom createNodeCmd elementNode s
+ dom createNodeCmd elementNode samp
+ dom createNodeCmd elementNode script
+ dom createNodeCmd elementNode select
+ dom createNodeCmd elementNode small
+ dom createNodeCmd elementNode span
+ dom createNodeCmd elementNode strike
+ dom createNodeCmd elementNode strong
+ dom createNodeCmd elementNode style
+ dom createNodeCmd elementNode sub
+ dom createNodeCmd elementNode sup
+ dom createNodeCmd elementNode table
+ dom createNodeCmd elementNode tbody
+ dom createNodeCmd elementNode td
+ dom createNodeCmd elementNode textarea
+ dom createNodeCmd elementNode tfoot
+ dom createNodeCmd elementNode th
+ dom createNodeCmd elementNode thead
+ dom createNodeCmd elementNode title
+ dom createNodeCmd elementNode tr
+ dom createNodeCmd elementNode tt
+ dom createNodeCmd elementNode u
+ dom createNodeCmd elementNode ul
+ dom createNodeCmd elementNode var
+
+
+ }
+
+ namespace eval ::tmpl {
+ dom createNodeCmd -returnNodeCmd elementNode div
+ dom createNodeCmd -returnNodeCmd elementNode body
+ }
+
+ namespace eval :: {
+ namespace import -force ::html::*
+ namespace import -force ::tmpl::*
+ }
+ }
+}
\ No newline at end of file
Index: openacs-4/packages/xotcl-core/tcl/thread_mod-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/thread_mod-procs.tcl,v
diff -u -r1.1 -r1.2
--- openacs-4/packages/xotcl-core/tcl/thread_mod-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1
+++ openacs-4/packages/xotcl-core/tcl/thread_mod-procs.tcl 14 Dec 2005 15:55:29 -0000 1.2
@@ -123,12 +123,13 @@
"set ::xotcl::currentThread [self]" \n\
$cmd
my set mutex [thread::mutex create]
+ ns_log notice "mutex [my set mutex] created"
next
}
-::xotcl::THREAD ad_proc recreate {obj args} {
- # this method catches recreation of THREADs in worker threads
- # it reinitializes the thread according to the new definition.
+::xotcl::THREAD ad_proc -private recreate {obj args} {
+ this method catches recreation of THREADs in worker threads
+ it reinitializes the thread according to the new definition.
} {
my log "recreating [self] $obj, tid [$obj exists tid]"
if {![string match ::* $obj]} { set obj ::$obj }
@@ -153,12 +154,25 @@
if {$refcount == 0} {
my log "thread terminated"
nsv_unset [self class] [self]
+ thread::mutex destroy [my set mutex]
+ ns_log notice "mutex [my set mutex] destroyed"
}
}
- thread::mutex destroy [my set mutex]
next
}
-::xotcl::THREAD instproc do {o args} {
+
+::xotcl::THREAD instproc get_tid {} {
+ if {[nsv_exists [self class] [self]]} {
+ # the thread was already started
+ return [nsv_get [self class] [self]]
+ }
+ # start a small command in the thread
+ my do info exists x
+ # now we have the thread and can return the tid
+ return [my set tid]
+}
+
+::xotcl::THREAD instproc do {-async:switch args} {
if {![nsv_exists [self class] [self]]} {
# lazy creation of a new slave thread
@@ -193,8 +207,12 @@
}
my set tid $tid
}
- #my log "calling [self class] ($tid, [pid]) $o $args"
- return [thread::send $tid "$o $args"]
+ #my log "calling [self class] ($tid, [pid]) $args"
+ if {$async} {
+ return [thread::send -async $tid $args]
+ } else {
+ return [thread::send $tid $args]
+ }
}
# create a sample persistent thread that can be acessed
@@ -209,37 +227,35 @@
#
################## forwarding proxy ##################
-Class ::xotcl::THREAD::Proxy -parameter {attach}
-::xotcl::THREAD::Proxy configure \
- -instproc forward args {
- set cp [self calledproc]
- if { [string equal $cp attach]
- || [string equal $cp filter]
- || [string equal $cp detachAll]} {
- next
- } elseif {[string equal $cp destroy]} {
- eval [my attach] do [self] $cp $args
- my log "destroy"
- next
- } else {
- my log "forwarding [my attach] do [self] $cp $args"
- eval [my attach] do [self] $cp $args
- }
- } -instproc init args {
- my filter forward
- } -proc detachAll {} {
- foreach i [my info instances] {$i filter ""}
- }
-# the following does not work yet
-#::xotcl::THREAD::Proxy proc create {obj args} {
-# my log "[self proc] $obj"
-# my filter ""
-# next
-#}
+# Class ::xotcl::THREAD::Proxy -parameter {attach}
+# ::xotcl::THREAD::Proxy configure \
+# -instproc forward args {
+# set cp [self calledproc]
+# if { [string equal $cp attach]
+# || [string equal $cp filter]
+# || [string equal $cp detachAll]} {
+# next
+# } elseif {[string equal $cp destroy]} {
+# eval [my attach] do [self] $cp $args
+# my log "destroy"
+# next
+# } else {
+# my log "forwarding [my attach] do [self] $cp $args"
+# eval [my attach] do [self] $cp $args
+# }
+# } -instproc init args {
+# my filter forward
+# } -proc detachAll {} {
+# foreach i [my info instances] {$i filter ""}
+# }
+
# sample Thread client routine, calls a same named object in the server thread
-Class create ::xotcl::THREAD::Client -parameter server
+# a thread client should be created in an connection thread dynamically to
+# avoid name clashes in the blueprint.
+
+Class create ::xotcl::THREAD::Client -parameter {server {serverobj [self]}}
::xotcl::THREAD::Client instproc do args {
- eval [my server] do [self] $args
+ eval [my server] do [my serverobj] $args
}
Index: openacs-4/packages/xotcl-core/www/show-object.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/show-object.tcl,v
diff -u -r1.1 -r1.2
--- openacs-4/packages/xotcl-core/www/show-object.tcl 11 Oct 2005 08:41:18 -0000 1.1
+++ openacs-4/packages/xotcl-core/www/show-object.tcl 14 Dec 2005 15:55:30 -0000 1.2
@@ -138,20 +138,32 @@
append output [::xotcl::api source_to_html $obj_create_source] \n
}
+proc api_src_doc {out show_source scope object proc m} {
+ set output "<a name='$proc-$m'></a><li>$out"
+ if { $show_source } {
+ append output \
+ "<pre class='code'>" \
+ [api_tcl_to_html [::xotcl::api proc_index $scope $object $proc $m]] \
+ </pre>
+ }
+ return $output
+}
+
if {$show_methods} {
append output "<h3>Methods</h3>\n" <ul> \n
- foreach m [lsort [DO $object info procs]] {
+ foreach m [lsort [DO $object info procs]] {
set out [api_documentation $scope $object proc $m]
if {$out ne ""} {
- append output "<a name='proc-$m'></a><li>$out"
- if { $show_source } {
- append output \
- "<pre class='code'>" \
- [api_tcl_to_html [::xotcl::api proc_index $scope $object proc $m]] \
- </pre>
- }
+ append output [api_src_doc $out $show_source $scope $object proc $m]
}
}
+ foreach m [lsort [DO $object info forward]] {
+ set out [api_documentation $scope $object forward $m]
+ if {$out ne ""} {
+ append output [api_src_doc $out $show_source $scope $object forward $m]
+ }
+ }
+
if {$isclass} {
set cls [lsort [DO $object info instprocs]]
foreach m $cls {