xotcl.wu-wien.ac.at
Begin main content
Methods: Source: Variables:
[All Methods | Documented Methods | Hide Methods] [Display Source | Hide Source] [Show Variables | Hide Variables]

::xotcl::Class[i] ::xo::db::Class

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

  • ::xotcl::Object[i]
    Meta-class:
    ::xotcl::Class[i]
    Methods for instances:
    __api_make_doc, __api_make_forward_doc, __timediff, abstract, ad_doc, ad_forward, ad_proc, appendC, arrayC, asHTML, autonameC, check, classC, cleanupC, configureC, containsC, copyC, db_0or1rowC, db_1rowC, debug, defaultmethodC, destroyC, destroy_on_cleanup, ds, evalC, existsC, extractConfigureArg, filterC, filterguardC, filtersearch, forward, hasclass, incrC, infoC, init, instvarC, invarC, isclass, ismetaclass, ismixin, isobject, istype, lappendC, log, method, mixinC, mixinguardC, moveC, msg, noinitC, objectparameter, parametercmdC, proc, procsearch, qn, requireNamespaceC, residualargsC, self, serialize, setC, set_instance_vars_defaults, show-object, substC, traceC, unknown, unsetC, uplevelC, upvarC, volatileC, vwait
    Methods to be applied on the class (in addition to the methods provided by the meta-class):
    getExitHandler, setExitHandler, unsetExitHandler
    • ::xotcl::Class[i]
      Meta-class:
      ::xotcl::Class[i]
      Parameter for instances:
      __default_metaclass (default "::xotcl::Class"), __default_superclass (default "::xotcl::Object")
      Methods for instances:
      ad_instproc, allinstances, allocC, createC, deallocC, extend_slot, infoC, instfilterC, instfilterguardC, instforward, instinvarC, instmixinC, instmixinguardC, instparametercmdC, instproc, method, newC, parameter, recreateC, slots, superclassC, unknown, uses
      Methods to be applied on the class (in addition to the methods provided by the meta-class):
      __unknown
::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[i]
  • subclass: ::xo::PackageMgr[i], ::xo::db::CrClass[i]
::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

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

    ::1065537 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[i] delete -id id 
    Delete the object from the database

    Switches:
    -id (required)
    ::1065537 proc delete -id:required {
        ::xo::db::sql::acs_object delete -object_id $id
      }
    
  • proc delete_all_acs_objects (public)

    ::xo::db::Class[i] delete_all_acs_objects -object_type object_type 
    Delete all acs_objects of the object_type from the database.

    Switches:
    -object_type (required)
    ::1065537 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[i] 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)
    ::1065537 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[i] exists_in_db -id id 
    Check, if an acs_object exists in the database.

    Switches:
    -id (required)
    Returns:
    0 or 1
    ::1065537 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

    ::1065537 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
          }]
        }
    
  • proc get_class_from_db (public)

    ::xo::db::Class[i] 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
    ::1065537 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
      }
    
  • proc get_instance_from_db (public)

    ::xo::db::Class[i] 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
    ::1065537 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
      }
    
  • proc get_object_type (public)

    ::xo::db::Class[i] get_object_type [ -id id ]
    Return the object type for the give id.

    Switches:
    -id (optional)
    Returns:
    object_type, typically an XOTcl class
    ::1065537 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
        }]
      }
    
  • proc get_table_name (public)

    ::xo::db::Class[i] 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
    ::1065537 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
        } ""]
      }
    
  • proc object_type_exists_in_db (public)

    ::xo::db::Class[i] 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
    ::1065537 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

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

    ::1065537 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[i]> check_table_atts
    Check table_name and id_column and set meaningful defaults, if these attributes are not provided.

    ::1065537 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[i]> create_object_type
    Create an acs object_type for the current XOTcl class

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

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

    ::1065537 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]
      }
    
  • instproc drop_object_type (public)

    <instance of ::xo::db::Class[i]> 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)
    ::1065537 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

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

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

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

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

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

    ::1065537 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
        }
    
  • instproc get_instances_from_db (public)

    <instance of ::xo::db::Class[i]> 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
    ::1065537 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

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

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

    ::1065537 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[i]> 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
    ::1065537 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[i]> 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)
    ::1065537 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

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

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

    ::1065537 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[i]> 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
    ::1065537 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[i]> 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
    ::1065537 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

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

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

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

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

Instances

::xo::db::Object[i], ::xo::db::apm_parameter[i], ::xo::db::sql::acs[i], ::xo::db::sql::acs_activity[i], ::xo::db::sql::acs_attribute[i], ::xo::db::sql::acs_event[i], ::xo::db::sql::acs_group[i], ::xo::db::sql::acs_log[i], ::xo::db::sql::acs_message[i], ::xo::db::sql::acs_object[i], ::xo::db::sql::acs_object_type[i], ::xo::db::sql::acs_object_util[i], ::xo::db::sql::acs_permission[i], ::xo::db::sql::acs_privilege[i], ::xo::db::sql::acs_reference[i], ::xo::db::sql::acs_rel[i], ::xo::db::sql::acs_rel_type[i], ::xo::db::sql::acs_sc_binding[i], ::xo::db::sql::acs_sc_contract[i], ::xo::db::sql::acs_sc_impl[i], ::xo::db::sql::acs_sc_impl_alias[i], ::xo::db::sql::acs_sc_implementation[i], ::xo::db::sql::acs_sc_msg_type[i], ::xo::db::sql::acs_sc_operation[i], ::xo::db::sql::acs_user[i], ::xo::db::sql::admin_rel[i], ::xo::db::sql::apm[i], ::xo::db::sql::apm_application[i], ::xo::db::sql::apm_package[i], ::xo::db::sql::apm_package_type[i], ::xo::db::sql::apm_package_version[i], ::xo::db::sql::apm_parameter_value[i], ::xo::db::sql::apm_service[i], ::xo::db::sql::application_group[i], ::xo::db::sql::authority[i], ::xo::db::sql::category[i], ::xo::db::sql::category_link[i], ::xo::db::sql::category_synonym[i], ::xo::db::sql::category_tree[i], ::xo::db::sql::composition_rel[i], ::xo::db::sql::content_extlink[i], ::xo::db::sql::content_folder[i], ::xo::db::sql::content_item[i], ::xo::db::sql::content_item_search[i], ::xo::db::sql::content_keyword[i], ::xo::db::sql::content_revision[i], ::xo::db::sql::content_search[i], ::xo::db::sql::content_symlink[i], ::xo::db::sql::content_template[i], ::xo::db::sql::content_type[i], ::xo::db::sql::doc[i], ::xo::db::sql::file_storage[i], ::xo::db::sql::image[i], ::xo::db::sql::journal_entry[i], ::xo::db::sql::membership_rel[i], ::xo::db::sql::notification[i], ::xo::db::sql::notification_delivery_method[i], ::xo::db::sql::notification_interval[i], ::xo::db::sql::notification_reply[i], ::xo::db::sql::notification_request[i], ::xo::db::sql::notification_type[i], ::xo::db::sql::party[i], ::xo::db::sql::party_approved_member[i], ::xo::db::sql::person[i], ::xo::db::sql::recurrence[i], ::xo::db::sql::rel_constraint[i], ::xo::db::sql::rel_segment[i], ::xo::db::sql::rss_gen_subscr[i], ::xo::db::sql::search_observer[i], ::xo::db::sql::site_node[i], ::xo::db::sql::site_node_object_map[i], ::xo::db::sql::subsite_callback[i], ::xo::db::sql::template_demo_note[i], ::xo::db::sql::time_interval[i], ::xo::db::sql::timespan[i], ::xo::db::sql::timezone[i], ::xo::db::sql::util[i], ::xo::db::sql::xorb_servicecontract[i], ::xo::db::sql::xorb_serviceimplementation[i]

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