01-debug-procs.tcl

Does not contain a contract.

Location:

/packages/xotcl-core/tcl/01-debug-procs.tcl

Related Files

• packages/xotcl-core/tcl/01-debug-procs.tcl

[ hide source ] | [ make this the default ]

File Contents

if {$::tcl_version < 8.5
    || ([regexp {8[.]5[.]([0-9]+)$} $::tcl_patchLevel _ minor] && $minor < 4)
  } {
  ns_log error "We require for this version of xotcl-core at least Tcl 8.5.4 (avail: Tcl $::tcl_patchLevel)"
  return
}
if {[info exists ::xotcl_version] || ([info exists ::xotcl::version] && $::xotcl::version < 2.0)} {
  ns_log error "We require for this version of xotcl-core at least XOTcl 2.0"
  return
}

package require xotcl::serializer

#
# Tell serializer to export methods, although these are methods of the
# base classes.
#
::Serializer exportMethods {
  ::xotcl::Object instproc log
  ::xotcl::Object instproc ds
  ::xotcl::Object instproc msg
  ::xotcl::Object instproc __timediff
  ::xotcl::Object instproc debug
  ::xotcl::Object instproc qn
  ::xotcl::Object instproc serialize
  ::xotcl::Object instproc www-show-object
  ::xotcl::Object instproc destroy_on_cleanup
  ::xotcl::Object instproc set_instance_vars_defaults
  ::xotcl::Object instproc mset
  ::xotcl::Class instproc extend_slot
}

namespace eval ::xo {
  # create xo::Attribute as a subclass of the slot ::xotcl::Attribute
  ::xotcl::MetaSlot create ::xo::Attribute \
      -superclass ::xotcl::Attribute \
      -parameter {
        spec
        {required false}
        pretty_name
        {pretty_plural ""}
        {datatype "text"}
        constraint_values
        help_text
        validator
      }
}

set ::xo::naviserver [expr {[ns_info name] eq "NaviServer"}]

if {[nsf::is object ::nx::Object]} {
  ns_log notice "Defining minimal XOTcl 1 compatibility"
  ::nsf::method::alias ::xo::Attribute instvar ::nsf::methods::object::instvar

  # provide compatibility with nsf 2.0b6, which has "-noinit" removed
  ::nx::ObjectParameterSlot create ::xo::Attribute::slot::noinit \
      -methodname ::nsf::methods::object::noinit -noarg true

  # The following line would cause a dependency of an nx object to
  # xotcl (serializer); since XOTcl depends on NX, this would be a
  # cyclic dependency.
  #     ::nsf::method::alias ::nx::Slot istype ::nsf::classes::xotcl::Object::istype
  # Therefore, we just grab the body to reduce dependencies on nsf internals
  ::nx::Slot public method istype {class}  [::nx::Object info method body ::nsf::classes::xotcl::Object::istype]
  ::nx::Slot public alias set -frame object ::set
  ::nx::Slot public method exists {var}   {::nsf::var::exists [self] $var}
  ::nx::Object public method serialize {} {::Serializer deepSerialize [self]}
  ::nx::Object public method destroy_on_cleanup {} {set ::xo::cleanup([self]) [list [self] destroy]}
  ::nx::Object method qn {query_name} {
    return "dbqd.[:uplevel [list current class]]-[:uplevel [list current method]].$query_name"
  }
  #
  # Allow the use of types "naturalnum", "token", "localurl", "html", "nohtml" e.g. in
  # ::xowiki::Package initialize.
  #
  ::nx::Slot eval {
    :method type=naturalnum {name value} {
      if {![string is integer -strict $value] || $value < 0 } {
        return -code error "Value '$value' of parameter $name is not a natural number."
      }
    }
    :method type=object_id {name value} {
      #
      # Object ID has SQL integers, which have a different value range
      # than Tcl integers. SQL integers are classical 32-bit quantities.
      #
      if {![string is integer -strict $value]
          || $value < -2147483648
          || $value > 2147483647
        } {
        return -code error "Value '$value' of parameter $name is not a valid object ID."
      }
    }
    :method type=token {name value} {
      if {![regexp {^[\w.,: -]+$} $value]} {
        return -code error "Value '$value' of parameter $name is not a valid token."
      }
    }
    :method type=localurl {name value} {
      if { $value eq "" || [util::external_url_p $value]} {
        return -code error "Value '$value' of parameter $name is not a valid local url."
      }
    }
    :method type=nohtml {name value} {
      if {[ad_page_contract_filter_proc_nohtml name value] == 0} {
        return -code error "Value '$value' of parameter $name contains HTML."
      }
    }
    :method type=html {name value} {
      if {[ad_page_contract_filter_proc_html name value] == 0} {
        return -code error "Value '$value' of parameter $name contains unsafe HTML."
      }
    }
    :method type=range {name value arg} {
      lassign [split $arg -] min max
      if {$min eq ""} {
        unset min
      }
      if {$max eq ""} {
        unset max
      }
      if {[info exists min] && [info exists max] &&
        ($value < $min || $value > $max)} {
        error "value '$value' of parameter $name not between $min and $max"
      } elseif {[info exists min] && $value < $min} {
        error "value '$value' of parameter $name must not be smaller than $min"
      } elseif {[info exists max] && $value > $max} {
        error "value '$value' of parameter $name must not be larger than $max"
      }
      return $value
    }
    :method type=signed {name input} {
      #
      # Check, if a value is a signed value, signed by
      # ::security::parameter::signed. Note that this is a converting
      # checker. Therefore, call it always with "signed,convert" to
      # obtain the value which was signed.
      #
      set pair [ns_base64urldecode $input]
      if {[string is list -strict $pair] && [llength $pair] == 2} {
        lassign $pair value signature
        set secret [ns_config "ns/server/[ns_info server]/acs" parametersecret ""]
        #ns_log notice "[list ad_verify_signature -secret $secret $value $signature]"
        if {[ad_verify_signature -secret $secret $value $signature]} {
          return $value
        }
      }
      ad_log warning "Value '$input' of parameter $name is not properly signed"
      return -code error "Value of parameter $name is not properly signed"
    }
    :method type=cr_item_of_package {name value:int32 package_id:int32} {
      if {![::xo::db::CrClass id_belongs_to_package -item_id $value -package_id $package_id]} {
        error "value '$value' of is not a valid content repository item of the required package"
      }
    }
  }

  ::xotcl::Object proc setExitHandler {code} {::nsf::exithandler set $code}
  ::xotcl::Object instproc set_instance_vars_defaults {} {:configure}

  ::Serializer exportMethods {
    ::nx::Object method serialize
    ::nx::Object method destroy_on_cleanup
    ::nx::Object method qn
    ::nx::Slot method istype
    ::nx::Slot method exists
    ::nx::Slot method set
    ::nx::Slot method type=naturalnum
    ::nx::Slot method type=object_id
    ::nx::Slot method type=token
    ::nx::Slot method type=localurl
    ::nx::Slot method type=html
    ::nx::Slot method type=nohtml
    ::nx::Slot method type=range
    ::nx::Slot method type=signed
    ::nx::Slot method type=cr_item_of_package
    ::nx::Object nsfproc ::nsf::debug::call
    ::nx::Object nsfproc ::nsf::debug::exit
  }

  #
  # Make sure, the ::nsf::debug namespace exists (might not be
  # available in older versions of nsf)
  #
  #namespace eval ::nsf::debug {}

  proc ::nsf::debug::call {level objectInfo methodInfo arglist} {
    ns_log Warning "DEBUG call($level) - {$objectInfo} {$methodInfo} $arglist"
  }

  if {[acs::icanuse "nsf::config profile"]} {
    #
    # The debug call-data of nsf returns only timing information, when
    # nsf was compiled with --enable-profile. So, just try to display
    # it, when available.
    #
    proc ::nsf::debug::exit {level objectInfo methodInfo result usec} {
      #ns_log Warning "DEBUG exit($level) - {$objectInfo} {$methodInfo} $usec usec -> $result"
      ns_log Warning "DEBUG exit($level) - {$objectInfo} {$methodInfo} $usec usec"
    }
  } else {
    proc ::nsf::debug::exit {level objectInfo methodInfo result usec} {
      #ns_log Warning "DEBUG exit($level) - {$objectInfo} {$methodInfo} -> $result"
      ns_log Warning "DEBUG exit($level) - {$objectInfo} {$methodInfo}"
    }
  }
}


namespace eval ::xo {
  ::xo::Attribute instproc init {} {
    next
    # provide a default pretty name for the attribute based on message keys
    if {![info exists :pretty_name]} {
      set object_type ${:domain}
      if {[regexp {^::([^:]+)::} $object_type _ head]} {
        set tail [namespace tail $object_type]
        set :pretty_name "#$head.$tail-${:name}#"
        #:log "--created pretty_name = ${:pretty_name}"
      } else {
        error "Cannot determine automatically message key for pretty name. \
        Use namespaces for classes"
      }
    }
  }

  proc package_id_from_package_key { key } {
    return [db_string dbqd.null.get_package_id_from_key \
                {select package_id from apm_packages where package_key = :key}]
  }
}


if {[info exists ::acs::preferdbi]} {
  ::xotcl::Object instforward dbi_1row    -objscope ::dbi_1row
  ::xotcl::Object instforward dbi_0or1row -objscope ::dbi_0or1row
  ::xotcl::Object instproc    db_1row    {. sql} {:dbi_1row $sql}
  ::xotcl::Object instproc    db_0or1row {. sql} {:dbi_0or1row $sql}
  ::Serializer exportMethods {
    ::xotcl::Object instforward dbi_1row
    ::xotcl::Object instforward dbi_0or1row
    ::xotcl::Object instproc db_1row
    ::xotcl::Object instproc db_0or1row
  }
} else {
  ::xotcl::Object instforward db_1row -objscope
  ::xotcl::Object instforward db_0or1row -objscope
  ::Serializer exportMethods {
    ::xotcl::Object instforward db_1row
    ::xotcl::Object instforward db_0or1row
  }
}

if {[::package vcompare [package require xotcl::serializer] 2.0] < -1} {
  #
  # The serializer of xotcl/2.0 registers already a method "serialize"
  # on ::xotcl::Object. Don't mess with that.
  #
  ::xotcl::Object instproc serialize {} {
    ::Serializer deepSerialize [self]
  }
}

::xotcl::Object instproc mset {pairs} {
  #
  # Import all attribute value pairs into the current XOTcl object.
  #
  if {[llength $pairs] > 0} {
    nsf::directdispatch [self] -frame object ::lassign [dict values $pairs] {*}[dict keys $pairs]
  }
}

::xotcl::Object instproc www-show-object {} {
  #
  # Allow to show an arbitrary object via API-browser.  Per-default,
  # e.g. a site-wide admin can use e.g. /xowiki/index?m=show-object
  #
  if {[ns_conn isconnected]} {
    set form [ns_getform]
    ns_set update $form object [self]
    ns_set update $form show_source    [::xo::cc query_parameter show_source:integer 1]
    ns_set update $form show_methods   [::xo::cc query_parameter show_methods:integer 2]
    ns_set update $form show_variables [::xo::cc query_parameter show_variables:integer 1]
    ns_set update $form as_img 1
    rp_internal_redirect /packages/xotcl-core/www/show-object
  } else {
    ns_log error "show-object can only be called with an active connection"
  }
  ad_script_abort
}

namespace eval ::xo {
  proc slotobjects cl {
    set so [list]
    array set names ""
    foreach c [list $cl {*}[$cl info heritage]] {
      foreach s [$c info slots] {
        set n [namespace tail $s]
        if {![info exists names($n)]} {
          lappend so $s
          set names($n) $s
        }
      }
    }
    return $so
  }
  ::xotcl::Class create ::xo::InstanceManager \
      -instproc alloc args {
        set r [next]
        set key blueprint($r)
        if {![ns_conn isconnected]} {
          [self class] set $key 1
        } elseif {![[self class] exists $key]} {
          [self class] set connectionobject($r) 1
        }
        return $r
      } \
      -instproc destroy args {
        next
        ns_log notice "--unset -nocomplain [self class]::blueprint([self])"
        [self class] unset -nocomplain blueprint([self])
        [self class] unset -nocomplain connectionobject([self])
      }

  # deactivate for now
  #::xotcl::Object instmixin add ::xo::InstanceManager
}

::xotcl::Object instproc __timediff {} {
  set now [ns_time get]
  if {[ns_conn isconnected]} {
    set start_time [ns_conn start]
  } else {
    if {![info exists ::__start_time]} {set ::__start_timestamp $now}
    set start_time $::__start_timestamp
  }
  set t [ns_time diff $now $start_time]
  set ms [expr {[ns_time seconds $t]*1000 + [ns_time microseconds $t]/1000}]
  if {[info exists ::__last_timestamp]} {
    set t [ns_time diff $now $::__last_timestamp]
    set dms [expr {[ns_time seconds $t]*1000 + [ns_time microseconds $t]/1000}]
    set diff ", ${dms}ms"
  } else {
    set diff ""
  }
  set ::__last_timestamp $now
  return "${ms}ms$diff"
}

::xotcl::Object instproc log args {
  set msg [join $args { }]
  ns_log notice "[self] [self callingclass]->[self callingproc]: $msg ([:__timediff])"
}
::xotcl::Object instproc ds args {
  set msg [join $args { }]
  ds_comment "[self] [self callingclass]->[self callingproc]: $msg ([:__timediff])"
}
::xotcl::Object instproc debug args {
  set msg [join $args { }]
  ns_log debug "[self] [self callingclass]->[self callingproc]: $msg"
}
::xotcl::Object instproc msg {{-html false} args} {
  set msg [join $args { }]
  if {[ns_conn isconnected]} {
    set msg "[self]: $msg  ([self callingclass]->[self callingproc])"
    if {$html} {
      util_user_message -html -message $msg
    } else {
      util_user_message -message $msg
    }
  }
}

# quick debugging tool
# proc ::! args {
#   ns_log notice "-- PROC [info level -1]"
#   ns_log notice "-- CALL $args"
#   set r [uplevel $args]
#   ns_log notice "-- EXIT $r"
#   return $r
# }

::xotcl::Object instproc qn query_name {
  #set qn "dbqd.[:uplevel [list self class]]-[:uplevel [list self proc]].$query_name"
  set l [info level]
  if {$l < 2} {
    set prefix topLevel
  } else {
    set prefix [lindex [:uplevel {info level 0}] 0]
    #ns_log notice "QN <$query_name> -> PREFIX <$prefix>"
  }
  return "dbqd.$prefix.$query_name"
}
namespace eval ::xo {
  Class create Timestamp
  Timestamp instproc init {} {set :time [clock clicks -milliseconds]}
  Timestamp instproc diffs {} {
    set now [clock clicks -milliseconds]
    set ldiff [expr {[info exists :ltime] ? ($now-${:ltime}): 0}]
    set :ltime $now
    return [list [expr {$now-${:time}}] $ldiff]
  }
  Timestamp instproc diff {{-start:switch}} {
    lindex [:diffs] [expr {$start ? 0 : 1}]
  }

  Timestamp instproc report {{string ""}} {
    lassign [:diffs] start_diff last_diff
    :log "--$string (${start_diff}ms, diff ${last_diff}ms)"
  }

  proc show_stack {{m 100}} {
    if {[::info exists ::template::parse_level]} {
      set parse_level $::template::parse_level
    } else {
      set parse_level ""
    }
    set msg "### template::parse_level <$parse_level> connected=[ns_conn isconnected] "
    if {[ns_conn isconnected]} {
      append msg "flags=[ad_conn flags] status=[ad_conn status] req=[ad_conn request]"
    }
    ns_log notice $msg
    set max [info level]
    if {$m<$max} {set max $m}
    ns_log notice "### Call Stack (level: command)"
    for {set i 0} {$i < $max} {incr i} {
      try {
        set s [uplevel $i self]
      } on error {errorMsg} {
        set s ""
      }
      ns_log notice "### [format %5d -$i]:   $s [info level [expr {-$i}]]"
    }
  }

}

namespace eval ::xo {
  #
  # Make reporting back of the version numbers of the most important
  # involved components easier.
  #
  proc report_version_numbers {{pkg_list {acs-kernel xotcl-core xotcl-request-monitor xowiki s5 xoportal xowf}}} {
    append _ "Database: "
    if {[db_driverkey {}] eq "postgresql"} {
      append _ [db_string dbqd.null.get_version {select version() from dual}] \n
    } else {
      append _ [db_driverkey {}]\n
    }
    append _ "Server:    [ns_info patchlevel] ([ns_info name] [ns_info tag])\n"
    append _ "NSF:       $::nsf::patchLevel\n"
    append _ "Tcl:       $::tcl_patchLevel\n"
    append _ "XOTcl:     $::xotcl::version$::xotcl::patchlevel\n"
    append _ "Tdom:      [package req tdom]\n"
    append _ "libthread: [ns_config ns/server/[ns_info server]/modules libthread]\n"
    append _ "Tcllib:    "
    foreach dir $::auto_path {
      set p [glob -nocomplain $dir/tcllib*]
      if {$p ne ""} {
        append _ "$p"
        # just show first occurrences on path
        break
      }
    }
    append _ \n
    foreach pk $pkg_list {
      if {[apm_package_installed_p $pk]} {
        apm_version_get -package_key $pk -array info
        append _ \
            "[format %-22s $pk:] " \
            "$info(release_date), $info(version_name)" \
            \n
      }
    }
    return $_
  }

  proc pg_version {} {
    #
    # Return 2 digit version number (suitable for number compare
    # operations) from PostgreSQL or 0.0 if not available
    #
    return [acs::per_thread_cache eval -key xotcl-core.pg_version {
      set version 0.0
      if {[db_driverkey {}] eq "postgresql"} {
        set version_string [db_string dbqd.null.get_version {select version() from dual}]
        regexp {PostgreSQL ([0-9]+[.][0-9+])} $version_string . version
      }
      set version
    }]
  }
}

#ns_log notice "--T [info commands ::ttrace::isenabled]"
# tell ttrace to put these to the blueprint
#if {[info commands ::ttrace::isenabled] ne "" && [::ttrace::isenabled]} {
#  ns_log notice "--T :ttrace::isenabled"
#  set blueprint [ns_ictl get]
#  ns_ictl save [append blueprint [::Serializer serializeExportedMethods \
    #                      [::Serializer new -volatile]]]
#  unset blueprint
#  ns_log notice "--T [ns_ictl get]"
#}

namespace eval ::xo {
  #
  # Cleanup functions
  #

  #
  # Register xo::freeconn function only once
  #
  if {"::xo::freeconn" ni [ns_ictl gettraces freeconn]} {
    if {[catch {ns_ictl trace freeconn ::xo::freeconn} errorMsg]} {
      ns_log Error "ns_ictl trace returned: $errorMsg"
    }
  }

  #
  # Register::xo::at_delete function only once
  #
  if {"::xo::at_delete" ni [ns_ictl gettraces delete]} {
    if {[catch {ns_ictl trace delete ::xo::at_delete} errorMsg]} {
      ns_log Warning "The command 'ns_ictl trace delete' returned: $errorMsg"
    }
  }

  proc ::xo::freeconn {} {
    catch {::xo::at_cleanup}
  }

  #proc ::xo::at_create {} {
  #  ns_log notice "--at_create *********"
  #  foreach i [::xo::InstanceManager array names blueprint] {
  #    if {![nsf::is object $i]} {
  #      ::xo::InstanceManager unset blueprint($i)
  #      ns_log notice "--at_create no such object: $i"
  #    }
  #  }
  #}

  ::xotcl::Object instproc destroy_on_cleanup {} {
    #:log "--cleanup adding ::xo::cleanup([self]) [list [self] destroy]"
    set ::xo::cleanup([self]) [list [self] destroy]
  }

  #
  # Activate/deactivate the following line to track (unexpected)
  # memory size changes in the system log.
  #
  set ::xo::rss 0 ;# set it to one to activate it

  #
  # Experimental low-level cleanup handlers, which are similar to
  # ::xo::cleanup, but which survive per-request cleanup and which
  # have to be manually deregistered.
  #
  proc add_cleanup {key cmd} {
    set ::xo::cleanup_always($key) $cmd
  }
  proc remove_cleanup {key} {
    unset ::xo::cleanup_always($key)
  }

  ad_proc at_cleanup {args} {
    #
    # Per-request cleanup handler. The handler is as well called by
    # the xowiki-datasource and must be therefore public.
    #

  } {
    #
    # The following block is a safety measure: When there is no cleanup
    # for ::xo::cc defined, the object will survive a request and many
    # things might go wrong. The test is quite cheap an can reduce
    # debugging time on some sites.
    #
    if {[nsf::is object ::xo::cc]} {
      if {![info exists ::xo::cleanup(::xo::cc)]} {
        ns_log notice [::xo::cc serialize]
        ns_log error "no cleanup for ::xo::cc registered"
        ::xo::cc destroy
      }
    }
    ::xo::dc profile off
    ::xo::broadcast receive

    if {$::xo::rss} {
      #
      # The following code works just for Linux, since it depends on
      # the /proc filesystem and the order of values in the resulting
      # line.
      #
      if {[file readable /proc/[pid]/statm]} {
        set F [open /proc/[pid]/statm]; set c [read $F]; close $F
        lassign $c size rss shared
        set size [format %.2f [expr {$rss * 4.096 / 1048576}]]
        if {$::xo::rss != $size} {
          ns_log notice "=== RSS size change to: $size GB"
          set ::xo::rss $size
        }
      }
    }

    #ns_log notice "*** start of cleanup <$args> ([array get ::xo::cleanup])"
    set at_end ""
    foreach {name cmd} [list {*}[array get ::xo::cleanup] {*}[array get ::xo::cleanup_always]] {
      #::trace remove variable ::xotcl_cleanup($name) unset ::xo::cleanup
      if {![nsf::is object $name]} {
        #ns_log notice "--D $name already destroyed, nothing to do"
        continue
      }
      if {$name eq "::xo::cc"} {
        append at_end $cmd\n
        continue
      }
      #ns_log notice "*** cleanup $cmd"
      try {
        {*}$cmd
      } on error {errorMsg} {
        set obj [lindex $cmd 0]
        ns_log error "Error during ::xo::cleanup: $errorMsg $::errorInfo"
        try {
          ns_log notice "... analyze: cmd = $cmd"
          ns_log notice "... analyze: $obj is_object? [nsf::is object $obj]"
          ns_log notice "... analyze: class [$obj info class]"
          ns_log notice "... analyze: precedence [$obj info precedence]"
          ns_log notice "... analyze: methods [lsort [$obj info methods]]"
          #
          # In case, we want to destroy some objects, and the
          # destructor fails, make sure to destroy them even
          # then. Half-deleted zombies can produce harm. We reclass
          # the object to the base class and try again.
          #
          if {[lindex $cmd 1] eq "destroy"} {
            ns_log error "... forcing object destroy without application level destructors"
            if {[$obj isclass]} {
              $obj class ::xotcl::Class; $obj destroy
            } else {
              $obj class ::xotcl::Object; $obj destroy
            }
          }
        }
      }
    }
    #ns_log notice "*** at_end $at_end"
    try {
      {*}$at_end
    } on error {errorMsg} {
      ns_log Error "Error during ::xo::cleanup: $errorMsg $::errorInfo"
    }
    array unset ::xo::cleanup
    #ns_log notice "*** end of cleanup"
  }

  proc ::xo::at_delete args {
    #
    # Delete all object and classes at a time, where the thread is
    # still fully functioning. During interp exit, the commands would
    # be deleted anyhow, but there exists a potential memory leak,
    # when e.g. a destroy method (or an exit handler) writes to
    # ns_log.  ns_log requires the thread name, but it is cleared
    # already earlier (after the interp deletion trace). AOLserver
    # recreated the name and the an entry in the thread list, but this
    # elements will not be freed. If we destroy the objects here, the
    # mentioned problem will not occur.
    #
    ns_log notice "ON DELETE $args"
    ::xo::broadcast clear

    #
    # Make sure, no handles are allocated any more. Otherwise, when
    # the thread is reused, there would be a conflict, when the thread
    # has already a handle associated but tries to obtain an
    # additional handle.
    #
    db_release_unused_handles

    set t0 [clock clicks -milliseconds]
    ::xo::system_stats recordtimes
    #
    # Check, if we have a new XOTcl implementation with ::xotcl::finalize
    #
    if {[info commands ::xotcl::finalize] ne ""} {
      ::xotcl::finalize
    } else {
      # Delete the objects and classes manually
      set objs [::xotcl::Object allinstances]
      ns_log notice "no finalize available, deleting [llength $objs] objects"
      foreach o $objs {
        if {![nsf::is object $o]} continue
        if {[$o istype ::xotcl::Class]} continue
        catch {$o destroy} errorMsg
      }
      foreach o [::xotcl::Class allinstances] {
        if {![nsf::is object $o]} continue
        if {$o eq "::xotcl::Object" || $o eq "::xotcl::Class"} continue
        catch {$o destroy} errorMsg
      }
    }
    set t1 [clock clicks -milliseconds]
    ns_log notice "ON DELETE done ([expr {$t1-$t0}]ms)"
  }

  proc ::xo::stats {{msg ""}} {
    set xobjs   [llength [::xotcl::Object info instances -closure]]
    set nobjs   [llength [::nx::Object info instances  -closure]]
    set tmpObjs [llength [info commands ::nsf::__#*]]
    set tdoms   [llength [list {*}[info commands domNode0*] {*}[info commands domDoc0x*]]]
    set nssets  [llength [ns_set list]]
    ns_log notice "xo::stats $msg: current objects xotcl $xobjs nx $nobjs tmp $tmpObjs tDOM $tdoms ns_set $nssets"
  }

  #
  # ::xo::Module is very similar to a plain Tcl namespace: When it is
  # created/recreated, it does not perform a cleanup of its
  # contents. This means that preexisting procs, objects classes,
  # variables etc. will survive a recreation. As a consequence,
  # ::xo::Modules can easily span multiple files and they can be used
  # like a namespace. However, the modules have the advantage that it
  # is possible to define procs, instprocs with non-positional
  # arguments directly in it. It is as well possible to use mixins
  # etc.
  #
  Class create Module
  Module instproc init    args {:requireNamespace}
  Module instproc cleanup args {ns_log notice "create/recreate [self] without cleanup"}
}

namespace eval ::xo {

  #
  # For the time being: catch changed parameter values; it would be nice
  # to have in the future a more generic interface to trigger actions
  # directly on all parameter changes.
  #
  d_proc -public -callback subsite::parameter_changed -impl xotcl-core_param_changed {
    -package_id:required
    -parameter:required
    -value:required
  } {
    Implementation of subsite::parameter_changed for xotcl-core parameters

    @param package_id the package_id of the package the parameter was changed for
    @param parameter  the parameter name
    @param value      the new value
  } {
    set package_key [apm_package_key_from_id $package_id]
    if {$package_key eq "xotcl-core"
        && $parameter eq "NslogRedirector"
        && [info commands ::xo::ns_log_redirector_manager] ne ""
      } {
      ::xo::ns_log_redirector_manager set_level $value
      #
      # Update the blueprint to reflect the parameter change
      # immediately.
      #
      # This is a heavy solution, but the NslogRedirector is not
      # likely to be changed frequently on a production system. The
      # alternative, a server restart, is even more expensive.
      #
      ns_eval [list ::xo::ns_log_redirector_manager set_level $value]
      #set blueprint [ns_ictl get]
      #set last [string last "\n::xo::ns_log_redirector_manager" $blueprint]
      #if {$last > -1} { set blueprint [string range $blueprint 0 $last-1]}
      #ns_ictl save "$blueprint\n::xo::ns_log_redirector_manager set_level $value"
    }
  }
}

namespace eval ::xo {

  ::xotcl::Object create ::xo::system_stats

  if {$::tcl_platform(os) eq "Linux"} {

    ::xo::system_stats proc thread_info {pid tid} {
      set s ""
      set fn /proc/$pid/task/$tid/stat
      if {[ad_file readable $fn]} {
        try {
          set f [open $fn]
          set s [read $f]
        } on error err {
          set errorMsg "IO error $err reading file $fn"
          if {[info exists f]} { append errorMsg " (fh $f)" }
          ns_log error $errorMsg
        } finally {
          close $f
        }
      } elseif {[file readable /proc/$pid/task/$pid/stat]} {
        set fn /proc/$pid/task/$pid/stat
        try {
          set f [open $fn]
          set s [read $f]
        } on error err {
          set errorMsg "IO error $err reading file $fn"
          if {[info exists f]} { append errorMsg " (fh $f)" }
          ns_log error $errorMsg
        } finally {
          close $f
        }
      }
      if {$s ne ""} {
        lassign $s tid comm state ppid pgrp session tty_nr tpgid flags minflt \
            cminflt majflt cmajflt utime stime cutime cstime priority nice \
            numthreads itrealval starttime vsize rss rsslim startcode endcode \
            startstack kstkesp kstkeip signal blocked sigignore sigcatch wchan \
            nswap cnswap ext_signal processor ...
        # utime and stimes are jiffies. Since Linux has HZ 100, we can
        # multiply the jiffies by 10 to obtain ms
        return [list utime [expr {$utime*10}] stime [expr {$stime*10}]]
      }
    }

  } else {
    ::xo::system_stats proc thread_info {pid tid} {
      return ""
    }
  }

  ::xo::system_stats proc gettid {} {
    #
    # Get name and tid of the current thread
    #
    set hex [ns_thread id]
    foreach t [ns_info threads] {
      if {[lindex $t 2] eq $hex} {
        return [list name [lindex $t 0] tid [lindex $t 7]]
      }
    }
    return ""
  }

  ::xo::system_stats proc thread_classify {name} {
    switch -glob -- $name {
      "-main-"    { set group main }
      "::*"       { set group tcl:[string range $name 2 end]}
      "-sched*"   { set group scheds  }
      "-conn:*"   { set group conns   }
      "-driver:*" { set group drivers }
      "-asynclogwriter*" { set group logwriter }
      "-writer*"  { set group writers }
      "-spooler*" { set group spoolers }
      "-socks-"   { set group socks }
      "-nsproxy*" { set group nsproxy }
      "-ns_job_*" { set group ns_job }
      default     { set group others  }
    }
    return $group
  }

  ::xo::system_stats proc recordtimes {} {
    set threadInfo [:gettid]
    if {$threadInfo ne ""} {
      set i [:thread_info [pid] [dict get $threadInfo tid]]
      lappend i {*}$threadInfo
      if {[dict exists $i stime]} {
        set group [:thread_classify [dict get $i name]]
        nsv_incr [self] $group,stime [dict get $i stime]
        nsv_incr [self] $group,utime [dict get $i utime]
      }
    }
  }

  ::xo::system_stats proc aggregate {group time value} {
    upvar $time times
    if {![info exists times($group)]} {set times($group) 0}
    set times($group) [expr {$times($group) + $value}]
  }

  ::xo::system_stats proc aggcpuinfo {utime stime ttime} {
    upvar $utime utimes $stime stimes $ttime ttimes
    set pid [pid]
    set varnames {utime utimes stime stimes}
    foreach index [nsv_array names [self]] {
      lassign [split $index ,] group kind
      :aggregate $group [dict get $varnames $kind] [nsv_get [self] $index]
    }
    set threadInfo [ns_info threads]
    if {[file readable /proc/$pid/statm] && [llength [lindex $threadInfo 0]] > 7} {
      foreach t $threadInfo {
        set s [:thread_info $pid [lindex $t 7]]
        if {[dict exists $s stime]} {
          set group [:thread_classify [lindex $t 0]]
          :aggregate $group [dict get $varnames utime] [dict get $s utime]
          :aggregate $group [dict get $varnames stime] [dict get $s stime]
        }
      }
    }
    foreach group [array names utimes] {
      :aggregate $group ttimes [expr {$utimes($group) + $stimes($group)}]
    }
  }
}


namespace eval ::xo {
  #
  # xo::broadcast implements a simple mechanism to send commands to
  # different connection and scheduled threads. The receiving threads
  # have to call "xo::broadcast receive" when they are able to process
  # the commands. The connection threads realize this in xo::atcleanup
  # after a request was processed (defined in this file).
  #
  ::xotcl::Object create ::xo::broadcast

  ::xo::broadcast proc send {-thread_pattern cmd} {

    set tids {}
    foreach thread_info [ns_info threads] {
      set tn [lindex $thread_info 0]
      set tid [lindex $thread_info 2]
      dict set tids $tid 1
      if { [info exists thread_pattern] && ![string match $thread_pattern $tn] } {
        continue
      }
      switch -glob -- $tn {
        -conn:* -
        -sched:* {
          nsv_lappend broadcast $tid $cmd
        }
      }
    }

    foreach tid [nsv_array names broadcast] {
      if {![dict exists $tids $tid]} {
        nsv_unset broadcast $tid
        ns_log notice "xo::broadcast cleanup of TID $tid (thread does not exist anymore)"
      }
    }
  }

  ::xo::broadcast proc blueprint {cmd} {
    foreach t [::xotcl::THREAD info instances] {
      $t do eval $cmd
    }
    ns_eval ${cmd}\n::xo::at_cleanup
  }
  ::xo::broadcast proc clear {} {
    catch {nsv_unset broadcast [ns_thread id]}
  }
  ::xo::broadcast proc receive {} {
    set tid [ns_thread id]
    if {[nsv_exists broadcast $tid]} {
      foreach cmd [nsv_get broadcast $tid] {
        ns_log notice "broadcast received {$cmd}"
        try {
          eval $cmd
        } on error {errorMsg} {
          ns_log notice "broadcast receive error: $errorMsg for cmd $cmd"
        }
      }
      :clear
    }
  }
}

proc ::xo::getObjectProperty {o what args} {
  switch -- $what {
    "mixin" {
      return [$o ::nsf::methods::object::info::mixins]
    }
    "instmixin" {
      return [$o ::nsf::methods::class::info::mixins]
    }
    "mixinof" {
      return [$o ::nsf::methods::class::info::mixinof -scope object]
    }
    "instmixinof" {
      return [$o ::nsf::methods::class::info::mixinof -scope class]
    }

    "instproc" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info instprocs {*}$args]}
      return [$o info methods -path -type scripted -callprotection all {*}$args]
    }
    "instcommand" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info instcommands {*}$args]}
      return [$o info methods -path {*}$args]
    }
    "instforward" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info instforward {*}$args]}
      return [$o info methods -type forwarder {*}$args]
    }
    "instmethodtype" {
      return [$o ::nsf::methods::class::info::method type {*}$args]
    }
    "methodtype" {
      return [$o ::nsf::methods::object::info::method type {*}$args]
    }
    "proc" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}$args]}
      return [$o info object methods -path -type scripted {*}$args]
    }
    "command" {
      return [$o ::nsf::methods::object::info::methods {*}$args]
    }
    "forward" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info forward {*}$args]}
      return [$o info object methods -type forwarder {*}$args]
    }
    "slots" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info slots]}
      return [$o info object methods -type forwarder]
    }
    "class" {
      #if {"::xotcl::Object" in [$o info precedence]} {return [$o info class]}
      return [$o ::nsf::methods::object::info::class]
    }
    "superclass" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info superclass]}
      return [$o info superclasses]
    }
    "heritage" {
      #if {"::xotcl::Object" in [$o info precedence]} {return [$o info heritage]}
      return [$o info heritage]
    }
    "subclass" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info subclass]}
      return [$o info subclasses]
    }
    "parameter" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info parameter]}
      return [lmap p [$o info variables -closure] {$o info variable parameter $p}]
    }
    "isclass" {
      return [nsf::is class $o]
    }
    "isobject" {
      return [nsf::is object $o]
    }
    "isbaseclass" {
      if {![nsf::is class $o]} {return 0}
      if {[catch {set p [$o info precedence]}]} {return 0}
      return [expr {[lindex $p end] eq $o}]
    }
    "instmethodparameter" {
      return [$o ::nsf::methods::class::info::method parameter {*}$args]
    }
    "methodparameter" {
      return [$o ::nsf::methods::object::info::method parameter {*}$args]
    }
    "instargs" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info instargs {*}$args]}
      set posargs {}
      foreach m [$o info method args {*}$args] p [$o info method parameters {*}$args] {
        if {[string index [lindex $p 0] 0] eq "-"} continue
        lappend posargs $m
      }
      return $posargs
    }
    "args" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o info args {*}$args]}
      set posargs {}
      foreach m [$o info object method args {*}$args] p [$o info object method parameters {*}$args] {
        if {[lindex [string index $p 0] 0] eq "-"} continue
        lappend posargs $m
      }
      return $posargs
    }
    "instargdefault" {
      if {"::xotcl::Object" in [$o info precedence]} {
        return [uplevel [list $o info instdefault {*}$args]]
      }
      lassign $args method arg varName
      foreach p [$o info method parameters $method] {
        lassign $p name default
        if {$name eq $arg} {
          uplevel [list set $varName $default]
          return [expr {[llength $p] == 2}]
        }
      }
      return 0
    }
    "argdefault" {
      if {"::xotcl::Object" in [$o info precedence]} {
        return [uplevel [list $o info default {*}$args]]
      }
      lassign $args method arg varName
      foreach p [$o info object method parameters $method] {
        lassign $p name default
        if {$name eq $arg} {
          uplevel [list set $varName $default]
          return [expr {[llength $p] == 2}]
        }
      }
      return 0
    }

    "array-exists" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o array exists {*}$args]}
      return [$o eval [list array exists :{*}$args]]
    }
    "array-get" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o array get {*}$args]}
      return [$o eval [list array get :{*}$args]]
    }
    "array-set" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o array set {*}$args]}
      return [$o eval [list array set :{*}$args]]
    }
    "set" {
      if {"::xotcl::Object" in [$o info precedence]} {return [$o set {*}$args]}
      return [$o eval [list set :[lindex $args 0]]]
    }
    "vars" {
      return [$o ::nsf::methods::object::info::vars]
    }

    "isnxobject" {
      if {[info commands ::nsf::dispatch] ne "" && [info commands $o] ne ""} {
        return [::nsf::dispatch $o ::nsf::methods::object::info::hastype ::nx::Object]
      } {
        return 0
      }
    }
    default {
      error "no idea how to return $what"
    }
  }
}

#
# Helper method to copy a slot and configure it
#
::xotcl::Class instproc extend_slot {arg} {

  # The argument list is e.g. "foo -name x -title y"
  #
  # It is placed into one argument to avoid interference with the "-"
  # argument parsing since it will always start with a non-dashed
  # value.
  #
  set name [lindex $arg 0]
  set config [lrange $arg 1 end]

  # search for slot
  foreach c [:info heritage] {
    if {[nsf::is object ${c}::slot::$name]} {
      set slot ${c}::slot::$name
      break
    }
  }
  if {![info exists slot]} {error "can't find slot $name"}

  # copy slot and configure it
  set newSlot [self]::slot::$name

  $slot copy $newSlot
  $newSlot configure \
      -domain [self] \
      -manager $newSlot \
      -create_acs_attribute false \
      -create_table_attribute false \
      {*}$config
  #
  # Changing the domain is necessary for "update_attribute_from_slot"
  # for the extended slots like "title", "description" etc. But then
  # the accessor methods (for "title", "description") have to be
  # installed manually for the classes, on which the extension
  # happens.
  #
  ::nsf::method::setter [$newSlot domain] $name
  ns_log notice "=== change domain of $name from [$newSlot domain] to [$slot domain]"
  $newSlot domain [$slot domain]

  #
  set :db_slot($name) $newSlot
}


#ns_log notice "*** FREECONN? [ns_ictl gettraces freeconn]"
#ns_ictl trace freeconn {ns_log notice "*** FREECONN  isconnected=[ns_conn isconnected]"}
#ns_ictl oncleanup {ns_log notice "*** ONCLEANUP isconnected=[ns_conn isconnected]"}

#
# Local variables:
#    mode: tcl
#    tcl-indent-level: 2
#    indent-tabs-mode: nil
# End: