Class ::xo::db::Class (public)

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

Defined in /var/www/openacs/packages/xotcl-core/tcl/05-db-procs.tcl

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

See Also:

• xo::db::Object

Testcases:

xotcl_core_tutorial_2

Source code:

namespace eval ::xo::db {}
::nsf::object::alloc ::xotcl::Class ::xo::db::Class {set :__default_metaclass ::xotcl::Class
   set :__default_superclass ::xotcl::Object
   array set :exclude_attribute {persons,bio 1 persons,bio_mime_type 1}}
::xo::db::Class proc object_type_exists_in_db -object_type {
    return [::xo::dc 0or1row check_type {
      select 1 from acs_object_types where object_type = :object_type
    }]
  }
::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 ""} {
      ::xo::dc dml delete_instances {delete from :table_name}
    }
  }
::xo::db::Class proc exists_in_db -id:required {
    return [::xo::dc 0or1row -prepare integer select_object {
      select 1 from acs_objects where object_id = :id
    }]
  }
::xo::db::Class proc delete -id:required {
    ::acs::dc call acs_object delete -object_id $id
  }
::xo::db::Class proc get_instance_from_db -id:required,integer {
    set type  [:get_object_type -id $id]
    set class [::xo::db::Class object_type_to_class $type]
    if {![:isclass $class]} {
      error "no class $class defined"
    }
    set r [$class create ::$id]
    $r db_1row dbqd..get_instance [$class fetch_query $id]
    $r set object_id $id
    $r destroy_on_cleanup
    $r initialize_loaded_object
    return $r
  }
::xo::db::Class proc get_class_from_db -object_type {
    # some table_names and id_columns in acs_object_types are unfortunately uppercase,
    # so we have to convert to lowercase here....
    ::xo::dc 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 [:object_type_to_class $object_type]
    if {![:isclass $classname]} {
      # the XOTcl class does not exist, we create it
      #:log "--db create class $classname superclass $supertype"
      ::xo::db::Class create $classname  -superclass [: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 {
      #:log "--db we have a class $classname"
    }
    set attributes [::xo::dc 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 {
      lassign $att_info attribute_name pretty_name pretty_plural datatype  default_value min_n_values max_n_values

      # ignore some erroneous definitions in the acs meta model
      if {[info 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
    }
    ad_try {
      $classname slots $slots
    } on error {errorMsg} {
      error "Error during slots: $errorMsg"
    }

    $classname init
    return $classname
  }
::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 {
        ::xo::dc dml delete_instances "delete from $table_name"
        if {$drop_table} {
          ::xo::dc dml drop_table "drop table $table_name"
        }
      } errorMsg]} {
        ns_log error "error during drop_type: $errorMsg"
      }
    }
    ::acs::dc call acs_object_type drop_type  -object_type $object_type -drop_children_p $cascade_p
    return ""
  }
::xo::db::Class 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}
    }
  }
::xo::db::Class proc class_to_object_type name {
    if {[: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 desperation.
        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}
    }
  }
::xo::db::Class proc create_all_functions {} {

    foreach item [::xo::dc get_all_package_functions] {
      lassign $item package_name object_name

      if {[string match "*TRG" [string toupper $object_name]]} {
        # no need to provide interface to trigger functions
        continue
      }

      set class_name ::xo::db::sql::[string tolower $package_name]
      if {![nsf::is object $class_name]} {

        ::xo::db::Class create $class_name
        #$class_name proc unknown args {
        #  ns_log warning "deprecated ::xo::db::[namespace tail [self]] $args was called."  #      "Use '::acs::dc call [namespace tail [self]] $args]' instead"
        #  return [::acs::dc call [namespace tail [self]] {*}$args]
        #}

      } elseif {![$class_name istype ::xo::db::Class]} {
        #
        # Make sure that we do not create new objects via the next
        # command.
        #
        continue
      }
      $class_name dbproc_nonposargs [string tolower $object_name]
    }
  }
::xo::db::Class proc get_object_type -id:integer,required {
    xo::xotcl_object_type_cache eval -partition_key $id $id {
      ::xo::dc 1row get_class "select object_type from acs_objects where object_id=:id"
      return $object_type
    }
  }
::xo::db::Class proc get_table_name -object_type:required {
    return [::xo::dc get_value get_table_name {
      select lower(table_name) as table_name from acs_object_types where object_type = :object_type
    } ""]
  }
::xo::db::Class instproc new_persistent_object {-package_id -creation_user -creation_ip args} {
    :get_context package_id creation_user creation_ip
    ::xo::dc transaction {
      set id [:new_acs_object  -package_id $package_id  -creation_user $creation_user  -creation_ip $creation_ip  ""]
      #[self class] set during_fetch 1
      ad_try {
        :create ::$id {*}$args
      } on error {errorMsg} {
        ad_log error "create fails: $errorMsg"
      }
      #[self class] unset during_fetch
      :initialize_acs_object ::$id $id
      ::$id insert
    }
    ::$id destroy_on_cleanup
    return ::$id
  }
::xo::db::Class instproc table_definition {} {
    array set column_specs [list]
    #
    # iterate over the slots and collect the column_specs for table generation
    #
    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}}]]
    }

    # Requires collected constraints on object's table.
    ::xo::db::Class instproc require_constraints {} {
      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 {
            "unique" {
              ::xo::db::require unique  -table $table_name -col $col
            }
            "index" {
              set value [expr {[string is true $value] ? "" : $value}]
              ::xo::db::require index -using $value  -table $table_name -col $col
            }
            "not_null" {
              ::xo::db::require not_null  -table $table_name -col $col
            }
            "references" {
              ::xo::db::require references  -table $table_name -col $col  -ref $value
            }
            "default" {
              ::xo::db::require default  -table $table_name -col $col  -value $value
            }
          }
        }
      }
    }

    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 $table_specs
    } else {
      set table_definition ""
    }
    # :log table_definition=$table_definition
    return $table_definition
  }
::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 [: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 [list [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
        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] = [: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::dc 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
  }
::xo::db::Class instproc db_slots {} {

    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.
    #
    # :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
      :collect_constraints $att
    }
    if {[self] ne "::xo::db::Object"} {
      if {[info exists :id_column] && ![info exists :db_slot(${:id_column})]} {
        # create automatically the slot for the 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}
      }
    }
    #:log "--setting db_slot of [self] to [array names _db_slot]"
  }
::xo::db::Class instproc object_types {{-subtypes_first:boolean false}} {
    return [::xo::dc list get_object_types  [:object_types_query -subtypes_first $subtypes_first]]
  }
::xo::db::Class instproc init_type_hierarchy {} {
      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
      }]
    }
::xo::db::Class instproc dbproc_nonposargs object_name {
    #
    # This method compiles a stored procedure into an XOTcl method
    # using a classic nonpositional argument style interface.
    #
    # The current implementation should work on PostgreSQL and Oracle
    # (not tested) but will not work, when a single OpenACS instance
    # want to talk to PostgreSQL and Oracle simultaneously. Not sure,
    # how important this is...
    #
    if {$object_name eq "set"} {
      :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 namespace tail as sql_package_name.
    #
    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"
    # puts "sql_info=$sql_info"
    array set defined [dict get $sql_info defined]

    set nonposarg_list [list [list -dbn ""]]
    foreach arg_name [dict get $sql_info 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 $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 new invocation.
    if {$object_name eq "new"} {lappend nonposarg_list -childof}
    #:log "-- define $object_name $nonposarg_list"

    #ns_log notice final=[dict get $sql_info body]
    :ad_proc $object_name $nonposarg_list {Automatically generated method} [dict get $sql_info body]
  }
::xo::db::Class instproc require_constraints {} {
      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 {
            "unique" {
              ::xo::db::require unique  -table $table_name -col $col
            }
            "index" {
              set value [expr {[string is true $value] ? "" : $value}]
              ::xo::db::require index -using $value  -table $table_name -col $col
            }
            "not_null" {
              ::xo::db::require not_null  -table $table_name -col $col
            }
            "references" {
              ::xo::db::require references  -table $table_name -col $col  -ref $value
            }
            "default" {
              ::xo::db::require default  -table $table_name -col $col  -value $value
            }
          }
        }
      }
    }
::xo::db::Class instproc init {} {
    if {![::xo::db::Class object_type_exists_in_db -object_type [:object_type]]} {
      :create_object_type
    }
    :init_type_hierarchy
    :check_table_atts
    :db_slots

    if {[:with_table]} {
      set table_definition [:table_definition]
      if {$table_definition ne ""} {
        ::xo::db::require table [:table_name] $table_definition
        :require_constraints
      }
      :mk_update_method
      :mk_insert_method
    }
    next
  }
::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
    :instproc insert {} {
      set __table_name [[self class] table_name]
      set __id [[self class] id_column]
      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] {
        if {[info exists :$__slot_name]} {
          set $__slot_name [set :$__slot_name]
          lappend __vars $__slot_name
          lappend __atts [$__slot column_name]
        }
      }
      ::xo::dc dml insert_$__table_name "insert into $__table_name
        ([join $__atts ,]) values (:[join $__vars ,:])"
    }
  }
::xo::db::Class instproc drop_object_type {{-cascade true}} {
    ::acs::dc call acs_object_type drop_type  -object_type ${:object_type}  -cascade_p [expr {$cascade ? "t" : "f"}]
  }
::xo::db::Class 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} {-keep_existing_objects:boolean false} {-ignore_missing_package_ids:boolean false} {-initialize true}} {

    if {$object_class eq ""} {set object_class [self]}
    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}
    } else {
      set __result [list]
    }
    if {$named_objects} {
      if {$object_named_after eq ""} {
        set object_named_after [:id_column]
      }
    }

    set sets [uplevel [list ::xo::dc sets -dbn $dbn dbqd..[self proc] $sql]]
    foreach selection $sets {
      if {$named_objects} {
        set object_name ::[ns_set get $selection $object_named_after]
        if {[nsf::is object $object_name]} {
          set o $object_name
          set new 0
        } else {
          set o [$object_class create $object_name]
          set new 1
        }
      } else {
        set new 0
        set o [$object_class new]
      }
      if {$as_ordered_composite} {
        $__result add $o
      } else {
        if {$destroy_on_cleanup} {
          $o destroy_on_cleanup
        }
        lappend __result $o
      }

      if {!$new && $keep_existing_objects} {
        #ns_log notice "+++ instantiate_objects keep existing object $o"
        continue
      }
      $o mset [ns_set array $selection]
      ns_set free $selection

      if {[$o exists object_type]} {
        #
        # Set the object type if it looks like managed from XOTcl.
        #
        set object_type [$o set object_type]
        if {[string match "::*" $object_type]} {
          $o class $object_type
        }
      }
      if {$initialize && [$o istype ::xo::db::Object]} {
        if {![$o exists package_id]} {
          if {[$o exists object_package_id]} {
            $o set package_id [$o set object_package_id]
          } elseif {!$ignore_missing_package_ids} {
            ns_log warning "[namespace tail [$o info class]] $o has no package_id and no object_package_id"
          }
        }
        ad_try {
          $o initialize_loaded_object
        } on error {errorMsg} {
          set context [lmap var {name item_id revision_id} {
            if {![$o exists $var]} continue
            set _ "$var [$o set $var]"
          }]
          ns_log error "$o initialize_loaded_object [join $context]"  "=> [lsort [$o info vars]] -> $errorMsg"
        }
      }
      #:log "--DB more = $continue [$o serialize]"
    }

    return $__result
  }
::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 "[:pretty_name] $id"
    #$obj set object_type [:object_type]
  }
::xo::db::Class instproc get_instances_from_db {{-select_attributes ""} {-from_clause ""} {-where_clause ""} {-orderby ""} {-page_size 20} {-page_number ""} {-initialize true}} {
    set s [:instantiate_objects  -object_class [self]  -sql [: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  ]  -initialize $initialize]
    return $s
  }
::xo::db::Class instproc unknown {m args} {
    error "Error: unknown database method '$m' for [self]"
  }
::xo::db::Class instproc object_types_query {{-subtypes_first:boolean false}} {
      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 check_table_atts {} {
    :check_default_values
    set table_name_error_tail ""
    set id_column_error_tail ""

    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! 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 explicitly!"
    }

    if {![info exists :table_name]} {
      set tail [namespace tail [self]]
      regexp {^::([^:]+)::} [self] _ head
      :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 {![info exists :id_column]} {
      set :id_column [string tolower [namespace tail [self]]]_id
      set id_column_error_tail ", or use different class names"
      #:log "-- created id_column '[:id_column]'"
    }

    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 [: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:]_]*$} [: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 {} {
    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 mk_update_method {} {
    set updates [list]
    set vars [list]
    foreach {slot_name slot} [array get :db_slot] {
      $slot instvar name column_name
      if {$column_name ne [:id_column]} {
        lappend updates "$column_name = :$name"
        lappend vars $name
      }
    }
    if {[llength $updates] == 0} return
    :instproc update {} [subst {
      ::xo::dc transaction {
        next
        :instvar object_id $vars
        ::xo::dc dml update_[:table_name] {update [:table_name]
          set [join $updates ,] where [:id_column] = :object_id
        }
      }
    }]
  }
::xo::db::Class instproc create_object_type {} {
    :check_default_values
    :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 [:info superclass]]
    }

    ::acs::dc call 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  [:sql_package_name]
  }
::xo::db::Class instproc get_context {package_id_var user_id_var ip_var} {
    :upvar  $package_id_var package_id  $user_id_var user_id  $ip_var ip

    if {![info exists package_id]} {
      if {[nsf::is object ::xo::cc]} {
        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 {[nsf::is object ::xo::cc]} {
        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 [ad_conn peeraddr]
      } else {
        set ip [ns_info address]
      }
    }
  }
::xo::db::Class instproc collect_constraints att {
    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]]
    }
    # ...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 {[$att exists unique] && [$att set unique]} {
        lappend :db_constraints($attname) unique
      }
      if {[$att exists not_null] && [$att set not_null]} {
        lappend :db_constraints($attname) not_null
      }
      if {![string is space [$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]]
      }
    }
  }
::xo::db::Class instproc new_acs_object {-package_id -creation_user -creation_ip {-context_id ""} {object_title ""}} {
    :get_context package_id creation_user creation_ip

    set id [::acs::dc call 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  -context_id $context_id  -security_inherit_p [:security_inherit_p]]
    return $id
  }
::xo::db::Class instproc fetch_query id {
    set tables [list]
    set attributes [list]
    set id_column [:id_column]
    set join_expressions [list "[:table_name].$id_column = $id"]
    foreach cl [list [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
        #: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] = [:table_name].$id_column"
        }
      }
    }
    return "SELECT [join $attributes ,]\nFROM [join $tables ,]\nWHERE [join $join_expressions { and }]"
  }
::xo::db::Class instparametercmd object_type
::xo::db::Class instparametercmd name_method
::xo::db::Class instparametercmd supertype
::xo::db::Class instparametercmd abstract_p
::xo::db::Class instparametercmd sql_package_name
::xo::db::Class instparametercmd table_name
::xo::db::Class instparametercmd pretty_name
::xo::db::Class instparametercmd security_inherit_p
::xo::db::Class instparametercmd id_column
::xo::db::Class instparametercmd with_table
::xo::db::Class instparametercmd auto_save
::xo::db::Class instparametercmd pretty_plural
::nsf::relation::set ::xo::db::Class superclass ::xotcl::Class

::nx::slotObj -container slot ::xo::db::Class
::xo::db::Class::slot eval {set :__parameter {
        pretty_name
        pretty_plural
        {supertype acs_object}
        table_name
        id_column
        {abstract_p f}
        {name_method ""}
        {object_type [self]}
        {security_inherit_p t}
        {auto_save false}
        {with_table true}
        {sql_package_name}
      }}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::auto_save {set :accessor public
   set :configurable true
   set :convert false
   set :default false
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::auto_save
   set :methodname auto_save
   set :multiplicity 1..1
   set :name auto_save
   set :parameterSpec {-auto_save:substdefault false}
   set :per-object false
   set :position 0
   set :required false
   set :substdefault 0b111
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::pretty_plural {set :accessor public
   set :configurable true
   set :convert false
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::pretty_plural
   set :methodname pretty_plural
   set :multiplicity 1..1
   set :name pretty_plural
   set :parameterSpec -pretty_plural
   set :per-object false
   set :position 0
   set :required false
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::object_type {set :accessor public
   set :configurable true
   set :convert false
   set :default {[self]}
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::object_type
   set :methodname object_type
   set :multiplicity 1..1
   set :name object_type
   set :parameterSpec {-object_type:substdefault {[self]}}
   set :per-object false
   set :position 0
   set :required false
   set :substdefault 0b111
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::table_name {set :accessor public
   set :configurable true
   set :convert false
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::table_name
   set :methodname table_name
   set :multiplicity 1..1
   set :name table_name
   set :parameterSpec -table_name
   set :per-object false
   set :position 0
   set :required false
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::supertype {set :accessor public
   set :configurable true
   set :convert false
   set :default acs_object
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::supertype
   set :methodname supertype
   set :multiplicity 1..1
   set :name supertype
   set :parameterSpec {-supertype:substdefault acs_object}
   set :per-object false
   set :position 0
   set :required false
   set :substdefault 0b111
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::name_method {set :accessor public
   set :configurable true
   set :convert false
   set :default {}
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::name_method
   set :methodname name_method
   set :multiplicity 1..1
   set :name name_method
   set :parameterSpec {-name_method:substdefault {}}
   set :per-object false
   set :position 0
   set :required false
   set :substdefault 0b111
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::security_inherit_p {set :accessor public
   set :configurable true
   set :convert false
   set :default t
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::security_inherit_p
   set :methodname security_inherit_p
   set :multiplicity 1..1
   set :name security_inherit_p
   set :parameterSpec {-security_inherit_p:substdefault t}
   set :per-object false
   set :position 0
   set :required false
   set :substdefault 0b111
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::with_table {set :accessor public
   set :configurable true
   set :convert false
   set :default true
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::with_table
   set :methodname with_table
   set :multiplicity 1..1
   set :name with_table
   set :parameterSpec {-with_table:substdefault true}
   set :per-object false
   set :position 0
   set :required false
   set :substdefault 0b111
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::pretty_name {set :accessor public
   set :configurable true
   set :convert false
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::pretty_name
   set :methodname pretty_name
   set :multiplicity 1..1
   set :name pretty_name
   set :parameterSpec -pretty_name
   set :per-object false
   set :position 0
   set :required false
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::id_column {set :accessor public
   set :configurable true
   set :convert false
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::id_column
   set :methodname id_column
   set :multiplicity 1..1
   set :name id_column
   set :parameterSpec -id_column
   set :per-object false
   set :position 0
   set :required false
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::sql_package_name {set :accessor public
   set :configurable true
   set :convert false
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::sql_package_name
   set :methodname sql_package_name
   set :multiplicity 1..1
   set :name sql_package_name
   set :parameterSpec -sql_package_name
   set :per-object false
   set :position 0
   set :required false
   set :trace none
   : init}

::nsf::object::alloc ::xotcl::Attribute ::xo::db::Class::slot::abstract_p {set :accessor public
   set :configurable true
   set :convert false
   set :default f
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::Class
   set :incremental 0
   set :manager ::xo::db::Class::slot::abstract_p
   set :methodname abstract_p
   set :multiplicity 1..1
   set :name abstract_p
   set :parameterSpec {-abstract_p:substdefault f}
   set :per-object false
   set :position 0
   set :required false
   set :substdefault 0b111
   set :trace none
   : init}

XQL Not present:

Generic, PostgreSQL, Oracle