Index: openacs-4/packages/xotcl-core/xotcl-core.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v
diff -u -N -r1.47 -r1.47.2.1
--- openacs-4/packages/xotcl-core/xotcl-core.info 14 Mar 2008 20:04:57 -0000 1.47
+++ openacs-4/packages/xotcl-core/xotcl-core.info 18 Jun 2008 06:51:18 -0000 1.47.2.1
@@ -8,10 +8,10 @@
t
xotcl
-
+
Gustaf Neumann
XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)
- 2008-03-14
+ 2008-04-05
Gustaf Neumann, WU Wien
This component contains some core functionality for OACS
applications using XOTcl. It includes
@@ -41,7 +41,7 @@
BSD-Style
0
-
+
Index: openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl,v
diff -u -N -r1.25 -r1.25.2.1
--- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 27 Sep 2007 10:40:05 -0000 1.25
+++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 18 Jun 2008 06:51:18 -0000 1.25.2.1
@@ -169,9 +169,14 @@
::xotcl::Object instproc debug msg {
ns_log debug "[self] [self callingclass]->[self callingproc]: $msg"
}
-::xotcl::Object instproc msg msg {
+::xotcl::Object instproc msg {{-html false} msg} {
if {[ns_conn isconnected]} {
- util_user_message -message "$msg ([self] [self callingclass]->[self callingproc])"
+ set msg "$msg ([self] [self callingclass]->[self callingproc])"
+ if {$html} {
+ util_user_message -html -message $msg
+ } else {
+ util_user_message -message $msg
+ }
}
}
::xotcl::Object instproc qn query_name {
Index: openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl,v
diff -u -N -r1.58.2.7 -r1.58.2.8
--- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 6 May 2008 12:38:45 -0000 1.58.2.7
+++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 18 Jun 2008 06:51:18 -0000 1.58.2.8
@@ -233,7 +233,7 @@
switch -- $type {
string { set type text }
long_text { set type text }
- date { set type timestampz }
+ date { set type "timestamp with time zone" }
ltree { set type [expr {[::xo::db::has_ltree] ? "ltree" : "text" }] }
}
return $type
@@ -362,6 +362,7 @@
{security_inherit_p t}
{auto_save false}
{with_table true}
+ {sql_package_name "[namespace tail [self]]"}
} -ad_doc {
::xo::db::Class is a meta class for interfacing with acs_object_types.
acs_object_types are instances of this meta class. The meta class defines
@@ -845,7 +846,7 @@
my log "We cannot handle object_name = '$object_name' in this version"
return
}
- set package_name [namespace tail [self]]
+ set package_name [my sql_package_name]
set sql_command [my generate_psql $package_name $object_name]
set proc_body [my generate_proc_body]
@@ -1000,7 +1001,8 @@
-table_name $table_name \
-id_column $id_column \
-abstract_p $abstract_p \
- -name_method $name_method
+ -name_method $name_method \
+ -package_name [my sql_package_name]
}
::xo::db::Class ad_instproc drop_object_type {{-cascade true}} {
@@ -1130,6 +1132,11 @@
Use namespaces for classes."
}
}
+
+ if {[string length [my sql_package_name]] > 31} {
+ error "SQL package_name '[my sql_package_name]' can be maximal 31 characters"
+ }
+
if {![my exists id_column]} {
my set id_column [string tolower [namespace tail [self]]]_id
set id_column_error_tail ", or use different class names"
Index: openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl,v
diff -u -N -r1.6.2.2 -r1.6.2.3
--- openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 6 May 2008 12:38:45 -0000 1.6.2.2
+++ openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 18 Jun 2008 06:51:18 -0000 1.6.2.3
@@ -312,7 +312,7 @@
-sql [::xo::db::apm_parameter instance_select_query] \
-object_class ::xo::db::apm_parameter \
-as_ordered_composite false -named_objects true -destroy_on_cleanup false
- #ns_log debug "--p got [llength [::xo::db::apm_parameter info instances]] parameters"
+ ns_log notice "--p got [llength [::xo::db::apm_parameter info instances]] parameters"
#foreach p [::xo::db::apm_parameter info instances] { ns_log notice [$p serialize] }
parameter proc initialize_parameters {} {
@@ -325,7 +325,7 @@
where p.parameter_id = v.parameter_id
and coalesce(attr_value,'') <> coalesce(p.default_value,'')
} {
- ns_log debug "--p $parameter_id $package_key $package_id $parameter_name <$attr_value>"
+ ns_log notice "--p $parameter_id $package_key $package_id $parameter_name <$attr_value>"
$parameter_id set_per_package_instance_value $package_id $attr_value
}
}
@@ -403,4 +403,4 @@
# $p save
# $p delete
-}
+}
\ No newline at end of file
Index: openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl,v
diff -u -N -r1.8 -r1.8.2.1
--- openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl 14 Jul 2007 17:59:08 -0000 1.8
+++ openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl 18 Jun 2008 06:51:18 -0000 1.8.2.1
@@ -97,16 +97,9 @@
}
################## main thread support ##################
-#::xotcl::RecreationClass create ::xotcl::THREAD \
-# -instrecreate 1 \
-# -parameter {{persistent 0}}
-
Class create ::xotcl::THREAD \
-parameter {{persistent 0} {lightweight 0}}
-#Class create ::xotcl::THREAD \
-# -parameter {{persistent 0}}
-
::xotcl::THREAD instproc check_blueprint {} {
if {![[self class] exists __blueprint_checked]} {
if {[string first ::xotcl::THREAD [ns_ictl get]] == -1} {
@@ -117,7 +110,9 @@
}
::xotcl::THREAD instproc init cmd {
+ if {$cmd eq "-noinit"} {return}
my instvar initcmd
+ #ns_log notice "+++ THREAD cmd='$cmd', epoch=[ns_ictl epoch]"
if {![ns_ictl epoch]} {
#ns_log notice "--THREAD init [self] no epoch"
Index: openacs-4/packages/xotcl-core/tcl/context-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/context-procs.tcl,v
diff -u -N -r1.33.2.3 -r1.33.2.4
--- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 19 May 2008 13:51:23 -0000 1.33.2.3
+++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 18 Jun 2008 06:51:18 -0000 1.33.2.4
@@ -189,12 +189,13 @@
#my log "--CONN ns_conn url"
set url [ns_conn url]
}
- #my log "--i [self args] URL='$url'"
+ #my log "--i [self args] URL='$url', pkg=$package_id"
# create connection context if necessary
if {$package_id == 0} {
array set "" [site_node::get_from_url -url $url]
set package_id $(package_id)
+ #my log "--i setting pkg tp $package_id"
}
# get locale; TODO at some time, we should get rid of the ad_conn init problem
@@ -217,16 +218,20 @@
-actual_query $actual_query \
-locale $locale \
-url $url
+ #::xo::show_stack
#my log "--cc ::xo::cc created $url [::xo::cc serialize]"
::xo::cc destroy_on_cleanup
} else {
- #my log "--cc ::xo::cc reused $url"
+ #my log "--cc ::xo::cc reused $url -package_id $package_id"
::xo::cc configure \
- -package_id $package_id \
-url $url \
-actual_query $actual_query \
-locale $locale \
[list -parameter_declaration $parameter]
+ #if {$package_id ne ""} {
+ # ::xo::cc package_id $package_id
+ #}
+ ::xo::cc package_id $package_id
::xo::cc set_user_id $user_id
::xo::cc process_query_parameter
}
@@ -444,6 +449,4 @@
return $query
}
-
-}
-
+}
\ No newline at end of file
Index: openacs-4/packages/xotcl-core/tcl/cr-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/cr-procs.tcl,v
diff -u -N -r1.16.2.1 -r1.16.2.2
--- openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 10 Apr 2008 08:16:25 -0000 1.16.2.1
+++ openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 18 Jun 2008 06:51:18 -0000 1.16.2.2
@@ -594,7 +594,7 @@
@param with_subtypes return subtypes as well
@param count return the query for counting the solutions
@param folder_id parent_id
- @param publish_status one of 'live', 'ready' or 'production'
+ @param publish_status one of 'live', 'ready', or 'production'
@param base_table typically automatic view, must contain title and revision_id
@return sql query
} {
@@ -824,7 +824,7 @@
lappend values $v
}
return "insert into [my set table_name]i ([join $attributes ,]) \
- values ([join $values ,])"
+ values (:[join $values ,:])"
}
CrItem instproc fix_content {{-only_text false} revision_id content} {
@@ -873,8 +873,8 @@
set sql "update [$domain table_name] \
set $att = :value \
where [$domain id_column] = $revision_id"
+ db_dml [my qn update_attribute-$att] $sql
}
- db_dml [my qn update_attribute-$att] $sql
}
}
Index: openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl,v
diff -u -N -r1.7.2.1 -r1.7.2.2
--- openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl 26 Mar 2008 13:44:45 -0000 1.7.2.1
+++ openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl 18 Jun 2008 06:51:18 -0000 1.7.2.2
@@ -1,5 +1,7 @@
ad_library {
- XOTcl implementation for synchronous and asynchronous HTTP and HTTPs requests
+
+ XOTcl implementation for synchronous and asynchronous
+ HTTP and HTTPS requests
@author Gustaf Neumann, Stefan Sobernig
@creation-date 2007-10-05
@@ -9,10 +11,11 @@
namespace eval ::xo {
#
# Defined classes
- # 1) HttpRequest
- # 2) AsyncHttpRequest
- # 3) HttpRequestTrace (mixin class)
- # 4) Tls (mixin class, applicable to various protocols)
+ # 1) HttpCore (common base class)
+ # 2) HttpRequest (for blocking requests + timeout support)
+ # 3) AsyncHttpRequest (for non-blocking requests + timeout support)
+ # 4) HttpRequestTrace (mixin class)
+ # 5) Tls (mixin class, applicable to various protocols)
#
######################
#
@@ -38,9 +41,27 @@
# set r [::xo::HttpRequest new \
# -url http://yourhost.yourdomain/yourpath \
# -post_data [export_vars {var1 var2}] \
- # -content_type application/x-www-form-urlencoded \
- # ]
+ # -content_type application/x-www-form-urlencoded]
#
+ # More recently, we added timeout support for blocking http
+ # requests. By passing a timeout parameter, you gain control
+ # on the total roundtrip time (in milliseconds, ms):
+ #
+ # set r [::xo::HttpRequest new \
+ # -url http://www.openacs.org/ \
+ # -timeout 1500]
+ #
+ # Please, make sure that you use a recent distribution of tclthread
+ # ( > 2.6.5 ) to have the blocking-timeout feature working
+ # safely. This newly introduced feature makes use of advanced thread
+ # synchronisation offered by tclthread that needed to be fixed in
+ # tclthread <= 2.6.5. At the time of this writing, there was no
+ # post-2.6.5 release of tclthread, hence, you are required to obtain a
+ # CVS snapshot, dating at least 2008-05-23. E.g.:
+ #
+ # cvs -z3 -d:pserver:anonymous@tcl.cvs.sourceforge.net:/cvsroot/tcl co \
+ # -D 20080523 -d thread2.6.5~20080523 thread
+ #
# Provided that the Tcl module tls (see e.g. http://tls.sourceforge.net/)
# is available and can be loaded via "package require tls" into
# the aolserver, you can use both TLS/SSL secured or unsecured requests
@@ -53,7 +74,7 @@
#
# 2 AsyncHttpRequest
#
- # AsyncHttpRequest is a subclass for HttpRequest implementing
+ # AsyncHttpRequest is a subclass for HttpCore implementing
# asynchronous HTTP requests without vwait (vwait causes
# stalls on aolserver). AsyncHttpRequest requires to provide a listener
# or callback object that will be notified upon success or failure of
@@ -78,9 +99,17 @@
# the other upon failure or cancellation (done).
#
# ::bgdelivery do Object ::listener \
- # -proc deliver {payload obj} {
- # my log "Asynchronous request suceeded!"
- # } -proc done {reason obj} {
+ # -proc start_request {payload obj} {
+ # my log "request $obj started"
+ # } -proc request_data {payload obj} {
+ # my log "partial or complete post"
+ # } -proc start_reply {payload obj} {
+ # my log "reply $obj started"
+ # } -proc reply_data {payload obj} {
+ # my log "partial or complete delivery"
+ # } -proc success {data obj} {
+ # my log "Asynchronous request successfully completed"
+ # } -proc failure {reason obj} {
# my log "Asynchronous request failed: $reason"
# }
#
@@ -96,40 +125,109 @@
#
# 3 HttpRequestTrace
#
- # HttpRequestTrace can be used to trace the one or all requests.
+ # HttpRequestTrace can be used to trace one or all requests.
# If activated, the class writes protocol data into
# /tmp/req-.
#
# Use
#
- # ::xo::HttpRequest instmixin add ::xo::HttpRequestTrace
+ # ::xo::HttpCore instmixin add ::xo::HttpRequestTrace
#
# to activate trace for all requests,
# or mixin the class into a single request to trace it.
#
- Class create HttpRequest \
- -parameter {
- {host}
- {protocol http}
- {port}
- {path /}
- {url}
- {post_data ""}
- {content_type text/plain}
- {request_manager}
- {request_header_fields {}}
- {user_agent xohttp/0.1}
+ Class create HttpCore \
+ -slots {
+ Attribute host
+ Attribute protocol -default "http"
+ Attribute port
+ Attribute path -default "/"
+ Attribute url
+ Attribute post_data -default ""
+ Attribute content_type -default "text/plain"
+ Attribute request_header_fields -default {}
+ Attribute user_agent -default "xohttp/0.2"
}
- HttpRequest instproc set_default_port {protocol} {
+ # Provide for mapping from HTTP charset encoding labels
+ # to Tcl-specific ones (see http://naviserver.cvs.sourceforge.net/naviserver/naviserver/nsd/encoding.c?view=markup)
+
+ HttpCore array set http_to_tcl_encodings {
+ iso-2022-jp iso2022-jp
+ iso-2022-kr iso2022-kr
+ iso-8859-1 iso8859-1
+ iso-8859-2 iso8859-2
+ iso-8859-3 iso8859-3
+ iso-8859-4 iso8859-4
+ iso-8859-5 iso8859-5
+ iso-8859-6 iso8859-6
+ iso-8859-7 iso8859-7
+ iso-8859-8 iso8859-8
+ iso-8859-9 iso8859-9
+ korean ksc5601
+ ksc_5601 ksc5601
+ mac macRoman
+ mac-centeuro macCentEuro
+ mac-centraleupore macCentEuro
+ mac-croatian macCroatian
+ mac-cyrillic macCyrillic
+ mac-greek macGreek
+ mac-iceland macIceland
+ mac-japan macJapan
+ mac-roman macRoman
+ mac-romania macRomania
+ mac-thai macThai
+ mac-turkish macTurkish
+ mac-ukraine macUkraine
+ maccenteuro macCentEuro
+ maccentraleupore macCentEuro
+ maccroatian macCroatian
+ maccyrillic macCyrillic
+ macgreek macGreek
+ maciceland macIceland
+ macintosh macRoman
+ macjapan macJapan
+ macroman macRoman
+ macromania macRomania
+ macthai macThai
+ macturkish macTurkish
+ macukraine macUkraine
+ shift_jis shiftjis
+ us-ascii ascii
+ windows-1250 cp1250
+ windows-1251 cp1251
+ windows-1252 cp1252
+ windows-1253 cp1253
+ windows-1254 cp1254
+ windows-1255 cp1255
+ windows-1256 cp1256
+ windows-1257 cp1257
+ windows-1258 cp1258
+ x-mac macRoman
+ x-mac-centeuro macCentEuro
+ x-mac-centraleupore macCentEuro
+ x-mac-croatian macCroatian
+ x-mac-cyrillic macCyrillic
+ x-mac-greek macGreek
+ x-mac-iceland macIceland
+ x-mac-japan macJapan
+ x-mac-roman macRoman
+ x-mac-romania macRomania
+ x-mac-thai macThai
+ x-mac-turkish macTurkish
+ x-mac-ukraine macUkraine
+ x-macintosh macRoman
+ }
+
+ HttpCore instproc set_default_port {protocol} {
switch $protocol {
http {my set port 80}
https {my set port 443}
}
}
- HttpRequest instproc parse_url {} {
+ HttpCore instproc parse_url {} {
my instvar protocol url host port path
if {[regexp {^(http|https)://([^/]+)(/.*)?$} $url _ protocol host path]} {
# Be friendly and allow strictly speaking invalid urls
@@ -142,21 +240,29 @@
}
}
- HttpRequest instproc open_connection {} {
+ HttpCore instproc open_connection {} {
my instvar host port S
- set S [socket $host $port]
+ set S [socket -async $host $port]
}
- HttpRequest instproc set_encoding {
+ HttpCore instproc set_encoding {
{-text_translation {auto binary}}
content_type
} {
#
- # for text, use translation with optional encodings, else set translation binary
+ # for text, use translation with optional encodings,
+ # else set translation binary
#
if {[string match "text/*" $content_type]} {
if {[regexp {charset=([^ ]+)$} $content_type _ encoding]} {
- fconfigure [my set S] -translation $text_translation -encoding [string tolower $encoding]
+ [self class] instvar http_to_tcl_encodings
+ set enc [string tolower $encoding]
+ if {[info exists http_to_tcl_encodings($enc)]} {
+ set enc $http_to_tcl_encodings($enc)
+ }
+ fconfigure [my set S] \
+ -translation $text_translation \
+ -encoding $enc
} else {
fconfigure [my set S] -translation $text_translation
}
@@ -165,7 +271,7 @@
}
}
- HttpRequest instproc init {} {
+ HttpCore instproc init {} {
my instvar S post_data host port protocol
my destroy_on_cleanup
my set meta [list]
@@ -193,6 +299,10 @@
my cancel "error during open connection via $protocol to $host $port: $err"
return
}
+ }
+
+ HttpCore instproc send_request {} {
+ my instvar S post_data host
if {[catch {
set method [expr {$post_data eq "" ? "GET" : "POST"}]
puts $S "$method [my path] HTTP/1.0"
@@ -206,61 +316,62 @@
}
my $method
} err]} {
- my cancel "error send $host $port: $err"
+ my cancel "error send $host [my port]: $err"
return
}
}
- HttpRequest instproc GET {} {
+ HttpCore instproc GET {} {
my instvar S
puts $S ""
- my query_done
+ my request_done
}
- HttpRequest instproc POST {} {
+ HttpCore instproc POST {} {
my instvar S post_data
puts $S "Content-Length: [string length $post_data]"
puts $S "Content-Type: [my content_type]"
puts $S ""
- #fconfigure $S -translation {auto binary}
my set_encoding [my content_type]
+ my send_POST_data
+ }
+ HttpCore instproc send_POST_data {} {
+ my instvar S post_data
puts -nonewline $S $post_data
- my query_done
+ my request_done
}
- HttpRequest instproc query_done {} {
+ HttpCore instproc request_done {} {
my instvar S
flush $S
- my received_first_line
+ my reply_first_line
}
- HttpRequest instproc notify {method arg} {
- if {[my exists request_manager]} {
- [my request_manager] $method $arg [self]
- }
- }
- HttpRequest instproc cancel {reason} {
- my log "--- $reason"
+
+ HttpCore instproc close {} {
+ my debug "--- closing socket"
catch {close [my set S]}
- my notify done $reason
}
- HttpRequest instproc finish {} {
- catch {close [my set S]}
- my log "--- [my host] [my port] [my path] has finished"
- my notify deliver [my set data]
+ HttpCore instproc cancel {reason} {
+ my debug "--- $reason"
+ my close
}
- HttpRequest instproc getLine {var} {
+
+ HttpCore instproc finish {} {
+ my close
+ my debug "--- [my host] [my port] [my path] has finished"
+ }
+ HttpCore instproc getLine {var} {
my upvar $var response
my instvar S
set n [gets $S response]
if {[eof $S]} {
my log "--premature eof"
return -2
}
- if {$n == -1} {my log "--input pending, no full line"; return -1}
- #my log "got $response"
+ if {$n == -1} {my debug "--input pending, no full line"; return -1}
return $n
}
- HttpRequest instproc received_first_line {} {
+ HttpCore instproc reply_first_line {} {
my instvar S status_code
fconfigure $S -translation crlf
set n [my getLine response]
@@ -270,24 +381,24 @@
}
if {[regexp {^HTTP/([0-9.]+) +([0-9]+) *} $response _ \
responseHttpVersion status_code]} {
- my received_first_line_done
+ my reply_first_line_done
} else {
my log "--unexpected response '$response'"
my cancel unexpected-response
}
}
- HttpRequest instproc received_first_line_done {} {
+ HttpCore instproc reply_first_line_done {} {
my header
}
- HttpRequest instproc header {} {
+ HttpCore instproc header {} {
while {1} {
set n [my getLine response]
switch -exact -- $n {
-2 {my cancel premature-eof; return}
-1 {continue}
0 {break}
default {
- #my log "--header $response"
+ #my debug "--header $response"
if {[regexp -nocase {^content-length:(.+)$} $response _ length]} {
my set content_length [string trim $length]
} elseif {[regexp -nocase {^content-type:(.+)$} $response _ type]} {
@@ -299,10 +410,11 @@
}
}
}
- my received_header_done
+ my reply_header_done
}
- HttpRequest instproc received_header_done {} {
- # we have received the header, including potentially the content_type of the returned data
+ HttpCore instproc reply_header_done {} {
+ # we have received the header, including potentially the
+ # content_type of the returned data
my set_encoding [my content_type]
if {[my exists content_length]} {
my set data [read [my set S] [my set content_length]]
@@ -311,56 +423,282 @@
}
}
+ HttpCore instproc set_status {key newStatus {value ""}} {
+ nsv_set bgdelivery $key [list $newStatus $value]
+ }
+
+ HttpCore instproc unset_status {key} {
+ nsv_unset bgdelivery $key
+ }
+
+ HttpCore instproc exists_status {key} {
+ return [nsv_exists bgdelivery $key]
+ }
+
+ HttpCore instproc get_status {key} {
+ return [lindex [nsv_get bgdelivery $key] 0]
+ }
+
+ HttpCore instproc get_value_for_status {key} {
+ return [lindex [nsv_get bgdelivery $key] 1]
+ }
+
+
+
#
- # Asynchronous requests
+ # Synchronous (blocking) requests
#
- Class AsyncHttpRequest -superclass HttpRequest -parameter {
- {timeout 10000}
+ Class HttpRequest -superclass HttpCore -slots {
+ Attribute timeout -type integer
}
+
+ HttpRequest instproc init {} {
+ if {[my exists timeout] && [my timeout] > 0} {
+ # create a cond and mutex
+ set cond [thread::cond create]
+ set mutex [thread::mutex create]
+
+ thread::mutex lock $mutex
+
+ # start the asynchronous request
+ my log "--a create new ::xo::AsyncHttpRequest"
+ set req [bgdelivery do -async ::xo::AsyncHttpRequest new \
+ -mixin ::xo::AsyncHttpRequest::RequestManager \
+ -url [my url] \
+ -timeout [my timeout] \
+ -post_data [my post_data] \
+ -request_header_fields [my request_header_fields] \
+ -content_type [my content_type] \
+ -user_agent [my user_agent] \
+ -condition $cond]
+
+ while {1} {
+ my set_status $cond COND_WAIT_TIMEOUT
+ thread::cond wait $cond $mutex [my timeout]
+
+ set status [my get_status $cond]
+ my log "status after cond-wait $status"
+
+ if {$status ne "COND_WAIT_REFRESH"} break
+ }
+ if {$status eq "COND_WAIT_TIMEOUT"} {
+ my set_status $cond "COND_WAIT_CANCELED"
+ }
+ set status_value [my get_value_for_status $cond]
+ if {$status eq "JOB_COMPLETED"} {
+ my set data $status_value
+ } else {
+ set msg "Timeout-constraint, blocking HTTP request failed. Reason: '$status'"
+ if {$status_value ne ""} {
+ append msg " ($status_value)"
+ }
+ error $msg
+ }
+ thread::cond destroy $cond
+ thread::mutex unlock $mutex
+ thread::mutex destroy $mutex
+ my unset_status $cond
+ } else {
+ next;# HttpCore->init()
+ my send_request
+ #
+ # test whether open_connection yielded
+ # a socket ...
+ #
+ if {[my exists S]} {
+ my send_request
+ }
+ }
+ }
+
+ #
+ # Asynchronous (non-blocking) requests
+ #
+
+ Class AsyncHttpRequest -superclass HttpCore -slots {
+ Attribute timeout -type integer -default 10000 ;# 10 seconds
+ Attribute request_manager
+ }
+ AsyncHttpRequest instproc set_timeout {} {
+ my log "--a"
+ my cancel_timeout
+ my debug "--- setting socket timeout: [my set timeout]"
+ my set timeout_handle [after [my set timeout] [self] cancel timeout]
+ }
+ AsyncHttpRequest instproc cancel_timeout {} {
+ if {[my exists timeout_handle]} {
+ after cancel [my set timeout_handle]
+ }
+ }
+ AsyncHttpRequest instproc send_request {} {
+ my log "--a"
+ # remove fileevent handler explicitly
+ fileevent [my set S] writable {}
+ next
+ }
AsyncHttpRequest instproc init {} {
- my set to_identifier [after [my set timeout] [self] cancel timeout]
+ my log "--a"
+ my notify start_request
+ my set_timeout
next
+ #
+ # test whether open_connection yielded
+ # a socket ...
+ #
+ if {[my exists S]} {
+ fileevent [my set S] writable [list [self] send_request]
+ }
}
+ AsyncHttpRequest instproc notify {method {arg ""}} {
+ if {[my exists request_manager]} {
+ [my request_manager] $method $arg [self]
+ }
+ }
AsyncHttpRequest instproc POST {} {
if {[my exists S]} {fconfigure [my set S] -blocking false}
+ fileevent [my set S] writable [list [self] send_POST_data]
+ my set bytes_sent 0
next
}
+ AsyncHttpRequest instproc send_POST_data {} {
+ my instvar S post_data bytes_sent
+ my set_timeout
+ set l [string length $post_data]
+ if {$bytes_sent < $l} {
+ set to_send [expr {$l - $bytes_sent}]
+ set block_size [expr {$to_send < 4096 ? $to_send : 4096}]
+ set bytes_sent_1 [expr {$bytes_sent + $block_size}]
+ set block [string range $post_data $bytes_sent $bytes_sent_1]
+ my notify request_data $block
+ puts -nonewline $S $block
+ set bytes_sent $bytes_sent_1
+ } else {
+ fileevent $S writable ""
+ my request_done
+ }
+ }
AsyncHttpRequest instproc cancel {reason} {
if {$reason ne "timeout"} {
- after cancel [my set to_identifier]
+ my cancel_timeout
}
next
+ my debug "--- canceled for $reason"
+ my notify failure $reason
}
AsyncHttpRequest instproc finish {} {
- after cancel [my set to_identifier]
+ my log "--a"
+ my cancel_timeout
next
+ my debug "--- finished data [my set data]"
+ my notify success [my set data]
}
- AsyncHttpRequest instproc query_done {} {
+ AsyncHttpRequest instproc request_done {} {
+ my log "--a"
+ my notify start_reply
+ my set_timeout
my instvar S
flush $S
fconfigure $S -blocking false
- fileevent $S readable [list [self] received_first_line]
+ fileevent $S readable [list [self] reply_first_line]
}
- AsyncHttpRequest instproc received_first_line_done {} {
- fileevent [my set S] readable [list [self] header]
+ AsyncHttpRequest instproc reply_first_line_done {} {
+ my log "--a"
+ my set_timeout
+ my instvar S
+ fileevent $S readable [list [self] header]
}
- AsyncHttpRequest instproc received_header_done {} {
- # we have received the header, including potentially the content_type of the returned data
+ AsyncHttpRequest instproc reply_header_done {} {
+ my log "--a"
+ my set_timeout
+ # we have received the header, including potentially the
+ # content_type of the returned data
my set_encoding [my content_type]
- fileevent [my set S] readable [list [self] received_data]
+ fileevent [my set S] readable [list [self] receive_reply_data]
}
- AsyncHttpRequest instproc received_data {} {
+ AsyncHttpRequest instproc receive_reply_data {} {
+ my log "--a"
my instvar S
+ my log "JOB receive_reply_data eof=[eof $S]"
if {[eof $S]} {
my finish
} else {
+ my set_timeout
set block [read $S]
+ my notify reply_data $block
my append data $block
- #my log "reveived [string length $block] bytes"
+ #my debug "reveived [string length $block] bytes"
}
}
+ #
+ # Mixin class, used to turn instances of
+ # AsyncHttpRequest into result callbacks
+ # in the scope of bgdelivery, realising
+ # the blocking-timeout feature ...
+ #
+
+ Class create AsyncHttpRequest::RequestManager \
+ -slots {
+ Attribute condition
+ } -instproc finalize {obj status value} {
+ # set the result and do the notify
+ my instvar condition
+ # If a job was canceled, the status variable might not exist
+ # anymore, the condition might be already gone as well. In
+ # this case, we do not have to perform the cond-notify.
+ if {[my exists_status $condition] &&
+ [my get_status $condition] eq "COND_WAIT_TIMEOUT"} {
+ my set_status $condition $status $value
+ catch {thread::cond notify $condition}
+ $obj debug "--- destroying after finish"
+ $obj destroy
+ }
+
+ } -instproc set_cond_timeout {} {
+ my instvar condition
+ if {[my exists_status $condition] &&
+ [my get_status $condition] eq "COND_WAIT_TIMEOUT"} {
+ my set_status $condition COND_WAIT_REFRESH
+ catch {thread::cond notify $condition}
+ }
+
+ } -instproc start_request {payload obj} {
+ my log "JOB start request $obj"
+ my set_cond_timeout
+
+ } -instproc request_data {payload obj} {
+ my log "JOB request data $obj [string length $payload]"
+ my set_cond_timeout
+
+ } -instproc start_reply {payload obj} {
+ my log "JOB start reply $obj"
+ my set_cond_timeout
+
+ } -instproc reply_data {payload obj} {
+ my log "JOB reply data $obj [string length $payload]"
+ my set_cond_timeout
+
+ } -instproc success {payload obj} {
+ my finalize $obj "JOB_COMPLETED" $payload
+
+ } -instproc failure {reason obj} {
+ my finalize $obj "JOB_FAILED" $reason
+
+ } -instproc init {} {
+ # register request object as its own request_manager
+ my request_manager [self]
+ next
+
+ } -instproc cancel {reason} {
+ next
+ my debug "--- destroying after cancel"
+ my destroy
+
+ } -instproc unknown {method args} {
+ my log "UNKNOWN $method"
+ }
+
#
# TLS/SSL support
#
@@ -430,5 +768,5 @@
# To activate trace for all requests, uncomment the following line.
# To trace a single request, mixin ::xo::HttpRequestTrace into the request.
#
- # HttpRequest instmixin add ::xo::HttpRequestTrace
+ # HttpCore instmixin add ::xo::HttpRequestTrace
}
Index: openacs-4/packages/xotcl-core/tcl/ical-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/ical-procs.tcl,v
diff -u -N -r1.2 -r1.2.2.1
--- openacs-4/packages/xotcl-core/tcl/ical-procs.tcl 3 Dec 2007 11:21:15 -0000 1.2
+++ openacs-4/packages/xotcl-core/tcl/ical-procs.tcl 18 Jun 2008 06:51:18 -0000 1.2.2.1
@@ -13,7 +13,7 @@
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 the xul-file for thunderbird or firefox).
+ calendar (Sunbird, or Lightning for Thunderbird).
@author Gustaf Neumann
}
@@ -32,6 +32,9 @@
set TZ [expr {$utc ? "GMT" : ""}]
return [clock scan "$year-$month-$day $hour:$min $TZ"]
}
+ ical proc tcl_time_to_utc {time} {
+ clock format [clock scan $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
}
@@ -74,4 +77,320 @@
return $text
}
-}
\ No newline at end of file
+}
+
+namespace eval ::xo {
+ Class create ::xo::ical::VCALITEM -parameter {
+ creation_date
+ last_modified
+ dtstart
+ dtstamp
+ uid
+ priority
+ summary
+ url
+ description
+ location
+ geo
+ status
+ }
+
+ ::xo::ical::VCALITEM instproc tag {-tag -conv -value slot} {
+ if {![info exists tag]} {
+ set tag [string toupper $slot]
+ }
+ if {![info exists value]} {
+ if {[my exists $slot]} {
+ set value [my $slot]
+ } else {
+ return ""
+ }
+ }
+ if {[info exists conv]} {
+ return "$tag:[::xo::ical $conv $value]\n"
+ } else {
+ return "$tag:$value\n"
+ }
+ return ""
+ }
+
+ ::xo::ical::VCALITEM instproc as_ical {} {
+ my instvar creation_date last_modified dtstamp
+ #
+ # All date/time stamps are provided either by
+ # the ANSI date (from postgres) or by a date
+ # which can be processed via clock scan
+ #
+ if {![info exists dtstamp]} {set dtstamp $creation_date}
+ if {![info exists last_modified]} {set last_modified $dtstamp}
+
+ set tcl_stamp [::xo::db::tcl_date $dtstamp tz]
+ set tcl_creation_date [::xo::db::tcl_date $creation_date tz]
+ set tcl_last_modified [::xo::db::tcl_date $last_modified tz]
+
+ # status values:
+ # VEVENT: TENTATIVE, CONFIRMED, CANCELLED
+ # 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" \
+ [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] \
+ [my tag -conv tcl_time_to_utc dtstart] \
+ [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 uid] \
+ [my tag url] \
+ [my tag geo] \
+ [my tag priority] \
+ [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"
+ return $t
+ }
+ #
+ # VTODO
+ #
+ # optional fields, must not occur more than once
+ #
+ # class / *completed / *created / *description / *dtstamp /
+ # *dtstart / *geo / *last-mod / *location / organizer /
+ # *percent-complete / *priority / recurid / seq / *status /
+ # *summary / *uid / *url /
+ #
+ # optional, but mutual exclusive
+ # *due / duration /
+ #
+ # optional fields, may occur more than once
+ #
+ # attach / attendee / categories / comment / contact /
+ # exdate / exrule / rstatus / related / resources /
+ # rdate / rrule / x-prop
+
+ Class create ::xo::ical::VTODO -superclass ::xo::ical::VCALITEM -parameter {
+ due
+ completed
+ percent-complete
+ }
+ #
+ # VEVENT
+ #
+ # optional fields, must not occur more than once
+ #
+ # class / *created / *description / *dtstart / *geo /
+ # *last-mod / *location / organizer / *priority /
+ # *dtstamp / seq / *status / *summary / transp /
+ # *uid / *url / recurid /
+ #
+ # dtend or duration may appear, but dtend and duration are mutual exclusive
+ # *dtend / duration /
+ #
+ # optional fields, may occur more than once
+ #
+ # attach / attendee / categories / comment / contact /
+ # exdate / exrule / rstatus / related / resources /
+ # rdate / rrule / x-prop
+ #
+ # just a stub for now
+ Class create ::xo::ical::VEVENT -superclass ::xo::ical::VCALITEM -parameter {
+ dtend
+ }
+
+ #
+ # This class is designed to be a mixin for an ordered composite
+ #
+ Class create ::xo::ical::VCALENDAR -parameter {prodid version method}
+ ::xo::ical::VCALENDAR instproc as_ical {} {
+ if {[my exists prodid]} {set prodid "PRODID:[my prodid]\n"} {set prodid ""}
+ if {[my exists method]} {set method "METHOD:[string toupper [my method]]\n"} {set method ""}
+ if {[my exists version]} {set version "VERSION:[my version]\n"} {set version "VERSION:2.0\n"}
+ set t ""
+ append t "BEGIN:VCALENDAR\n" $prodid $version $method
+ foreach i [my children] {
+ append t [$i as_ical]
+ }
+ append t "END:VCALENDAR\n"
+ return $t
+ }
+
+}
+
+namespace eval ::xo {
+ Class create dav -parameter {
+ {url /webdav}
+ {package}
+ }
+
+ dav ad_instproc unknown {method args} {
+ Return dav specific connection info similar to ad_conn
+ } {
+ my log "--dav unknown called with '$method' <$args>"
+ switch [llength $args] {
+ 0 {if {[my exists $method]} {return [my set method]}
+ return [ad_conn $method]
+ }
+ 1 {my set method $args}
+ default {my log "--dav ignoring <$method> <$args>"}
+ }
+ }
+
+ dav ad_instproc set_user_id {} {
+ Set user_id based on authentication header
+ } {
+ set ah [ns_set get [ns_conn headers] Authorization]
+ if {$ah ne ""} {
+ # should be something like "Basic 29234k3j49a"
+ my debug "auth_check authentication info $ah"
+ # get the second bit, the base64 encoded bit
+ set up [lindex [split $ah " "] 1]
+ # after decoding, it should be user:password; get the username
+ set user [lindex [split [ns_uudecode $up] ":"] 0]
+ set password [lindex [split [ns_uudecode $up] ":"] 1]
+ array set auth [auth::authenticate \
+ -username $user \
+ -authority_id [::auth::get_register_authority] \
+ -password $password]
+ my debug "auth $user $password returned [array get auth]"
+ if {$auth(auth_status) ne "ok"} {
+ array set auth [auth::authenticate \
+ -email $user \
+ -password $password]
+ if {$auth(auth_status) ne "ok"} {
+ my debug "auth status $auth(auth_status)"
+ ns_returnunauthorized
+ my set user_id 0
+ return 0
+ }
+ }
+ my debug "auth_check user_id='$auth(user_id)'"
+ ad_conn -set user_id $auth(user_id)
+
+ } else {
+ # no authenticate header, anonymous visitor
+ ad_conn -set user_id 0
+ ad_conn -set untrusted_user_id 0
+ }
+ my set user_id [ad_conn user_id]
+ }
+
+ dav ad_instproc initialize {} {
+ Setup connection object and authenticate user
+ } {
+ my instvar uri method urlv destination
+ ad_conn -reset
+ set uri [ns_urldecode [ns_conn url]]
+ set dav_url_regexp "^[my url]"
+ regsub $dav_url_regexp $uri {} uri
+ if {$uri eq ""} {
+ set uri "/"
+ }
+ my set_user_id
+
+ set method [string toupper [ns_conn method]]
+ #my log "--dav conn_setup: uri '$uri' method $method"
+ set urlv [split [string trimright $uri "/"] "/"]
+ set destination [ns_urldecode [ns_set iget [ns_conn headers] Destination]]
+ regsub {https?://[^/]+/} $destination {/} dest
+ regsub $dav_url_regexp $dest {} destination
+ #my log "--dav conn_setup: destination = $destination"
+ }
+
+ dav ad_instproc preauth { args } {
+ Check if user_id has permission to perform the WebDAV method on
+ the URI
+ } {
+ #my log "--dav preauth args=<$args>"
+ my instvar user_id
+
+ # Restrict to SSL if required
+ if { [security::RestrictLoginToSSLP] && ![security::secure_conn_p] } {
+ ns_returnunauthorized
+ return filter_return
+ }
+
+ # set common data for all kind of requests
+ my initialize
+
+ # for now, require for every user authentification
+ if {$user_id == 0} {
+ ns_returnunauthorized
+ return filter_return
+ }
+
+ #my log "--dav preauth filter_ok"
+ return filter_ok
+ }
+
+ dav ad_instproc register { } {
+ Register the the aolserver filter and traces.
+ This method is typically called via *-init.tcl.
+ } {
+ set filter_url [my url]*
+ set url [my url]/*
+ foreach method {
+ GET HEAD PUT MKCOL COPY MOVE PROPFIND PROPPATCH
+ DELETE LOCK UNLOCK
+ } {
+ ns_register_filter preauth $method $filter_url [self]
+ ns_register_proc $method $url [self] handle_request
+ #my log "--dav ns_register_filter preauth $method $filter_url [self]"
+ #my log "--dav ns_register_proc $method $url [self] handle_request"
+ }
+ }
+
+ dav instproc GET {} {
+ my instvar uri
+ my log "--dav handle_request GET method"
+ #set with_recurrences [ns_queryget with_recurrences 1]
+ # ...
+ ns_return 200 text/plain GET-$uri
+ }
+ dav instproc PUT {} {
+ my log "--dav handle_request PUT method [ns_conn content]"
+ #set calendar_id_list [ns_queryget calendar_id_list 0]
+ #if {[llength $write_calendar_ids] == 0} {
+ #ns_return 403 text/plain "no permissions to write to calendar"
+ #} else {
+ ns_return 201 text/plain "0 items processed"
+ #}
+ }
+ dav instproc PROPFIND {} {
+ my log "--dav PROPFIND [ns_conn content]"
+ ns_return 204 text/xml {}
+ }
+
+ dav ad_instproc get_package_id {} {
+ initialize the given package
+ @return package_id
+ } {
+ my instvar uri package
+ $package initialize -url $uri
+ #my log "--dav [my package] initialize -url $uri"
+ return $package_id
+ }
+
+ dav ad_instproc handle_request { args } {
+ Process the incoming web-dav request. This method
+ could be overloaded by the application and
+ dispatches the HTTP requests.
+ } {
+ my instvar uri method user_id
+
+ #my log "--dav handle_request method=$method uri=$uri\
+ # userid=$user_id -ns_conn query '[ns_conn query]'"
+ if {[my exists package]} {
+ my get_package_id
+ }
+ if {[my procsearch $method] ne ""} {
+ my $method
+ } else {
+ ns_return 404 text/plain "not implemented"
+ }
+ }
+}