proc class_to_object_type
::435800 proc class_to_object_type name {
if {[my isclass $name]} {
if {[$name exists object_type]} {
# The specified class has an object_type defined; return it
return [$name object_type]
}
if {![$name istype ::xo::db::Object]} {
# The specified class is not subclass of ::xo::db::Object.
# return acs_object in your desparation.
return acs_object
}
}
# Standard mapping rules
switch -glob -- $name {
::xo::db::Object {return acs_object}
::xo::db::CrItem {return content_revision}
::xo::db::image {return image}
::xo::db::CrFolder {return content_folder}
::xo::db::* {return [string range $name 10 end]}
default {return $name}
}
}
proc create_all_functions
::435800 proc create_all_functions {} {
foreach item [my get_all_package_functions] {
foreach {package_name object_name} $item break
set class_name ::xo::db::sql::[string tolower $package_name]
if {![my isobject $class_name]} { ::xo::db::Class create $class_name }
$class_name dbproc_nonposargs [string tolower $object_name]
}
}
::xo::db::Class![[i]](/resources/acs-subsite/ZoomIn16.gif)
delete -id id
Delete the object from the database
- Switches:
- -id (required)
::435800 proc delete -id:required {
::xo::db::sql::acs_object delete -object_id $id
}
::xo::db::Class delete_all_acs_objects -object_type object_type
Delete all acs_objects of the object_type from the database.
- Switches:
- -object_type (required)
::435800 proc delete_all_acs_objects -object_type:required {
set table_name [::xo::db::Class get_table_name -object_type $object_type]
if {$table_name ne ""} {
db_dml delete_instances {delete from :table_name}
}
}
::xo::db::Class drop_type -object_type object_type \
[ -drop_table drop_table ] [ -cascade_p cascade_p ]
Drop the object_type from the database and drop optionally the table.
This method deletes as well all acs_objects of the object_type from the database.
- Switches:
- -object_type (required)
- -drop_table (defaults to
"f") (optional) - -cascade_p (defaults to
"t") (optional)
::435800 proc drop_type {-object_type:required {-drop_table f} {-cascade_p t}} {
set table_name [::xo::db::Class get_table_name -object_type $object_type]
if {$table_name ne ""} {
if {[catch {
db_dml [my qn delete_instances] "delete from $table_name"
if {$drop_table} {
db_dml [my qn drop_table] "drop table $table_name"
}
} errorMsg]} {
my log "error during drop_type"
}
}
::xo::db::sql::acs_object_type drop_type -object_type $object_type -cascade_p $cascade_p
return ""
}
::xo::db::Class exists_in_db -id id
Check, if an acs_object exists in the database.
- Switches:
- -id (required)
- Returns:
- 0 or 1
::435800 proc exists_in_db -id:required {
return [::xo::db_string select_object {
select 1 from acs_objects where object_id = :id
} 0]
}
proc get_all_package_functions
::435800 proc get_all_package_functions {} {
#
# Load defintions in one swap fropm function args; only for
# those definitions where we do not have function args, we parse
# the function arg aliases.
#
set definitions [::xo::db_list_of_lists get_all_package_functions0 {
select
args.function,
args.arg_name,
args.arg_default
from acs_function_args args
order by function, arg_seq
}]
set last_function ""
set function_args {}
foreach definition $definitions {
foreach {function arg_name default} $definition break
if {$last_function ne "" && $last_function ne $function} {
set ::xo::db::sql::fnargs($last_function) $function_args
#puts stderr "$last_function [list $function_args]"
set function_args {}
}
lappend function_args [list $arg_name $default]
set last_function $function
}
set ::xo::db::sql::fnargs($last_function) $function_args
#puts stderr "$last_function [list $function_args]"
ns_log notice "loaded [array size ::xo::db::sql::fnargs] definitions from function args"
#ns_log notice "... [lsort [array names ::xo::db::sql::fnargs *__*]]"
#
# Get all package functions (package name, object name) from PostgreSQL
# system catalogs.
#
return [::xo::db_list_of_lists [self proc] {
select distinct
upper(substring(proname from 0 for position('__' in proname))) as package_name,
upper(substring(proname from position('__' in proname)+2)) as object_name
from pg_proc
where strpos(proname,'__') > 1
}]
}
::xo::db::Class get_class_from_db [ -object_type object_type ]
Fetch an acs_object_type from the database and create
an XOTcl class from this information.
- Switches:
- -object_type (optional)
- Returns:
- class name of the created XOTcl class
::435800 proc get_class_from_db -object_type {
# some table_names and id_columns in acs_object_types are unfortunately upper case,
# so we have to convert to lower case here....
::xo::db_1row fetch_class {
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]} {
# the XOTcl class does not exist, we create it
#my log "--db create class $classname superclass $supertype"
::xo::db::Class create $classname -superclass [my object_type_to_class $supertype] -object_type $object_type -supertype $supertype -pretty_name $pretty_name -id_column $id_column -table_name $table_name -sql_package_name [namespace tail $classname] -noinit
} else {
#my log "--db we have a class $classname"
}
set attributes [::xo::db_list_of_lists get_atts {
select attribute_name, pretty_name, pretty_plural, datatype,
default_value, min_n_values, max_n_values
from acs_attributes where object_type = :object_type
}]
set slots ""
foreach att_info $attributes {
foreach {attribute_name pretty_name pretty_plural datatype default_value
min_n_values max_n_values} $att_info break
# ignore some erroneous definitions in the acs meta model
if {[my exists exclude_attribute($table_name,$attribute_name)]} continue
set defined_att($attribute_name) 1
set cmd [list ::xo::db::Attribute create $attribute_name -pretty_name $pretty_name -pretty_plural $pretty_plural -datatype $datatype -min_n_values $min_n_values -max_n_values $max_n_values]
if {$default_value ne ""} {
# if the default_value is "", we assume, no default
lappend cmd -default $default_value
}
append slots $cmd \n
}
if {[catch {$classname slots $slots} errorMsg]} {
error "Error during slots: $errorMsg"
}
$classname init
return $classname
}
::xo::db::Class get_instance_from_db -id id
Create an XOTcl object from an acs_object_id. This method
determines the type and initializes the object from the
information stored in the database. The XOTcl object is
destroyed automatically on cleanup (end of a connection request).
- Switches:
- -id (required)
- Returns:
- fully qualified object
::435800 proc get_instance_from_db -id:required {
set type [my get_object_type -id $id]
set class [::xo::db::Class object_type_to_class $type]
if {![my isclass $class]} {
error "no class $class defined"
}
set r [$class create ::$id]
$r db_1row get_instance [$class fetch_query $id]
$r set object_id $id
$r destroy_on_cleanup
$r initialize_loaded_object
return $r
}
::xo::db::Class get_object_type [ -id id ]
Return the object type for the give id.
- Switches:
- -id (optional)
- Returns:
- object_type, typically an XOTcl class
::435800 proc get_object_type -id:integer,required {
return [ns_cache eval xotcl_object_type_cache $id {
::xo::db_1row get_class "select object_type from acs_objects where object_id=$id"
return $object_type
}]
}
::xo::db::Class get_table_name -object_type object_type
Get the table_name of an object_type from the database. If the
object_type does not exist, the return value is empty.
- Switches:
- -object_type (required)
- Returns:
- table_name
::435800 proc get_table_name -object_type:required {
return [::xo::db_string get_table_name {
select lower(table_name) as table_name from acs_object_types where object_type = :object_type
} ""]
}
::xo::db::Class object_type_exists_in_db [ -object_type object_type ]
Check, if an object_type exists in the database.
- Switches:
- -object_type (optional)
- Returns:
- 0 or 1
::435800 proc object_type_exists_in_db -object_type {
return [::xo::db_string check_type {
select 1 from acs_object_types where object_type = :object_type
} 0]
}
proc object_type_to_class
::435800 proc object_type_to_class name {
switch -glob -- $name {
acs_object {return ::xo::db::Object}
content_revision -
content_item {return ::xo::db::CrItem}
content_folder {return ::xo::db::CrFolder}
::* {return $name}
default {return ::xo::db::$name}
}
}
instproc check_default_values
::435800 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}
}
<instance of ::xo::db::Class> check_table_atts
Check table_name and id_column and set meaningful
defaults, if these attributes are not provided.
::435800 instproc check_table_atts {} {
my 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 {[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 ""} {
error "Cannot determine SQL package_name. Please specify it explicitely!"
}
if {![my 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]'"
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
set id_column_error_tail ", or use different class names"
#my log "-- created id_column '[my id_column]'"
}
if {![regexp {^[[:alpha:]_][[:alnum:]_]*$} [my table_name]]} {
error "Table name '[my 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! 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: Please specify a different id_column$id_column_error_tail"
}
}
<instance of ::xo::db::Class> create_object_type
Create an acs object_type for the current XOTcl class
::435800 instproc create_object_type {} {
my instvar object_type supertype pretty_name pretty_plural table_name id_column name_method abstract_p
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]]
}
::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]
}
instproc db_slots
::435800 instproc db_slots {} {
my instvar id_column db_slot
array set db_slot [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]"
if {![$att istype ::xo::db::Attribute]} continue
set db_slot([$att name]) $att
}
if {[self] ne "::xo::db::Object"} {
if {[my 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 -pretty_name "ID" -datatype integer -create_acs_attribute false
}]
set db_slot($id_column) [self]::slot::$id_column
}
}
#my log "--setting db_slot of [self] to [array names db_slot]"
}
instproc dbproc_nonposargs
::435800 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...
#
if {$object_name eq "set"} {
my 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 sql_command [my generate_psql $package_name $object_name]
set proc_body [my generate_proc_body]
set nonposarg_list [list [list -dbn ""]]
foreach arg_name [my set arg_order] {
# special rule for DBN ... todo: proc has to handle this as well
set nonposarg_name [expr {$arg_name eq "DBN" ? "DBN" : [string tolower $arg_name]}]
#
# handling of default values:
# - no value ("") --> the attribute is required
# - value different from NULL --> make it default
# - otherwise: non-required argument
#
set default_value [my set defined($arg_name)]
if {$default_value eq ""} {
set arg -$nonposarg_name:required
} elseif {[string tolower $default_value] ne "null"} {
set arg [list -$nonposarg_name $default_value]
} else {
set arg -$nonposarg_name
}
lappend nonposarg_list $arg
}
# When the new method is executed within a contains, -childof is
# appended. we have to added it here to avoid complains. xotcl 2.0
# should find better ways to handle contain or the news invocation.
if {$object_name eq "new"} {lappend nonposarg_list -childof}
#my log "-- define $object_name $nonposarg_list"
my ad_proc $object_name $nonposarg_list {Automatically generated method} [subst -novariables $proc_body]
}
<instance of ::xo::db::Class> drop_object_type \
[ -cascade cascade ]
Drop an acs object_type; cascde true means that the attributes
are droped as well.
- Switches:
- -cascade (defaults to
"true") (optional)
::435800 instproc drop_object_type {{-cascade true}} {
my instvar object_type
::xo::db::sql::acs_object_type drop_type -object_type $object_type -cascade_p [expr {$cascade ? "t" : "f"}]
}
instproc fetch_query
::435800 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]] {
#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]"
foreach {slot_name slot} [$cl array get db_slot] {
# avoid duplicate output names
set name [$slot name]
if {![info exists names($name)]} {
lappend attributes [$slot attribute_reference $tn]
}
set names($name) 1
}
if {$cl ne [self]} {
lappend join_expressions "$tn.[$cl id_column] = [my table_name].$id_column"
}
}
}
return "SELECT [join $attributes ,]\nFROM [join $tables ,]\nWHERE [join $join_expressions { and }]"
}
instproc fix_function_args
::435800 instproc fix_function_args {function_args package_name object_name} {
#
# Load fallback defaults for buggy function args. The values
# provided here are only used for function args without specified
# defaults. This is a transitional solution; actually, the
# function args should be fixed.
#
if {![[self class] exists fallback_defaults(${package_name}__$object_name)]} {
return $function_args
}
array set additional_defaults [[self class] set fallback_defaults(${package_name}__$object_name)]
set result [list]
foreach arg $function_args {
foreach {arg_name default_value} $arg break
if {$default_value eq "" && [info exists additional_defaults($arg_name)]} {
lappend result [list $arg_name $additional_defaults($arg_name)]
} else {
lappend result [list $arg_name $default_value]
}
}
return $result
}
instproc generate_proc_body
::435800 instproc generate_proc_body {} {
return {
#function_args: [my set function_args]
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 "[my set sql]"
db_with_handle -dbn $dbn db {
#ns_log notice "--sql=$sql"
return \[ [set sql_command] \]
}
}
}
instproc generate_psql
::435800 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 psql_args [my sql-arguments $function_args $package_name $object_name]
#ns_log notice "-- select ${package_name}__${object_name} ($psql_args)"
my set sql [subst {
select ${package_name}__${object_name}($psql_args)
}]
return {ns_set value [ns_pg_bind 0or1row $db $sql] 0}
}
instproc get_context
::435800 instproc get_context {package_id_var user_id_var ip_var} {
my upvar $package_id_var package_id $user_id_var user_id $ip_var ip
if {![info exists package_id]} {
if {[info command ::xo::cc] ne ""} {
set package_id [::xo::cc package_id]
} elseif {[ns_conn isconnected]} {
set package_id [ad_conn package_id]
} else {
set package_id ""
}
}
if {![info exists user_id]} {
if {[info command ::xo::cc] ne ""} {
set user_id [::xo::cc user_id]
} elseif {[ns_conn isconnected]} {
set user_id [ad_conn user_id]
} else {
set user_id 0
}
}
if {![info exists ip]} {
if {[ns_conn isconnected]} {
set ip [ns_conn peeraddr]
} else {
set ip [ns_info address]
}
}
}
instproc get_function_args
::435800 instproc get_function_args {package_name object_name} {
set key [string toupper ${package_name}__${object_name}]
if {[info exists ::xo::db::sql::fnargs($key)]} {
return $::xo::db::sql::fnargs($key)
}
#
# Get function_args for a single sql-function from PostgreSQL
# system catalogs. We retrieve always the longest function for
# our definition, since we use an interface with non positional
# arguments, where in most situations, many arguments are
# optional. In cases, where more function with the samenumber
# of arguments are available, we sort by the type as well to
# obtain a predictable ordering and to give string interfaces
# (text, varchar) a higher priority than integer or boolean
# arguments (e.g. int4, int8m bool).
#
# Note: based on the ordering, char has lower priority over int* which
# is probably a bug, but is not a problem in OpenACS.
#
# Note, that we can as well get the type in future versions.
#
db_foreach [my qn get_function_params] {
select proname, pronargs, proargtypes, prosrc
from pg_proc
where proname = lower(:package_name) || '__' || lower(:object_name)
order by pronargs desc, proargtypes desc
} {
set n 1
set function_args [list]
foreach line [split $prosrc \n] {
if {[regexp -nocase "alias +for +\\\$$n" $line]} {
regexp {^[^a-zA-Z]+([a-zA-Z0-9_]+)\s} $line _ fq_name
if {![info exists fq_name]} {
ns_log notice "--***** Could not retrieve argument name for $proname argument $n from line '$line' in $prosrc'"
set fq_name arg$n
}
#lappend fq_names $fq_name
set name $fq_name
set default ""
if {![regexp {^.+__(.+)$} $fq_name _ name]} {
regexp {^[vp]_(.+)$} $fq_name _ name
}
if {[regexp {^.*-- default +([^, ]+) *$} $line _ default]} {
set default [string trim $default '\n\r]
}
lappend function_args [list [string toupper $name] $default]
if {[incr n]>$pronargs} break
}
}
if {$n == 1 && $pronargs > 0} {
set comment [string map [list \n "\n----\t"] $prosrc]
ns_log notice "---- no aliases for $proname/$pronargs $comment"
continue
}
break
}
return $function_args
}
<instance of ::xo::db::Class> get_instances_from_db \
[ -select_attributes select_attributes ] \
[ -from_clause from_clause ] [ -where_clause where_clause ] \
[ -orderby orderby ] [ -page_size page_size ] \
[ -page_number page_number ]
Returns a set (ordered composite) of the answer tuples of
an 'instance_select_query' with the same attributes. Note, that
the returned objects might by partially instantiated.
- Switches:
- -select_attributes (optional)
- -from_clause (optional)
- -where_clause (optional)
- -orderby (optional)
- -page_size (defaults to
"20") (optional) - -page_number (optional)
- Returns:
- ordered composite
::435800 instproc get_instances_from_db {{-select_attributes ""} {-from_clause ""} {-where_clause ""} {-orderby ""} {-page_size 20} {-page_number ""}} {
set s [my instantiate_objects -object_class [self] -sql [my instance_select_query -select_attributes $select_attributes -from_clause $from_clause -where_clause $where_clause -orderby $orderby -page_size $page_size -page_number $page_number ]]
return $s
}
instproc init
::435800 instproc init {} {
if {![::xo::db::Class object_type_exists_in_db -object_type [my object_type]]} {
my create_object_type
}
my init_type_hierarchy
my check_table_atts
my db_slots
if {[my with_table]} {
set table_definition [my table_definition]
if {$table_definition ne ""} {
::xo::db::require table [my table_name] $table_definition
}
my mk_save_method
my mk_insert_method
}
next
}
instproc init_type_hierarchy
::435800 instproc init_type_hierarchy {} {
my instvar object_type
my set object_type_key [::xo::db_list get_tree_sortkey {
select tree_sortkey from acs_object_types
where object_type = :object_type
}]
}
instproc initialize_acs_object
::435800 instproc initialize_acs_object {obj id} {
#
# This method is called, whenever a new (fresh) object with
# a new object_id is created.
#
$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]
}
<instance of ::xo::db::Class> instance_select_query \
[ -select_attributes select_attributes ] [ -orderby orderby ] \
[ -where_clause where_clause ] [ -from_clause from_clause ] \
[ -count on|off ] [ -page_size page_size ] \
[ -page_number page_number ]
Returns the SQL-query to select ACS Objects of the object_type
of the class.
- Switches:
- -select_attributes (optional)
- -orderby (optional)
- for ordering the solution set
- -where_clause (optional)
- clause for restricting the answer set
- -from_clause (optional)
- -count (boolean) (defaults to
"false") (optional) - return the query for counting the solutions
- -page_size (defaults to
"20") (optional) - -page_number (optional)
- Returns:
- SQL query
::435800 instproc instance_select_query {{-select_attributes ""} {-orderby ""} {-where_clause ""} {-from_clause ""} {-count:boolean false} {-page_size 20} {-page_number ""}} {
set tables [list]
set id_column [my id_column]
if {$count} {
set select_attributes "count(*)"
set orderby "" ;# no need to order when we count
set page_number "" ;# no pagination when count is used
}
set all_attributes [expr {$select_attributes eq ""}]
set join_expressions [list]
foreach cl [concat [self] [my 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
if {$all_attributes} {
foreach {slot_name slot} [$cl array get db_slot] {
# avoid duplicate output names
set name [$slot name]
if {![info exists names($name)]} {
lappend select_attributes [$slot attribute_reference $tn]
}
set names($name) 1
}
}
if {$cl ne [self]} {
lappend join_expressions "$tn.[$cl id_column] = [my table_name].$id_column"
}
}
}
if {$page_number ne ""} {
set limit $page_size
set offset [expr {$page_size*($page_number-1)}]
} else {
set limit ""
set offset ""
}
set sql [::xo::db::sql select -vars [join $select_attributes ,] -from "[join $tables ,] $from_clause" -where [string trim "[join $join_expressions { and }] $where_clause"] -orderby $orderby -limit $limit -offset $offset]
return $sql
}
<instance of ::xo::db::Class> instantiate_objects [ -dbn dbn ] \
[ -sql sql ] [ -full_statement_name full_statement_name ] \
[ -as_ordered_composite on|off ] [ -object_class object_class ] \
[ -named_objects on|off ] \
[ -object_named_after object_named_after ] \
[ -destroy_on_cleanup on|off ] [ -initialize initialize ]
Retrieve multiple objects from the database using the given SQL
query and create XOTcl objects from the tuples.
- Switches:
- -dbn (optional)
- -sql (optional)
- The SQL query to retrieve tuples. Note that if the SQL
query only returns a restricted set of attributes, the objects will
be only partially instantiated.
- -full_statement_name (optional)
- -as_ordered_composite (boolean) (defaults to
"true") (optional) - return an ordered composite object
preserving the order. If the flag is false, one has to use
"info instances" to access the resulted objects.
- -object_class (defaults to
"::xotcl::Object") (optional) - specifies the XOTcl class, for which instances
are created.
- -named_objects (boolean) (defaults to
"false") (optional) - -object_named_after (optional)
- -destroy_on_cleanup (boolean) (defaults to
"true") (optional) - -initialize (defaults to
"true") (optional)
::435800 instproc instantiate_objects {{-dbn ""} {-sql ""} {-full_statement_name ""} {-as_ordered_composite:boolean true} {-object_class "::xotcl::Object"} {-named_objects:boolean false} {-object_named_after ""} {-destroy_on_cleanup:boolean true} {-initialize true}} {
if {$object_class eq ""} {set object_class [self]}
if {$sql eq ""} {set sql [my instance_select_query]}
if {$as_ordered_composite} {
set __result [::xo::OrderedComposite new]
if {$destroy_on_cleanup} {$__result destroy_on_cleanup}
} else {
set __result [list]
}
if {$named_objects} {
if {$object_named_after eq ""} {
set object_named_after [my id_column]
}
}
db_with_handle -dbn $dbn db {
set selection [db_exec select $db $full_statement_name $sql]
while {1} {
set continue [ns_db getrow $db $selection]
if {!$continue} break
if {$named_objects} {
set object_name ::[ns_set get $selection $object_named_after]
set o [$object_class create $object_name]
} else {
set o [$object_class new]
}
if {$as_ordered_composite} {
$__result add $o
} else {
if {$destroy_on_cleanup} {
$o destroy_on_cleanup
}
lappend __result $o
}
foreach {att val} [ns_set array $selection] {$o set $att $val}
if {[$o exists object_type]} {
# set the object type if it looks like managed from XOTcl
if {[string match "::*" [set ot [$o set object_type]] ]} {
$o class $ot
}
}
if {$initialize && [$o istype ::xo::db::Object]} {
if {![$o exists package_id]} {
ns_log error "$o has no package_id but [$o exists object_package_id]"
if {[$o exists object_package_id]} {$o set package_id [$o set object_package_id]}
}
if {[catch {$o initialize_loaded_object} errorMsg]} {
ns_log error "$o initialize_loaded_object => [$o info vars] -> $errorMsg"
}
}
#my log "--DB more = $continue [$o serialize]"
}
}
return $__result
}
instproc mk_insert_method
::435800 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 {} {
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]"
next
foreach {__slot_name __slot} [[self class] array get db_slot] {
my instvar $__slot_name
if {[info exists $__slot_name]} {
lappend __vars $__slot_name
lappend __atts [$__slot column_name]
}
}
db_dml dbqd..insert_$__table_name "insert into $__table_name
([join $__atts ,]) values (:[join $__vars ,:])"
}
}
instproc mk_save_method
::435800 instproc mk_save_method {} {
set updates [list]
set vars [list]
foreach {slot_name slot} [my array get db_slot] {
$slot instvar name column_name
if {$column_name ne [my id_column]} {
lappend updates "$column_name = :$name"
lappend vars $name
}
}
if {[llength $updates] == 0} return
my instproc save {} [subst {
db_transaction {
next
my instvar object_id $vars
db_dml dbqd..update_[my table_name] {update [my table_name]
set [join $updates ,] where [my id_column] = :object_id
}
}
}]
}
instproc new_acs_object
::435800 instproc new_acs_object {-package_id -creation_user -creation_ip {object_title {}}} {
my 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]]
return $id
}
<instance of ::xo::db::Class> new_persistent_object \
[ -package_id package_id ] [ -creation_user creation_user ] \
[ -creation_ip creation_ip ] args [ args... ]
Create a new instance of the given class,
configure it with the given arguments and
insert it into the database. The XOTcl object is
destroyed automatically on cleanup (end of a connection request).
- Switches:
- -package_id (optional)
- -creation_user (optional)
- -creation_ip (optional)
- Parameters:
-
args
- Returns:
- fully qualified object
::435800 instproc new_persistent_object {-package_id -creation_user -creation_ip args} {
my get_context package_id creation_user creation_ip
db_transaction {
set id [my new_acs_object -package_id $package_id -creation_user $creation_user -creation_ip $creation_ip ""]
#[self class] set during_fetch 1
if {[catch {eval my create ::$id $args} errorMsg]} {
my log "Error: $errorMsg, $::errorInfo"
}
#[self class] unset during_fetch
my initialize_acs_object ::$id $id
::$id insert
}
::$id destroy_on_cleanup
return ::$id
}
<instance of ::xo::db::Class> object_types \
[ -subtypes_first on|off ]
Return the type and subtypes of the class, on which
the method is called. If subtypes_first is specified,
the subtypes are returned first.
- Switches:
- -subtypes_first (boolean) (defaults to
"false") (optional)
- Returns:
- list of object_types
::435800 instproc object_types {{-subtypes_first:boolean false}} {
return [::xo::db_list get_object_types [my object_types_query -subtypes_first $subtypes_first]]
}
instproc object_types_query
::435800 instproc object_types_query {{-subtypes_first:boolean false}} {
my instvar 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"
}
instproc sql-arguments
::435800 instproc sql-arguments {function_args package_name object_name} {
my array unset defined
set psql_args [list]
my set arg_order [list]
my set function_args $function_args
foreach arg $function_args {
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
}
return [join $psql_args ", "]
}
instproc table_definition
::435800 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] {
set column_name [$slot column_name]
set column_specs($column_name) [$slot column_spec -id_column [expr {$column_name eq $id_column}]]
}
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"
}
set table_specs [list]
foreach {att spec} [array get column_specs] {lappend table_specs " $att $spec"}
set table_definition [join $table_specs ",\n"]
} else {
set table_definition ""
}
# my log table_definition=$table_definition
return $table_definition
}
instproc unknown
::435800 instproc unknown {m args} {
error "Error: unknown database method '$m' for [self]"
}