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 --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/xotcl-core.info 11 Oct 2005 08:41:17 -0000 1.1 @@ -0,0 +1,36 @@ + + + + + XOTcl Core + XOTcl Core + f + t + xotcl + + + Gustaf Neumann + XOTcl library functionality (e.g. thread handling, online documentation) + 2005-10-07 + This component contains some core functionality for OACS +applications using XOTcl. It includes +XOTcl thread handling for OACS (supporting persistent and +volatile threads) and a definitions for +documenting XOTcl object, classes and methods +integrated with the api-browser of OACS. Documented +procs and instproc an be created using the methods ad_proc +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. + + + + + + + + + + + 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 --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,12 @@ +# tell serializer to export methods, allthough these are methods of ::xotcl::Object +::Serializer exportMethods { + ::xotcl::Object instproc log + ::xotcl::Object instproc debug +} + +::xotcl::Object instproc log msg { + ns_log notice "[self] $msg" +} +::xotcl::Object instproc debug msg { + ns_log debug "[self] $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 --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/tcl/05-doc-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,290 @@ +ad_library { + XOTcl API for api browser, defines the methods + ad_proc (for object specific methods), + ad_instproc (for tradional methods) and + ad_odc (for documenting classes). Syntax for the methods + ad_proc and ad_instproc is like oacs ad_proc, ad_doc + receives one argument, similar to ad_library. + + @author Gustaf Neumann + @creation-date 2005-05-13 + @cvs-id $Id: 05-doc-procs.tcl,v 1.1 2005/10/11 08:41:18 gustafn Exp $ +} + +package require xotcl::serializer 0.8 + +# Per default, the content of the ::xotcl:: namespace is not serialized; +# so we add the specified methods explizitely to the export list +::Serializer exportMethods { + ::xotcl::Object instproc ad_proc + ::xotcl::Class instproc ad_instproc + ::xotcl::Object instproc ad_doc + ::xotcl::Object instproc __api_make_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} { + if {$scope eq ""} { + set isclass [::xotcl::Object isclass $obj] + } else { + set isclass [$scope do ::xotcl::Object isclass $obj] + } + + } -proc scope {} { + if {[info exists ::xotcl::currentThread]} { + # we are in an xotcl thread; the body won't be accessible directly + return $::xotcl::currentThread + } + return "" + + } -proc scope_from_object_reference {scope_var object_var} { + upvar $scope_var scope $object_var object + set scope "" + regexp {^(.+) do (.+)$} $object match scope object + + } -proc scope_from_proc_index {proc_index} { + set scope "" + regexp {^(.+) .+ (inst)?proc (.+)$} $proc_index match scope + return $scope + + } -proc inscope {scope args} { + expr {$scope eq "" ? [eval $args] : [$scope do $args]} + + } -proc script_name {scope} { + #set kind [expr {[my istype ::xotcl::Class] ? "Class" : "Object"}] + #return "$scope$kind [self]" + set script [info script] + if {[string equal "" $script] && [info exists ::xotcl::currentScript]} { + set script $::xotcl::currentScript + } + set root_dir [nsv_get acs_properties root_directory] + set root_length [string length $root_dir] + if { $root_dir eq [string range $script 0 [expr {$root_length - 1}]]} { + set script [string range $script [expr {$root_length + 1}] end] + } + return $script + + } -proc object_link {{-noimg:boolean off} scope obj} { + set link "" + if {$noimg} { + return "$link$obj" + } else { + return "$obj$link\[i\]" + } + + } -proc object_url {{-show_source 0} {-show_methods 1} scope obj} { + set object [expr {$scope eq "" ? $obj : "$scope do $obj"}] + return [export_vars -base /xotcl/show-object {object show_source show_methods}] + } -proc object_index {scope obj} { + set kind [expr {[my isclass $scope $obj] ? "Class" : "Object"}] + return "$scope$kind $obj" + + } -proc proc_index {scope obj instproc proc_name} { + if {[string equal "" $scope]} { + return "$obj $instproc $proc_name" + } else { + return "$scope $obj $instproc $proc_name" + } + + } -proc source_to_html {{-width 100} string} { + set lines [list] + foreach l [split $string \n] { + while {[string length $l] > $width} { + set pos [string last " \{" $l $width] + if {$pos>10} { + lappend lines "[string range $l 0 [expr {$pos-1}]] \\" + set l " [string range $l $pos end]" + } else { + # search for a match right of the target + set pos [string first " \{" $l $width] + if {$pos>10} { + lappend lines "[string range $l 0 [expr {$pos-1}]] \\" + set l " [string range $l $pos end]" + } else { + # last resort try to split around spaces + set pos [string last " " $l $width] + if {$pos>10} { + lappend lines "[string range $l 0 [expr {$pos-1}]] \\" + set l " [string range $l $pos end]" + } else { + break + } + } + } + } + lappend lines $l + } + set string [join $lines \n] + set html [ad_quotehtml $string] + regsub -all {(\n[\t ]*)(\#[^\n]*)} $html \\1\\2 html + return "
$html
" + } + + + + +::xotcl::Object instproc __api_make_doc {inst proc_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 + } + set defaults [list] + foreach a [my info ${inst}args $proc_name] { + if {[my info ${inst}default $proc_name $a d]} {lappend defaults $a $d} + } + 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) [expr {[lsearch args [my info ${inst}args $proc_name]]>-1}] + set doc_elements(flags) [list] + set doc_elements(switches) [list] + foreach f [my info ${inst}nonposargs $proc_name] { + set pair [split [lindex $f 0 0] :] + set sw [string range [lindex $pair 0] 1 end] + lappend doc_elements(switches) $sw + lappend doc_elements(flags) $sw [lindex $pair 1] + #my log "default_value $proc_name: $sw -> '[lindex $f 1]' <$pair/$f>" + if {[lindex $pair 1] eq "switch" && [lindex $f 1] eq ""} { + set default "false" + } else { + set default [lindex $f 1] + } + #my log "default_value $proc_name: $sw -> 'default' <$pair/$f>" + lappend defaults $sw $default + } + set doc_elements(default_values) $defaults + set doc_elements(positionals) [my info ${inst}args $proc_name] + # 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}proc $proc_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 args} { + ::xotcl::api split_arguments + uplevel [list [self] proc $proc_name $arguments $body] + my __api_make_doc "" $proc_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 +} + +::xotcl::Object instproc ad_doc {doc_string} { + ad_parse_documentation_string $doc_string doc_elements + set scope [::xotcl::api scope] + set doc_elements(script) [::xotcl::api script_name $scope] + set proc_index [::xotcl::api object_index $scope [self]] + + #if {![nsv_exists api_proc_doc $proc_index]} { + # nsv_lappend api_proc_doc_scripts $doc_elements(script) $proc_index + #} + set doc_elements(public_p) true + set doc_elements(private_p) false + set doc_elements(varargs_p) false + set doc_elements(deprecated_p) false + set doc_elements(default_values) "" + set doc_elements(switches) "" + set doc_elements(positionals) "" + set doc_elements(flags) "" + nsv_set api_proc_doc $proc_index [array get doc_elements] + nsv_set api_library_doc \ + $proc_index \ + [array get doc_elements] + + set file_index $doc_elements(script) + if {[nsv_exists api_library_doc $file_index]} { + array set elements [nsv_get api_library_doc $file_index] + } + set oldDoc [expr {[info exists elements(main)] ? \ + [lindex $elements(main) 0] : ""}] + set prefix "This file defines the following Objects and Classes" + set entry [::xotcl::api object_link $scope [self]] + if {![string match *$prefix* $oldDoc]} { + append oldDoc "

$prefix: $entry" + } else { + append oldDoc ", $entry" + } + set elements(main) [list $oldDoc] + #my log "elements = [array get elements]" + nsv_set api_library_doc $file_index [array get elements] +} + + +Class ::Test -ad_doc { + Test Class for the documentation of + Classes, + Objects, + instprocs, and + procs. + @author Gustaf Neumann + @cvs-id $Id: 05-doc-procs.tcl,v 1.1 2005/10/11 08:41:18 gustafn Exp $ +} +::Test ad_proc my-class-specific-proc {x y} { + This is a proc of Class Test merely for testing purposes... + @param x First Operand + @param y Second Operand +} { + ns_log notice "hello world $x $y" +} + +::Test ad_instproc my-method {-id:required} { + This is an instproc of Class Test merely for testing purposes... + @param id Some Id +} { + ns_log notice "hello world $id" +} +::Test ad_instproc my-method2 {-id:required {-flag:boolean true}} { + This is an instproc of Class Test merely for testing purposes... + @param id Some Id + @param flag Some flag +} { + ns_log notice "hello world $id" +} +::Test ad_instproc -private my-method3 {-id:required {-flag:boolean true} -switch:switch x {y 1}} { + This is an instproc of Class Test merely for testing purposes... + @param id Some Id + @param flag Some flag + @param switch Switch to turn on or off depending on default + @param x First Operand + @param y Second Operand +} { + ns_log notice "hello world $id" +} + +Class ::SpecializedTest -superclass ::Test -ad_doc { + A Class defined as a subclass of ::Test for testing the + documentation stuff... +} 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 --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 11 Oct 2005 08:41:18 -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,v 1.1 2005/10/11 08:41:18 gustafn Exp $ +} + +if {![::xotcl::Object isclass ::xotcl::RecreationClass]} { + ::xotcl::Class create ::xotcl::RecreationClass -ad_doc { +

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.

+ +

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.

+ +

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.

+ +

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).

+ The following parameters are defined: + + } -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/generic-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/generic-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,604 @@ +ad_library { + XOTcl API simple Content repository apps, supports categories. + + @author Gustaf Neumann + @creation-date 2005-08-13 + @cvs-id $Id: generic-procs.tcl,v 1.1 2005/10/11 08:41:18 gustafn Exp $ +} + +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 + {name_method ""} + {description ""} + {mime_type text/plain} + {nls_language ""} + {text ""} + {storage_type "text"} + } -ad_doc { +

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

+ +

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

+ +

Each content item is retrieved though the method + get, + added through the method + add, + edited (updated) throught the + method + edit, + and deleted though the the method + delete.

+ +

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.

+ } + + CrClass instproc unknown { obj args } { + my log "unknown called with $obj $args" + } + + CrClass set query_atts { + item_id creation_user creation_date last_modified object_type + } + CrClass set insert_atts {title description mime_type nls_language text} + + CrClass instproc object_types { + {-subtypes_first:boolean false} + } { + my instvar object_type_key + set order_clause [expr {$subtypes_first ? "order by tree_sortkey desc":""}] + return [db_list get_object_types " + select object_type from acs_object_types where + tree_sortkey between :object_type_key and tree_right(:object_type_key) + $order_clause + "] + } + + CrClass instproc edit_atts {} { + concat [[self class] set insert_atts] [my atts] + } + 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 + expr {$object_type eq [db_list select_type { + select object_type from acs_object_types where + object_type = :object_type + }]} + } + + 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 :] + } + 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) + } + db_1row register_type { + select content_folder__register_content_type(-100,:object_type,'t') + } + } + } + + CrClass ad_instproc drop_object_type {} { + Delete the object type and remove the table for the attributes. + This method should be called when all instances are deleted. It + undoes everying what create_object_type has produced. + } { + my instvar object_type table_name + db_transaction { + db_1row unregister_type { + select content_folder__unregister_content_type(-100,:object_type,'t') + } + db_1row drop_type { + select content_type__drop_type(:object_type,'t','t') + } + } + } + + CrClass instproc init {} { + my instvar object_type + set object_type [string trimleft [self] :] + if {[my info superclass] ne "::xotcl::Object"} { + my set superclass [[my info superclass] set object_type] + } + 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 + }] + 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. + + @param item_id id of the item to be retreived. + } { + 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 + } + + 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 + } + + 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 ::Generic::Form) from where the values are obtained + @return item_id of the new note. + } { + my instvar object_type table_name storage_type + + set atts [list item_id revision_id] + foreach v [[self class] set insert_atts] { + my instvar $v + lappend atts $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) + } + } + return $item_id + } + + 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 + } { + Updates an item in the content repository and makes + it the live revision. We insert a new revision instead of + changing the current revision. + + @param form form-object (instance of ::Generic::Form) from where the values are obtained + } { + 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 + } + } + + CrClass ad_instproc delete { + -item_id:required + } { + Delete a content item from the content repository. + @param item_id id of the item to be deleted + } { + db_exec_plsql note_delete { + select content_item__delete(:item_id) + } + } + + CrClass ad_instproc instance_select_query { + {-select_attributes ""} + {-order_clause ""} + {-with_subtypes:boolean true} + {-count:boolean false} + } { + 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 + @param order_clause clause for ordering the solution set + @return sql query + } { + my instvar object_type_key + set attributes [list ci.item_id acs_objects.object_type] + foreach a $select_attributes { + if {$a eq "title"} {set a cr.title} + lappend attributes $a + } + set type_selection [expr {$with_subtypes ? + "acs_object_types.tree_sortkey between \ + '$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 ,]}] + 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" + } + + # + # Form template class + # + + Class Form -parameter { + fields + object_type + {name {[namespace tail [self]]}} + add_page_title + edit_page_title + {with_categories false} + } -ad_doc { + Class for the simplified generation of forms. This class was designed + together with the content repository class + ::Generic::CrClass. + This class can be parameterized with + + } + + Form instproc init {} { + if {![my exists add_page_title]} { + my set add_page_title "Add [[my object_type] pretty_name]" + } + if {![my exists edit_page_title]} { + my set edit_page_title "Edit [[my object_type] 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 + } + + Form instproc form_vars {} { + set vars [list] + foreach varspec [my fields] { + lappend vars [lindex [split [lindex $varspec 0] :] 0] + } + return $vars + } + Form instproc get_vars {object_type} { + foreach var [my form_vars] { + uplevel [list set $var [$object_type set $var]] + } + } + + + Form ad_instproc generate { + {-template "formTemplate"} + } { + the method generate is used to actually generate the form template + from the specifications and to set up page_title and context + when appropriate. + @template is the name of the tcl variable to contain the filled in template + } { + # 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]]] + + set new_data [subst -novariables {[my object_type] add [self]}] + set edit_data [subst -novariables {[my object_type] edit [self]}] + set on_submit {} + + if {[my with_categories]} { + upvar item_id 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] + append 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)" + } + append edit_data { + db_dml update_asc_named_object \ + "update acs_named_objects set object_name = :title, \ + package_id = :package_id where object_id = :item_id" + 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] + } + } + + # action blocks must be added last + ad_form -extend -name [my name] \ + -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 + } + } + + # + # List template class + # + + Class List -parameter { + fields + object_type + object_types + {with_subtypes true} + {name {[namespace tail [self]]}} + {edit_link edit} + {delete_link delete} + } -ad_doc { + Class for the simplified generation of lists. This class was designed + together with the content repository class + ::Generic::CrClass. + This class can be parameterized with + + } + + + 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 + by e.g. a subclass or an object specific method + } { + my instvar object_types + set actions [list] + foreach object_type $object_types { + lappend actions \ + "Add [$object_type pretty_name]" \ + [export_vars -base [my edit_link] {object_type}] \ + "Add a new item of kind [$object_type pretty_name]" + } + return $actions + } + + List ad_instproc elements {} { + elements is a method to compute the elements of each line in the list + depending on the specified fields. It can be easily overwritten + by e.g. a subclass or an object specific method + } { + set elements [list] + foreach {e spec} [my fields] { + switch -exact $e { + EDIT { + lappend elements edit { + link_url_col edit_url + display_template { + edit + } + sub_class narrow + } + } + DELETE { + lappend elements delete { + link_url_col delete_url + display_template { + delete + } + sub_class narrow + } + } + default { + lappend elements $e $spec + } + } + } + return $elements + } + + + List ad_instproc generate { + -order_by + -template + } { + the method generate is used to actually generate the list template + from the specifications and to fill in the actual values from a generic + query + @param order_by specifies the attribute the order of the listing + @template is the name of the tcl variable to contain the filled in template + } { + my instvar object_type with_subtypes + + set order_clause [expr {[info exists order_by] ? "order by $order_by":""}] + if {![info exists template]} { + set template [my name] + } + uplevel set template $template + + set select_attributes [list] + foreach {e spec} [my fields] { + if {[lsearch -exact {item_id object_type EDIT DELETE} $e] == -1} { + lappend select_attributes $e + } + } + + template::list::create \ + -name $template \ + -actions [my actions] \ + -elements [my elements] + + db_multirow \ + -extend { + edit_url + delete_url + } $template instance_select [$object_type instance_select_query \ + -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}] + } + } +} 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 --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/tcl/thread_mod-procs.tcl 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,245 @@ +ad_library { + Tcl API for Thread management provides some support for threads + under the AOL-server and XOTcl. It contains + essentially two classes THREAD and Proxy. +

+ The class THREAD is used to create, initialize + and destroy threads and to pass commands to these + threads. It is designed in a way to create threads + lazyly such that thread definitions can be included + in the modules directory of the aolserver and + therefore be part of the aolserver blueprints. + When an instance of THREAD is created (e.g. t1), + an init-command is provided. e.g.: + 

+    THREAD create t1 {
+      Class Counter -parameter {{value 1}}
+      Counter instproc ++ {} {my incr value}
+      Counter c1
+      Counter c2
+    }
+
+ Commands are sent to the thread via the + "do" method, which returns the result of the + command evaluated in the specified thread. + When the first command is sent to a + non-initialized thread, such as + 
+    set x [t1 do c1 ++]
+
+ the actual thread is created and the thread + ID is remembered in a tsv array. When a + THREAD object is destroyed, the associated + thread is terminated as well. + + Notice that according to the aol-server behavior it + is possible to create **persistent threads** + (when the thread object is created during + startup and provided to all request threads + through the blueprint, or to create **volatile + threads** that are created during a request + and which are deleted when the thread cleanup + is called after some timeout. Volatile threads can + shared as well (when different request-threads + create the same-named thread objects) and can + be used for caching proposes. Flushing the cache + can be done in the thread's exitHandler. + + The Proxy class can be used to simplify + the interaction with a thread and to + hide the fact, that certain classes/objects + are part of a thread. The following command + creates a Proxy for an object c1 in thread t1. + After this, c1 can be used like an local object. + 
+    THREAD::Proxy c1 -attach t1
+    set x [c1 ++]
+
+ The Proxy forwards all commands to the + attached thread except the methods attatch, filter, + detachAll and destroy. The attach method can be used + to reattach a proxy instance to a different thread, such as + 
  
+    c1 attach t2
+
+ A proxy can be (temporarily) detachted from a thread via + 
+    c1 filter ""
+
+ Later forwarding to the thread can be re-enabled via + 
+    c1 filter forward
+
+ When a proxy is attached to a thread and + receives a destroy command, both the proxy + and the corresponding object in the thread + are deleted. If only the proxy object is to be + destroyed, the proxy must be detachted at first. + The class method detatchAll is provided to detach + all proxies from their objects. + + @author Gustaf Neumann + @creation-date 2005-05-13 + @cvs-id $Id: thread_mod-procs.tcl,v 1.1 2005/10/11 08:41:18 gustafn Exp $ +} + +::xotcl::Object setExitHandler { + #my log "EXITHANDLER of request thread [pid]" + if {[catch {Proxy detachAll} m]} { + #my log "EXITHANDLER error in detachAll $m" + } +} + +::Serializer exportObjects { + ::xotcl::THREAD + ::xotcl::THREAD::Client + ::xotcl::THREAD::Proxy +} + +################## main thread support ################## +::xotcl::RecreationClass create ::xotcl::THREAD \ + -instrecreate 1 \ + -parameter {{persistent 0}} + +::xotcl::THREAD instproc check_blueprint {} { + if {![[self class] exists __blueprint_checked]} { + if {[string first ::xotcl::THREAD [ns_ictl get]] == -1} { + _ns_savenamespaces + } + [self class] set __blueprint_checked 1 + } +} + +::xotcl::THREAD instproc init cmd { + my instvar initcmd + set initcmd { + ::xotcl::Object setExitHandler { + #my log "EXITHANDLER of slave thread SELF [pid]" + } + } + regsub -all SELF $initcmd [self] initcmd + append initcmd \n\ + "set ::xotcl::currentScript [info script]" \n\ + "set ::xotcl::currentThread [self]" \n\ + $cmd + my set mutex [thread::mutex create] + 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. +} { + my log "recreating [self] $obj, tid [$obj exists tid]" + if {![string match ::* $obj]} { set obj ::$obj } + $obj set recreate 1 + next + $obj init [lindex $args 0] + if {[nsv_exists [self] $obj]} { + set tid [nsv_get [self] $obj] + ::thread::send $tid [$obj set initcmd] + $obj set tid $tid + my log "+++ content of thread $obj ($tid) redefined" + } +} + +::xotcl::THREAD instproc destroy {} { + my log "destroy called" + if {![my persistent] && + [nsv_exists [self class] [self]]} { + set tid [nsv_get [self class] [self]] + set refcount [::thread::release $tid] + my log "destroying thread object tid=$tid cnt=$refcount" + if {$refcount == 0} { + my log "thread terminated" + nsv_unset [self class] [self] + } + } + thread::mutex destroy [my set mutex] + next +} +::xotcl::THREAD instproc do {o args} { + if {![nsv_exists [self class] [self]]} { + # lazy creation of a new slave thread + + thread::mutex lock [my set mutex] + my check_blueprint + #my log "after lock" + if {![nsv_exists [self class] [self]]} { + set tid [::thread::create] + nsv_set [self class] [self] $tid + if {[my persistent]} { + my log "created new persistent [self class] as $tid pid=[pid]" + } else { + my log "created new [self class] as $tid pid=[pid]" + } + ::thread::send $tid [my set initcmd] + } else { + set tid [nsv_get [self class] [self]] + } + #my log "doing unlock" + thread::mutex unlock [my set mutex] + } else { + # target thread is already up and running + set tid [nsv_get [self class] [self]] + } + if {![my exists tid]} { + # this is the first call + if {![my persistent] && ![my exists recreate]} { + # for a shared thread, we do ref-counting through preseve + my log "must preserve for sharing request-thread [pid]" + set tid [nsv_get [self class] [self]] + ::thread::preserve $tid + } + my set tid $tid + } + #my log "calling [self class] ($tid, [pid]) $o $args" + return [thread::send $tid "$o $args"] +} + +# create a sample persistent thread that can be acessed +# via request threads +#THREAD create t0 { +# Class Counter -parameter {{value 1}} +# Counter instproc ++ {} {my incr value} +# +# Counter c1 +# Counter c2 +#} -persistent 1 +# + +################## forwarding proxy ################## +Class ::xotcl::THREAD::Proxy -parameter {attach} +::xotcl::THREAD::Proxy configure \ + -instproc forward args { + set cp [self calledproc] + if { [string equal $cp attach] + || [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 +#} + +# sample Thread client routine, calls a same named object in the server thread +Class create ::xotcl::THREAD::Client -parameter server +::xotcl::THREAD::Client instproc do args { + eval [my server] do [self] $args +} + Index: openacs-4/packages/xotcl-core/www/ad-instproc.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/Attic/ad-instproc.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/www/ad-instproc.tcl 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,23 @@ + + +Object o +o ad_proc t1 {{-a 1} -b:required x {y 4}} {} { + expr {$a + $b + $x + $y} +} + + +ad_proc t2 {{-a 1} -b:required x {y 4}} {} { + expr {$a + $b + $x + $y} +} + +set v1 [o t1 -b 2 3] +set v2 [t2 -b 2 3] + + +ns_return 200 text/plain " +xotcl ad_proc t1=$v1 [time {time {o t1 -b 2 3} 10000}] +ad_proc t2=$v2 [time {time {t2 -b 2 3} 10000}] +xotcl ad_proc t1=$v1 [time {time {o t1 -b 2 3} 10000}] +ad_proc t2=$v2 [time {time {t2 -b 2 3} 10000}] +" + Index: openacs-4/packages/xotcl-core/www/index.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/index.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/www/index.adp 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,16 @@ + +@title@ +@context;noquote@ + +
+@dimensional_slider;noquote@ +
+
+ +@output;noquote@ + +
+
+@dimensional_slider;noquote@ +
+ Index: openacs-4/packages/xotcl-core/www/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/index.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/www/index.tcl 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,92 @@ +ad_page_contract { + Show classed defined in the connection threads + + @author Gustaf Neumann + @cvs-id $id:$ +} -query { + {all_classes:optional 0} +} -properties { + title:onevalue + context:onevalue + output:onevalue +} + +set title "XOTcl Classes Defined in Connection Threads" +set context [list "XOTcl"] + +set dimensional_slider [ad_dimensional { + { + all_classes "Show:" 0 { + { 1 "All Classes" } + { 0 "Application Classes only" } + } + } +}] + + +proc local_link cl { + upvar all_classes all_classes + if {$all_classes || ![string match ::xotcl::* $cl]} { + return "$cl" + } else { + return $cl + } +} + +proc doc_link {obj kind method} { + set kind [string trimright $kind s] + set proc_index [::xotcl::api proc_index "" $obj $kind $method] + if {[nsv_exists api_proc_doc $proc_index]} { + return "$method" + } else { + return $method + } +} + +proc info_classes {cl key} { + upvar all_classes all_classes + set infos "" + foreach s [$cl info $key] { + append infos [local_link $s] ", " + } + set infos [string trimright $infos ", "] + if {[string compare "" $infos]} { + return "
  • $key $infos
    • \n" + } else { + return "" + } +} + +set output " + Index: openacs-4/packages/xotcl-core/www/show-object.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/show-object.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/www/show-object.adp 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,44 @@ + + +@title;noquote@ +@context;noquote@ + + + + +
    +@dimensional_slider;noquote@ +
    +
    + +

    @title;noquote@

    +@output;noquote@ + +
    +
    +@dimensional_slider;noquote@ +
    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 --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/www/show-object.tcl 11 Oct 2005 08:41:18 -0000 1.1 @@ -0,0 +1,203 @@ +ad_page_contract { + Show an xotcl class or object + + @author Gustaf Neumann + @cvs-id $id:$ +} -query { + {object:optional ::xotcl::Object} + {show_methods:optional 1} + {show_source:optional 0} + {show_variables:optional 0} +} -properties { + title:onevalue + context:onevalue + output:onevalue +} + +set context [list "XOTcl"] +set output "" +::xotcl::api scope_from_object_reference scope object +set isclass [::xotcl::api isclass $scope $object] + +interp alias {} DO {} ::xotcl::api inscope $scope +set s [DO Serializer new] + +set dimensional_slider [ad_dimensional { + { + show_methods "Methods:" 1 { + { 2 "All Methods" } + { 1 "Documented Methods" } + { 0 "Hide Methods" } + } + } + { + show_source "Source:" 0 { + { 1 "Display Source" } + { 0 "Hide Source" } + } + } + { + show_variables "Variables:" 0 { + { 1 "Show Variables" } + { 0 "Hide Variables" } + } + } + }] + + +proc api_documentation {scope object kind method} { + upvar show_methods show_methods + set proc_index [::xotcl::api proc_index $scope $object $kind $method] + if {[nsv_exists api_proc_doc $proc_index]} { + set documentation [api_proc_documentation \ + -first_line_tag "

    " \ + -label "$kind $method" \ + $proc_index] + set result $documentation + } else { + if {$show_methods == 2} { + set result "

    $kind $method

    " + } else { + set result "" + } + } + return $result +} + +proc info_option {scope object kind {dosort 0}} { + upvar class_references class_references + set list [DO $object info $kind] + set refs [list] + foreach e $list { + if {[DO $object isclass $e]} { + lappend refs [::xotcl::api object_link $scope $e] + } + } + if {[llength $refs]>0 && [string compare ::xotcl::Object $list]} { + append class_references "
  • $kind: [join $refs {, }]
    • \n" + } + if {[llength $list]>0 && [string compare ::xotcl::Object $list]} { + return " \\\n -$kind [list $list]" + } + return "" +} + + +# +# document the class or the object" +# +set index [::xotcl::api object_index $scope $object] +append output "
    \n" + +if {[nsv_exists api_library_doc $index]} { + array set doc_elements [nsv_get api_library_doc $index] + append output [lindex $doc_elements(main) 0] + append output "
    \n" + if { [info exists doc_elements(creation-date)] } { + append output "
    Created:\n
    [lindex $doc_elements(creation-date) 0]\n" + } + if { [info exists doc_elements(author)] } { + append output "
    Author[ad_decode [llength $doc_elements(author)] 1 "" "s"]:\n" + foreach author $doc_elements(author) { + append output "
    [api_format_author $author]\n" + } + } + if { [info exists doc_elements(cvs-id)] } { + append output "
    CVS Identification:\n
    \ + [ns_quotehtml [lindex $doc_elements(cvs-id) 0]]\n" + } + append output "
    \n" + + set url "/api-doc/procs-file-view?path=[ns_urlencode $doc_elements(script)]" + append output "Defined in     $doc_elements(script)

    " + + array unset doc_elements +} +set my_class [DO $object info class] +set obj_create_source "$my_class create $object" +set title "[::xotcl::api object_link $scope $my_class] $object" +set class_references "" + +if {$isclass} { + append obj_create_source \ + [info_option $scope $object superclass] \ + [info_option $scope $object parameter] \ + [info_option $scope $object instmixin] + info_option $scope $object subclass +} + +append obj_create_source \ + [info_option $scope $object mixin] + +if {$class_references ne ""} { + append output "

    Class Relations

    \n" +} +append output "
    \n" + +if {$show_source} { + append output [::xotcl::api source_to_html $obj_create_source] \n +} + +if {$show_methods} { + append output "

    Methods

    \n" \n +} + +if {$show_variables} { + set vars "" + foreach v [lsort [DO $object info vars]] { + if {[DO $object array exists $v]} { + append vars "$object array set $v [list [DO $object array get $v]]\n" + } else { + append vars "$object set $v [list [DO $object set $v]]\n" + } + } + if {[string compare "" $vars]} { + append output "

    Variables

    \n" \ + [::xotcl::api source_to_html $vars] \n + } +} + +if {$isclass} { + set instances "" + foreach o [lsort [DO $object info instances]] { + append instances [::xotcl::api object_link $scope $o] ", " + } + set instances [string trimright $instances ", "] + if {[string compare "" $instances]} { + append output "

    Instances

    \n" \ +
    \n \ + $instances \ +
    \n + } +} + + +DO $s destroy