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 {
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).
-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.
+Each content item can be retrieved either through the + general method + + CrItem instantiate or through the "instantiate" method of + every subclass of CrItem. -
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.
+This Class is a meta-class providing methods for Classes + manageing CrItems.
} + 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 ::Generic::Form) 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 ::Generic::Form) 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 ::Generic::CrClass. - This class can be parameterized with +