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.107 -r1.108
--- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 6 Oct 2017 13:11:50 -0000 1.107
+++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 9 Oct 2017 13:06:53 -0000 1.108
@@ -75,7 +75,7 @@
string { set type text }
long_text { set type text }
date { set type "timestamp with time zone" }
- ltree { set type [expr {[my has_ltree] ? "ltree" : "text" }] }
+ ltree { set type [expr {[:has_ltree] ? "ltree" : "text" }] }
default { return [next] }
}
return $type
@@ -110,15 +110,15 @@
::xo::db::postgresql instproc has_ltree {} {
ns_cache eval xotcl_object_cache [self]::has_ltree {
- if {[my get_value check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"] > 0} {
+ if {[:get_value check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"] > 0} {
return 1
}
return 0
}
}
::xo::db::postgresql instproc has_hstore {} {
ns_cache eval xotcl_object_cache [self]::has_hstore {
- if {[my get_value check_ltree "select count(*) from pg_proc where proname = 'hstore_in'"] > 0} {
+ if {[:get_value check_ltree "select count(*) from pg_proc where proname = 'hstore_in'"] > 0} {
return 1
}
return 0
@@ -191,7 +191,7 @@
set constraint ""
switch -- $type {
boolean {
- set cname [my mk_sql_constraint_name $table $att _ck]
+ set cname [:mk_sql_constraint_name $table $att _ck]
set constraint "constraint $cname check ($att in ('t','f'))"}
}
return $constraint
@@ -212,7 +212,7 @@
set where_clause [expr {$where ne "" ? "WHERE $where" : ""}]
set order_clause [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}]
set group_clause [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}]
- if {$map_function_names} {set vars [my map_function_name $vars]}
+ if {$map_function_names} {set vars [:map_function_name $vars]}
set sql "SELECT $vars FROM $from $where_clause $group_clause"
if {$limit ne "" || $offset ne ""} {
if {$offset eq ""} {
@@ -228,7 +228,7 @@
} else {
append sql " " $order_clause
}
- my log "--returned sql = $sql"
+ :log "--returned sql = $sql"
return $sql
}
::xo::db::oracle instproc date_trunc {field date} {
@@ -291,7 +291,7 @@
set full_statement_name [db_qd_get_fullname $qn 2]
set full_query [db_qd_fetch $full_statement_name $dbn]
set sql [db_fullquery_get_querytext $full_query]
- my uplevel 2 [list subst $sql]
+ :uplevel 2 [list subst $sql]
}
@@ -301,88 +301,88 @@
#
::xo::db::DBI instproc profile {onOff} {
if {$onOff} {
- my mixin ::xo::db::DBI::Profile
+ :mixin ::xo::db::DBI::Profile
} else {
- if {[my info mixin] ne ""} {my mixin ""}
+ if {[:info mixin] ne ""} {:mixin ""}
}
}
::xo::db::DBI instproc sets {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- return [my uplevel [list dbi_rows -result sets {*}$bindOpt -- $sql]]
+ return [:uplevel [list dbi_rows -result sets {*}$bindOpt -- $sql]]
}
#
# foreach based on "dbi_rows + results avlists"
#
::xo::db::DBI instproc foreach {{-dbn ""} {-bind ""} -prepare qn sql body} {
- #if {$sql eq ""} {set sql [my get_sql $qn]}
+ #if {$sql eq ""} {set sql [:get_sql $qn]}
if {$sql eq ""} {set qn [uplevel [list [self] qn $qn]]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- set avlists [my uplevel [list dbi_rows -result avlists {*}$bindOpt -- $sql]]
+ set avlists [:uplevel [list dbi_rows -result avlists {*}$bindOpt -- $sql]]
foreach avlist $avlists {
- foreach {a v} $avlist {my uplevel [list set $a $v]}
- my uplevel $body
+ foreach {a v} $avlist {:uplevel [list set $a $v]}
+ :uplevel $body
}
}
#
# foreach based on "dbi_eval"
#
#::xo::db::DBI instproc foreach {{-dbn ""} {-bind ""} -prepare qn sql body} {
- # if {$sql eq ""} {set sql [my get_sql $qn]}
+ # if {$sql eq ""} {set sql [:get_sql $qn]}
# if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- # my uplevel [list dbi_foreach $sql $body]
+ # :uplevel [list dbi_foreach $sql $body]
#}
::xo::db::DBI instproc 0or1row {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- return [my uplevel [list ::dbi_0or1row {*}$bindOpt $sql]]
+ return [:uplevel [list ::dbi_0or1row {*}$bindOpt $sql]]
}
::xo::db::DBI instproc 1row {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- return [my uplevel [list ::dbi_1row {*}$bindOpt $sql]]
+ return [:uplevel [list ::dbi_1row {*}$bindOpt $sql]]
}
::xo::db::DBI instproc list_of_lists {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- return [my uplevel [list ::dbi_rows -result lists -max 1000000 {*}$bindOpt -- $sql]]
+ return [:uplevel [list ::dbi_rows -result lists -max 1000000 {*}$bindOpt -- $sql]]
}
::xo::db::DBI instproc list {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- set flat [my uplevel [list ::dbi_rows -columns __columns {*}$bindOpt -- $sql]]
- if {[my uplevel {llength $__columns}] > 1} {error "query is returing more than one column"}
+ set flat [:uplevel [list ::dbi_rows -columns __columns {*}$bindOpt -- $sql]]
+ if {[:uplevel {llength $__columns}] > 1} {error "query is returing more than one column"}
return $flat
}
::xo::db::DBI instproc dml {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- return [my uplevel [list ::dbi_dml {*}$bindOpt -- $sql]]
+ return [:uplevel [list ::dbi_dml {*}$bindOpt -- $sql]]
}
::xo::db::DBI instproc transaction {{-dbn ""} script args} {
if {$args ne ""} {
lassign $args op on_error_code
set result ""
if {$op ne "on_error"} {error "only 'on_error' as argument after script allowed"}
if {[catch {
- set result [my uplevel [list ::dbi_eval -transaction committed $script]]
+ set result [:uplevel [list ::dbi_eval -transaction committed $script]]
}]} {
- my uplevel $on_error_code
+ :uplevel $on_error_code
}
return $result
} else {
- return [my uplevel [list ::dbi_eval -transaction committed $script]]
+ return [:uplevel [list ::dbi_eval -transaction committed $script]]
}
}
::xo::db::DBI instproc prepare {-handle {-argtypes ""} sql} {
return $sql
}
::xo::db::DBI instproc get_value {{-dbn ""} -prepare qn sql {default ""}} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
- set answers [my uplevel [list ::dbi_rows -result sets -max 1 $sql]]
+ if {$sql eq ""} {set sql [:get_sql $qn]}
+ set answers [:uplevel [list ::dbi_rows -result sets -max 1 $sql]]
if {$answers ne ""} {
set result [ns_set value $answers 0]
ns_set free $answers
@@ -399,10 +399,10 @@
foreach call {sets 0or1row 1row list_of_lists list dml} {
::xo::db::DBI::Profile instproc $call {{-dbn ""} qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
set start_time [expr {[clock clicks -microseconds]/1000.0}]
set result [next]
- ds_add db $dbn [my ds_map [self proc]] $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 ""
+ ds_add db $dbn [:ds_map [self proc]] $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 ""
return $result
}
}
@@ -411,22 +411,22 @@
# foreach based on "dbi_rows + results avlists"
#
::xo::db::DBI::Profile instproc foreach {{-dbn ""} {-bind ""} -prepare qn sql body} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
set start_time [expr {[clock clicks -microseconds]/1000.0}]
- set avlists [my uplevel [list dbi_rows -result avlists {*}$bindOpt -- $sql]]
+ set avlists [:uplevel [list dbi_rows -result avlists {*}$bindOpt -- $sql]]
ds_add db $dbn "exec foreach" $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 ""
foreach avlist $avlists {
- foreach {a v} $avlist {my uplevel [list set $a $v]}
- my uplevel $body
+ foreach {a v} $avlist {:uplevel [list set $a $v]}
+ :uplevel $body
}
}
#
# foreach based on "dbi_foreach"
#
#::xo::db::DBI::Profile instproc foreach {{-dbn ""} {-bind ""} -prepare qn sql body} {
- # if {$sql eq ""} {set sql [my get_sql $qn]}
+ # if {$sql eq ""} {set sql [:get_sql $qn]}
# if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
# set start_time [expr {[clock clicks -microseconds]/1000.0}]
# set result [next]
@@ -445,8 +445,8 @@
# things look fine.
::xo::db::DBI::Profile instproc 1row {{-dbn ""} {-bind ""} -prepare qn sql} {
set start_time [expr {[clock clicks -microseconds]/1000.0}]
- set result [my uplevel [list ::dbi_1row $sql]]
- ds_add db $dbn [my ds_map [self proc]] $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 ""
+ set result [:uplevel [list ::dbi_1row $sql]]
+ ds_add db $dbn [:ds_map [self proc]] $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 ""
return $result
}
@@ -460,14 +460,14 @@
}
::xo::db::DB instproc transaction {{-dbn ""} script args} {
- return [my uplevel [list ::db_transaction -dbn $dbn $script {*}$args]]
+ return [:uplevel [list ::db_transaction -dbn $dbn $script {*}$args]]
}
::xo::db::DB instproc prepare {-handle {-argtypes ""} sql} {
return $sql
}
::xo::db::DB instproc sets {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
db_with_handle -dbn $dbn db {
if {[info exists prepare]} {set sql [:prepare -handle $db -argtypes $prepare $sql]}
@@ -481,7 +481,7 @@
}
::xo::db::DB instproc foreach {{-dbn ""} {-bind ""} -prepare qn sql body} {
- #if {$sql eq ""} {set sql [my get_sql $qn]}
+ #if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
set qn [uplevel [list [self] qn $qn]]
#
@@ -510,7 +510,7 @@
uplevel [list ::db_1row [uplevel [list [self] qn $qn]] $sql {*}$bindOpt]
}
::xo::db::DB instproc dml {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
uplevel [list ::db_dml [uplevel [list [self] qn $qn]] $sql {*}$bindOpt]
return [db_resultrows]
@@ -545,7 +545,7 @@
# DB driver functions, optimized for PostgreSQL
#
::xo::db::DB-postgresql instproc 0or1row {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
set prepOpt [expr {[info exists prepare] ? [list -prepare $prepare] : ""}]
set answers [uplevel [list [self] exec_0or1row {*}$prepOpt -bind $bind $sql]]
if {$answers ne ""} {
@@ -556,7 +556,7 @@
return 0
}
::xo::db::DB-postgresql instproc 1row {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
set prepOpt [expr {[info exists prepare] ? [list -prepare $prepare] : ""}]
set answers [uplevel [list [self] exec_0or1row {*}$prepOpt -bind $bind $sql]]
if {$answers ne ""} {
@@ -567,7 +567,7 @@
error "query $sql did not return an answer"
}
::xo::db::DB-postgresql instproc get_value {{-dbn ""} {-bind ""} -prepare qn sql {default ""}} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
set prepOpt [expr {[info exists prepare] ? [list -prepare $prepare] : ""}]
set answers [uplevel [list [self] exec_0or1row {*}$prepOpt -bind $bind $sql]]
if {$answers ne ""} {
@@ -578,7 +578,7 @@
return $default
}
::xo::db::DB-postgresql instproc list_of_lists {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
db_with_handle db {
if {[info exists prepare]} {set sql [:prepare -handle $db -argtypes $prepare $sql]}
@@ -594,7 +594,7 @@
return $result
}
::xo::db::DB-postgresql instproc list {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
db_with_handle db {
if {[info exists prepare]} {set sql [:prepare -handle $db -argtypes $prepare $sql]}
@@ -608,7 +608,7 @@
return $result
}
::xo::db::DB-postgresql instproc dml {{-dbn ""} {-bind ""} -prepare qn sql} {
- if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$sql eq ""} {set sql [:get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
set bind $bindOpt
db_with_handle -dbn $dbn db {
@@ -807,12 +807,12 @@
}
require proc table {name definition {populate ""}} {
- #my log "==== require table $name exists: [my exists_table $name]\n$definition"
- if {![my exists_table $name]} {
+ #:log "==== require table $name exists: [:exists_table $name]\n$definition"
+ if {![:exists_table $name]} {
set lines {}
foreach col [dict keys $definition] {lappend lines "$col [dict get $definition $col]"}
set definition [join $lines ",\n"]
- # my log "--table $name does not exist, creating with definition: $definition"
+ # :log "--table $name does not exist, creating with definition: $definition"
::xo::dc dml create-table-$name "create table $name ($definition)"
if {$populate ne ""} {
::xo::dc dml populate-table-$name $populate
@@ -822,7 +822,7 @@
# add columns. We do not alter attribute types, and we do not
# delete columns.
foreach col [dict keys $definition] {
- if {![my exists_column $name $col]} {
+ if {![:exists_column $name $col]} {
ns_log notice "xodb: adding column <alter table $name add column $col [dict get $definition $col]>"
::xo::dc dml alter-table-$name \
"alter table $name add column $col [dict get $definition $col]"
@@ -913,7 +913,7 @@
}
require proc package {package_key} {
- if {![my exists required_package($package_key)]} {
+ if {![info exists :required_package($package_key)]} {
foreach path [apm_get_package_files \
-package_key $package_key \
-file_types tcl_procs] {
@@ -922,7 +922,7 @@
# sourcing should no happen)
uplevel #1 apm_source "[acs_root_dir]/packages/$package_key/$path"
}
- my set required_package($package_key) 1
+ set :required_package($package_key) 1
}
}
@@ -978,12 +978,12 @@
}
if {[file readable $sql_file]} {
- my log "Sourcing '$sql_file'"
+ :log "Sourcing '$sql_file'"
db_source_sql_file $sql_file
::xo::db::Class create_all_functions
return 1
} else {
- my log "Could not source '$sql_file'"
+ :log "Could not source '$sql_file'"
}
}
return 0
@@ -1074,9 +1074,9 @@
@return fully qualified object
} {
- set type [my get_object_type -id $id]
+ set type [:get_object_type -id $id]
set class [::xo::db::Class object_type_to_class $type]
- if {![my isclass $class]} {
+ if {![:isclass $class]} {
error "no class $class defined"
}
set r [$class create ::$id]
@@ -1161,12 +1161,12 @@
select object_type, supertype, pretty_name, lower(id_column) as id_column, lower(table_name) as table_name
from acs_object_types where object_type = :object_type
}
- set classname [my object_type_to_class $object_type]
- if {![my isclass $classname]} {
+ set classname [:object_type_to_class $object_type]
+ if {![:isclass $classname]} {
# the XOTcl class does not exist, we create it
- #my log "--db create class $classname superclass $supertype"
+ #:log "--db create class $classname superclass $supertype"
::xo::db::Class create $classname \
- -superclass [my object_type_to_class $supertype] \
+ -superclass [:object_type_to_class $supertype] \
-object_type $object_type \
-supertype $supertype \
-pretty_name $pretty_name \
@@ -1175,7 +1175,7 @@
-sql_package_name [namespace tail $classname] \
-noinit
} else {
- #my log "--db we have a class $classname"
+ #:log "--db we have a class $classname"
}
set attributes [::xo::dc list_of_lists get_atts {
select attribute_name, pretty_name, pretty_plural, datatype,
@@ -1189,7 +1189,7 @@
default_value min_n_values max_n_values
# ignore some erroneous definitions in the acs meta model
- if {[my exists exclude_attribute($table_name,$attribute_name)]} {
+ if {[:exists exclude_attribute($table_name,$attribute_name)]} {
continue
}
@@ -1341,9 +1341,9 @@
#
::xo::db::DBI instproc generate_psql {package_name object_name} {
- set function_args [my get_function_args $package_name $object_name]
- set function_args [my fix_function_args $function_args $package_name $object_name]
- set sql_info [my sql_arg_info $function_args $package_name $object_name]
+ set function_args [:get_function_args $package_name $object_name]
+ set function_args [:fix_function_args $function_args $package_name $object_name]
+ set sql_info [:sql_arg_info $function_args $package_name $object_name]
#ns_log notice "-- select ${package_name}__${object_name}($psql_args)"
set sql_suffix [:psql_statement_suffix ${package_name} ${object_name}]
dict set sql_info sql [subst { select ${package_name}__${object_name}([dict get $sql_info psql_args]) $sql_suffix}]
@@ -1392,9 +1392,9 @@
# DB and Postgres interface method generation (no autonull):
#
::xo::db::DB-postgresql instproc generate_psql {package_name object_name} {
- set function_args [my get_function_args $package_name $object_name]
- set function_args [my fix_function_args $function_args $package_name $object_name]
- set sql_info [my sql_arg_info $function_args $package_name $object_name]
+ set function_args [:get_function_args $package_name $object_name]
+ set function_args [:fix_function_args $function_args $package_name $object_name]
+ set sql_info [:sql_arg_info $function_args $package_name $object_name]
#ns_log notice "-- select ${package_name}__${object_name} ($psql_args)"
set sql_suffix [:psql_statement_suffix ${package_name} ${object_name}]
set sql [subst {
@@ -1464,9 +1464,9 @@
and position = 0)
}]
- set function_args [my get_function_args $package_name $object_name]
- set function_args [my fix_function_args $function_args $package_name $object_name]
- set sql_info [my sql_info $function_args $package_name $object_name]
+ set function_args [:get_function_args $package_name $object_name]
+ set function_args [:fix_function_args $function_args $package_name $object_name]
+ set sql_info [:sql_info $function_args $package_name $object_name]
if {$is_function} {
set sql [subst {BEGIN :1 := ${package_name}.${object_name}(\$sql_args); END;}]
@@ -1487,7 +1487,7 @@
set sql_args \[join \$sql_args ,\]
set sql "$sql"
db_with_handle -dbn \$dbn db {
- #my log "sql=$sql, sql_command=$sql_cmd"
+ #:log "sql=$sql, sql_command=$sql_cmd"
return \[ $sql_cmd \]
}
}]
@@ -1582,14 +1582,14 @@
# postgres and oracle simultaneously. Not sure, how important this is...
#
if {$object_name eq "set"} {
- my log "We cannot handle object_name = '$object_name' in this version"
+ :log "We cannot handle object_name = '$object_name' in this version"
return
}
#
# Object names have the form of e.g. ::xo::db::apm_parameter.
# Therefore, we use the namspace tail as sql_package_name.
#
- set package_name [my sql_package_name [namespace tail [self]]]
+ set package_name [:sql_package_name [namespace tail [self]]]
set sql_info [::xo::dc generate_psql $package_name $object_name]
# puts "sql_command=$sql_command"
@@ -1620,10 +1620,10 @@
# appended. we have to added it here to avoid complains. xotcl 2.0
# should find better ways to handle contain or the new invocation.
if {$object_name eq "new"} {lappend nonposarg_list -childof}
- #my log "-- define $object_name $nonposarg_list"
+ #:log "-- define $object_name $nonposarg_list"
#ns_log notice final=[dict get $sql_info body]
- my ad_proc $object_name $nonposarg_list {Automatically generated method} [dict get $sql_info body]
+ :ad_proc $object_name $nonposarg_list {Automatically generated method} [dict get $sql_info body]
}
::xo::db::Class instproc unknown {m args} {
@@ -1641,7 +1641,7 @@
}
set class_name ::xo::db::sql::[string tolower $package_name]
- if {![my isobject $class_name]} {
+ if {![:isobject $class_name]} {
::xo::db::Class create $class_name
} elseif {![$class_name istype ::xo::db::Class]} {
#
@@ -1656,7 +1656,7 @@
}
::xo::db::Class proc class_to_object_type {name} {
- if {[my isclass $name]} {
+ if {[:isclass $name]} {
if {[$name exists object_type]} {
# The specified class has an object_type defined; return it
return [$name object_type]
@@ -1810,15 +1810,15 @@
::xo::db::Class instproc object_types_query {
{-subtypes_first:boolean false}
} {
- my instvar object_type_key
+ set object_type_key ${:object_type_key}
set order_clause [expr {$subtypes_first ? "order by tree_sortkey desc":""}]
return "select object_type from acs_object_types where
tree_sortkey between '$object_type_key' and tree_right('$object_type_key')
$order_clause"
}
::xo::db::Class instproc init_type_hierarchy {} {
- my instvar object_type
- my set object_type_key [::xo::dc list get_tree_sortkey {
+ set object_type ${:object_type}
+ set :object_type_key [::xo::dc list get_tree_sortkey {
select tree_sortkey from acs_object_types
where object_type = :object_type
}]
@@ -1830,14 +1830,14 @@
::xo::db::Class instproc object_types_query {
{-subtypes_first:boolean false}
} {
- my instvar object_type
+ set object_type ${:object_type}
set order_clause [expr {$subtypes_first ? "order by LEVEL desc":""}]
return "select object_type from acs_object_types
start with object_type = '$object_type'
connect by prior object_type = supertype $order_clause"
}
::xo::db::Class instproc init_type_hierarchy {} {
- my set object_type_key {}
+ set :object_type_key {}
}
}
@@ -1851,125 +1851,117 @@
@return list of object_types
} {
return [::xo::dc list get_object_types \
- [my object_types_query -subtypes_first $subtypes_first]]
+ [:object_types_query -subtypes_first $subtypes_first]]
}
::xo::db::Class ad_instproc create_object_type {} {
Create an acs object_type for the current XOTcl class
} {
- my instvar object_type supertype pretty_name pretty_plural \
- table_name id_column name_method abstract_p
+ :check_default_values
+ :check_table_atts
- my check_default_values
- my check_table_atts
-
# The default supertype is acs_object. If the supertype
# was not changed (still acs_object), we map the superclass
# to the object_type to obtain the ACS supertype.
- if {$supertype eq "acs_object"} {
- set supertype [::xo::db::Class class_to_object_type [my info superclass]]
+ if {${:supertype} eq "acs_object"} {
+ set :supertype [::xo::db::Class class_to_object_type [:info superclass]]
}
::xo::db::sql::acs_object_type create_type \
- -object_type $object_type \
- -supertype $supertype \
- -pretty_name $pretty_name \
- -pretty_plural $pretty_plural \
- -table_name $table_name \
- -id_column $id_column \
- -abstract_p $abstract_p \
- -name_method $name_method \
- -package_name [my sql_package_name]
+ -object_type ${:object_type} \
+ -supertype ${:supertype} \
+ -pretty_name ${:pretty_name} \
+ -pretty_plural ${:pretty_plural} \
+ -table_name ${:table_name} \
+ -id_column ${:id_column} \
+ -abstract_p ${:abstract_p} \
+ -name_method ${:name_method} \
+ -package_name [:sql_package_name]
}
::xo::db::Class ad_instproc drop_object_type {{-cascade true}} {
Drop an acs object_type; cascde true means that the attributes
are droped as well.
} {
- my instvar object_type
::xo::db::sql::acs_object_type drop_type \
- -object_type $object_type \
+ -object_type ${:object_type} \
-cascade_p [expr {$cascade ? "t" : "f"}]
}
::xo::db::Class instproc db_slots {} {
- my instvar id_column db_slot db_constraints
- array set db_slot [list]
- array set db_constraints [list]
+ array set :db_slot [list]
+ array set :db_constraints [list]
#
# First get all ::xo::db::Attribute slots and check later,
# if we have to add the id_column automatically.
#
- # my log "--setting db_slot all=[my info slots]"
- foreach att [my info slots] {
- #my log "--checking $att [$att istype ::xo::db::Attribute] [$att info class]"
+ # :log "--setting db_slot all=[:info slots]"
+ foreach att [:info slots] {
+ #:log "--checking $att [$att istype ::xo::db::Attribute] [$att info class]"
if {![$att istype ::xo::db::Attribute]} continue
- set db_slot([$att name]) $att
- my collect_constraints $att
+ set :db_slot([$att name]) $att
+ :collect_constraints $att
}
if {[self] ne "::xo::db::Object"} {
- if {[my exists id_column] && ![info exists db_slot($id_column)]} {
+ if {[info exists :id_column] && ![info exists :db_slot(${:id_column})]} {
# create automatically the slot for the id column
- my slots [subst {
- ::xo::db::Attribute create $id_column \
+ :slots [subst {
+ ::xo::db::Attribute create ${:id_column} \
-pretty_name "ID" \
-datatype integer \
-create_acs_attribute false
}]
- set db_slot($id_column) [self]::slot::$id_column
+ set :db_slot(${:id_column}) [self]::slot::${:id_column}
}
}
- #my log "--setting db_slot of [self] to [array names db_slot]"
+ #:log "--setting db_slot of [self] to [array names _db_slot]"
}
# read attribute constraints and store them so they can be added
# after plain table creation
::xo::db::Class instproc collect_constraints {att} {
- my instvar db_constraints table_name
set attname [$att name]
# Index is always created after table creation, so it is always ok
# to collect this...
if {[$att exists index]} {
- lappend db_constraints($attname) [list index [$att set index]]
+ lappend :db_constraints($attname) [list index [$att set index]]
}
# ...in all other cases, when column doesn not exist will be
# created properly. No need to collect constraints.
- if {[::xo::db::require exists_column $table_name $attname]} {
+ if {[::xo::db::require exists_column ${:table_name} $attname]} {
if {[$att exists unique] && [$att set unique]} {
- lappend db_constraints($attname) unique
+ lappend :db_constraints($attname) unique
}
if {[$att exists not_null] && [$att set not_null]} {
- lappend db_constraints($attname) not_null
+ lappend :db_constraints($attname) not_null
}
if {![string is space [$att set references]]} {
- lappend db_constraints($attname) [list references [$att set references]]
+ lappend :db_constraints($attname) [list references [$att set references]]
}
if {[$att exists default]} {
- lappend db_constraints($attname) [list default [$att set default]]
+ lappend :db_constraints($attname) [list default [$att set default]]
}
}
}
::xo::db::Class instproc table_definition {} {
- my instvar id_column table_name db_slot
array set column_specs [list]
#
# iterate over the slots and collect the column_specs for table generation
#
- foreach {slot_name slot} [my array get db_slot] {
+ foreach {slot_name slot} [array get :db_slot] {
if {![$slot create_table_attribute]} continue
set column_name [$slot column_name]
set column_specs($column_name) \
- [$slot column_spec -id_column [expr {$column_name eq $id_column}]]
+ [$slot column_spec -id_column [expr {$column_name eq ${:id_column}}]]
}
# Requires collected constraints on object's table.
::xo::db::Class instproc require_constraints {} {
- my instvar db_constraints
- set table_name [my table_name]
- foreach col [array names db_constraints] {
- foreach constr $db_constraints($col) {
+ set table_name [:table_name]
+ foreach col [array names :db_constraints] {
+ foreach constr [set :db_constraints($col)] {
set type [lindex $constr 0]
set value [join [lrange $constr 1 end]]
switch -- $type {
@@ -2002,38 +1994,38 @@
}
if {[array size column_specs] > 0} {
- if {$table_name eq ""} {error "no table_name specified"}
- if {$id_column eq ""} {error "no id_column specified"}
- if {![info exists column_specs($id_column)]} {
- error "no ::xo::db::Attribute slot for id_column '$id_column' specified"
+ if {${:table_name} eq ""} {error "no table_name specified"}
+ if {${:id_column} eq ""} {error "no id_column specified"}
+ if {![info exists column_specs(${:id_column})]} {
+ error "no ::xo::db::Attribute slot for id_column '${:id_column}' specified"
}
set table_specs [list]
foreach {att spec} [array get column_specs] {lappend table_specs $att $spec}
set table_definition $table_specs
} else {
set table_definition ""
}
- # my log table_definition=$table_definition
+ # :log table_definition=$table_definition
return $table_definition
}
::xo::db::Class instproc mk_update_method {} {
set updates [list]
set vars [list]
- foreach {slot_name slot} [my array get db_slot] {
+ foreach {slot_name slot} [array get :db_slot] {
$slot instvar name column_name
- if {$column_name ne [my id_column]} {
+ if {$column_name ne [:id_column]} {
lappend updates "$column_name = :$name"
lappend vars $name
}
}
if {[llength $updates] == 0} return
- my instproc update {} [subst {
+ :instproc update {} [subst {
::xo::dc transaction {
next
- my instvar object_id $vars
- ::xo::dc dml update_[my table_name] {update [my table_name]
- set [join $updates ,] where [my id_column] = :object_id
+ :instvar object_id $vars
+ ::xo::dc dml update_[:table_name] {update [:table_name]
+ set [join $updates ,] where [:id_column] = :object_id
}
}
}]
@@ -2042,15 +2034,15 @@
::xo::db::Class instproc mk_insert_method {} {
# create method 'insert' for the application class
# The caller (e.g. method new) should care about db_transaction
- my instproc insert {} {
+ :instproc insert {} {
set __table_name [[self class] table_name]
set __id [[self class] id_column]
- my set $__id [my set object_id]
- my log "ID insert in $__table_name, id = $__id = [my set $__id]"
+ set :$__id ${:object_id}
+ :log "ID insert in $__table_name, id = $__id = [set :$__id]"
next
foreach {__slot_name __slot} [[self class] array get db_slot] {
- my instvar $__slot_name
- if {[info exists $__slot_name]} {
+ if {[info exists :$__slot_name]} {
+ set $__slot_name [set :$__slot_name]
lappend __vars $__slot_name
lappend __atts [$__slot column_name]
}
@@ -2064,82 +2056,79 @@
Check table_name and id_column and set meaningful
defaults, if these attributes are not provided.
} {
- my check_default_values
+ :check_default_values
set table_name_error_tail ""
set id_column_error_tail ""
- my instvar sql_package_name
- if {![my exists sql_package_name]} {
- set sql_package_name [self]
- #my log "-- sql_package_name of [self] is '$sql_package_name'"
+ if {![info exists :sql_package_name]} {
+ set :sql_package_name [self]
+ #:log "-- sql_package_name of [self] is '${:sql_package_name}'"
}
- if {[string length $sql_package_name] > 30} {
- error "SQL package_name '$sql_package_name' can be maximal 30 characters long!\
+ if {[string length ${:sql_package_name}] > 30} {
+ error "SQL package_name '${:sql_package_name}' can be maximal 30 characters long!\
Please specify a shorter sql_package_name in the class definition."
}
- if {$sql_package_name eq ""} {
+ if {${:sql_package_name} eq ""} {
error "Cannot determine SQL package_name. Please specify it explicitely!"
}
- if {![my exists table_name]} {
+ if {![info exists :table_name]} {
set tail [namespace tail [self]]
regexp {^::([^:]+)::} [self] _ head
- my table_name [string tolower ${head}_$tail]
- #my log "-- table_name of [self] is '[my table_name]'"
+ :table_name [string tolower ${head}_$tail]
+ #:log "-- table_name of [self] is '[:table_name]'"
set table_name_error_tail ", or use different namespaces/class names"
}
- if {![my exists id_column]} {
- my set id_column [string tolower [namespace tail [self]]]_id
+ if {![info exists :id_column]} {
+ set :id_column [string tolower [namespace tail [self]]]_id
set id_column_error_tail ", or use different class names"
- #my log "-- created id_column '[my id_column]'"
+ #:log "-- created id_column '[:id_column]'"
}
- if {![regexp {^[[:alpha:]_][[:alnum:]_]*$} [my table_name]]} {
- error "Table name '[my table_name]' is unsafe in SQL: \
+ if {![regexp {^[[:alpha:]_][[:alnum:]_]*$} [:table_name]]} {
+ error "Table name '[:table_name]' is unsafe in SQL: \
Please specify a different table_name$table_name_error_tail."
}
- if {[string length [my table_name]] > 30} {
- error "SQL table_name '[my table_name]' can be maximal 30 characters long!\
+ if {[string length [:table_name]] > 30} {
+ error "SQL table_name '[:table_name]' can be maximal 30 characters long!\
Please specify a shorter table_name in the class definition."
}
- if {![regexp {^[[:alpha:]_][[:alnum:]_]*$} [my id_column]]} {
- error "Name for id_column '[my id_column]' is unsafe in SQL: \
+ if {![regexp {^[[:alpha:]_][[:alnum:]_]*$} [:id_column]]} {
+ error "Name for id_column '[:id_column]' is unsafe in SQL: \
Please specify a different id_column$id_column_error_tail"
}
}
::xo::db::Class instproc check_default_values {} {
- my instvar pretty_name pretty_plural
- if {![info exists pretty_name]} {set pretty_name [namespace tail [self]]}
- if {![info exists pretty_plural]} {set pretty_plural $pretty_name}
+ if {![info exists :pretty_name]} {set :pretty_name [namespace tail [self]]}
+ if {![info exists :pretty_plural]} {set :pretty_plural ${:pretty_name}}
}
::xo::db::Class instproc init {} {
- if {![::xo::db::Class object_type_exists_in_db -object_type [my object_type]]} {
- my create_object_type
+ if {![::xo::db::Class object_type_exists_in_db -object_type [:object_type]]} {
+ :create_object_type
}
- my init_type_hierarchy
- my check_table_atts
- my db_slots
+ :init_type_hierarchy
+ :check_table_atts
+ :db_slots
- if {[my with_table]} {
- set table_definition [my table_definition]
+ if {[:with_table]} {
+ set table_definition [:table_definition]
if {$table_definition ne ""} {
- ::xo::db::require table [my table_name] $table_definition
- my require_constraints
+ ::xo::db::require table [:table_name] $table_definition
+ :require_constraints
}
-
- my mk_update_method
- my mk_insert_method
+ :mk_update_method
+ :mk_insert_method
}
next
}
::xo::db::Class instproc get_context {package_id_var user_id_var ip_var} {
- my upvar \
+ :upvar \
$package_id_var package_id \
$user_id_var user_id \
$ip_var ip
@@ -2177,15 +2166,15 @@
-creation_ip
{object_title ""}
} {
- my get_context package_id creation_user creation_ip
+ :get_context package_id creation_user creation_ip
set id [::xo::db::sql::acs_object new \
-object_type [::xo::db::Class class_to_object_type [self]] \
-title $object_title \
-package_id $package_id \
-creation_user $creation_user \
-creation_ip $creation_ip \
- -security_inherit_p [my security_inherit_p]]
+ -security_inherit_p [:security_inherit_p]]
return $id
}
@@ -2196,8 +2185,8 @@
#
$obj set object_id $id
# construct the same object_title as acs_object.new() does
- $obj set object_title "[my pretty_name] $id"
- #$obj set object_type [my object_type]
+ $obj set object_title "[:pretty_name] $id"
+ #$obj set object_type [:object_type]
}
::xo::db::Class ad_instproc new_persistent_object {
@@ -2213,19 +2202,19 @@
@return fully qualified object
} {
- my get_context package_id creation_user creation_ip
+ :get_context package_id creation_user creation_ip
::xo::dc transaction {
- set id [my new_acs_object \
+ set id [:new_acs_object \
-package_id $package_id \
-creation_user $creation_user \
-creation_ip $creation_ip \
""]
#[self class] set during_fetch 1
- if {[catch {my create ::$id {*}$args} errorMsg]} {
+ if {[catch {:create ::$id {*}$args} errorMsg]} {
ad_log error $errorMsg
}
#[self class] unset during_fetch
- my initialize_acs_object ::$id $id
+ :initialize_acs_object ::$id $id
::$id insert
}
::$id destroy_on_cleanup
@@ -2277,7 +2266,7 @@
} {
if {$object_class eq ""} {set object_class [self]}
- if {$sql eq ""} {set sql [my instance_select_query]}
+ if {$sql eq ""} {set sql [:instance_select_query]}
if {$as_ordered_composite} {
set __result [::xo::OrderedComposite new]
if {$destroy_on_cleanup} {$__result destroy_on_cleanup}
@@ -2286,7 +2275,7 @@
}
if {$named_objects} {
if {$object_named_after eq ""} {
- set object_named_after [my id_column]
+ set object_named_after [:id_column]
}
}
@@ -2331,7 +2320,7 @@
ns_log error "$o initialize_loaded_object => [$o info vars] -> $errorMsg"
}
}
- #my log "--DB more = $continue [$o serialize]"
+ #:log "--DB more = $continue [$o serialize]"
}
return $__result
@@ -2340,15 +2329,15 @@
::xo::db::Class instproc fetch_query {id} {
set tables [list]
set attributes [list]
- set id_column [my id_column]
- set join_expressions [list "[my table_name].$id_column = $id"]
- foreach cl [concat [self] [my info heritage]] {
+ set id_column [:id_column]
+ set join_expressions [list "[:table_name].$id_column = $id"]
+ foreach cl [concat [self] [:info heritage]] {
#if {$cl eq "::xo::db::Object"} break
if {$cl eq "::xotcl::Object"} break
set tn [$cl table_name]
if {$tn ne ""} {
lappend tables $tn
- #my log "--db_slots of $cl = [$cl array get db_slot]"
+ #:log "--db_slots of $cl = [$cl array get db_slot]"
foreach {slot_name slot} [$cl array get db_slot] {
# avoid duplicate output names
set name [$slot name]
@@ -2358,7 +2347,7 @@
set names($name) 1
}
if {$cl ne [self]} {
- lappend join_expressions "$tn.[$cl id_column] = [my table_name].$id_column"
+ lappend join_expressions "$tn.[$cl id_column] = [:table_name].$id_column"
}
}
}
@@ -2384,7 +2373,7 @@
@return SQL query
} {
set tables [list]
- set id_column [my id_column]
+ set id_column [:id_column]
if {$count} {
set select_attributes "count(*)"
@@ -2394,7 +2383,7 @@
set all_attributes [expr {$select_attributes eq ""}]
set join_expressions [list]
- foreach cl [concat [self] [my info heritage]] {
+ foreach cl [concat [self] [:info heritage]] {
#if {$cl eq "::xo::db::Object"} break
if {$cl eq "::xotcl::Object"} break
set tn [$cl table_name]
@@ -2412,7 +2401,7 @@
}
}
if {$cl ne [self]} {
- lappend join_expressions "$tn.[$cl id_column] = [my table_name].$id_column"
+ lappend join_expressions "$tn.[$cl id_column] = [:table_name].$id_column"
}
}
}
@@ -2449,9 +2438,9 @@
@return ordered composite
} {
- set s [my instantiate_objects \
+ set s [:instantiate_objects \
-object_class [self] \
- -sql [my instance_select_query \
+ -sql [:instance_select_query \
-select_attributes $select_attributes \
-from_clause $from_clause \
-where_clause $where_clause \
@@ -2471,16 +2460,16 @@
-pretty_plural "Objects" \
-table_name "acs_objects" -id_column "object_id"
- ::xo::db::Object instproc insert {} {my log no-insert;}
+ ::xo::db::Object instproc insert {} {:log no-insert;}
::xo::db::Object ad_instproc update {-package_id -modifying_user} {
Update the current object in the database
} {
- my instvar object_id
- if {![info exists package_id] && [my exists package_id]} {
- set package_id [my package_id]
+ set object_id ${:object_id}
+ if {![info exists package_id] && [info exists :package_id]} {
+ set package_id ${:package_id}
}
- [my info class] get_context package_id modifying_user modifying_ip
+ [:info class] get_context package_id modifying_user modifying_ip
::xo::dc dml update_object {update acs_objects
set modifying_user = :modifying_user, modifying_ip = :modifying_ip
where object_id = :object_id}
@@ -2489,8 +2478,8 @@
::xo::db::Object ad_instproc delete {} {
Delete the object from the database and from memory
} {
- ::xo::db::sql::acs_object delete -object_id [my set object_id]
- my destroy
+ ::xo::db::sql::acs_object delete -object_id ${:object_id}
+ :destroy
}
::xo::db::Object ad_instproc save {-package_id -modifying_user} {
@@ -2510,18 +2499,18 @@
@return new object id
} {
- if {![info exists package_id] && [my exists package_id]} {
- set package_id [my package_id]
+ if {![info exists package_id] && [info exists :package_id]} {
+ set package_id ${:package_id}
}
- [my info class] get_context package_id creation_user creation_ip
+ [:info class] get_context package_id creation_user creation_ip
::xo::dc transaction {
- set id [[my info class] new_acs_object \
+ set id [[:info class] new_acs_object \
-package_id $package_id \
-creation_user $creation_user \
-creation_ip $creation_ip \
""]
- [my info class] initialize_acs_object [self] $id
- my insert
+ [:info class] initialize_acs_object [self] $id
+ :insert
}
return $id
}
@@ -2552,83 +2541,79 @@
}
::xo::db::Attribute instproc create_attribute {} {
- if {![my create_acs_attribute]} return
+ if {![:create_acs_attribute]} return
- my instvar datatype pretty_name min_n_values max_n_values domain column_name
- set object_type [$domain object_type]
+ set column_name ${:column_name}
+ set object_type [${:domain} object_type]
if {[::xo::dc get_value check_att {select 0 from acs_attributes where
attribute_name = :column_name and object_type = :object_type} 1]} {
if {![::xo::db::Class object_type_exists_in_db -object_type $object_type]} {
- $domain create_object_type
+ ${:domain} create_object_type
}
::xo::db::sql::acs_attribute create_attribute \
- -object_type $object_type \
+ -object_type $object_type \
-attribute_name $column_name \
- -datatype $datatype \
- -pretty_name $pretty_name \
- -min_n_values $min_n_values \
- -max_n_values $max_n_values
- #my save
+ -datatype ${:datatype} \
+ -pretty_name ${:pretty_name} \
+ -min_n_values ${:min_n_values} \
+ -max_n_values ${:max_n_values}
+ #:save
}
}
::xo::db::Attribute instproc attribute_reference {tn} {
- my instvar column_name name
- if {$column_name ne $name} {
- return "$tn.$column_name AS $name"
+ if {${:column_name} ne ${:name}} {
+ return "$tn.${:column_name} AS ${:name}"
} else {
- return "$tn.$name"
+ return "$tn.${:name}"
}
}
::xo::db::Attribute instproc column_spec {{-id_column false}} {
- my instvar sqltype name references default not_null unique
- set table_name [[my domain] table_name]
+ set table_name [${:domain} table_name]
set column_spec ""
- append column_spec " " [::xo::dc map_datatype $sqltype]
+ append column_spec " " [::xo::dc map_datatype ${:sqltype}]
#
# Default
#
- if {[info exists default]} {append column_spec " DEFAULT '$default' "}
+ if {[info exists :default]} {
+ append column_spec " DEFAULT '${:default}' "
+ }
#
# References
#
- if {[info exists references] && $references ne ""} {
- append column_spec " REFERENCES $references"
+ if {[info exists :references] && ${:references} ne ""} {
+ append column_spec " REFERENCES ${:references}"
} elseif {$id_column} {
- set sc [[my domain] info superclass]
+ set sc [${:domain} info superclass]
if {![$sc istype ::xo::db::Class]} {set sc ::xo::db::Object}
append column_spec " REFERENCES [$sc table_name]([$sc id_column])\
ON DELETE CASCADE "
}
#
- # Unique
+ # Unique and Not NULL
#
- if {[info exists unique]} {append column_spec " UNIQUE "}
+ if {[info exists :unique]} {append column_spec " UNIQUE " }
+ if {[info exists :not_null]} {append column_spec " NOT NULL "}
#
- # Not null
- #
- if {[info exists not_null]} {append column_spec " NOT NULL "}
- #
# Primary key
#
if {$id_column} {
# add automatically a constraint for the id_column
append column_spec " PRIMARY KEY "
}
- append column_spec [::xo::dc datatype_constraint $sqltype $table_name $name]
+ append column_spec [::xo::dc datatype_constraint ${:sqltype} $table_name ${:name}]
return $column_spec
}
::xo::db::Attribute instproc init {} {
next ;# do first ordinary slot initialization
- my instvar datatype name
- if {![my exists sqltype]} {my set sqltype $datatype}
- if {![my exists column_name]} {my set column_name $name}
+ if {![info exists :sqltype]} {set :sqltype ${:datatype}}
+ if {![info exists :column_name]} {set :column_name ${:name}}
- my create_attribute
+ :create_attribute
}
##############
@@ -2637,30 +2622,30 @@
::xo::db::CrAttribute instproc create_attribute {} {
# do nothing, if create_acs_attribute is set to false
- if {![my create_acs_attribute]} return
+ if {![:create_acs_attribute]} return
- my instvar name column_name datatype pretty_name domain
- set object_type [$domain object_type]
+ set column_name ${:column_name}
+ set object_type [${:domain} object_type]
if {$object_type eq "content_folder"} {
# content_folder does NOT allow to use create_attribute etc.
return
}
- #my log "check attribute $column_name ot=$object_type, domain=$domain"
+ #:log "check attribute $column_name ot=$object_type, domain=${:domain}"
if {[::xo::dc get_value check_att {select 0 from acs_attributes where
attribute_name = :column_name and object_type = :object_type} 1]} {
if {![::xo::db::Class object_type_exists_in_db -object_type $object_type]} {
- $domain create_object_type
+ ${:domain} create_object_type
}
::xo::db::sql::content_type create_attribute \
- -content_type $object_type \
+ -content_type $object_type \
-attribute_name $column_name \
- -datatype $datatype \
- -pretty_name $pretty_name \
- -column_spec [my column_spec]
+ -datatype ${:datatype} \
+ -pretty_name ${:pretty_name} \
+ -column_spec [:column_spec]
}
}
@@ -2684,23 +2669,23 @@
# When destroy_on_cleanup is executed, there might be already some global
# data for the database interaction gone.... So, destroy these objects
# by hand for now.
- # my destroy_on_cleanup
+ # :destroy_on_cleanup
# PRESERVE ROWS means that the data will be available until the end of the SQL session
- set sql_create "CREATE global temporary table [my name] on commit PRESERVE ROWS as "
+ set sql_create "CREATE global temporary table [:name] on commit PRESERVE ROWS as "
# When the table exists already, simply insert into it ...
- if {[::xo::db::require exists_table [my name]]} {
- ::xo::dc dml . "insert into [my name] ([my vars]) ([my query])"
+ if {[::xo::db::require exists_table [:name]]} {
+ ::xo::dc dml . "insert into [:name] ([:vars]) ([:query])"
} else {
# ... otherwise, create the table with the data in one step
- ::xo::dc dml get_n_most_recent_contributions $sql_create[my query]
+ ::xo::dc dml get_n_most_recent_contributions $sql_create[:query]
}
}
::xo::db::temp_table instproc destroy {} {
# A session spans multiple connections in OpenACS.
# We want to get rid the data when we are done.
- ::xo::dc dml truncate_temp_table "truncate table [my name]"
+ ::xo::dc dml truncate_temp_table "truncate table [:name]"
next
}
Index: openacs-4/packages/xotcl-core/tcl/cr-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/cr-procs.tcl,v
diff -u -r1.55 -r1.56
--- openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 7 Aug 2017 23:48:30 -0000 1.55
+++ openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 9 Oct 2017 13:06:53 -0000 1.56
@@ -88,7 +88,7 @@
@return fully qualified object containing the attributes of the CrItem
} {
- set object_type [my get_object_type -item_id $item_id -revision_id $revision_id]
+ set object_type [:get_object_type -item_id $item_id -revision_id $revision_id]
set class [::xo::db::Class object_type_to_class $object_type]
return [$class get_instance_from_db -item_id $item_id -revision_id $revision_id -initialize $initialize]
}
@@ -103,7 +103,7 @@
@return parent_id
} {
# TODO: the following line is deactivated, until we get rid of the "folder object" in xowiki
- #if {[my isobject ::$item_id]} {return [::$item_id parent_id]}
+ #if {[:isobject ::$item_id]} {return [::$item_id parent_id]}
::xo::dc 1row get_parent "select parent_id from cr_items where item_id = :item_id"
return $parent_id
}
@@ -118,7 +118,7 @@
@return parent_id
} {
# TODO: the following line is deactivated, until we get rid of the "folder object" in xowiki
- #if {[my isobject ::$item_id]} {return [::$item_id parent_id]}
+ #if {[:isobject ::$item_id]} {return [::$item_id parent_id]}
::xo::dc 1row get_name "select name from cr_items where item_id = :item_id"
return $name
}
@@ -163,15 +163,15 @@
} {
Delete a CrItem in the database
} {
- set object_type [my get_object_type -item_id $item_id]
+ set object_type [:get_object_type -item_id $item_id]
$object_type delete -item_id $item_id
}
CrClass instproc unknown { obj args } {
# When this happens, this is most likely an error. Ease debugging
# by writing the call stack to the error log.
::xo::show_stack
- my log "::xo::db::CrClass: unknown called with $obj $args"
+ :log "::xo::db::CrClass: unknown called with $obj $args"
}
#
@@ -210,19 +210,18 @@
#
CrClass instproc type_selection_clause {{-base_table cr_revisions} {-with_subtypes:boolean false}} {
- my instvar object_type
if {$with_subtypes} {
if {$base_table eq "cr_revisions"} {
# do type selection manually
- return "acs_objects.object_type in ([my object_types_query])"
+ return "acs_objects.object_type in ([:object_types_query])"
}
# the base-table defines contains the subtypes
return ""
} else {
if {$base_table eq "cr_revisions"} {
- return "acs_objects.object_type = '$object_type'"
+ return "acs_objects.object_type = '${:object_type}'"
} else {
- return "bt.object_type = '$object_type'"
+ return "bt.object_type = '${:object_type}'"
}
}
}
@@ -244,7 +243,7 @@
CrClass instproc edit_atts {} {
# TODO remove, when name and text are slots (only for generic)
- my array names db_slot
+ :array names db_slot
}
CrClass ad_instproc folder_type_unregister_all {
@@ -255,7 +254,7 @@
@param include_subtypes Boolean value (t/f) to flag whether the
operation should be applied on subtypes as well
} {
- my instvar object_type
+ set object_type ${:object_type}
xo::dc foreach all_folders {
select folder_id from cr_folder_type_map
where content_type = :object_type
@@ -281,43 +280,39 @@
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
+ set folder_id ${:folder_id}
}
::xo::db::sql::content_folder ${operation}_content_type \
-folder_id $folder_id \
- -content_type $object_type \
+ -content_type ${:object_type} \
-include_subtypes $include_subtypes
}
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
+ :check_table_atts
- my check_table_atts
-
- set supertype [my info superclass]
- switch -- $supertype {
+ set :supertype [:info superclass]
+ switch -- ${:supertype} {
::xotcl::Object -
- ::xo::db::CrItem {set supertype content_revision}
+ ::xo::db::CrItem {set :supertype content_revision}
}
- if {![info exists pretty_plural]} {set pretty_plural $pretty_name}
+ if {![info exists :pretty_plural]} {set :pretty_plural ${:pretty_name}}
::xo::dc transaction {
::xo::db::sql::content_type create_type \
- -content_type $object_type \
- -supertype $supertype \
- -pretty_name $pretty_name \
- -pretty_plural $pretty_plural \
- -table_name $table_name \
- -id_column $id_column \
- -name_method $name_method
+ -content_type ${:object_type} \
+ -supertype ${:supertype} \
+ -pretty_name ${:pretty_name} \
+ -pretty_plural ${:pretty_plural} \
+ -table_name ${:table_name} \
+ -id_column ${:id_column} \
+ -name_method ${:name_method}
- my folder_type register
+ :folder_type register
}
}
@@ -328,11 +323,11 @@
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
+ set object_type ${:object_type}
::xo::dc transaction {
- my folder_type unregister
+ :folder_type unregister
::xo::db::sql::content_type drop_type \
- -content_type $object_type \
+ -content_type ${:object_type} \
-drop_children_p t \
-drop_table_p t
}
@@ -347,24 +342,24 @@
}
CrClass instproc getFormClass {-data:required} {
- if {[$data exists item_id] && [$data set item_id] != 0 && [my exists edit_form]} {
- return [my edit_form]
+ if {[$data exists item_id] && [$data set item_id] != 0 && [info exists :edit_form]} {
+ return [:edit_form]
} else {
- return [my form]
+ return [:form]
}
}
CrClass instproc remember_long_text_slots {} {
#
# keep long_text_slots in a separate array (for Oracle)
#
- my array unset long_text_slots
- foreach {slot_name slot} [my array get db_slot] {
+ :array unset long_text_slots
+ foreach {slot_name slot} [array get :db_slot] {
if {[$slot sqltype] eq "long_text"} {
- my set long_text_slots($slot_name) $slot
+ set :long_text_slots($slot_name) $slot
}
}
- #my log "--long_text_slots = [my array names long_text_slots]"
+ #my log "--long_text_slots = [array names :long_text_slots]"
}
#
@@ -378,39 +373,38 @@
CrClass instproc mk_insert_method {} {;}
CrClass instproc init {} {
- my instvar object_type db_slot
# first, do whatever ::xo::db::Class does for initialization ...
next
# We want to be able to define for different CrClasses different
# default mime-types. Therefore, we define attribute slots per
# application class with the given default for mime_type.
if {[self] ne "::xo::db::CrItem"} {
- my slots {
- ::xotcl::Attribute create mime_type -default [my mime_type]
+ :slots {
+ ::xotcl::Attribute create mime_type -default [:mime_type]
}
- my db_slots
+ :db_slots
}
# ... then we do the CrClass specific initialization.
- #if {[my info superclass] ne "::xo::db::CrItem"} {
- # my set superclass [[my info superclass] set object_type]
+ #if {[:info superclass] ne "::xo::db::CrItem"} {
+ # set :superclass [[:info superclass] set object_type]
#}
# CrClasses store all attributes of the class hierarchy in
# db_slot. This is due to the usage of the
# automatically created views. Note, that classes created with
# ::xo::db::Class keep only the class specific db slots.
#
- foreach {slot_name slot} [[my info superclass] array get db_slot] {
+ foreach {slot_name slot} [[:info superclass] array get :db_slot] {
# don't overwrite slots, unless the object_title (named title)
- if {![info exists db_slot($slot_name)] ||
+ if {![info exists :db_slot($slot_name)] ||
$slot eq "::xo::db::Object::slot::object_title"} {
- set db_slot($slot_name) $slot
+ set :db_slot($slot_name) $slot
}
}
- my remember_long_text_slots
+ :remember_long_text_slots
- if {![::xo::db::Class object_type_exists_in_db -object_type $object_type]} {
- my create_object_type
+ if {![::xo::db::Class object_type_exists_in_db -object_type ${:object_type}]} {
+ :create_object_type
}
}
@@ -430,7 +424,7 @@
#my log "-- generic fetch_object [self args]"
if {![::xotcl::Object isobject $object]} {
# if the object does not yet exist, we have to create it
- my create $object
+ :create $object
}
set raw_atts [::xo::db::CrClass set common_query_atts]
#my log "-- raw_atts = '$raw_atts'"
@@ -446,7 +440,7 @@
}
lappend atts $fq
}
- foreach {slot_name slot} [my array get db_slot] {
+ foreach {slot_name slot} [array get :db_slot] {
switch -- $slot {
::xo::db::CrItem::slot::text {
# We need the rule, since insert the handling of the sql
@@ -478,7 +472,7 @@
db_with_handle db {
set sql [::xo::dc prepare -handle $db -argtypes integer "\
select [join $atts ,], i.parent_id \
- from [my set table_name]i n, cr_items i,acs_objects o \
+ from ${:table_name}i n, cr_items i,acs_objects o \
where n.revision_id = :revision_id \
and i.item_id = n.item_id \
and o.object_id = n.revision_id"]
@@ -495,11 +489,11 @@
$object set item_id $item_id
- $object db_1row [my qn fetch_from_view_item_id] "\
+ $object db_1row [:qn fetch_from_view_item_id] "\
select [join $atts ,], i.parent_id \
- from [my set table_name]i n, cr_items i, acs_objects o \
+ from ${:table_name}i n, cr_items i, acs_objects o \
where i.item_id = :item_id \
- and n.[my id_column] = coalesce(i.live_revision, i.latest_revision) \
+ and n.[:id_column] = coalesce(i.live_revision, i.latest_revision) \
and o.object_id = i.item_id"
}
# the method db_1row treats all newly created variables as instance variables,
@@ -533,8 +527,8 @@
@return fully qualified object
} {
set object ::[expr {$revision_id ? $revision_id : $item_id}]
- if {![my isobject $object]} {
- my fetch_object -object $object \
+ if {![:isobject $object]} {
+ :fetch_object -object $object \
-item_id $item_id -revision_id $revision_id \
-initialize $initialize
$object destroy_on_cleanup
@@ -550,9 +544,9 @@
@return fully qualified object
} {
- my get_context package_id creation_user creation_ip
+ :get_context package_id creation_user creation_ip
#my log "ID [self] create $args"
- if {[catch {set p [my create ::0 {*}$args]} errorMsg]} {
+ if {[catch {set p [:create ::0 {*}$args]} errorMsg]} {
ad_log error $errorMsg
}
#my log "ID [::0 serialize]"
@@ -604,7 +598,7 @@
@param base_table typically automatic view, must contain title and revision_id
@return sql query
} {
- if {![info exists folder_id]} {my instvar folder_id}
+ if {![info exists folder_id]} {set folder_id ${:folder_id}}
if {![info exists parent_id]} {set parent_id $folder_id}
if {$base_table eq "cr_revisions"} {
@@ -616,7 +610,7 @@
if {$a eq "title"} {set a bt.title}
lappend attributes $a
}
- set type_selection_clause [my type_selection_clause -base_table $base_table -with_subtypes $with_subtypes]
+ set type_selection_clause [:type_selection_clause -base_table $base_table -with_subtypes $with_subtypes]
#my log "type_selection_clause -with_subtypes $with_subtypes returns $type_selection_clause"
if {$count} {
set attribute_selection "count(*)"
@@ -683,8 +677,8 @@
The tuples are instances of the class, on which the
method was called.
} {
- set s [my instantiate_objects -sql \
- [my instance_select_query \
+ set s [:instantiate_objects -sql \
+ [:instance_select_query \
-select_attributes $select_attributes \
-from_clause $from_clause \
-where_clause $where_clause \
@@ -765,21 +759,21 @@
# due to the handling of CLOBS.
#
CrClass instproc insert_statement {atts vars} {
- return "insert into [my set table_name]i ([join $atts ,]) \
+ return "insert into ${:table_name}i ([join $atts ,]) \
values (:[join $vars ,:])"
}
CrItem instproc fix_content {revision_id content} {
- [my info class] instvar storage_type
- #my msg "--long_text_slots: [[my info class] array get long_text_slots]"
- #foreach {slot_name slot} [[my info class] array get long_text_slots] {
+ [:info class] instvar storage_type
+ #my msg "--long_text_slots: [[:info class] array get long_text_slots]"
+ #foreach {slot_name slot} [[:info class] array get long_text_slots] {
# set cls [$slot domain]
- # set content [my set $slot_name]
- # my msg "$slot_name [$cls table_name] [$cls id_column] length=[string length $content]"
+ # set content [set :$slot_name]
+ # :msg "$slot_name [$cls table_name] [$cls id_column] length=[string length $content]"
#}
if {$storage_type eq "file"} {
::xo::dc dml fix_content_length "update cr_revisions \
- set content_length = [file size [my set import_file]] \
+ set content_length = [file size ${:import_file}] \
where revision_id = :revision_id"
}
}
@@ -790,17 +784,17 @@
# an content item without creating a new revision. This works
# currently only for storage_type == "text".
#
- [my info class] instvar storage_type
+ [:info class] instvar storage_type
if {$storage_type eq "file"} {
- my log "--update_content not implemented for type file"
+ :log "--update_content not implemented for type file"
} else {
::xo::dc dml update_content "update cr_revisions set content = :content \
where revision_id = :revision_id"
}
}
CrItem instproc update_attribute_from_slot {-revision_id slot value} {
- if {![info exists revision_id]} {my instvar revision_id}
+ if {![info exists revision_id]} {set revision_id ${:revision_id}}
set domain [$slot domain]
set sql "update [$domain table_name] \
set [$slot column_name] = :value \
@@ -821,26 +815,26 @@
#
set values [list]
set attributes [list]
- #my msg "--long_text_slots: [my array get long_text_slots]"
+ #my msg "--long_text_slots: [array get :long_text_slots]"
foreach a $atts v $vars {
#
# "text" and long_text_slots are handled in Oracle
# via separate update statement.
#
- if {$a eq "text" || [my exists long_text_slots($a)]} continue
+ if {$a eq "text" || [info exists :long_text_slots($a)]} continue
lappend attributes $a
lappend values $v
}
- return "insert into [my set table_name]i ([join $attributes ,]) \
+ return "insert into ${:table_name}i ([join $attributes ,]) \
values (:[join $values ,:])"
}
CrItem instproc fix_content {{-only_text false} revision_id content} {
- [my info class] instvar storage_type
+ [:info class] instvar storage_type
if {$storage_type eq "file"} {
::xo::dc dml fix_content_length "update cr_revisions \
- set content_length = [file size [my set import_file]] \
+ set content_length = [file size ${:import_file}] \
where revision_id = :revision_id"
} elseif {$storage_type eq "text"} {
::xo::dc dml fix_content "update cr_revisions \
@@ -849,8 +843,8 @@
returning content into :1" -blobs [list $content]
}
if {!$only_text} {
- foreach {slot_name slot} [[my info class] array get long_text_slots] {
- my update_attribute_from_slot -revision_id $revision_id $slot [my set $slot_name]
+ foreach {slot_name slot} [[:info class] array get long_text_slots] {
+ :update_attribute_from_slot -revision_id $revision_id $slot [set :$slot_name]
}
}
}
@@ -861,16 +855,16 @@
# an content item without creating a new revision. This works
# currently only for storage_type == "text".
#
- [my info class] instvar storage_type
+ [:info class] instvar storage_type
if {$storage_type eq "file"} {
- my log "--update_content not implemented for type file"
+ :log "--update_content not implemented for type file"
} else {
- my fix_content -only_text true $revision_id $content
+ :fix_content -only_text true $revision_id $content
}
}
CrItem instproc update_attribute_from_slot {-revision_id slot value} {
- if {![info exists revision_id]} {my instvar revision_id}
+ if {![info exists revision_id]} {set revision_id ${:revision_id}}
set domain [$slot domain]
set att [$slot column_name]
if {[$slot sqltype] eq "long_text"} {
@@ -898,7 +892,7 @@
}
CrItem instproc current_user_id {} {
- if {[my isobject ::xo::cc]} {return [::xo::cc user_id]}
+ if {[:isobject ::xo::cc]} {return [::xo::cc user_id]}
if {[ad_conn isconnected]} {return [ad_conn user_id]}
return ""
}
@@ -913,7 +907,6 @@
@param modifying_user
@param live_p make this revision the live revision
} {
- #my instvar creation_user
set __atts [list creation_user]
set __vars $__atts
@@ -928,23 +921,23 @@
set creation_user [expr {[info exists modifying_user] ?
$modifying_user :
- [my current_user_id]}]
- #set old_revision_id [my set revision_id]
+ [:current_user_id]}]
+ #set old_revision_id ${:revision_id}
- foreach {__slot_name __slot} [[my info class] array get db_slot] {
+ foreach {__slot_name __slot} [[:info class] array get db_slot] {
if {
$__slot eq "::xo::db::Object::slot::object_title" ||
$__slot eq "::xo::db::CrItem::slot::name" ||
$__slot eq "::xo::db::CrItem::slot::publish_date"
} continue
- my instvar $__slot_name
+ set $__slot_name [set :$__slot_name]
lappend __atts [$__slot column_name]
lappend __vars $__slot_name
}
if {$use_given_publish_date} {
if {"publish_date" ni $__atts} {
- my instvar publish_date
+ set publish_date ${:publish_date}
lappend __atts publish_date
lappend __vars publish_date
}
@@ -954,22 +947,21 @@
}
::xo::dc transaction {
- [my info class] instvar storage_type
+ [:info class] instvar storage_type
set revision_id [xo::dc nextval acs_object_id_seq]
if {$storage_type eq "file"} {
- my instvar import_file mime_type name
# Get the mime_type from the file, eventually creating a new
# one if it's unrecognized.
- set mime_type [cr_check_mime_type \
- -mime_type $mime_type \
- -filename $name \
- -file $import_file]
- set text [cr_create_content_file $item_id $revision_id $import_file]
+ set :mime_type [cr_check_mime_type \
+ -mime_type ${:mime_type} \
+ -filename ${:name} \
+ -file ${:import_file}]
+ set text [cr_create_content_file $item_id $revision_id ${:import_file}]
}
::xo::dc [::xo::dc insert-view-operation] revision_add \
- [[my info class] insert_statement $__atts $__vars]
+ [[:info class] insert_statement $__atts $__vars]
- my fix_content $revision_id $text
+ :fix_content $revision_id $text
if {$live_p} {
#
@@ -978,18 +970,18 @@
#
::xo::db::sql::content_item set_live_revision \
-revision_id $revision_id \
- -publish_status [my set publish_status] \
+ -publish_status ${:publish_status} \
-is_latest true \
{*}$publish_date_flag
- my set revision_id $revision_id
- my update_item_index
+ set :revision_id $revision_id
+ :update_item_index
} else {
# if we do not make the revision live, use the old revision_id,
# and let CrCache save it ...... TODO: is this still needed? comment out for testing
#set revision_id $old_revision_id
}
- my set modifying_user $creation_user
- my set last_modified [::xo::dc get_value get_last_modified \
+ set :modifying_user $creation_user
+ set :last_modified [::xo::dc get_value get_last_modified \
{select last_modified from acs_objects where object_id = :revision_id}]
}
return $item_id
@@ -1007,7 +999,7 @@
-revision_id $revision_id \
-publish_status $publish_status \
-is_latest $is_latest
- ::xo::clusterwide ns_cache flush xotcl_object_cache ::[my item_id]
+ ::xo::clusterwide ns_cache flush xotcl_object_cache ::${:item_id}
::xo::clusterwide ns_cache flush xotcl_object_cache ::$revision_id
}
@@ -1031,14 +1023,13 @@
@param live_p make this revision the live revision
} {
- set __class [my info class]
- my instvar parent_id item_id import_file name
+ set __class [:info class]
- if {![info exists package_id] && [my exists package_id]} {
- set package_id [my package_id]
+ if {![info exists package_id] && [info exists :package_id]} {
+ set package_id ${:package_id}
}
[self class] get_context package_id creation_user creation_ip
- my set creation_user $creation_user
+ set :creation_user $creation_user
set __atts [list creation_user]
set __vars $__atts
@@ -1050,15 +1041,15 @@
$__slot eq "::xo::db::CrItem::slot::name" ||
$__slot eq "::xo::db::CrItem::slot::publish_date"
} continue
- my instvar $__slot_name
+ :instvar $__slot_name
if {![info exists $__slot_name]} {set $__slot_name ""}
lappend __atts [$__slot column_name]
lappend __vars $__slot_name
}
if {$use_given_publish_date} {
if {"publish_date" ni $__atts} {
- my instvar publish_date
+ set publish_date ${:publish_date}
lappend __atts publish_date
lappend __vars publish_date
}
@@ -1071,49 +1062,49 @@
$__class instvar storage_type object_type
[self class] lock acs_objects "SHARE ROW EXCLUSIVE"
set revision_id [xo::dc nextval acs_object_id_seq]
- my set revision_id $revision_id
+ set :revision_id $revision_id
- if {![my exists name] || $name eq ""} {
+ if {![info exists :name] || ${:name} eq ""} {
# we have an autonamed item, use a unique value for the name
- set name [expr {[my exists __autoname_prefix] ?
- "[my set __autoname_prefix]$revision_id" : $revision_id}]
+ set :name [expr {[info exists :__autoname_prefix] ?
+ "${:__autoname_prefix}$revision_id" : $revision_id}]
}
if {$title eq ""} {
- set title [expr {[my exists __title_prefix] ?
- "[my set __title_prefix] ($name)" : $name}]
+ set title [expr {[info exists :__title_prefix] ?
+ "${:__title_prefix} (${:name})" : ${:name}}]
}
if {$storage_type eq "file"} {
# Get the mime_type from the file, eventually creating a new
# one if it's unrecognized.
set mime_type [cr_check_mime_type \
-mime_type $mime_type \
- -filename $name \
- -file $import_file]
+ -filename ${:name} \
+ -file ${:import_file}]
}
- set item_id [::xo::db::sql::content_item new \
- -name $name \
- -parent_id $parent_id \
- -creation_user $creation_user \
- -creation_ip $creation_ip \
- -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 \
- -with_child_rels f]
+ set :item_id [::xo::db::sql::content_item new \
+ -name ${:name} \
+ -parent_id ${:parent_id} \
+ -creation_user $creation_user \
+ -creation_ip $creation_ip \
+ -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 \
+ -with_child_rels f]
if {$storage_type eq "file"} {
- set text [cr_create_content_file $item_id $revision_id $import_file]
+ set text [cr_create_content_file ${:item_id} $revision_id ${:import_file}]
}
::xo::dc [::xo::dc insert-view-operation] revision_add \
- [[my info class] insert_statement $__atts $__vars]
- my fix_content $revision_id $text
+ [[:info class] insert_statement $__atts $__vars]
+ :fix_content $revision_id $text
if {$live_p} {
#
@@ -1122,37 +1113,37 @@
#
::xo::db::sql::content_item set_live_revision \
-revision_id $revision_id \
- -publish_status [my set publish_status] \
+ -publish_status ${:publish_status} \
-is_latest true \
{*}$publish_date_flag
- my update_item_index
+ :update_item_index
}
}
- my db_1row [my qn get_dates] {
+ :db_1row [:qn get_dates] {
select creation_date, last_modified
from acs_objects where object_id = :revision_id
}
- my set object_id $item_id
- return $item_id
+ set :object_id ${:item_id}
+ 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 -item_id [my set item_id]
+ [:info class] delete -item_id ${:item_id}
}
CrItem ad_instproc rename {-old_name:required -new_name:required} {
Rename a content item
} {
- my instvar item_id
+ set item_id ${:item_id}
::xo::dc dml update_rename \
"update cr_items set name = :new_name where item_id = :item_id"
- my set name $new_name
- my update_item_index
+ set :name $new_name
+ :update_item_index
}
#
@@ -1188,10 +1179,10 @@
ImageField_DeleteIcon version_delete -label "" -html {align center}
}
- set user_id [my current_user_id]
- set page_id [my set item_id]
+ set user_id [:current_user_id]
+ set page_id ${:item_id}
set live_revision_id [::xo::db::sql::content_item get_live_revision -item_id $page_id]
- my instvar package_id
+ set package_id ${:package_id}
set base [$package_id url]
set sql [::xo::dc select \
-map_function_names true \
@@ -1291,8 +1282,8 @@
} {
set allowed 0
#my log "--checking privilege [self args]"
- if {[my exists creation_user]} {
- if {[my set creation_user] == $user_id} {
+ if {[info exists :creation_user]} {
+ if {${:creation_user} == $user_id} {
set allowed 1
} else {
# allow the package admin always access
@@ -1383,7 +1374,7 @@
@param base_table typically automatic view, must contain title and revision_id
@return sql query
} {
- if {![info exists folder_id]} {my instvar folder_id}
+ if {![info exists folder_id]} {set folder_id ${:folder_id}}
if {![info exists parent_id]} {set parent_id $folder_id}
if {$base_table eq "cr_folders"} {
@@ -1396,7 +1387,7 @@
lappend attributes $a
}
# FIXME: This is dirty: We "fake" the base table for this function, so we can reuse the code
- set type_selection_clause [my type_selection_clause -base_table cr_revisions -with_subtypes false]
+ set type_selection_clause [:type_selection_clause -base_table cr_revisions -with_subtypes false]
#my log "type_selection_clause -with_subtypes $with_subtypes returns $type_selection_clause"
if {$count} {
set attribute_selection "count(*)"
@@ -1463,8 +1454,8 @@
"standard naming convention". Instead we create them as ::cr_folder<acs_object_id>
} {
set object ::cr_folder$item_id
- if {![my isobject $object]} {
- my fetch_object -object $object -item_id $item_id -initialize $initialize
+ if {![:isobject $object]} {
+ :fetch_object -object $object -item_id $item_id -initialize $initialize
$object destroy_on_cleanup
}
return $object
@@ -1498,10 +1489,10 @@
@see CrClass fetch_object
} {
if {![::xotcl::Object isobject $object]} {
- my create $object
+ :create $object
}
- $object db_1row [my qn fetch_folder] "
+ $object db_1row [:qn fetch_folder] "
SELECT * FROM cr_folders
JOIN cr_items on cr_folders.folder_id = cr_items.item_id
JOIN acs_objects on cr_folders.folder_id = acs_objects.object_id
@@ -1513,59 +1504,57 @@
::xo::db::CrFolder ad_instproc save_new {-creation_user} {
} {
- my instvar parent_id package_id folder_id
- [my info class] get_context package_id creation_user creation_ip
- set folder_id [::xo::db::sql::content_folder new \
- -name [my name] -label [my label] \
- -description [my description] \
- -parent_id $parent_id \
- -package_id $package_id \
- -creation_user $creation_user \
- -creation_ip $creation_ip]
+ set package_id ${:package_id}
+ [:info class] get_context package_id creation_user creation_ip
+ set :folder_id [::xo::db::sql::content_folder new \
+ -name [:name] -label [:label] \
+ -description [:description] \
+ -parent_id ${:parent_id} \
+ -package_id $package_id \
+ -creation_user $creation_user \
+ -creation_ip $creation_ip]
#parent_s has_child_folders attribute could have become outdated
- if { [my isobject ::$parent_id] } {
- ::$parent_id set has_child_folders t
+ if { [:isobject ::${:parent_id}] } {
+ ::${:parent_id} set has_child_folders t
}
# well, obtaining the allowed content_types this way is not very
# straightforward, but since we currently create these folders via
# ad_forms, and we have no form variable, this should be at least
# robust.
if {[[self class] exists allowed_content_types]} {
::xo::db::CrFolder register_content_types \
- -folder_id $folder_id \
+ -folder_id ${:folder_id} \
-content_types [[self class] set allowed_content_types]
}
- ::xo::clusterwide ns_cache flush xotcl_object_cache ::$parent_id
+ ::xo::clusterwide ns_cache flush xotcl_object_cache ::${:parent_id}
# who is setting sub_folder_list?
#db_flush_cache -cache_key_pattern sub_folder_list_*
- return $folder_id
+ return ${:folder_id}
}
::xo::db::CrFolder ad_instproc save {args} { } {
- my instvar folder_id
+ set folder_id ${:folder_id}
content::folder::update \
-folder_id $folder_id \
-attributes [list \
- [list name [my set name]] \
- [list label [my set label]] \
- [list description [my set description]]\
+ [list name ${:name}] \
+ [list label ${:label}] \
+ [list description ${:description}]\
]
- my get_context package_id user_id ip
+ :get_context package_id user_id ip
::xo::dc 1row _ "select acs_object__update_last_modified(:folder_id,$user,'$ip')"
}
::xo::db::CrFolder instproc is_package_root_folder {} {
- my instvar package_id folder_id
- return [expr {$folder_id eq [::$package_id folder_id]} ? true : false]
+ return [expr {${:folder_id} eq [::${:package_id} folder_id]} ? true : false]
}
::xo::db::CrFolder instproc delete {} {
- my instvar package_id name parent_id folder_id
- if {[my is_package_root_folder]} {
+ if {[:is_package_root_folder]} {
ad_return_error "Removal denied" "Dont delete the package root folder, delete the package"
return
}
- ::xo::db::sql::content_folder del -folder_id $folder_id -cascade_p t
+ ::xo::db::sql::content_folder del -folder_id ${:folder_id} -cascade_p t
}
@@ -1600,10 +1589,10 @@
# The variable serialized_object contains the serialization of
# the object from the cache; check if the object exists already
# or create it.
- if {[my isobject $object]} {
+ if {[:isobject $object]} {
# There would have been no need to call this method. We could
# raise an error here.
- # my log "--!! $object exists already"
+ # :log "--!! $object exists already"
} else {
# Create the object from the serialization and initialize it
eval $serialized_object
@@ -1660,11 +1649,11 @@
set arrays {}
set scalars {}
set non_cached_vars {}
- foreach pattern [[my info class] non_cached_instance_var_patterns] {
+ foreach pattern [[:info class] non_cached_instance_var_patterns] {
lappend non_cached_vars {*}[info vars :$pattern]
}
- #puts stderr "pattern [[my info class] non_cached_instance_var_patterns], non_cached_vars=$non_cached_vars"
+ #puts stderr "pattern [[:info class] non_cached_instance_var_patterns], non_cached_vars=$non_cached_vars"
foreach x $non_cached_vars {
if {[array exists :$x]} {
lappend arrays $x [array get :$x]
@@ -1719,14 +1708,14 @@
}
CrCache::Item instproc update_attribute_from_slot args {
set r [next]
- my flush_from_cache_and_refresh
+ :flush_from_cache_and_refresh
return $r
}
CrCache::Item instproc save args {
# we perform next before the cache update, since when update fails, we do not
# want to populate wrong content in the cache
set r [next]
- my flush_from_cache_and_refresh
+ :flush_from_cache_and_refresh
return $r
}
CrCache::Item instproc save_new args {
@@ -1738,13 +1727,13 @@
}
CrCache::Item instproc delete args {
::xo::clusterwide ns_cache flush xotcl_object_cache [self]
- #my msg "delete flush xotcl_object_type_cache [my parent_id]-[my name]"
- ::xo::clusterwide ns_cache flush xotcl_object_type_cache [my parent_id]-[my name]
+ #my msg "delete flush xotcl_object_type_cache ${:parent_id}-[:name]"
+ ::xo::clusterwide ns_cache flush xotcl_object_type_cache ${:parent_id}-[:name]
next
}
CrCache::Item instproc rename {-old_name:required -new_name:required} {
- #my msg "rename flush xotcl_object_type_cache [my parent_id]-$old_name"
- ::xo::clusterwide ns_cache flush xotcl_object_type_cache [my parent_id]-$old_name
+ #my msg "rename flush xotcl_object_type_cache ${:parent_id}-$old_name"
+ ::xo::clusterwide ns_cache flush xotcl_object_type_cache ${:parent_id}-$old_name
next
}