Methods:	Source:	Variables:
[All Methods \| Documented Methods \| Hide Methods]	[Display Source \| Hide Source]	[Show Variables \| Hide Variables]

::xotcl::Class ::xo::db::Class

Class Hierarchy of ::xo::db::Class
::xotcl::Object
Meta-class:

::xotcl::Class

Methods for instances:

__api_make_doc, __api_make_forward_doc, __next^C, __timediff, abstract, ad_doc, ad_forward, ad_proc, append^C, array^C, asHTML, autoname^C, check^C, class^C, cleanup^C, configure^C, contains, copy, db_1row^C, debug, defaultmethod, destroy^C, destroy_on_cleanup, eval^C, exists^C, extractConfigureArg, filter^C, filterguard^C, filtersearch^C, forward^C, hasclass, incr^C, info^C, init, instvar^C, invar^C, isclass^C, ismetaclass^C, ismixin^C, isobject^C, istype^C, lappend^C, log, method, mixin^C, mixinguard^C, move, msg, noinit^C, parametercmd^C, proc^C, procsearch^C, qn, requireNamespace^C, self, serialize, set^C, subst^C, trace^C, unset^C, uplevel^C, upvar^C, volatile^C, vwait^C
Methods to be applied on the class (in addition to the methods provided by the meta-class):

__exitHandler, getExitHandler, setExitHandler, unsetExitHandler
::xotcl::Class
Meta-class:

::xotcl::Class

Methods for instances:

ad_instproc, allinstances, alloc^C, autoname^C, create^C, extend_slot, info^C, instdestroy^C, instfilter^C, instfilterguard^C, instforward^C, instinvar^C, instmixin^C, instmixinguard^C, instparametercmd^C, instproc^C, method, new^C, parameter, parameterclass^C, recreate^C, slots^C, superclass^C, unknown^C, uses
Methods to be applied on the class (in addition to the methods provided by the meta-class):

__unknown
::xo::db::Class
Meta-class:

::xotcl::Class

Parameter for instances:

abstract_p (default "f"), auto_save (default "false"), id_column, name_method (default ""), object_type (default "[self]"), pretty_name, pretty_plural, security_inherit_p (default "t"), sql_package_name, supertype (default "acs_object"), table_name, with_table (default "true")

Methods for instances:

check_default_values, check_table_atts, create_object_type, db_slots, dbproc_nonposargs, drop_object_type, fetch_query, fix_function_args, generate_proc_body, generate_psql, get_context, get_function_args, get_instances_from_db, init, init_type_hierarchy, initialize_acs_object, instance_select_query, instantiate_objects, mk_insert_method, mk_save_method, new_acs_object, new_persistent_object, object_types, object_types_query, sql-arguments, table_definition, unknown
Methods to be applied on the class (in addition to the methods provided by the meta-class):

class_to_object_type, create_all_functions, delete, delete_all_acs_objects, drop_type, exists_in_db, get_all_package_functions, get_class_from_db, get_instance_from_db, get_object_type, get_table_name, object_type_exists_in_db, object_type_to_class
::xo::db::Class is a meta class for interfacing with acs_object_types. acs_object_types are instances of this meta class. The meta class defines the behavior common to all acs_object_types. The behavior common to all acs_objects is defined by the class ::xo::db::Object.

Defined in packages/xotcl-core/tcl/05-db-procs.tcl
Class Relations

superclass: ::xotcl::Class

subclass: ::xo::PackageMgr, ::xo::db::CrClass

::xotcl::Class create ::xo::db::Class \
     -superclass ::xotcl::Class \
     -parameter {{abstract_p f} {auto_save false} id_column {name_method ""} \
       {object_type [self]} pretty_name pretty_plural {security_inherit_p t} sql_package_name \
       {supertype acs_object} table_name {with_table true}}

Methods

proc class_to_object_type

::xo::db::Class 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::*      {return [string range $name 10 end]}
      default          {return $name}
    }
  }

proc create_all_functions

::xo::db::Class 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]
    }
  }

proc delete (public)

::xo::db::Class delete -id id

Delete the object from the database

Switches:

-id (required)

::xo::db::Class proc delete -id:required {
    ::xo::db::sql::acs_object delete -object_id $id
  }

proc delete_all_acs_objects (public)

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

::xo::db::Class 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}
    }
  }

proc drop_type (public)

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

::xo::db::Class 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 ""
  }

proc exists_in_db (public)

::xo::db::Class exists_in_db -id id

Check, if an acs_object exists in the database.

Switches:

-id (required)

Returns:
0 or 1

::xo::db::Class proc exists_in_db -id:required {
    return [db_string [my qn select_object] {
      select 1 from acs_objects where object_id = :id
    } -default 0]
  }

proc get_all_package_functions

::xo::db::Class proc get_all_package_functions {} {
      #
      # Get all package functions (package name, object name) from Oracle
      # system catalogs.
      #
      return [db_list_of_lists [my qn [self proc]] {
        select distinct package_name, object_name
          from user_arguments args
          where args.position > 0 and package_name is not null
      }]
    }

proc get_class_from_db (public)

::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

::xo::db::Class 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....
    db_1row dbqd..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 [db_list_of_lists dbqd..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
  }

proc get_instance_from_db (public)

::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

::xo::db::Class 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 dbq..get_instance [$class fetch_query $id]
    $r set object_id $id
    $r destroy_on_cleanup
    $r initialize_loaded_object
    return $r
  }

proc get_object_type (public)

::xo::db::Class get_object_type -id id

Return the object type for the give id.

Switches:

-id (required)

Returns:
object_type, typically an XOTcl class

::xo::db::Class proc get_object_type -id:required {
    db_1row [my qn get_class]  "select object_type from acs_objects where object_id=$id"
    return $object_type
  }

proc get_table_name (public)

::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

::xo::db::Class proc get_table_name -object_type:required {
    return [db_string [my qn get_table_name] {
      select lower(table_name) as table_name from acs_object_types where object_type = :object_type
    } -default ""]
  }

proc object_type_exists_in_db (public)

::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

::xo::db::Class proc object_type_exists_in_db -object_type {
    return [db_string [my qn check_type] {
      select 1 from acs_object_types where object_type = :object_type
    } -default 0]
  }

proc object_type_to_class

::xo::db::Class proc object_type_to_class name {
    switch -glob -- $name {
      acs_object       {return ::xo::db::Object}
      content_revision {return ::xo::db::CrItem}
      ::*              {return $name}
      default          {return ::xo::db::$name}
    }
  }

instproc check_default_values

::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}
  }

instproc check_table_atts (public)

<instance of ::xo::db::Class> check_table_atts

Check table_name and id_column and set meaningful defaults, if these attributes are not provided.

::xo::db::Class 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" 
    }
  }

instproc create_object_type (public)

<instance of ::xo::db::Class> create_object_type

Create an acs object_type for the current XOTcl class

::xo::db::Class 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

::xo::db::Class 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

::xo::db::Class 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
    }
    #my log "-- define $object_name $nonposarg_list"

    my ad_proc $object_name $nonposarg_list {Automatically generated method} [subst -novariables $proc_body]
  }

instproc drop_object_type (public)

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

::xo::db::Class 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

::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]] {
      #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

::xo::db::Class instproc fix_function_args {function_args package_name object_name} {
    if {![[self class] exists defaults(${package_name}__$object_name)]} {
      return $function_args
    }

    array set additional_defaults [[self class] set 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

::xo::db::Class instproc generate_proc_body {} {
      return {
        #function_args: [my set function_args]
        set sql_args \[list\]
        foreach var \[list [my set arg_order]\]  {
          set varname \[string tolower $var\]
          if {\[info exists $varname\]} {
            lappend sql_args "$varname => :$varname"
          } 
        }
        set sql_args \[join $sql_args ,\]
        set sql "[my set sql]"
        db_with_handle -dbn $dbn db {
          #my log "sql=$sql, sql_command=[set sql_command]"
          return \[ [set sql_command] \]
        }
      }
    }

instproc generate_psql

::xo::db::Class instproc generate_psql {package_name object_name} {
      # 
      # in Oracle, we have to distinguish between functions and procs
      #
      set is_function [db_0or1row [my qn is_function] {
        select 1 from dual
        where exists (select 1 from user_arguments where
                      package_name = upper(:package_name)
                      and object_name = upper(:object_name)
                      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 psql_args [my sql-arguments $function_args $package_name $object_name]

      if {$is_function} {
        my set sql [subst {BEGIN :1 := ${package_name}.${object_name}(\$sql_args); END;}]
        return {ns_ora exec_plsql_bind $db $sql 1 ""}
      } else {
        my set sql [subst {BEGIN ${package_name}.${object_name}(\$sql_args); END;}]
        #return {ns_set value [ns_ora select $db $sql] 0}
        return {ns_ora dml $db $sql}
      }
    }

instproc get_context

::xo::db::Class 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

::xo::db::Class instproc get_function_args {package_name object_name} {
      # In Oracle, args.default_value appears to be defunct and useless.
      # for now, we simply return a constant "unknown", otherwise the
      # argument would be required
      return [db_list_of_lists [my qn get_function_params] {
	select args.argument_name, 'NULL'
        from user_arguments args
        where args.position > 0
        and args.object_name = upper(:object_name)
        and args.package_name = upper(:package_name)
        order by args.position
      }]
    }

instproc get_instances_from_db (public)

<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

::xo::db::Class 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

::xo::db::Class 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

::xo::db::Class instproc init_type_hierarchy {} {
      my set object_type_key {}
    }

instproc initialize_acs_object

::xo::db::Class 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]    
  }

instproc instance_select_query (public)

<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

::xo::db::Class 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
  }

instproc instantiate_objects (public)

<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 ] [ -destroy_on_cleanup on|off ]

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)
-destroy_on_cleanup (boolean) (defaults to "true") (optional)

::xo::db::Class instproc instantiate_objects {{-dbn {}} {-sql {}} {-full_statement_name {}} {-as_ordered_composite:boolean true} {-object_class ::xotcl::Object} {-named_objects:boolean false} {-destroy_on_cleanup:boolean 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 ""
    }

    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 [my id_column]]
          set o [$object_class create $object_name]
        } else {
          set o [$object_class new]
        }
        if {$as_ordered_composite} {
          $__result add $o
        } elseif {$destroy_on_cleanup} {
          $o destroy_on_cleanup
        }
        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 {[$o istype ::xo::db::Object]} {
          $o initialize_loaded_object
        }
        #my log "--DB more = $continue [$o serialize]" 
      }
    }
    return $__result
  }

instproc mk_insert_method

::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 {} {
      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

::xo::db::Class 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

::xo::db::Class 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
  }

instproc new_persistent_object (public)

<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

::xo::db::Class 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
  }

instproc object_types (public)
```
<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
```
::xo::db::Class instproc object_types {{-subtypes_first:boolean false}} {
    return [db_list [my qn get_object_types]  [my object_types_query -subtypes_first $subtypes_first]]
  }
```

instproc object_types_query

::xo::db::Class instproc object_types_query {{-subtypes_first:boolean false}} {
      my instvar 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"
    }

instproc sql-arguments

::xo::db::Class 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

::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] {
      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

::xo::db::Class instproc unknown {m args} {
    error "Error: unknown database method '$m' for [self]"
  }

Instances

::xo::db::Object, ::xo::db::apm_parameter, ::xo::db::sql::acs, ::xo::db::sql::acs_activity, ::xo::db::sql::acs_attribute, ::xo::db::sql::acs_event, ::xo::db::sql::acs_group, ::xo::db::sql::acs_log, ::xo::db::sql::acs_mail_body, ::xo::db::sql::acs_mail_gc_object, ::xo::db::sql::acs_mail_link, ::xo::db::sql::acs_mail_multipart, ::xo::db::sql::acs_mail_nt, ::xo::db::sql::acs_mail_queue_message, ::xo::db::sql::acs_message, ::xo::db::sql::acs_object, ::xo::db::sql::acs_object_type, ::xo::db::sql::acs_object_util, ::xo::db::sql::acs_permission, ::xo::db::sql::acs_privilege, ::xo::db::sql::acs_reference, ::xo::db::sql::acs_rel, ::xo::db::sql::acs_rel_type, ::xo::db::sql::acs_sc_binding, ::xo::db::sql::acs_sc_contract, ::xo::db::sql::acs_sc_impl, ::xo::db::sql::acs_sc_impl_alias, ::xo::db::sql::acs_sc_msg_type, ::xo::db::sql::acs_sc_operation, ::xo::db::sql::acs_user, ::xo::db::sql::admin_rel, ::xo::db::sql::alf_admission, ::xo::db::sql::alf_bounce_emails, ::xo::db::sql::alf_cluster_message, ::xo::db::sql::alf_cluster_node, ::xo::db::sql::alf_dotlrn_department, ::xo::db::sql::alf_dotlrn_faculty, ::xo::db::sql::alf_edu_audit, ::xo::db::sql::alf_process_manager, ::xo::db::sql::alf_study, ::xo::db::sql::alf_study_community, ::xo::db::sql::alf_undergraduate, ::xo::db::sql::apm, ::xo::db::sql::apm_application, ::xo::db::sql::apm_package, ::xo::db::sql::apm_package_type, ::xo::db::sql::apm_package_version, ::xo::db::sql::apm_parameter_value, ::xo::db::sql::apm_service, ::xo::db::sql::application_group, ::xo::db::sql::as_action, ::xo::db::sql::as_backup, ::xo::db::sql::as_inter_item_check, ::xo::db::sql::assignation_rel, ::xo::db::sql::authority, ::xo::db::sql::bulk_mail, ::xo::db::sql::cal_item, ::xo::db::sql::calendar, ::xo::db::sql::category, ::xo::db::sql::category_link, ::xo::db::sql::category_synonym, ::xo::db::sql::category_tree, ::xo::db::sql::chat_room, ::xo::db::sql::chat_transcript, ::xo::db::sql::composition_rel, ::xo::db::sql::content_extlink, ::xo::db::sql::content_folder, ::xo::db::sql::content_item, ::xo::db::sql::content_keyword, ::xo::db::sql::content_permission, ::xo::db::sql::content_revision, ::xo::db::sql::content_symlink, ::xo::db::sql::content_template, ::xo::db::sql::content_type, ::xo::db::sql::develop_audit, ::xo::db::sql::doc, ::xo::db::sql::dotlrn_admin_profile_rel, ::xo::db::sql::dotlrn_admin_rel, ::xo::db::sql::dotlrn_ca_rel, ::xo::db::sql::dotlrn_cadmin_rel, ::xo::db::sql::dotlrn_class, ::xo::db::sql::dotlrn_class_instance, ::xo::db::sql::dotlrn_club, ::xo::db::sql::dotlrn_community, ::xo::db::sql::dotlrn_community_type, ::xo::db::sql::dotlrn_department, ::xo::db::sql::dotlrn_external_profile_rel, ::xo::db::sql::dotlrn_instructor_rel, ::xo::db::sql::dotlrn_member_rel, ::xo::db::sql::dotlrn_privacy, ::xo::db::sql::dotlrn_professor_profile_rel, ::xo::db::sql::dotlrn_student_profile_rel, ::xo::db::sql::dotlrn_student_rel, ::xo::db::sql::dotlrn_ta_rel, ::xo::db::sql::dotlrn_user_profile_rel, ::xo::db::sql::evaluation, ::xo::db::sql::evaluation_stats, ::xo::db::sql::faq, ::xo::db::sql::file_storage, ::xo::db::sql::forums_forum, ::xo::db::sql::forums_message, ::xo::db::sql::forums_tag, ::xo::db::sql::forums_view, ::xo::db::sql::gm_enlaces, ::xo::db::sql::homepage, ::xo::db::sql::image, ::xo::db::sql::journal_entry, ::xo::db::sql::membership_rel, ::xo::db::sql::new_stuff_portlet, ::xo::db::sql::news, ::xo::db::sql::notification, ::xo::db::sql::notification_delivery_method, ::xo::db::sql::notification_interval, ::xo::db::sql::notification_reply, ::xo::db::sql::notification_request, ::xo::db::sql::notification_type, ::xo::db::sql::party, ::xo::db::sql::party_approved_member, ::xo::db::sql::person, ::xo::db::sql::pinds_blog_category, ::xo::db::sql::pinds_blog_entry, ::xo::db::sql::portal, ::xo::db::sql::portal_datasource, ::xo::db::sql::portal_element_theme, ::xo::db::sql::portal_layout, ::xo::db::sql::portal_page, ::xo::db::sql::profiled_group, ::xo::db::sql::quiz, ::xo::db::sql::quiz_session, ::xo::db::sql::recurrence, ::xo::db::sql::rel_constraint, ::xo::db::sql::rel_segment, ::xo::db::sql::research_rel, ::xo::db::sql::rss_gen_subscr, ::xo::db::sql::search_observer, ::xo::db::sql::site_node, ::xo::db::sql::site_node_object_map, ::xo::db::sql::static_portal_content_item, ::xo::db::sql::subsite_callback, ::xo::db::sql::survey, ::xo::db::sql::survey_predefined_question, ::xo::db::sql::survey_question, ::xo::db::sql::survey_response, ::xo::db::sql::survey_section, ::xo::db::sql::teaching_rel, ::xo::db::sql::template_demo_note, ::xo::db::sql::time_interval, ::xo::db::sql::timespan, ::xo::db::sql::timezone, ::xo::db::sql::tree, ::xo::db::sql::uforums, ::xo::db::sql::user_pref_type, ::xo::db::sql::user_profile_rel, ::xo::db::sql::util, ::xo::db::sql::views_view, ::xo::db::sql::weblogger_blogroll_entry, ::xo::db::sql::weblogger_channel

Methods:	Source:	Variables:
[All Methods \| Documented Methods \| Hide Methods]	[Display Source \| Hide Source]	[Show Variables \| Hide Variables]

::xotcl::Class ::xo::db::Class

Class Hierarchy of ::xo::db::Class

Class Relations

Methods

proc class_to_object_type

proc create_all_functions

proc delete (public)

proc delete_all_acs_objects (public)

proc drop_type (public)

proc exists_in_db (public)

proc get_all_package_functions

proc get_class_from_db (public)

proc get_instance_from_db (public)

proc get_object_type (public)

proc get_table_name (public)

proc object_type_exists_in_db (public)

proc object_type_to_class

instproc check_default_values

instproc check_table_atts (public)

instproc create_object_type (public)

instproc db_slots

instproc dbproc_nonposargs

instproc drop_object_type (public)

instproc fetch_query

instproc fix_function_args

instproc generate_proc_body

instproc generate_psql

instproc get_context

instproc get_function_args

instproc get_instances_from_db (public)

instproc init

instproc init_type_hierarchy

instproc initialize_acs_object

instproc instance_select_query (public)

instproc instantiate_objects (public)

instproc mk_insert_method

instproc mk_save_method

instproc new_acs_object

instproc new_persistent_object (public)

instproc object_types (public)

instproc object_types_query

instproc sql-arguments

instproc table_definition

instproc unknown

Instances