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.25 -r1.26 --- openacs-4/packages/xotcl-core/xotcl-core.info 10 Apr 2007 13:19:27 -0000 1.25 +++ openacs-4/packages/xotcl-core/xotcl-core.info 16 Apr 2007 09:52:56 -0000 1.26 @@ -8,10 +8,10 @@ t xotcl - + Gustaf Neumann XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes) - 2007-04-10 + 2007-04-16 This component contains some core functionality for OACS applications using XOTcl. It includes XOTcl thread handling for OACS (supporting persistent and @@ -37,7 +37,7 @@ BSD-Style 0 - + Index: openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl,v diff -u -r1.10 -r1.11 --- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 11 Apr 2007 12:19:38 -0000 1.10 +++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 16 Apr 2007 09:52:56 -0000 1.11 @@ -29,18 +29,29 @@ Class DbPackage DbPackage instproc sql-arguments {sql package_name object_name} { - set psql_args [list] my array unset defined - my set function_args [db_list [my qn get_function_params] $sql] + my set function_args [db_list_of_lists [my qn get_function_params] $sql] + set psql_args [list] + my set arg_order [list] foreach arg [my set function_args] { - lappend psql_args \$_$arg - my set defined($arg) 1 + foreach {arg_name default_value} $arg break + lappend psql_args \$_$arg_name + my lappend arg_order $arg_name + my set defined($arg_name) $default_value } + if {"$package_name-$object_name" eq "CONTENT_ITEM-NEW"} { + # content_item__new does currently not define null default values. + # This ugly - temporary - hack is used to keep the :required passing and to allow + # the xowiki regression test to run. The correct fix is to define in + # correct default values in the database with define_function_args() + my array set defined {RELATION_TAG null DESCRIPTION null TEXT null CREATION_IP null NLS_LANGUAGE null LOCALE null CONTEXT_ID null DATA null TITLE null ITEM_ID null + } + } return [join $psql_args ", "] } DbPackage instproc psql-postgresql {package_name object_name full_statement_name} { set psql_args [my sql-arguments { - select args.arg_name + select args.arg_name, args.arg_default from acs_function_args args where args.function = upper(:package_name) || '__' || upper(:object_name) order by function, arg_seq @@ -62,7 +73,7 @@ and position = 0) }] set psql_args [my sql-arguments { - select args.argument_name + select args.argument_name, args.default_value from user_arguments args where args.position > 0 and args.object_name = upper(:object_name) @@ -78,13 +89,15 @@ } } - DbPackage instproc dbproc {{-f:switch false} object_name} { + DbPackage instproc dbproc_exportvars {object_name} { # - # This method compiles a stored procedure into a xotcl method. + # This method compiles a stored procedure into a xotcl method using + # a export_vars style interface. + # # The current implementation should work on postgres and oracle (not tested) # but will not work, when a single openacs instance want to talk to # postgres and oracle simultaneously. Not sure, how important this is... - + # set package_name [namespace tail [self]] set statement_name [my qn $package_name-$object_name] set sql_command [my psql-[db_driverkey ""] $package_name $object_name $statement_name] @@ -106,7 +119,8 @@ my log "ERROR: $attribute not defined in ${package_name}.${object_name}" } } - foreach arg [list [my set function_args]] { + foreach {_arg} [list [my set function_args]] { + foreach {arg default_value} $_arg break set _$arg \[expr {\[info exists $arg\] ? ":$arg" : "null"}\] } set sql \[list "[my set sql]"\] @@ -122,14 +136,60 @@ }] } + DbPackage instproc dbproc_nonposargs {object_name} { + # + # This method compiles a stored procedure into a xotcl method + # using a classic nonpositional argument style interface. + # + # The current implementation should work on postgres and oracle (not tested) + # but will not work, when a single openacs instance want to talk to + # postgres and oracle simultaneously. Not sure, how important this is... + # + set package_name [namespace tail [self]] + set statement_name [my qn $package_name-$object_name] + set sql_command [my psql-[db_driverkey ""] $package_name $object_name $statement_name] + + set nonposarg_list [list [list -dbn ""]] + foreach arg_name [my set arg_order] { + set default_value [my set defined($arg_name)] + set required [expr {$default_value eq "" ? ":required" : ""}] + set nonposarg_name [expr {$arg_name eq "DBN" ? "DBN" : [string tolower $arg_name]}] + lappend nonposarg_list -$nonposarg_name$required + } + + my ad_proc $object_name $nonposarg_list {} [subst -novariables { + #defined: [my array get defined] + + foreach var \[list [my set arg_order]\] { + set varname \[string tolower $var\] + if {\[info exists $varname\]} { + set $var \[set $varname\] + set _$var :$var + } else { + set _$var null + } + } + + set sql \[list "[my set sql]"\] + db_with_handle -dbn $dbn db { + #my log "sql=$sql, sql_command=[set sql_command]" + set selection \[eval [set sql_command]\] + return \[ns_set value $selection 0\] + } + }] + } + DbPackage instproc unknown {m args} { error "Error: unknown database method $m for dbpackage [self]" } DbPackage proc create_all_functions {} { db_foreach [my qn ""] [call set [db_driverkey ""]_all_package_functions] { if {![my isobject $package_name]} { DbPackage create $package_name } - $package_name dbproc $object_name + $package_name dbproc_exportvars $object_name + set class_name [string tolower $package_name] + if {![my isobject $class_name]} { DbPackage create $class_name } + $class_name dbproc_nonposargs [string tolower $object_name] } } DbPackage create_all_functions @@ -174,9 +234,9 @@ ns_cache eval xotcl_object_cache ::xo::has_ltree { if {[db_driverkey ""] eq "postgresql" && [db_0or1row check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"]} { - return 0 + return 1 } - return 1 + return 0 } } Index: openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl,v diff -u -r1.12 -r1.13 --- openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 3 Apr 2007 19:17:17 -0000 1.12 +++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 16 Apr 2007 09:52:56 -0000 1.13 @@ -134,7 +134,11 @@ # proc get_user_name {uid} { if {$uid ne "" && $uid != 0} { - acs_user::get -user_id $uid -array user + if {[catch {acs_user::get -user_id $uid -array user}]} { + # we saw some strange cases, where after a regression, + # a user_id was present, which was already deleted... + return nobody + } return "$user(first_names) $user(last_name)" } else { return nobody 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.53 -r1.54 --- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 11 Apr 2007 12:19:38 -0000 1.53 +++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 16 Apr 2007 09:52:56 -0000 1.54 @@ -155,18 +155,22 @@ register the current object type for folder_id. If folder_id is not specified, use the instvar of the class instead. } { - set operation [string toupper $operation] - if {$operation ne "REGISTER" && $operation ne "UNREGISTER"} { - error "[self] operation for folder_type must be '\ - register' or 'unregister'" + #set operation [string toupper $operation] + #if {$operation ne "REGISTER" && $operation ne "UNREGISTER"} + 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 } - ::xo::db::CONTENT_FOLDER ${operation}_CONTENT_TYPE { - folder_id {content_type $object_type} {include_subtypes t} - } + ::xo::db::content_folder ${operation}_content_type \ + -folder_id $folder_id \ + -content_type $object_type \ + -include_subtypes t +# ::xo::db::CONTENT_FOLDER ${operation}_CONTENT_TYPE { +# folder_id {content_type $object_type} {include_subtypes t} +# } } CrClass ad_instproc create_object_type {} { @@ -183,19 +187,36 @@ } db_transaction { - ::xo::db::CONTENT_TYPE CREATE_TYPE { - {content_type $object_type} supertype pretty_name pretty_plural - table_name id_column name_method - } +# ::xo::db::CONTENT_TYPE CREATE_TYPE { +# {content_type $object_type} supertype pretty_name pretty_plural +# table_name id_column name_method +# } + ::xo::db::content_type create_type \ + -content_type $object_type \ + -supertype $super_type \ + -pretty_name $pretty_name \ + -pretty_plural $pretty_plural \ + -table_name $table_name \ + -id_column $id_column \ + -name_method $name_method + if {[my cr_attributes] ne ""} { set o [::xo::OrderedComposite new -contains [my cr_attributes]] $o destroy_on_cleanup foreach att [$o children] { $att instvar attribute_name datatype pretty_name sqltype - ::xo::db::CONTENT_TYPE CREATE_ATTRIBUTE { - {content_type $object_type} attribute_name datatype - pretty_name {column_spec $sqltype} - } + + ::xo::db::content_type create_attribute \ + -content_type $object_type \ + -attribute_name $attribute_name \ + -datatype $datatype \ + -pretty_name $pretty_name \ + -column_spec $sqltype + +# ::xo::db::CONTENT_TYPE CREATE_ATTRIBUTE { +# {content_type $object_type} attribute_name datatype +# pretty_name {column_spec $sqltype} +# } } } my folder_type register @@ -210,9 +231,13 @@ my instvar object_type table_name db_transaction { my folder_type unregister - ::xo::db::CONTENT_TYPE DROP_TYPE { - {content_type $object_type} {drop_children_p t} {drop_table_p t} - } + ::xo::db::content_type drop_type \ + -content_type $object_type \ + -drop_children_p t \ + -drop_table_p t +# ::xo::db::CONTENT_TYPE DROP_TYPE { +# {content_type $object_type} {drop_children_p t} {drop_table_p t} +# } } } @@ -424,7 +449,8 @@ Delete a content item from the content repository. @param item_id id of the item to be deleted } { - ::xo::db::CONTENT_ITEM DELETE {item_id} + #::xo::db::CONTENT_ITEM DELETE {item_id} + ::xo::db::content_item delete -item_id $item_id } CrClass ad_instproc instance_select_query { @@ -679,9 +705,11 @@ values (:[join $__atts ,:])" my update_content_length $storage_type $revision_id if {$live_p} { - set publish_status [my set publish_status] - ::xo::db::CONTENT_ITEM SET_LIVE_REVISION {revision_id publish_status} - + #set publish_status [my set publish_status] + #::xo::db::CONTENT_ITEM SET_LIVE_REVISION {revision_id publish_status} + ::xo::db::content_item set_live_revision \ + -revision_id $revision_id \ + -publish_status [my set publish_status] } else { # if we do not make the revision live, use the old revision_id, # and let CrCache save it @@ -693,23 +721,38 @@ if {[apm_version_names_compare [ad_acs_version] 5.2] > -1} { ns_log notice "--Version 5.2 or newer [ad_acs_version]" +# CrItem set content_item__new_args { +# name parent_id creation_user {item_subtype "content_item"} {content_type $object_type} +# description mime_type nls_language {is_live f} storage_type package_id +# } CrItem set content_item__new_args { - name parent_id creation_user {item_subtype "content_item"} {content_type $object_type} - description mime_type nls_language {is_live f} storage_type package_id + -name $name -parent_id $parent_id -creation_user $creation_user \ + -item_subtype "content_item" -content_type $object_type \ + -description $description -mime_type $mime_type -nls_language $nls_language \ + -is_live f -storage_type $storage_type -package_id $package_id } } else { ns_log notice "--Version 5.1 or older [ad_acs_version]" +# CrItem set content_item__new_args { +# name parent_id creation_user {item_subtype "content_item"} {content_type $object_type} +# description mime_type nls_language {is_live f} storage_type +# } CrItem set content_item__new_args { - name parent_id creation_user {item_subtype "content_item"} {content_type $object_type} - description mime_type nls_language {is_live f} storage_type + -name $name -parent_id $parent_id -creation_user $creation_user \ + -item_subtype "content_item" -content_type $object_type \ + -description $description -mime_type $mime_type -nls_language $nls_language \ + -is_live f -storage_type $storage_type } } CrItem ad_instproc set_live_revision {-revision_id:required {-publish_status "ready"}} { @param revision_id @param publish_status one of 'live', 'ready' or 'production' } { - ::xo::db::CONTENT_ITEM SET_LIVE_REVISION {revision_id publish_status} + ::xo::db::content_item set_live_revision \ + -revision_id $revision_id \ + -publish_status $publish_status + #::xo::db::CONTENT_ITEM SET_LIVE_REVISION {revision_id publish_status} } CrItem ad_instproc save_new {-package_id -creation_user_id {-live_p:boolean true}} { @@ -753,7 +796,8 @@ set name [expr {[my exists __autoname_prefix] ? "[my set __autoname_prefix]$revision_id" : $revision_id}] } - set item_id [::xo::db::CONTENT_ITEM NEW [[self class] set content_item__new_args]] + #set item_id [::xo::db::CONTENT_ITEM NEW [[self class] set content_item__new_args]] + set item_id [eval ::xo::db::content_item new [[self class] set content_item__new_args]] if {$storage_type eq "file"} { set text [cr_create_content_file $item_id $revision_id $import_file] } @@ -763,8 +807,11 @@ values (:[join $__atts ,:])" my update_content_length $storage_type $revision_id if {$live_p} { - set publish_status [my set publish_status] - ::xo::db::CONTENT_ITEM SET_LIVE_REVISION {revision_id publish_status} + ::xo::db::content_item set_live_revision \ + -revision_id $revision_id \ + -publish_status [my set publish_status] + #set publish_status [my set publish_status] + #::xo::db::CONTENT_ITEM SET_LIVE_REVISION {revision_id publish_status} } } my set revision_id $revision_id