- Upgrade XoTCL Core to 0.124

tcl/01-debug-procs.tcl

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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
+file delete $tmpfile
\ No newline at end of file
+
+#set f [open $tmpnam.dot w]; puts $f $dot_code; close $f
+#file delete $tmpnam.dot

xotcl-core.info

@@ -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"/>