Skip to content

X
xotcl-core
Commit 14da75a7 authored by Frank Bergmann's avatar Frank Bergmann
Browse files
Options

- Upgrade XoTCL Core to 0.124

parent f8ad3bf0
Hide whitespace changes
Inline Side-by-side
Showing with 451 additions and 56 deletions
tcl/01-debug-procs.tcl
View file @ 14da75a7
......@@ -13,6 +13,7 @@ package require xotcl::serializer
::xotcl::Object instproc serialize
::xotcl::Object instproc show-object
::xotcl::Object instforward db_1row
::xotcl::Object instforward db_0or1row
::xotcl::Object instproc destroy_on_cleanup
::xotcl::Object instproc set_instance_vars_defaults
::xotcl::nonposArgs proc integer
......@@ -70,19 +71,22 @@ if {$::xotcl::version < 1.5} {
if {[info command ::nx::Object] ne ""} {
ns_log notice "Defining minimal XOTcl 1 compatibility"
::nsf::alias ::xo::Attribute instvar ::nsf::methods::object::instvar
# the following line would cause a dependency of an nx object to xotcl (serializer)
#::nsf::alias ::nx::Slot istype ::nsf::classes::xotcl::Object::istype
::nx::Slot public method istype {class} {
return [expr {[::nsf::is class $class] &&
[::nsf::dispatch [self] ::nsf::methods::object::info::hastype $class]}]
}
::nsf::method::alias ::xo::Attribute instvar ::nsf::methods::object::instvar
# 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::existsvar [self] $var}
::nx::Slot public method exists {var} {::nsf::var::exists [self] $var}
::nx::Object public method serialize {} {::Serializer deepSerialize [self]}
::nx::Object method set_instance_vars_defaults {} {:configure}
::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"
}
::xotcl::Object instproc set_instance_vars_defaults {} {:configure}
::xotcl::Object proc setExitHandler {code} {::nsf::exithandler set $code}
......@@ -91,6 +95,7 @@ if {[info command ::nx::Object] ne ""} {
::nx::Object method show-object
::nx::Object method set_instance_vars_defaults
::nx::Object method destroy_on_cleanup
::nx::Object method qn
::nx::Slot method istype
::nx::Slot method exists
::nx::Slot method set
......@@ -128,6 +133,7 @@ namespace eval ::xo {
}
::xotcl::Object instforward db_1row -objscope
::xotcl::Object instforward db_0or1row -objscope
::xotcl::Object instproc serialize {} {
::Serializer deepSerialize [self]
......@@ -245,7 +251,7 @@ proc ::! args {
}
::xotcl::Object instproc qn query_name {
set qn "dbqd.[my uplevel self class]-[my uplevel self proc].$query_name"
set qn "dbqd.[my uplevel [list self class]]-[my uplevel [list self proc]].$query_name"
return $qn
}
namespace eval ::xo {
......@@ -382,7 +388,7 @@ namespace eval ::xo {
} else {
# register only once
if {[lsearch $registered ::xo::cleanup] == -1} {
if {[lsearch $registered ::xo::freeconn] == -1} {
ns_ictl trace freeconn ::xo::freeconn
}
if {[lsearch [ns_ictl gettraces delete] ::xo::at_delete] == -1} {
......@@ -414,6 +420,7 @@ namespace eval ::xo {
}
proc at_cleanup {args} {
::xo::broadcast receive
#ns_log notice "*** start of cleanup <$args> ([array get ::xo::cleanup])"
set at_end ""
foreach {name cmd} [array get ::xo::cleanup] {
......@@ -474,6 +481,7 @@ namespace eval ::xo {
# problem will not occur.
#
ns_log notice "ON DELETE $args"
::xo::broadcast clear
set t0 [clock clicks -milliseconds]
#
# Check, if we have a new XOTcl implementation with ::xotcl::finalize
......@@ -625,6 +633,43 @@ namespace eval ::xo {
}
}
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 {cmd} {
foreach thread_info [ns_info threads] {
switch -glob -- [lindex $thread_info 0] {
-conn:* -
-sched:* {
set tid [lindex $thread_info 2]
nsv_lappend broadcast $tid $cmd
}
}
}
}
::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}"
if {[catch $cmd errorMsg]} {
ns_log notice "broadcast receive error: $errorMsg for cmd $cmd"
}
}
my clear
}
}
}
#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]"}
tcl/03-doc-procs.tcl
View file @ 14da75a7
......@@ -75,7 +75,7 @@ ad_library {
if {$script eq "" && [info exists ::xotcl::currentScript]} {
set script $::xotcl::currentScript
}
set root_dir [nsv_get acs_properties root_directory]
set root_dir [acs_root_dir]
set root_length [string length $root_dir]
if { $root_dir eq [string range $script 0 [expr {$root_length - 1}]]} {
set script [string range $script [expr {$root_length + 1}] end]
......
tcl/05-db-procs.tcl
View file @ 14da75a7
......@@ -596,6 +596,36 @@ namespace eval ::xo::db {
# }
::xo::db::Class proc get_all_package_functions {} {
#
# Load defintions in one swap fropm function args; only for
# those definitions where we do not have function args, we parse
# the function arg aliases.
#
set definitions [db_list_of_lists [my qn get_all_package_functions0] {
select
args.function,
args.arg_name,
args.arg_default
from acs_function_args args
order by function, arg_seq
}]
set last_function ""
set function_args {}
foreach definition $definitions {
foreach {function arg_name default} $definition break
if {$last_function ne "" && $last_function ne $function} {
set ::xo::db::sql::fnargs($last_function) $function_args
#puts stderr "$last_function [list $function_args]"
set function_args {}
}
lappend function_args [list $arg_name $default]
set last_function $function
}
set ::xo::db::sql::fnargs($last_function) $function_args
#puts stderr "$last_function [list $function_args]"
ns_log notice "loaded [array size ::xo::db::sql::fnargs] definitions from function args"
#ns_log notice "... [lsort [array names ::xo::db::sql::fnargs *__*]]"
#
# Get all package functions (package name, object name) from PostgreSQL
# system catalogs.
......@@ -623,6 +653,12 @@ namespace eval ::xo::db {
# }
::xo::db::Class instproc get_function_args {package_name object_name} {
set key [string toupper ${package_name}__${object_name}]
if {[info exists ::xo::db::sql::fnargs($key)]} {
return $::xo::db::sql::fnargs($key)
}
#
# Get function_args for a single sql-function from PostgreSQL
# system catalogs. We retrieve always the longest function for
......@@ -792,8 +828,9 @@ namespace eval ::xo::db {
# is to define the correct default values in the database with
# define_function_args()
::xo::db::Class array set defaults {
"content_item__new" {RELATION_TAG null DESCRIPTION null TEXT null
::xo::db::Class array set fallback_defaults {
"content_item__new" {
RELATION_TAG null DESCRIPTION null TEXT null
CREATION_IP null NLS_LANGUAGE null LOCALE null CONTEXT_ID null
DATA null TITLE null ITEM_ID null
CREATION_DATE now
......@@ -809,14 +846,28 @@ namespace eval ::xo::db {
"content_type__drop_type" {
DROP_CHILDREN_P f DROP_TABLE_P f DROP_OBJECTS_P f
}
"acs_attribute__create_attribute" {
PRETTY_PLURAL null TABLE_NAME null COLUMN_NAME null
DEFAULT_VALUE null SORT_ORDER null DATABASE_TYPE null SIZE null
REFERENCES null CHECK_EXPR null COLUMN_SPEC null
}
"acs_object_type__create_type" {
TYPE_EXTENSION_TABLE null NAME_METHOD null
}
}
::xo::db::Class instproc fix_function_args {function_args package_name object_name} {
if {![[self class] exists defaults(${package_name}__$object_name)]} {
#
# Load fallback defaults for buggy function args. The values
# provided here are only used for function args without specified
# defaults. This is a transitional solution; actually, the
# function args should be fixed.
#
if {![[self class] exists fallback_defaults(${package_name}__$object_name)]} {
return $function_args
}
array set additional_defaults [[self class] set defaults(${package_name}__$object_name)]
array set additional_defaults [[self class] set fallback_defaults(${package_name}__$object_name)]
set result [list]
foreach arg $function_args {
foreach {arg_name default_value} $arg break
......
tcl/06-package-procs.tcl
View file @ 14da75a7
......@@ -72,6 +72,7 @@ namespace eval ::xo {
{-init_url true}
{-keep_cc false}
{-form_parameter}
{-export_vars true}
} {
Create the connection context ::xo::cc and a package object
if these are none defined yet. The connection context ::xo::cc
......@@ -134,7 +135,7 @@ namespace eval ::xo {
auth::require_login
}
::xo::cc export_vars -level 2
if {$export_vars} {::xo::cc export_vars -level 2}
return $package_id
}
......
tcl/30-widget-procs.tcl
View file @ 14da75a7
......@@ -171,8 +171,8 @@ namespace eval ::xo::tdom {
set HTMLattribute $attribute
}
#my msg "[my name] check for $attribute => [my exists $attribute]"
if {[my uplevel info exists $attribute]} {
lappend pairs $HTMLattribute [my uplevel set $attribute]
if {[my uplevel [list info exists $attribute]]} {
lappend pairs $HTMLattribute [my uplevel [list set $attribute]]
}
}
return $pairs
......@@ -196,6 +196,13 @@ namespace eval ::xo::tdom {
namespace eval ::xo {
#
# Escape provided char in provided string with backslash
#
proc backslash_escape {char string} {
return [string map [list $char \\$char] $string]
}
#
# Localization
#
......@@ -424,7 +431,8 @@ namespace eval ::xo {
#ns_return 200 text/plain $output
my instvar name
if {![my exists name]} {set name "table"}
ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=$name.csv"
set fn [xo::backslash_escape \" $name.csv]
ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=\"$fn\""
ns_return 200 text/csv $output
}
......@@ -458,7 +466,7 @@ namespace eval ::xo {
Class Field \
-superclass ::xo::OrderedComposite::Child \
-parameter {label {html {}} {orderby ""} name {richtext false} no_csv {CSSclass ""}} \
-parameter {label {html {}} {orderby ""} name {richtext false} no_csv {CSSclass ""} {hide 0}} \
-instproc init {} {
my set name [namespace tail [self]]
} \
......@@ -472,7 +480,7 @@ namespace eval ::xo {
Class BulkAction \
-superclass ::xo::OrderedComposite::Child \
-parameter {name id {html {}}} \
-parameter {name id {html {}} {hide 0}} \
-instproc actions {cmd} {
#my init
set grandParent [[my info parent] info parent]
......
tcl/50-protocol-handler-procs.tcl
View file @ 14da75a7
......@@ -61,6 +61,11 @@ namespace eval ::xo {
} {
my instvar uri method urlv destination
ad_conn -reset
# Make sure, there is no ::ad_conn(request); otherwise the
# developer support will add all its output to a single var, which
# can lead easily to running out of resources in busy sites. When
# unset, the developer support will create its own id.
catch {unset ::ad_conn(request)}
set uri [ns_urldecode [ns_conn url]]
set url_regexp "^[my url]"
#my log "--conn_setup: uri '$uri' my url='[my url]' con='[ns_conn url]'"
......@@ -119,9 +124,57 @@ namespace eval ::xo {
} {
set filter_url [my url]*
set url [my url]/*
#
# Methods defined by RFC 2086 (19.6.1 Additional Request Methods):
#
# LINK UNLINK PATCH
#
# Methods defined by RFC 2616:
#
# OPTIONS GET HEAD POST PUT DELETE TRACE CONNECT
#
# Methods defined by RF C2518:
#
# PROPFIND PROPPATCH MKCOL COPY MOVE LOCK UNLOCK
#
# Methods defined by RFC 3253 (versioning extensions):
#
# VERSION-CONTROL REPORT CHECKOUT CHECKIN UNCHECKOUT
# MKWORKSPACE UPDATE LABEL MERGE BASELINE-CONTROL
# MKACTIVITY
#
# Methods defined by RFC 3648 (ordered collections):
#
# ORDERPATCH
#
# Methods defined by RFC 3744 (WebDAV):
#
# ACL REPORT
#
# Methods defined by RFC 4437 (redirect reference resources):
#
# MKREDIRECTREF UPDATEREDIRECTREF
#
# Methods defined by RFC $791 (CalDAV):
#
# MKCALENDAR
#
# Methods defined by RFC 4918 (HTTP Extensions):
#
# COPY LOCK MKCOL MOVE PROPFIND PROPPATCH UNLOCK
#
# Methods defined by RFC 5323 (WebDAV SEARCH):
#
# SEARCH
#
# Methods defined by RFC 5789:
#
# PATCH
#
foreach method {
GET HEAD PUT POST MKCOL COPY MOVE PROPFIND PROPPATCH
DELETE LOCK UNLOCK OPTIONS
REPORT
} {
ns_register_filter preauth $method $filter_url [self]
ns_register_proc $method $url [self] handle_request
......
tcl/bgdelivery-procs.tcl
View file @ 14da75a7
......@@ -47,12 +47,39 @@ if {![string match *contentsentlength* $msg]} {
FileSpooler create fileSpooler
fileSpooler set tick_interval 60000 ;# 1 min
fileSpooler proc spool {{-delete false} -channel -filename -context {-client_data ""}} {
fileSpooler proc deliver_ranges {ranges client_data filename fd channel} {
set first_range [lindex $ranges 0]
set remaining_ranges [lrange $ranges 1 end]
foreach {from to size} $first_range break
if {$remaining_ranges eq ""} {
# A single delivery, which is as well the last; when finished
# with this chunk, terminate delivery
set cmd [list [self] end-delivery -client_data $client_data $filename $fd $channel]
} else {
#
# For handling multiple ranges, HTTP/1.1 requires multipart
# messages (multipart media type: multipart/byteranges);
# currenty these are not implemented (missing test cases). The
# code handling the range tag switches currently to full
# delivery, when multiple ranges are requested.
#
set cmd [list [self] deliver_ranges $remaining_ranges $client_data $filename $fd $channel]
}
seek $fd $from
#ns_log notice "Range seek $from $filename // $first_range"
fcopy $fd $channel -size $size -command $cmd
}
fileSpooler proc spool {{-ranges ""} {-delete false} -channel -filename -context {-client_data ""}} {
set fd [open $filename]
fconfigure $fd -translation binary
fconfigure $channel -translation binary
if {$ranges eq ""} {
ns_log notice "no Range spool for $filename"
fcopy $fd $channel -command [list [self] end-delivery -client_data $client_data $filename $fd $channel]
} else {
my deliver_ranges $ranges $client_data $filename $fd $channel
}
#ns_log notice "--- start of delivery of $filename (running:[array size ::running])"
fcopy $fd $channel -command [list [self] end-delivery -client_data $client_data $filename $fd $channel]
set key $channel,$fd,$filename
set ::running($key) $context
if {$delete} {set ::delete_file($key) 1}
......@@ -91,6 +118,9 @@ if {![string match *contentsentlength* $msg]} {
fileSpooler tick
###############
# h264Spooler
###############
#
# A first draft of a h264 pseudo streaming spooler.
# Like for the fileSpooler, we create a single spooler object
......@@ -167,6 +197,63 @@ if {![string match *contentsentlength* $msg]} {
}
}
#################
# AsyncDiskWriter
#################
::xotcl::Class create ::AsyncDiskWriter -parameter {
{blocksize 4096}
{autoflush false}
{verbose false}
}
::AsyncDiskWriter instproc log {msg} {
if {[my verbose]} {ns_log notice "[self] --- $msg"}
}
::AsyncDiskWriter instproc open {-filename {-mode w}} {
my set channel [open $filename $mode]
my set content ""
my set filename $filename
fconfigure [my set channel] -translation binary -blocking false
my log "open [my set filename]"
}
::AsyncDiskWriter instproc close {{-sync false}} {
my instvar content channel
if {$sync || [string length $content] == 0} {
my log "close sync"
if {$content ne ""} {
fconfigure $channel -translation binary -blocking true
puts -nonewline $channel $content
}
close $channel
my destroy
} else {
my log "close async"
my set finishWhenDone 1
}
}
::AsyncDiskWriter instproc async_write {block} {
my append content $block
fileevent [my set channel] writable [list [self] writeBlock]
}
::AsyncDiskWriter instproc writeBlock {} {
my instvar content blocksize channel
if {[string length $content] < $blocksize} {
puts -nonewline $channel $content
my log "write [string length $content] bytes"
fileevent [my set channel] writable ""
set content ""
if {[my autoflush]} {flush $channel}
if {[my exists finishWhenDone]} {
my close -sync true
}
} else {
set chunk [string range $content 0 [expr {$blocksize-1}]]
set content [string range $content $blocksize end]
puts -nonewline $channel $chunk
my log "write [string length $chunk] bytes ([string length $content] buffered)"
}
}
###############
# Subscriptions
......@@ -225,6 +312,11 @@ if {![string match *contentsentlength* $msg]} {
incr ::subscription_count
}
###############
# HttpSpooler
###############
Class ::HttpSpooler -parameter {channel {timeout 10000} {counter 0}}
::HttpSpooler instproc init {} {
my set running 0
......@@ -297,6 +389,19 @@ if {![string match *contentsentlength* $msg]} {
-timeout [my timeout] -post_data $post_data -request_manager [self]
}
}
#
# Add an exit handler to close all AsyncDiskWriter, when this thread goes
# down.
#
::xotcl::Object setExitHandler {
ns_log notice "--- exit handler"
foreach writer [::AsyncDiskWriter info instances -closure] {
ns_log notice "close AsyncDiskWriter $writer"
$writer close
}
}
} -persistent 1 ;# -lightweight 1
bgdelivery ad_forward running {
......@@ -340,7 +445,8 @@ bgdelivery ad_proc returnfile {
&& [info command h264open] ne ""}]
if {[info exists content_disposition]} {
ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=$content_disposition"
set fn [xo::backslash_escape \" $content_disposition]
ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=\"$fn\""
}
if {$use_h264} {
......@@ -371,18 +477,58 @@ bgdelivery ad_proc returnfile {
ns_conn keepalive 0
}
set range [ns_set iget [ns_conn headers] range]
ns_log notice "Range: '$range' (raw header field)"
if {[regexp {bytes=(.*)$} $range _ range]} {
set ranges [list]
set bytes 0
set pos 0
foreach r [split $range ,] {
regexp {^(\d*)-(\d*)$} $r _ from to
if {$from eq ""} {
# The last $to bytes, $to must be specified; 'to' is
# differently interpreted as in the case, where from is
# non-empty
set from [expr {$size - $to}]
} else {
if {$to eq ""} {set to [expr {$size-1}]}
}
set rangeSize [expr {1 + $to - $from}]
lappend ranges [list $from $to $rangeSize]
set pos [expr {$to + 1}]
incr bytes $rangeSize
}
} else {
set ranges ""
set bytes $size
}
#ns_log notice "Range=$range bytes=$bytes // $ranges"
#
# For the time being, we write the headers in a simplified version
# directly in the spooling thread to avoid the overhead of double
# h264opens.
if {!$use_h264} {
my write_headers $status_code $mime_type $size
if {[llength $ranges] == 1 && $status_code == 200} {
set first_range [lindex $ranges 0]
foreach {from to .} $first_range break
ns_set put [ns_conn outputheaders] Content-Range "bytes $from-$to/$size"
ns_log notice "added header-field Content-Range: bytes $from-$to/$size // $ranges"
set status_code 206
} elseif {[llength $ranges]>1} {
ns_log warning "Multiple ranges are currently not supported, ignoring range request"
}
my write_headers $status_code $mime_type $bytes
}
if {$size == 0} {
if {$bytes == 0} {
# Tcl behaves different, when one tries to send 0 bytes via
# file_copy. So, we handle this special case here...
# There is actualy nothing to deliver....
ns_set put [ns_conn outputheaders] "Content-Length" 0
ns_return 200 text/plain {}
return
}
......@@ -429,7 +575,7 @@ bgdelivery ad_proc returnfile {
-client_data $client_data
} else {
#my log "FILE SPOOL $filename"
my do -async ::fileSpooler spool -delete $delete -channel $ch -filename $filename \
my do -async ::fileSpooler spool -ranges $ranges -delete $delete -channel $ch -filename $filename \
-context [list [::xo::cc requestor],[::xo::cc url] [ns_conn start]] \
-client_data $client_data
}
......
tcl/context-procs.tcl
View file @ 14da75a7
......@@ -46,7 +46,9 @@ namespace eval ::xo {
set ([lindex [split [lindex $v 0] :] 0]) 1
}
if {$actual_query eq " "} {
set actual_query [ns_conn query]
if {[ns_conn isconnected]} {
set actual_query [ns_conn query]
}
#my log "--CONN ns_conn query = <$actual_query>"
}
......@@ -134,8 +136,8 @@ namespace eval ::xo {
my instvar queryparm package_id
foreach p [my array names queryparm] {
set value [my set queryparm($p)]
uplevel $level [list set $p [my set queryparm($p)]]
regsub -all : $p _ varName
uplevel $level [list set $varName [my set queryparm($p)]]
}
uplevel $level [list set package_id $package_id]
#::xo::show_stack
......@@ -176,6 +178,7 @@ namespace eval ::xo {
requestor
user
url
mobile
}
ConnectionContext proc require_package_id_from_url {{-package_id 0} url} {
......@@ -263,6 +266,14 @@ namespace eval ::xo {
::xo::cc set_user_id $user_id
::xo::cc process_query_parameter
}
# simple mobile detection
::xo::cc mobile 0
if {[ns_conn isconnected]} {
set user_agent [string tolower [ns_set get [ns_conn headers] User-Agent]]
::xo::cc mobile [regexp (android|webos|iphone|ipad) $user_agent]
}
if {![info exists ::ad_conn(charset)]} {
set ::ad_conn(charset) [lang::util::charset_for_locale $locale]
set ::ad_conn(language) [::xo::cc lang]
......@@ -450,7 +461,8 @@ namespace eval ::xo {
ConnectionContext instproc load_form_parameter {} {
my instvar form_parameter
if {[ns_conn isconnected]} {
if {[ns_conn isconnected] && [ns_conn method] eq "POST"} {
#array set form_parameter [ns_set array [ns_getform]]
foreach {att value} [ns_set array [ns_getform]] {
# For some unknown reasons, Safari 3.* returns sometimes
......@@ -465,6 +477,7 @@ namespace eval ::xo {
array set form_parameter {}
}
}
ConnectionContext instproc form_parameter {name {default ""}} {
my instvar form_parameter form_parameter_multiple
if {![info exists form_parameter]} {
......@@ -532,7 +545,7 @@ namespace eval ::xo {
set query [ns_urlencode $var]=[ns_urlencode $value]
foreach pair [split $old_query &] {
foreach {key value} [split $pair =] break
if {$key eq $var} continue
if {[ns_urldecode $key] eq $var} continue
append query &$pair
}
return $query
......
tcl/cr-procs.tcl
View file @ 14da75a7
......@@ -157,7 +157,10 @@ namespace eval ::xo::db {
}
CrClass instproc unknown { obj args } {
my log "unknown called with $obj $args"
# When this happens, this is most likely an error. Ease debugging
# by writing the call stack to the error log.
::xo::show_stack
my log "::xo::db::CrClass: unknown called with $obj $args"
}
#
......@@ -1555,7 +1558,23 @@ namespace eval ::xo::db {
# remove as well vars and array starting with "__", assuming these
# are volatile variables created by initialize_loaded_object or
# similar mechanisms
foreach x [my info vars __*] {if {[my array exists $x]} {my array unset $x} {my unset $x}}
set arrays {}
set scalars {}
foreach x [my info vars __*] {
if {[my array exists $x]} {
lappend arrays $x [my array get $x]
my array unset $x
} {
lappend scalars $x [my set $x]
my unset $x
}
}
return [list $arrays $scalars]
}
CrCache::Item instproc set_non_persistent_vars {vars} {
foreach {arrays scalars} $vars break
foreach {var value} $arrays {my array set $var $value}
foreach {var value} $scalars {my set $var $value}
}
CrCache::Item instproc flush_from_cache_and_refresh {} {
# cache only names with IDs
......@@ -1575,8 +1594,9 @@ namespace eval ::xo::db {
# session.
set mixins [$obj info mixin]
$obj mixin [list]
$obj remove_non_persistent_vars
set npv [$obj remove_non_persistent_vars]
ns_cache set xotcl_object_cache $obj [$obj serialize]
$obj set_non_persistent_vars $npv
$obj mixin $mixins
} else {
# in any case, flush the canonical name
......
tcl/http-client-procs.tcl
View file @ 14da75a7
......@@ -703,7 +703,12 @@ namespace eval ::xo {
# this case, we do not have to perform the cond-notify.
if {[my exists_status $condition] &&
[my get_status $condition] eq "COND_WAIT_REFRESH"} {
# Before, we had here COND_WAIT_TIMEOUT instead of
}
if {[my exists_status $condition] &&
( [my get_status $condition] eq "COND_WAIT_REFRESH"
|| [my get_status $condition] eq "COND_WAIT_TIMEOUT")
} {
# Before, we had here one COND_WAIT_TIMEOUT, and once
# COND_WAIT_REFRESH
my set_status $condition $status $value
catch {thread::cond notify $condition}
......
tcl/ical-procs.tcl
View file @ 14da75a7
......@@ -35,6 +35,12 @@ namespace eval ::xo {
ical proc tcl_time_to_utc {time} {
clock format [clock scan $time] -format "%Y%m%dT%H%M%SZ" -gmt 1
}
ical proc tcl_time_to_local_day {time} {
VALUE=DATE:[my clock_to_local_day [clock scan $time]]
}
ical proc utc_to_clock {utc_time} {
clock scan $utc_time -format "%Y%m%dT%H%M%SZ" -gmt 1
}
ical proc clock_to_utc {seconds} {
clock format $seconds -format "%Y%m%dT%H%M%SZ" -gmt 1
}
......@@ -80,6 +86,10 @@ namespace eval ::xo {
}
namespace eval ::xo {
#
# VCALITEM is the superclass of a VTODO and a VEVENT, intended as an
# abstract class
#
Class create ::xo::ical::VCALITEM -parameter {
creation_date
last_modified
......@@ -93,6 +103,7 @@ namespace eval ::xo {
location
geo
status
{is_day_item false}
}
::xo::ical::VCALITEM instproc tag {-tag -conv -value slot} {
......@@ -107,14 +118,43 @@ namespace eval ::xo {
}
}
if {[info exists conv]} {
return "$tag:[::xo::ical $conv $value]\n"
return "$tag:[::xo::ical $conv $value]\r\n"
} else {
return "$tag:$value\n"
return "$tag:$value\r\n"
}
return ""
}
::xo::ical::VCALITEM instproc start_end {} {
if {[my is_day_item]} {
append result \
[my tag -conv tcl_time_to_local_day dtstart] \
[my tag -conv tcl_time_to_local_day dtend]
} else {
append result \
[my tag -conv tcl_time_to_utc dtstart] \
[my tag -conv tcl_time_to_utc dtend]
}
}
::xo::ical::VCALITEM instproc as_ical {} {
set item_type [namespace tail [my info class]]
append t "BEGIN:$item_type\r\n" \
[my ical_body] \
"END:$item_type\r\n"
return $t
}
::xo::ical::VCALITEM instproc ical_body {} {
#
# The method ical_body returns the ical-formatted content of the
# variables. All variables of VEVENTs and VTODOs are listed below,
# since the names are distinct, and no methods are used.
#
# So far there is no handling for the repetition fields (which
# might occur more than once). An option would be to handle these
# as lists.
#
my instvar creation_date last_modified dtstamp
#
# All date/time stamps are provided either by
......@@ -133,8 +173,7 @@ namespace eval ::xo {
# VTODO: NEEDS-ACTION, COMPLETED, IN-PROCESS, CANCELLED
# VJOURNAL: DRAFT, FINAL, CANCELLED
set item_type [namespace tail [my info class]]
append t "BEGIN:$item_type\n" \
append t \
[my tag -conv tcl_time_to_utc -value $tcl_creation_date created] \
[my tag -conv tcl_time_to_utc -value $tcl_last_modified last-modified] \
[my tag -conv tcl_time_to_utc -value $tcl_stamp dtstamp] \
......@@ -142,16 +181,22 @@ namespace eval ::xo {
[my tag -conv tcl_time_to_utc dtend] \
[my tag -conv tcl_time_to_utc completed] \
[my tag -conv tcl_time_to_utc percent-complete] \
[my tag transp] \
[my tag uid] \
[my tag url] \
[my tag geo] \
[my tag priority] \
[my tag sequence] \
[my tag CLASS] \
[my tag location] \
[my tag status] \
[my tag -conv text_to_ical description] \
[my tag -conv text_to_ical summary] \
[my tag -conv tcl_time_to_utc due] \
"END:$item_type\n"
[my tag -conv tcl_time_to_utc due]
if {[my exists formatted_recurrences]} {
append t [my set formatted_recurrences]
}
return $t
}
#
......@@ -200,7 +245,10 @@ namespace eval ::xo {
# just a stub for now
Class create ::xo::ical::VEVENT -superclass ::xo::ical::VCALITEM -parameter {
dtend
}
sequence
transp
formatted_recurrences
}
#
# This class is designed to be a mixin for an ordered composite
......
www/show-class-graph.tcl
View file @ 14da75a7
......@@ -87,7 +87,9 @@ ad_page_contract {
lappend reduced_sc $sc
}
if {$reduced_sc eq {}} continue
append superclasses "[my dotquote $e]->[my dotquotel $reduced_sc];\n"
foreach sc $reduced_sc {
append superclasses "[my dotquote $e]->[my dotquotel $sc];\n"
}
}
set children ""
set mixins ""
......@@ -133,12 +135,12 @@ ad_page_contract {
dpi = $dpi;
rankdir = BT;
node \[$font shape=record\]; $tclasses
edge \[arrawohead=empty\]; $superclasses
edge \[arrowhead=empty\]; $superclasses
node \[color=Green,shape=ellipse,fontcolor=Blue, style=filled, fillcolor=darkseagreen1\]; $objects
edge \[color=Blue,style=dotted\]; $instances
edge \[color=Blue,style=dotted,arrowhead=normal,label=\"instance of\",fontsize=10\]; $instances
edge \[color=pink,arrowhead=diamond, style=dotted\]; $children
edge \[label=instmixin,fontsize=10,color=$imcolor,fontcolor=$imcolor,arrowhead=none,arrowtail=vee, style=dashed,dir=back, constraint=0\]; $instmixins
edge \[label=mixin,fontsize=10,color=$imcolor,fontcolor=$imcolor,arrowhead=none,arrowtail=vee, style=dashed,dir=back, constraint=0\]; $mixins
edge \[label=instmixin,fontsize=10,color=$imcolor,fontcolor=$imcolor,arrowhead=none,arrowtail=vee,style=dashed,dir=back,constraint=0\]; $instmixins
edge \[label=mixin,fontsize=10,color=$imcolor,fontcolor=$imcolor,arrowhead=none,arrowtail=vee,style=dashed,dir=back,constraint=0\]; $mixins
}"
}
......@@ -152,9 +154,11 @@ catch {set dot [::util::which dot]}
if {$dot eq "" && [file executable /usr/bin/dot]} {set dot /usr/bin/dot}
if {$dot eq ""} {ns_return 404 plain/text "do dot found"; ad_script_abort}
set tmpfile [ns_tmpnam].png
set f [open "|$dot -Tpng -o $tmpfile" w]
puts $f $dot_code
close $f
set tmpnam [ns_tmpnam]
set tmpfile $tmpnam.png
set f [open "|$dot -Tpng -o $tmpfile" w]; puts $f $dot_code; close $f
ns_returnfile 200 [ns_guesstype $tmpfile] $tmpfile
file delete $tmpfile
\ No newline at end of file
file delete $tmpfile
#set f [open $tmpnam.dot w]; puts $f $dot_code; close $f
#file delete $tmpnam.dot
xotcl-core.info
View file @ 14da75a7
......@@ -10,7 +10,7 @@
<inherit-templates-p>t</inherit-templates-p>
<auto-mount>xotcl</auto-mount>
<version name="0.118" url="http://media.wu-wien.ac.at/download/xotcl-core-0.118.apm">
<version name="0.124" url="http://media.wu-wien.ac.at/download/xotcl-core-0.124.apm">
<owner url="mailto:neumann@wu-wien.ac.at">Gustaf Neumann</owner>
<summary>XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)</summary>
<release-date>2011-01-14</release-date>
......@@ -43,7 +43,8 @@ when components are reloaded.
<license>BSD-Style</license>
<maturity>0</maturity>
<provides url="xotcl-core" version="0.118"/>
<provides url="xotcl-core" version="0.124"/>
<requires url="acs-kernel" version="5.2.0"/>
<callbacks>
<callback type="before-install" proc="::xotcl-core::before_install_callback"/>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment