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

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

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

The meta class CrClass serves for a class of applications that mostly store information in the content repository and that use a few attributes adjoining this information. The class handles the open acs object_type creation and the automatic creation of the necessary tables based on instances of this meta-class.

The definition of new types is handled in the constructor of CrType through the method create_object_type, the removal of the object type is handled through the method drop_object_type (requires that all instances of this type are deleted).

Each content item can be retrieved either through the general method CrClass get_instance_from_db or through the "get_instance_from_db" method of every subclass of CrItem.

This Class is a meta-class providing methods for Classes managing CrItems.

Testcases:

No testcase defined.

Source code:

namespace eval ::xo::db {}
::nsf::object::alloc ::xotcl::Class ::xo::db::CrClass {set :__default_metaclass ::xotcl::Class
   set :__default_superclass ::xotcl::Object
   set :common_query_atts {
    object_type package_id
    creation_user creation_date
    publish_status storage_type
    last_modified
  }}
::xo::db::CrClass proc get_instance_from_db {{-item_id:integer 0} {-revision_id:integer 0} {-initialize:boolean true}} {
    set object ::[expr {$revision_id ? $revision_id : $item_id}]
    if {$object eq "::0"} {
      set msg "get_instance_from_db must be called with either item_id or revision_id different from 0"
      ad_log error $msg
      error $msg
    }
    if {![::nsf::is object $object]} {
      set object_type [:get_object_type -item_id $item_id -revision_id $revision_id]
      set class [::xo::db::Class object_type_to_class $object_type]
      set object [$class get_instance_from_db -item_id $item_id -revision_id $revision_id -initialize $initialize]
    }
    return $object
  }
::xo::db::CrClass proc get_name -item_id:required {
    # TODO: the following line is deactivated, until we get rid of the "folder object" in xowiki
    #if {[nsf::is object ::$item_id]} {return [::$item_id parent_id]}
    ::xo::dc 1row -prepare integer get_name "select name from cr_items where item_id = :item_id"
    return $name
  }
::xo::db::CrClass proc get_child_item_ids -item_id:required {
    #
    # The following construct (commented out) is fully PostgreSQL and
    # Oracle compliant.  However, all newer Oracle installations
    # should as well support the recursive query below as well, which
    # requires less DB interactions.
    #
    # set items [list]
    # foreach item_id [::xo::dc list -prepare integer get_child_items  #                      "select item_id from cr_items where parent_id = :item_id"] {
    #   lappend items $item_id {*}[my [self proc] -item_id $item_id]
    # }
    # return $items

    return [::xo::dc list -prepare integer get_child_items {
      WITH RECURSIVE child_items AS (
           select item_id from cr_items
           where parent_id = :item_id
      UNION ALL
        select i.item_id from cr_items i, child_items
        where i.parent_id = child_items.item_id
      )
      select * from child_items
    }]
  }
::xo::db::CrClass proc get_parent_id -item_id:required {
    # TODO: the following line is deactivated, until we get rid of the "folder object" in xowiki
    #if {[nsf::is object ::$item_id]} {return [::$item_id parent_id]}
    ::xo::dc 1row -prepare integer get_parent "select parent_id from cr_items where item_id = :item_id"
    return $parent_id
  }
::xo::db::CrClass proc ensure_item_ids_instantiated {{-initialize:boolean true} -item_ids:required} {
    foreach item_id $item_ids {
      #if {![::nsf::is object ::$item_id]} { ns_log notice "===== we have to fetch ::$item_id"}
      :get_instance_from_db -item_id $item_id -initialize $initialize
    }
  }
::xo::db::CrClass proc lookup {-name:required {-parent_id -100} -content_type} {
    if {[info exists content_type]} {
      set result [::xo::dc get_value lookup_by_name_and_ct {
        select item_id from cr_items
        where name = :name and parent_id = :parent_id
        and content_type like :content_type
      } 0]
    } else {
      set result [::xo::dc get_value lookup_by_name {
        select item_id from cr_items
        where name = :name and parent_id = :parent_id
      } 0]
    }
    return $result
  }
::xo::db::CrClass proc get_object_type {-item_id:integer,required {-revision_id:integer 0}} {
    #
    # Use a request-spanning cache. When the object_type would change,
    # we require xo::broadcast or server restart.
    #
    set key ::xo::object_type($item_id,$revision_id)
    if {[info exists $key]} {
      return [set $key]
    }
    set entry_key [expr {$item_id ? $item_id : $revision_id}]
    set $key [xo::xotcl_object_type_cache eval -partition_key $entry_key $entry_key {
      if {$item_id} {
        ::xo::dc 1row -prepare integer get_class_from_item_id  "select content_type as object_type from cr_items where item_id=:item_id"
      } else {
        ::xo::dc 1row -prepare integer get_class_from_revision_id  "select object_type from acs_objects where object_id=:revision_id"
      }
      return $object_type
    }]
  }
::xo::db::CrClass proc id_belongs_to_package {{-item_id:integer 0} {-revision_id:integer 0} -package_id:integer,required} {
    set id [expr {$revision_id ? $revision_id : $item_id}]
    if {$id eq 0} {
      return 0
    }
    set what [expr {$item_id != 0 ? "item_id" : "revision_id"}]
    return [::xo::dc 0or1row -prepare integer,integer check_package [subst {
      select 1 from cr_items, acs_objects
      where $what = :$what and object_id = :$what
      and package_id = :package_id
      fetch first 1 rows only
    }]]
  }
::xo::db::CrClass proc delete -item_id {
    set object_type [:get_object_type -item_id $item_id]
    $object_type delete -item_id $item_id
  }
::nsf::relation::set ::xo::db::CrClass object-mixin ::xo::db::CrCache::Class
::xo::db::CrClass instproc new_persistent_object {-package_id -creation_user -creation_ip args} {
    :get_context package_id creation_user creation_ip
    # :log "ID [self] create $args"
    ad_try {
      :create ::0 {*}$args
    } on error {errorMsg} {
      ad_log error "CrClass create raises: $errorMsg"
    }
    # :log "ID [::0 serialize]"
    set item_id [::0 save_new  -package_id $package_id  -creation_user $creation_user  -creation_ip $creation_ip]
    ::0 move ::$item_id
    ::$item_id destroy_on_cleanup
    return ::$item_id
  }
::xo::db::CrClass instproc fetch_object {-item_id:required {-revision_id 0} -object:required {-initialize:boolean true}} {
    # :log "-- generic fetch_object [self args]"
    if {![nsf::is object $object]} {
      # if the object does not yet exist, we have to create it
      :create $object
    }
    set raw_atts [::xo::db::CrClass set common_query_atts]
    #:log "-- raw_atts = '$raw_atts'"

    set atts [list]
    foreach v $raw_atts {
      switch -glob -- $v {
        publish_status {set fq i.$v}
        storage_type   {set fq i.$v}
        creation_date  {set fq o.$v}
        creation_user  {set fq o.$v}
        package_id     {set fq o.$v}
        default        {set fq n.$v}
      }
      lappend atts $fq
    }

    foreach {slot_name slot} [array get :db_slot] {
      switch -glob -- $slot {
        ::xo::db::CrItem::slot::text {
          #
          # We need the rule, since insert the handling of the sql
          # attribute "text" is somewhat magic. On insert, one can use
          # the automatic view with column_name "text, on queries, one
          # has to use "data". Therefore, we cannot use simply
          # -column_name for the slot.
          #
          lappend atts "n.data AS text"
        }

        ::xowiki::Page::slot::text {
          #
          # This is just a hotfix for now.
          #
          #ns_log notice [$slot serialize]
          lappend atts "n.data as text"
        }

        ::xo::db::CrItem::slot::name {
          lappend atts i.[$slot column_name]
        }
        ::xo::db::Object::slot::context_id {
          #
          # If we are fetching by revision_id, skip the context_id,
          # since on object-save-operations, we want to keep the
          # context_id of the item, and not the context_id from the
          # revision.
          #
          if {$revision_id == 0} {
            #
            # Fetch by item_id.
            #
            lappend atts o.[$slot column_name]
          }
        }
        ::xo::db::Object::slot::* {
          lappend atts o.[$slot column_name]
        }
        default {
          lappend atts n.[$slot column_name]
        }
      }
    }
    if {$revision_id} {
      $object set revision_id $revision_id
      set sql [subst {
        select [join $atts ,], i.parent_id
          from ${:table_name}i n, cr_items i, acs_objects o
         where n.revision_id = :revision_id
           and i.item_id = n.item_id
           and o.object_id = n.revision_id
      }]
      set selection [lindex [::xo::dc sets  -prepare integer  fetch_object_from_revision_id $sql] 0]
      $object mset [ns_set array $selection]
    } else {
      #
      # We fetch the creation_user and the modifying_user by returning
      # the creation_user of the automatic view as modifying_user. In
      # case of troubles, comment next line out.
      #
      lappend atts "n.creation_user as modifying_user"

      $object set item_id $item_id

      $object db_1row [:qn fetch_from_view_item_id] " select [join $atts ,], i.parent_id  from   ${:table_name}i n, cr_items i, acs_objects o  where  i.item_id = :item_id  and    n.${:id_column} = coalesce(i.live_revision, i.latest_revision)  and    o.object_id = i.item_id"
    }
    #
    # The method "db_1row" treats all newly created variables as
    # instance variables, so we can see vars like "__db_sql",
    # "__db_lst" that we do not want to keep.
    #
    foreach v [$object info vars __db_*] {
      $object unset $v
    }

    #
    # Deactivate compatibility with versions before OpenACS 5.2
    # (2005), since this is a busy code, but leave it here for easy
    # reactivating in legacy applications.
    #
    #if {[apm_version_names_compare [ad_acs_version] 5.2] <= -1} {
    #  set parent_id [$object set parent_id]
    #  $object set package_id [::xo::dc get_value get_pid {
    #    select package_id from cr_folders where folder_id = :parent_id
    #  }
    #}

    # :log "--AFTER FETCH\n[$object serialize]"
    if {$initialize} {$object initialize_loaded_object}
    return $object
  }
::xo::db::CrClass instproc instance_select_query {{-select_attributes ""} {-orderby ""} {-where_clause ""} {-from_clause ""} {-with_subtypes:boolean true} {-with_children:boolean false} -publish_status {-count:boolean false} -folder_id -parent_id {-page_size 20} {-page_number ""} {-base_table "cr_revisions"}} {
    if {![info exists folder_id]} {set folder_id ${:folder_id}}
    if {![info exists parent_id]} {set parent_id $folder_id}

    if {$base_table eq "cr_revisions"} {
      set attributes [list ci.item_id ci.name ci.publish_status acs_objects.object_type acs_objects.package_id]
    } else {
      set attributes [list bt.item_id ci.name ci.publish_status bt.object_type "bt.object_package_id as package_id"]
    }
    foreach a $select_attributes {
      if {$a eq "title"} {set a bt.title}
      lappend attributes $a
    }
    set type_selection_clause [:type_selection_clause -base_table $base_table -with_subtypes $with_subtypes]
    # :log "type_selection_clause -with_subtypes $with_subtypes returns $type_selection_clause"
    if {$count} {
      set attribute_selection "count(*)"
      set orderby ""      ;# no need to order when we count
      set page_number  ""      ;# no pagination when count is used
    } else {
      set attribute_selection [join $attributes ,]
    }

    set cond [list]
    if {$type_selection_clause ne ""} {lappend cond $type_selection_clause}
    if {$where_clause ne ""}          {lappend cond $where_clause}
    if {[info exists publish_status]} {lappend cond "ci.publish_status = :publish_status"}
    if {$base_table eq "cr_revisions"} {
      lappend cond "acs_objects.object_id = bt.revision_id"
      set acs_objects_table "acs_objects, "
    } else {
      lappend cond "ci.item_id = bt.item_id"
      set acs_objects_table ""
    }
    lappend cond "coalesce(ci.live_revision,ci.latest_revision) = bt.revision_id"
    if {$parent_id ne ""} {
      if {$with_children} {
        append from_clause ", (select $parent_id as item_id from dual union  select item_id from cr_items where parent_id = $parent_id) children"
        lappend cond "ci.parent_id = children.item_id"
      } else {
        lappend cond "ci.parent_id = $parent_id"
      }
    }

    if {$page_number ne ""} {
      set limit $page_size
      set offset [expr {$page_size*($page_number-1)}]
    } else {
      set limit ""
      set offset ""
    }

    if {!$count} {
      #
      # In case the query is not explicitly referring to a context_id,
      # return the context_id of the item. The problem are queries
      # using "*" in the attribute list, which should be deprecated.
      # Before that we should walk through the common call patterns of
      # this function to check, if this is feasible.
      #
      # This local hack was necessary to deal with a recent fix that
      # honors now correctly changes in the context_id. Before this
      # change, e.g. "get_all_children" was returning due to the
      # nature of the call the context_id of the revision (not of the
      # item), although it was returning items. A following bug-fix
      # actually triggered this change.
      # https://cvs.openacs.org/changelog/OpenACS?cs=oacs-5-10%3Agustafn%3A20210308161117
      #
      # TODO: remove me, when not necessary anymore.
      #
      if {[lsearch -glob $attributes *context_id*] == -1} {
        append attribute_selection {,(select context_id from acs_objects where object_id = ci.item_id)}
      }
    }

    set sql [::xo::dc select  -vars $attribute_selection  -from "$acs_objects_table cr_items ci, $base_table bt $from_clause"  -where [join $cond " and "]  -orderby $orderby  -limit $limit -offset $offset]
    #:log "--sql=$sql"
    return $sql
  }
::xo::db::CrClass instproc lock {tablename mode} {;}
::xo::db::CrClass instproc delete -item_id:required {
    ::acs::dc call content_item del -item_id $item_id
  }
::xo::db::CrClass instproc type_selection_clause {{-base_table cr_revisions} {-with_subtypes:boolean false}} {
    if {$with_subtypes} {
      if {$base_table eq "cr_revisions"} {
        # do type selection manually
        return "acs_objects.object_type in ([:object_types_query])"
      }
      # the base-table defines contains the subtypes
      return ""
    } else {
      if {$base_table eq "cr_revisions"} {
        return "acs_objects.object_type = '${:object_type}'"
      } else {
        return "bt.object_type = '${:object_type}'"
      }
    }
  }
::xo::db::CrClass instproc get_instance_from_db {{-item_id 0} {-revision_id 0} {-initialize:boolean true}} {
    set object ::[expr {$revision_id ? $revision_id : $item_id}]
    if {![nsf::is object $object]} {
      :fetch_object -object $object  -item_id $item_id -revision_id $revision_id  -initialize $initialize
      $object destroy_on_cleanup
    }
    return $object
  }
::xo::db::CrClass instproc init {} {
    #
    # First, do whatever ::xo::db::Class does for initialization ...
    #
    next
    #
    # We want to be able to define for different CrClasses different
    # default mime-types. Therefore, we define attribute slots per
    # application class with the given default for mime_type.
    #
    if {[self] ne "::xo::db::CrItem"} {
      :slots {
        ::xotcl::Attribute create mime_type -default [:mime_type]
      }
      :db_slots
    }
    # ... then we do the CrClass specific initialization.
    #if {[:info superclass] ne "::xo::db::CrItem"} {
    #  set :superclass [[:info superclass] set object_type]
    #}

    # "CrClasses" stores all attributes of the class hierarchy in
    # db_slot. This is due to the usage of the
    # automatically created views. Note that classes created with
    # ::xo::db::Class keep only the class specific db slots.
    #
    foreach {slot_name slot} [[:info superclass] array get :db_slot] {
      # don't overwrite slots, unless the object_title (named title)
      if {![info exists :db_slot($slot_name)] ||
          $slot eq "::xo::db::Object::slot::object_title"} {
        set :db_slot($slot_name) $slot
      }
    }
    :remember_long_text_slots

    if {![::xo::db::Class object_type_exists_in_db -object_type ${:object_type}]} {
      :create_object_type
    }
  }
::xo::db::CrClass instproc mk_insert_method {} {;}
::xo::db::CrClass instproc drop_object_type {} {
    set object_type ${:object_type}
    ::xo::dc transaction {
      :folder_type unregister
      ::acs::dc call content_type drop_type  -content_type ${:object_type}  -drop_children_p t  -drop_table_p t
    }
  }
::xo::db::CrClass instproc folder_type_unregister_all {{-include_subtypes t}} {
    set object_type ${:object_type}
    xo::dc foreach all_folders {
      select folder_id from cr_folder_type_map
      where content_type = :object_type
    } {
      ::acs::dc call content_folder unregister_content_type  -folder_id $folder_id  -content_type $object_type  -include_subtypes $include_subtypes
    }
  }
::xo::db::CrClass instproc folder_type {{-include_subtypes t} -folder_id operation} {
    if {$operation ne "register" && $operation ne "unregister"} {
      error "[self] operation for folder_type must be 'register' or 'unregister'"
    }
    if {![info exists folder_id]} {
      set folder_id ${:folder_id}
    }
    ::acs::dc call content_folder ${operation}_content_type  -folder_id $folder_id  -content_type ${:object_type}  -include_subtypes $include_subtypes
  }
::xo::db::CrClass instproc mk_save_method {} {;}
::xo::db::CrClass instproc get_instances_from_db {{-select_attributes ""} {-from_clause ""} {-where_clause ""} {-orderby ""} {-with_subtypes:boolean true} -folder_id {-page_size 20} {-page_number ""} {-base_table "cr_revisions"} {-initialize true}} {
    if {![info exists folder_id]} {
      set folder_id ${:folder_id}
    }
    set s [:instantiate_objects -sql  [:instance_select_query  -select_attributes $select_attributes  -from_clause $from_clause  -where_clause $where_clause  -orderby $orderby  -with_subtypes $with_subtypes  -folder_id $folder_id  -page_size $page_size  -page_number $page_number  -base_table $base_table  ]  -initialize $initialize]
    return $s
  }
::xo::db::CrClass instproc unknown {obj args} {
    # When this happens, this is most likely an error. Ease debugging
    # by writing the call stack to the error log.
    ::xo::show_stack
    :log "::xo::db::CrClass: unknown called with $obj $args"
  }
::xo::db::CrClass instproc edit_atts {} {
    # TODO remove, when name and text are slots (only for generic)
    array names :db_slot
  }
::xo::db::CrClass instproc insert_statement {atts vars} {
      return "insert into ${:table_name}i ([join $atts ,])  values (:[join $vars ,:])"
    }
::xo::db::CrClass instproc getFormClass -data:required {
    if {[$data exists item_id] && [$data set item_id] != 0 && [info exists :edit_form]} {
      return [:edit_form]
    } else {
      return [:form]
    }
  }
::xo::db::CrClass instproc create_object_type {} {
    :check_table_atts

    set :supertype [:info superclass]
    switch -- ${:supertype} {
      ::xotcl::Object -
      ::xo::db::CrItem {set :supertype content_revision}
    }
    if {![info exists :pretty_plural]} {set :pretty_plural ${:pretty_name}}

    ::xo::dc transaction {
      ::acs::dc call content_type create_type  -content_type  ${:object_type}  -supertype     ${:supertype}  -pretty_name   ${:pretty_name}  -pretty_plural ${:pretty_plural}  -table_name    ${:table_name}  -id_column     ${:id_column}  -name_method   ${:name_method}

      :folder_type register
    }
  }
::xo::db::CrClass instproc remember_long_text_slots {} {
    #
    # Keep "long_text_slots" in a separate array (for Oracle)
    #
    unset -nocomplain :long_text_slots
    foreach {slot_name slot} [array get :db_slot] {
      if {[$slot sqltype] eq "long_text"} {
        set :long_text_slots($slot_name) $slot
      }
    }
    # :log "--long_text_slots = [array names :long_text_slots]"
  }
::xo::db::CrClass instparametercmd supertype
::xo::db::CrClass instparametercmd form
::xo::db::CrClass instparametercmd storage_type
::xo::db::CrClass instparametercmd folder_id
::xo::db::CrClass instparametercmd edit_form
::xo::db::CrClass instparametercmd mime_type
::xo::db::CrClass instparametercmd non_cached_instance_var_patterns
::nsf::relation::set ::xo::db::CrClass superclass ::xo::db::Class
::nsf::relation::set ::xo::db::CrClass class-mixin ::xo::db::CrCache

::nx::slotObj -container slot ::xo::db::CrClass
::xo::db::CrClass::slot eval {set :__parameter {
        {supertype content_revision}
        form
        edit_form
        {mime_type text/plain}
        {storage_type "text"}
        {folder_id -100}
        {non_cached_instance_var_patterns {__*}}
      }}

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

::nsf::object::alloc ::xotcl::Attribute ::xo::db::CrClass::slot::non_cached_instance_var_patterns {set :accessor public
   set :configurable true
   set :convert false
   set :default __*
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::CrClass
   set :incremental 0
   set :manager ::xo::db::CrClass::slot::non_cached_instance_var_patterns
   set :methodname non_cached_instance_var_patterns
   set :multiplicity 1..1
   set :name non_cached_instance_var_patterns
   set :parameterSpec {-non_cached_instance_var_patterns: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::CrClass::slot::form {set :accessor public
   set :configurable true
   set :convert false
   set :defaultmethods {}
   set :disposition alias
   set :domain ::xo::db::CrClass
   set :incremental 0
   set :manager ::xo::db::CrClass::slot::form
   set :methodname form
   set :multiplicity 1..1
   set :name form
   set :parameterSpec -form
   set :per-object false
   set :position 0
   set :required false
   set :trace none
   : init}

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

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

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

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

XQL Not present:

Generic, PostgreSQL, Oracle