- Publicity: Public Only All
01-debug-procs.tcl
This file defines the following Objects and Classes: ::xo::ical
, ::caldav::calendars
- Location:
- packages/xotcl-core/tcl/01-debug-procs.tcl
Procedures in this file
- Class ::xo::Attribute (public)
- Object ::boomerang::handler (public)
- Object ::caldav::calendars (public)
- Object ::ns_cache (public)
- Object ::template::CSS (public)
- Object ::xo::api (public)
- Object ::xo::ical (public)
- boomerang::handler proc record (public)
- caldav::calendars proc alwaysQueriedCalendars (public)
- caldav::calendars proc alwaysQueriedClause (public)
- caldav::calendars proc calendar_clause (public)
- caldav::calendars proc communityCalendarClause (public)
- caldav::calendars proc footer (public)
- caldav::calendars proc format_recurrence (public)
- caldav::calendars proc get_cal_item_from_uid (public)
- caldav::calendars proc get_calendar_and_cal_item_from_uid (public)
- caldav::calendars proc header (public)
- caldav::calendars proc parse (public)
- caldav::calendars proc timezone (public)
- ns_cache proc create (public)
- ns_cache proc eval (public)
- ns_cache proc get (public)
- ns_cache proc names (public)
- ns_cache proc set (public)
- template::CSS proc class (public)
- template::CSS proc classes (public)
- template::CSS proc clear (public)
- template::CSS proc icon_name (public)
- template::CSS proc initialize (public)
- template::CSS proc registerCSSclasses (public)
- template::CSS proc require_toolkit (public)
- template::CSS proc toolkit (public)
- template::CSS proc toolkits (public)
- xo::Attribute instproc init (public)
- xo::api proc debug_widget (public)
- xo::api proc get_doc_block (public)
- xo::api proc get_init_block (public)
- xo::api proc get_method_body (public)
- xo::api proc get_method_source (public)
- xo::api proc get_object_source (public)
- xo::api proc get_proc_definition_flags (public)
- xo::api proc get_returns_spec (public)
- xo::api proc isclass (public)
- xo::api proc isobject (public)
- xo::api proc method_label (public)
- xo::api proc method_link (public)
- xo::api proc object_from_proc_index (public)
- xo::api proc object_index (public)
- xo::api proc object_link (public)
- xo::api proc object_url (public)
- xo::api proc proc_index (public)
- xo::api proc scope (public)
- xo::api proc scope_eval (public)
- xo::api proc scope_from_object_reference (public)
- xo::api proc scope_from_proc_index (public)
- xo::api proc script_name (public)
- xo::api proc source_to_html (public)
- xo::api proc update_method_doc (public)
- xo::api proc update_nx_docs (public)
- xo::api proc update_object_doc (public)
- xo::at_cleanup (public)
- xo::ical proc clock_to_iso (public)
- xo::ical proc clock_to_local_day (public)
- xo::ical proc clock_to_oacstime (public)
- xo::ical proc clock_to_utc (public)
- xo::ical proc date_time_to_clock (public)
- xo::ical proc dates_valid_p (public)
- xo::ical proc ical_to_text (public)
- xo::ical proc reflow_content_line (public)
- xo::ical proc tcl_time_to_local_day (public)
- xo::ical proc tcl_time_to_utc (public)
- xo::ical proc text_to_ical (public)
- xo::ical proc utc_to_clock (public)
Detailed information
Class ::xo::Attribute (public)
::xotcl::MetaSlot ::xo::AttributeOpenACS specific attribute slot class, which can be further refined. Contains meta data based on the OpenACS meta-data conventions.
- Testcases:
- No testcase defined.
Object ::boomerang::handler (public)
::nx::Object ::boomerang::handlerDon't quote the following boomerang attributes when output format is JSON.
- Testcases:
- No testcase defined.
Object ::caldav::calendars (public)
::nx::Object ::caldav::calendarsThe class "calendars" implements the interface to the database structures.
- ::caldav::calendars get_cal_item_from_uid ?-calendar_ids /integer .../? /uid/
- ::caldav::calendars timezone
- ::caldav::calendars communityCalendarClause /user_id/
- ::caldav::calendars get_calendar_and_cal_item_from_uid ?-calendar_ids /integer .../? /uid/
- ::caldav::calendars alwaysQueriedClause /user_id/
- ::caldav::calendars get_calitems ?-user_id /integer/? ?-start_date /value/? ?-end_date /value/? ?-calendar_ids /integer .../?
- ::caldav::calendars header ?-calendar_name /value/?
- ::caldav::calendars parse /text/
- ::caldav::calendars alwaysQueriedCalendars ?-with_sync_calendar /boolean/? /user_id/
- ::caldav::calendars calendar_clause ?-calendar_ids /integer .../? ?-user_id /integer/? ?-attr /value/?
- ::caldav::calendars format_recurrence ?-recurrence_id /integer/?
- ::caldav::calendars footer
- Testcases:
- No testcase defined.
Object ::template::CSS (public)
::nx::Object ::template::CSSCSS property manager. This class is used for agnostic handling of icons, CSS class names, or styling preferences of a subsite/instance.
- ::template::CSS registerCSSclasses /toolkit/ /dict/
- ::template::CSS toolkits
- ::template::CSS icon_name /filename/
- ::template::CSS toolkit
- ::template::CSS require_toolkit ?-css? ?-js?
- ::template::CSS initialize
- ::template::CSS classes /classNames/
- ::template::CSS class ?-toolkit /value/? /name/
- ::template::CSS clear
- Testcases:
- No testcase defined.
Object ::xo::api (public)
::nx::Object ::xo::apiGeneral interface to obtain information from XOTcl/NX objects and classes for the API browser.
- ::xo::api get_method_source /scope/ /obj/ /prefix/ /method/
- ::xo::api scope_from_object_reference /scope_var/ /object_var/
- ::xo::api object_url ?-show_source /value/? ?-show_methods /value/? /scope/ /obj/
- ::xo::api scope
- ::xo::api debug_widget /proc_spec/
- ::xo::api isclass /scope/ /obj/
- ::xo::api proc_index /scope/ /obj/ /instproc/ /proc_name/
- ::xo::api get_init_block /scope/ /obj/
- ::xo::api get_method_body /scope/ /obj/ /prefix/ /method/
- ::xo::api get_object_source /scope/ /obj/
- ::xo::api method_link ?-label /value/? /obj/ /kind/ /method/
- ::xo::api source_to_html ?-width /value/? /string/
- ::xo::api scope_from_proc_index /proc_index/
- ::xo::api get_doc_block /text/ ?restVar?
- ::xo::api get_proc_definition_flags /debug/ /deprecated/
- ::xo::api update_nx_docs ?objects?
- ::xo::api update_method_doc ?-protection /value/? ?-deprecated? ?-debug? ?-warn? /scope/ /obj/ /inst/ /proc_name/ /docString/
- ::xo::api method_label ?-kind? /proc_spec/
- ::xo::api scope_eval /scope/ ?/arg .../?
- ::xo::api isobject /scope/ /obj/
- ::xo::api object_link ?-noimg /boolean/? /scope/ /obj/
- ::xo::api object_from_proc_index /proc_index/
- ::xo::api get_returns_spec /returns/
- ::xo::api script_name ?-obj /value/? /scope/
- ::xo::api update_object_doc /scope/ /obj/ /doc_string/
- ::xo::api object_index /scope/ /obj/
- Testcases:
- No testcase defined.
Object ::xo::ical (public)
::nx::Object ::xo::icalThe Object ::calendar::ical provides the methods for importing and exporting single or multiple calendar items in the ical format (see rfc 2445). Currently only the part of ical is implemented, which is used by the mozilla calendar (Sunbird, or Lightning for Thunderbird).
- Author:
- Gustaf Neumann
- ::xo::ical::VCALENDAR
- ::xo::ical clock_to_iso /seconds/
- ::xo::ical reflow_content_line /text/
- ::xo::ical date_time_to_clock /date/ /time/ /utc/
- ::xo::ical clock_to_oacstime /seconds/
- ::xo::ical tcl_time_to_local_day /time/
- ::xo::ical clock_to_local_day /seconds/
- ::xo::ical tcl_time_to_utc /time/
- ::xo::ical::VEVENT
- ::xo::ical utc_to_clock /utc_time/
- ::xo::ical clock_to_utc /seconds/
- ::xo::ical::VTODO
- ::xo::ical::VCALITEM
- ::xo::ical dates_valid_p -start_date /value/ -end_date /value/
- ::xo::ical ical_to_text /text/
- ::xo::ical text_to_ical ?-remove_tags /boolean/? /text/
- Testcases:
- No testcase defined.
boomerang::handler proc record (public)
boomerang::handler record -ns_set ns_set -peeraddr peeraddr
- Switches:
- -ns_set (required)
- -peeraddr (required)
- Testcases:
- No testcase defined.
caldav::calendars proc alwaysQueriedCalendars (public)
caldav::calendars alwaysQueriedCalendars \
[ -with_sync_calendar on|off ] user_id
- Switches:
- -with_sync_calendar (optional, boolean, defaults to
"true")- Parameters:
- user_id (required, integer)
- Returns:
- the calendar_ids, which should be always returned
- Testcases:
- No testcase defined.
caldav::calendars proc alwaysQueriedClause (public)
caldav::calendars alwaysQueriedClause user_id
- Parameters:
- user_id (required, integer)
- Returns:
- SQL clause which is always queried
- Testcases:
- No testcase defined.
caldav::calendars proc calendar_clause (public)
caldav::calendars calendar_clause [ -calendar_ids calendar_ids ] \
[ -user_id user_id ] [ -attr attr ]When calendar_ids are empty, user_id has to be specified
- Switches:
- -calendar_ids (optional, integer)
- -user_id (optional, integer)
- -attr (optional, defaults to
"c.on_which_calendar")- Testcases:
- No testcase defined.
caldav::calendars proc communityCalendarClause (public)
caldav::calendars communityCalendarClause user_idGet calendars from communities, when DotLRN is active.
- Parameters:
- user_id (required, integer)
- Testcases:
- No testcase defined.
caldav::calendars proc footer (public)
caldav::calendars footerReturn the footer of the ical file.
- Testcases:
- No testcase defined.
caldav::calendars proc format_recurrence (public)
caldav::calendars format_recurrence [ -recurrence_id recurrence_id ]Return the recurrence specification in form of a formatted ical RRULE. @param recurrence_id is the unique id of the recurrence item.
- Switches:
- -recurrence_id (optional, integer, accept empty)
- Testcases:
- No testcase defined.
caldav::calendars proc get_cal_item_from_uid (public)
caldav::calendars get_cal_item_from_uid [ -calendar_ids calendar_ids ] \
uid
- Switches:
- -calendar_ids (optional, integer)
- Parameters:
- uid (required)
- unique id of an calendar item
- Returns:
- for a uid the cal_item_id(s?)
- Testcases:
- No testcase defined.
caldav::calendars proc get_calendar_and_cal_item_from_uid (public)
caldav::calendars get_calendar_and_cal_item_from_uid \
[ -calendar_ids calendar_ids ] uid
- Switches:
- -calendar_ids (optional, integer)
- Parameters:
- uid (required)
- unique id of an calendar item
- Returns:
- for a uid the cal_item_id(s?)
- Testcases:
- No testcase defined.
caldav::calendars proc header (public)
caldav::calendars header [ -calendar_name calendar_name ]Return the header of the ical file. GN TODO: don't hardcode TIMEZONE "X-WR-TIMEZONE:Europe/Vienna"
- Switches:
- -calendar_name (optional)
- Testcases:
- No testcase defined.
caldav::calendars proc parse (public)
caldav::calendars parse textParse the ical file passed in as string and output a list of CalItem objects. The attributes specified in opaque_tags are passed as opaque values. Opaque attributes are not shown in OpenACS, but output when the calendar item is requested in ical format.
- Parameters:
- text (required)
- the text do be parsed TODO: this should go into ical-procs..... but first check dependencies - $item add_ical_var .... - ::caldav::calitem new
- Testcases:
- No testcase defined.
caldav::calendars proc timezone (public)
caldav::calendars timezoneReturn the timezone
- Testcases:
- No testcase defined.
ns_cache proc create (public)
ns_cache create [ -size size ] [ -timeout timeout ] cache_nameexpire in NS means timeout in AOLserver
- Switches:
- -size (optional, defaults to
"1024000")- -timeout (optional)
- Parameters:
- cache_name (required)
- Testcases:
- No testcase defined.
ns_cache proc eval (public)
ns_cache eval cache_name key script
- Parameters:
- cache_name (required)
- key (required)
- script (required)
- Testcases:
- No testcase defined.
ns_cache proc get (public)
ns_cache get cache_name key var_name
- Parameters:
- cache_name (required)
- key (required)
- var_name (required)
- Testcases:
- No testcase defined.
ns_cache proc names (public)
ns_cache names cache_name args [ args... ]
- Parameters:
- cache_name (required)
- args (required)
- Testcases:
- No testcase defined.
ns_cache proc set (public)
ns_cache set cache_name key value
- Parameters:
- cache_name (required)
- key (required)
- value (required)
- Testcases:
- No testcase defined.
template::CSS proc class (public)
template::CSS class [ -toolkit toolkit ] nameIn case, a mapping for CSS classes is defined, return the mapping for the provided class name. Otherwise return the input class name unmodified.
- Switches:
- -toolkit (optional)
- Parameters:
- name (required)
- Testcases:
- No testcase defined.
template::CSS proc classes (public)
template::CSS classes classNamesMap a list of CSS class names
- Parameters:
- classNames (required)
- Testcases:
- No testcase defined.
template::CSS proc clear (public)
template::CSS clearClear the cached toolkit name, such that it is reloads the settings on the next initialize call.
- Testcases:
- No testcase defined.
template::CSS proc icon_name (public)
template::CSS icon_name filenameReturn an icon name for the proved filename Default icon name
- Parameters:
- filename (required)
- Testcases:
- No testcase defined.
template::CSS proc initialize (public)
template::CSS initializeInitialize tailorization for CSS toolkits. The function reads the global apm package parameter and sets/resets accordingly (a) the default values (actually parameters) for the form field and (b) defines the toolkit specific CSS class name mapping. Loading optional, but universally present header files has do be performed per request... not sure this is the best place, since packages are as well initialized in the background.
- Testcases:
- No testcase defined.
template::CSS proc registerCSSclasses (public)
template::CSS registerCSSclasses toolkit dictRegister CSS class mapping for the provided framework
- Parameters:
- toolkit (required)
- dict (required)
- Testcases:
- No testcase defined.
template::CSS proc require_toolkit (public)
template::CSS require_toolkit [ -css ] [ -js ]Make sure that the preferred toolkit is loaded. Note that some combination won't match nicely, since e.g. the toolbar of a theme based on bootstrap5 is messed up, when the preferred toolkit is bootstrap3. .... so, we should have some default setting or fallbacks to handle such situations.
- Switches:
- -css (optional)
- -js (optional)
- Testcases:
- No testcase defined.
template::CSS proc toolkit (public)
template::CSS toolkitReturn the preferred CSS toolkit
- Testcases:
- No testcase defined.
template::CSS proc toolkits (public)
template::CSS toolkitsReturn the list of known toolkits
- Testcases:
- No testcase defined.
xo::Attribute method init (public)
<instance of xo::Attribute> initConstructor of the OpenACS specific attribute slot class
- Testcases:
- No testcase defined.
xo::api proc debug_widget (public)
xo::api debug_widget proc_specReturn HTML code for a debug switch that lets an admin turn debugging of functions and methods on and off. This functionality is only allowed to site-wide admins.
- Parameters:
- proc_spec (required)
- Testcases:
- No testcase defined.
xo::api proc get_doc_block (public)
xo::api get_doc_block text [ restVar ]Get the (first) documentation block of the provided text (which might be e.g. the body of a method).
- Parameters:
- text (required)
- restVar (optional)
- Testcases:
- No testcase defined.
xo::api proc get_init_block (public)
xo::api get_init_block scope objGet the init block of an object/class or return empty
- Parameters:
- scope (required)
- obj (required)
- Testcases:
- No testcase defined.
xo::api proc get_method_body (public)
xo::api get_method_body scope obj prefix methodReturn the method body on object (when "prefix" is empty) or class (when "prefix" is "inst").
- Parameters:
- scope (required)
- obj (required)
- prefix (required)
- method (required)
- Testcases:
- No testcase defined.
xo::api proc get_method_source (public)
xo::api get_method_source scope obj prefix methodReturn the full method definition.
- Parameters:
- scope (required)
- obj (required)
- prefix (required)
- method (required)
- Testcases:
- No testcase defined.
xo::api proc get_object_source (public)
xo::api get_object_source scope objReturn the full object definition
- Parameters:
- scope (required)
- obj (required)
- Testcases:
- No testcase defined.
xo::api proc get_proc_definition_flags (public)
xo::api get_proc_definition_flags debug deprecatedHelper for version compatibility
- Parameters:
- debug (required)
- deprecated (required)
- Returns:
- flags for proc definition
- Testcases:
- No testcase defined.
xo::api proc get_returns_spec (public)
xo::api get_returns_spec returnsHelper for version compatibility
- Parameters:
- returns (required)
- Returns:
- flags for -returns flag
- Testcases:
- No testcase defined.
xo::api proc isclass (public)
xo::api isclass scope objCheck, whether the passed in obj is a class
- Parameters:
- scope (required)
- obj (required)
- Testcases:
- No testcase defined.
xo::api proc isobject (public)
xo::api isobject scope objCheck, whether the passed in obj is an object
- Parameters:
- scope (required)
- obj (required)
- Testcases:
- No testcase defined.
xo::api proc method_label (public)
xo::api method_label [ -kind ] proc_specReturn a user-friendly label for methods and objects.
- Switches:
- -kind (optional)
- when set, use naming convention from nx, otherwise XOTcl
- Parameters:
- proc_spec (required)
- Testcases:
- No testcase defined.
xo::api proc method_link (public)
xo::api method_link [ -label label ] obj kind methodReturn a link for the method if possible. If no proc-doc is available, return just plain text.
- Switches:
- -label (optional)
- Parameters:
- obj (required)
- kind (required)
- method (required)
- Testcases:
- No testcase defined.
xo::api proc object_from_proc_index (public)
xo::api object_from_proc_index proc_indexParse the proc_index and return the scope from it.
- Parameters:
- proc_index (required)
- Testcases:
- No testcase defined.
xo::api proc object_index (public)
xo::api object_index scope objReturn a canonical index string for the object
- Parameters:
- scope (required)
- obj (required)
- Testcases:
- No testcase defined.
xo::api proc object_link (public)
xo::api object_link [ -noimg on|off ] scope objReturn a link for the object.
- Switches:
- -noimg (optional, boolean, defaults to
"off")- Parameters:
- scope (required)
- obj (required)
- Testcases:
- No testcase defined.
xo::api proc object_url (public)
xo::api object_url [ -show_source show_source ] \
[ -show_methods show_methods ] scope objReturn a link for the object in the object browser (show-object)
- Switches:
- -show_source (optional, defaults to
"0")- -show_methods (optional, defaults to
"1")- Parameters:
- scope (required)
- obj (required)
- Testcases:
- No testcase defined.
xo::api proc proc_index (public)
xo::api proc_index scope obj instproc proc_nameReturn a canonical index string for the specified method
- Parameters:
- scope (required)
- obj (required)
- instproc (required)
- proc_name (required)
- Testcases:
- No testcase defined.
xo::api proc scope (public)
xo::api scopeReturn the scope of the object. When executed in an XOTcl thread; the body won't be accessible by default without the explicit scope. The purpose of this proc is to document objects and classes that live only in a certain thread.
- Testcases:
- No testcase defined.
xo::api proc scope_eval (public)
xo::api scope_eval scope args [ args... ]When the scope is not empty, evaluate the command in the specified scope (thread)
- Parameters:
- scope (required)
- args (required)
- Testcases:
- No testcase defined.
xo::api proc scope_from_object_reference (public)
xo::api scope_from_object_reference scope_var object_varParse the object reference and return the scope from it.
- Parameters:
- scope_var (required)
- object_var (required)
- Testcases:
- No testcase defined.
xo::api proc scope_from_proc_index (public)
xo::api scope_from_proc_index proc_indexParse the proc_index and return the scope from it.
- Parameters:
- proc_index (required)
- Testcases:
- No testcase defined.
xo::api proc script_name (public)
xo::api script_name [ -obj obj ] scopeDetermine name of the current "script" as displayed by "Defined in" in the API browser. Define different sources available in different situatons.
- Switches:
- -obj (optional)
- class name for identifying the source filename
- Parameters:
- scope (required)
- either empty or thread name
- Returns:
- path starting with the "packages" directory
- Testcases:
- No testcase defined.
xo::api proc source_to_html (public)
xo::api source_to_html [ -width width ] stringHelper proc to preserve indentation in source-code to HTML conversion.
- Switches:
- -width (optional, defaults to
"100")- Parameters:
- string (required)
- Testcases:
- No testcase defined.
xo::api proc update_method_doc (public)
xo::api update_method_doc [ -protection protection ] [ -deprecated ] \
[ -debug ] [ -warn ] scope obj inst proc_name docStringObtain a doc-string for a method, convert it and add it to the proc-doc.
- Switches:
- -protection (optional, defaults to
"public")- -deprecated (optional, defaults to
"false")- -debug (optional, defaults to
"false")- -warn (optional, defaults to
"false")- Parameters:
- scope (required)
- obj (required)
- inst (required)
- proc_name (required)
- docString (required)
- Testcases:
- No testcase defined.
xo::api proc update_nx_docs (public)
xo::api update_nx_docs [ objects ]Update for the provided (or all) nx::Object instances the internal documentation structures.
- Parameters:
- objects (optional)
- Testcases:
- No testcase defined.
xo::api proc update_object_doc (public)
xo::api update_object_doc scope obj doc_stringUpdate the API browser nsvs with information about the provided object. If no doc string is provided, try to get it from the object definition. if {![string match ::* $obj]} { ad_log error "==== update_object_doc OBJECT WITHOUT leading colons <$obj>" }
- Parameters:
- scope (required)
- obj (required)
- doc_string (required)
- Testcases:
- No testcase defined.
xo::at_cleanup (public)
xo::at_cleanup [ args... ]
# # Per-request cleanup handler. The handler is as well called by # the xowiki-datasource and must be therefore public. #
- Partial Call Graph (max 5 caller/called nodes):
- Testcases:
- xowiki_test_cases
xo::ical proc clock_to_iso (public)
xo::ical clock_to_iso secondsConvert clock epoch (result from [clock seconds]) into ISO format
- Parameters:
- seconds (required, integer)
- Testcases:
- No testcase defined.
xo::ical proc clock_to_local_day (public)
xo::ical clock_to_local_day secondsConvert clock epoch (result from [clock seconds]) to local day (YearMonthDay)
- Parameters:
- seconds (required, integer)
- Testcases:
- No testcase defined.
xo::ical proc clock_to_oacstime (public)
xo::ical clock_to_oacstime secondsConvert clock epoch (result from [clock seconds]) into time format usually used in OpenACS.
- Parameters:
- seconds (required, integer)
- Testcases:
- No testcase defined.
xo::ical proc clock_to_utc (public)
xo::ical clock_to_utc secondsConvert clock epoch (result from [clock seconds]) into UTC time.
- Parameters:
- seconds (required, integer)
- Testcases:
- No testcase defined.
xo::ical proc date_time_to_clock (public)
xo::ical date_time_to_clock date time utcConvert separate fields date and time with boolean utc flags into clock value in seconds.
- Parameters:
- date (required)
- time (required)
- utc (required)
- Testcases:
- No testcase defined.
xo::ical proc dates_valid_p (public)
xo::ical dates_valid_p -start_date start_date -end_date end_date A sanity check that the start time is before the end time. This is a rewrite of calendar::item::dates_valid_p, but about 100 times faster.
- Switches:
- -start_date (required)
- -end_date (required)
- Testcases:
- No testcase defined.
xo::ical proc ical_to_text (public)
xo::ical ical_to_text textTransform the escaped ical text format to plain text
- Parameters:
- text (required)
- Testcases:
- No testcase defined.
xo::ical proc reflow_content_line (public)
xo::ical reflow_content_line textPerform line folding: According to RFC 5545 section 3.1, SHOULD NOT be longer than 75 octets, excluding the line break. https://www.ietf.org/rfc/rfc5545.txt
- Parameters:
- text (required)
- Testcases:
- No testcase defined.
xo::ical proc tcl_time_to_local_day (public)
xo::ical tcl_time_to_local_day timeConvert Tcl time stamp into local day format https://tools.ietf.org/html/rfc5545#section-3.3.4
- Parameters:
- time (required)
- Testcases:
- No testcase defined.
xo::ical proc tcl_time_to_utc (public)
xo::ical tcl_time_to_utc timeConvert Tcl time stamp to UTC.
- Parameters:
- time (required)
- Testcases:
- No testcase defined.
xo::ical proc text_to_ical (public)
xo::ical text_to_ical [ -remove_tags on|off ] textTransform arbitrary text to the escaped ical text format (see rfc 2445)
- Switches:
- -remove_tags (optional, boolean, defaults to
"false")- Parameters:
- text (required)
- Testcases:
- No testcase defined.
xo::ical proc utc_to_clock (public)
xo::ical utc_to_clock utc_timeConvert UTC time to clock seconds.
- Parameters:
- utc_time (required)
- Testcases:
- No testcase defined.
Content File Source
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 } { # # OpenACS specific attribute slot class, which can be further # refined. Contains meta data based on the OpenACS meta-data # conventions. # } } 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=oneof {name value arg} { if {$value ni [split $arg |]} { error "value '$value' of parameter $name is invalid" } } :method type=dbtext {name value} { # # Ensure that the value can be used in an SQL query. # # Note that this is not the same as quoting or otherwise # ensuring the safety of the statement itself. What we enforce # here is that the value will be accepted by the db interface # without complaining. The actual definition may change or be # database specific in the future. # # # Reject the NUL character # if {[string first \u00 $value] != -1} { error "value '$value' of parameter $name contains the NUL character" } } :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 exists ::nx::Slot method istype ::nx::Slot method set ::nx::Slot method type=cr_item_of_package ::nx::Slot method type=dbtext ::nx::Slot method type=html ::nx::Slot method type=localurl ::nx::Slot method type=naturalnum ::nx::Slot method type=nohtml ::nx::Slot method type=object_id ::nx::Slot method type=oneof ::nx::Slot method type=range ::nx::Slot method type=signed ::nx::Slot method type=token ::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 {} { # # Constructor of the OpenACS specific attribute slot class # 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] && ![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 ::nsf::methods::object::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" } unset -nocomplain ::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 ""}} { dict set stats xotcl [llength [::xotcl::Object info instances -closure]] dict set stats nx [llength [::nx::Object info instances -closure]] dict set stats tmpObjs [llength [info commands ::nsf::__#*]] dict set stats tdom [llength [list {*}[info commands domNode0*] {*}[info commands domDoc0x*]]] dict set stats nssets [expr {[acs::icanuse "ns_set stats"] ? [list [ns_set stats]] : [llength [ns_set list]]}] ns_log notice "xo::stats $msg: $stats" return $stats } # # ::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 { "-asynclogwriter*" { set group logwriter } "-conn:*" { set group conns } "-driver:*" { set group drivers } "-main-" { set group main } "-ns_job_*" { set group ns_job } "-nsproxy*" { set group nsproxy } "-sched*" { set group scheds } "-socks-" { set group socks } "-spooler*" { set group spoolers } "-task:tclhttp*" { set group tclhttp } "-writer*" { set group writers } "::*" { set group tcl:[string range $name 2 end]} 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 } } } # nx::Object create acs::object_property { # :public object method mixin {o} { # $o ::nsf::methods::object::info::mixins # } # :public object method instmixin {o} { # $o ::nsf::methods::class::info::mixins # } # :public object method mixinof {o} { # $o ::nsf::methods::class::info::mixinof -scope object # } # :public object method instmixinof {o} { # $o ::nsf::methods::class::info::mixinof -scope class # } # :public object method instproc {o args} { # if {[nsf::is class,type=::xotcl::Class $o]} {return [$o info instprocs {*}$args]} # if {[nsf::is class,type=::nx::Class $o]} {return $o info methods -path -type scripted -callprotection all {*}$args} # } # :public object method instcommand {o args} { # if {[nsf::is class,type=::xotcl::Class $o]} {return [$o info instcommands {*}$args]} # if {[nsf::is class,type=::nx::Class $o]} {return [$o info methods -path {*}$args]} # } # } # # 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:
