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.2.1 -r1.47.2.2
--- openacs-4/packages/xotcl-core/xotcl-core.info 18 Jun 2008 06:51:18 -0000 1.47.2.1
+++ openacs-4/packages/xotcl-core/xotcl-core.info 20 Jun 2008 08:25:41 -0000 1.47.2.2
@@ -8,10 +8,10 @@
t
xotcl
-
+
Gustaf Neumann
XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)
- 2008-04-05
+ 2008-03-14
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.2.2 -r1.25.2.3
--- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 19 Jun 2008 08:45:26 -0000 1.25.2.2
+++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 20 Jun 2008 08:25:41 -0000 1.25.2.3
@@ -75,7 +75,7 @@
if {[regexp {^::([^:]+)::} $object_type _ head]} {
set tail [namespace tail $object_type]
set pretty_name "#$head.$tail-$name#"
- #my log "--created pretty_name = $pretty_name"
+ my log "--created pretty_name = $pretty_name"
} else {
error "Cannot determine automatically message key for pretty name. \
Use namespaces for classes"
@@ -169,14 +169,9 @@
::xotcl::Object instproc debug msg {
ns_log debug "[self] [self callingclass]->[self callingproc]: $msg"
}
-::xotcl::Object instproc msg {{-html false} msg} {
+::xotcl::Object instproc msg msg {
if {[ns_conn isconnected]} {
- set msg "$msg ([self] [self callingclass]->[self callingproc])"
- if {$html} {
- util_user_message -html -message $msg
- } else {
- util_user_message -message $msg
- }
+ util_user_message -message "$msg ([self] [self callingclass]->[self callingproc])"
}
}
::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.9 -r1.58.2.10
--- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 19 Jun 2008 08:45:26 -0000 1.58.2.9
+++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 20 Jun 2008 08:25:41 -0000 1.58.2.10
@@ -233,7 +233,7 @@
switch -- $type {
string { set type text }
long_text { set type text }
- date { set type "timestamp with time zone" }
+ date { set type timestampz }
ltree { set type [expr {[::xo::db::has_ltree] ? "ltree" : "text" }] }
}
return $type
@@ -362,7 +362,6 @@
{security_inherit_p t}
{auto_save false}
{with_table true}
- {sql_package_name}
} -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
@@ -374,13 +373,6 @@
::xo::db::Class set __default_superclass ::xo::db::Object ;# will be supported in XOTcl 1.6
- ::xo::db::Class proc namespace_head {name} {
- if {[regexp {^(::)?([^:]+)::} $name _ colons head]} {
- return $head
- }
- return ""
- }
-
#
# Define an XOTcl interface for creating new object types
#
@@ -527,7 +519,6 @@
-pretty_name $pretty_name \
-id_column $id_column \
-table_name $table_name \
- -sql_package_name [namespace tail $classname] \
-noinit
} else {
#my log "--db we have a class $classname"
@@ -854,11 +845,7 @@
my log "We cannot handle object_name = '$object_name' in this version"
return
}
- #
- # Object names have the form of e.g. ::xo::db::apm_parameter.
- # Therefore, we use the namspace tail as sql_package_name.
- #
- set package_name [my sql_package_name [namespace tail [self]]]
+ set package_name [namespace tail [self]]
set sql_command [my generate_psql $package_name $object_name]
set proc_body [my generate_proc_body]
@@ -1013,8 +1000,7 @@
-table_name $table_name \
-id_column $id_column \
-abstract_p $abstract_p \
- -name_method $name_method \
- -package_name [my sql_package_name]
+ -name_method $name_method
}
::xo::db::Class ad_instproc drop_object_type {{-cascade true}} {
@@ -1133,25 +1119,17 @@
my check_default_values
set table_name_error_tail ""
set id_column_error_tail ""
- my instvar sql_package_name
-
- if {![my exists sql_package_name]} {
- set sql_package_name [::xo::db::Class namespace_head [self]]
- my log "-- sql_package_name of [self] is '$sql_package_name'"
- }
- if {[string length $sql_package_name] > 31} {
- error "SQL package_name '$sql_package_name' can be maximal 31 characters long!"
- }
- if {$sql_package_name eq ""} {
- error "Cannot determine SQL package_name. Please specify it explicitely!"
- }
-
if {![my exists table_name]} {
- set tail [namespace tail [self]]
- my set table_name [string tolower ${sql_package_name}_$tail]
- set table_name_error_tail ", or use different namespaces/class names"
+ if {[regexp {^::([^:]+)::} [self] _ head]} {
+ set tail [namespace tail [self]]
+ my set table_name [string tolower ${head}_$tail]
+ set table_name_error_tail ", or use different namespaces/class names"
+ #my log "-- created table_name '[my table_name]'"
+ } else {
+ error "Cannot determine automatically table name for class [self]. \
+ Use namespaces for classes."
+ }
}
-
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.3 -r1.6.2.4
--- openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 18 Jun 2008 06:51:18 -0000 1.6.2.3
+++ openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 20 Jun 2008 08:25:42 -0000 1.6.2.4
@@ -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 notice "--p got [llength [::xo::db::apm_parameter info instances]] parameters"
+ #ns_log debug "--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 notice "--p $parameter_id $package_key $package_id $parameter_name <$attr_value>"
+ ns_log debug "--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.2.1 -r1.8.2.2
--- openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl 18 Jun 2008 06:51:18 -0000 1.8.2.1
+++ openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl 20 Jun 2008 08:25:42 -0000 1.8.2.2
@@ -97,9 +97,16 @@
}
################## 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} {
@@ -110,9 +117,7 @@
}
::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.4 -r1.33.2.5
--- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 18 Jun 2008 06:51:18 -0000 1.33.2.4
+++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 20 Jun 2008 08:25:42 -0000 1.33.2.5
@@ -189,13 +189,12 @@
#my log "--CONN ns_conn url"
set url [ns_conn url]
}
- #my log "--i [self args] URL='$url', pkg=$package_id"
+ #my log "--i [self args] URL='$url'"
# 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
@@ -218,20 +217,16 @@
-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 -package_id $package_id"
+ #my log "--cc ::xo::cc reused $url"
::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
}
@@ -449,4 +444,6 @@
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.2 -r1.16.2.3
--- openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 18 Jun 2008 06:51:18 -0000 1.16.2.2
+++ openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 20 Jun 2008 08:25:42 -0000 1.16.2.3
@@ -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.2 -r1.7.2.3
--- openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl 18 Jun 2008 06:51:18 -0000 1.7.2.2
+++ openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl 20 Jun 2008 08:25:42 -0000 1.7.2.3
@@ -1,7 +1,5 @@
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
@@ -11,11 +9,10 @@
namespace eval ::xo {
#
# Defined classes
- # 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)
+ # 1) HttpRequest
+ # 2) AsyncHttpRequest
+ # 3) HttpRequestTrace (mixin class)
+ # 4) Tls (mixin class, applicable to various protocols)
#
######################
#
@@ -41,27 +38,9 @@
# 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
@@ -74,7 +53,7 @@
#
# 2 AsyncHttpRequest
#
- # AsyncHttpRequest is a subclass for HttpCore implementing
+ # AsyncHttpRequest is a subclass for HttpRequest 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
@@ -99,17 +78,9 @@
# the other upon failure or cancellation (done).
#
# ::bgdelivery do Object ::listener \
- # -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} {
+ # -proc deliver {payload obj} {
+ # my log "Asynchronous request suceeded!"
+ # } -proc done {reason obj} {
# my log "Asynchronous request failed: $reason"
# }
#
@@ -125,109 +96,40 @@
#
# 3 HttpRequestTrace
#
- # HttpRequestTrace can be used to trace one or all requests.
+ # HttpRequestTrace can be used to trace the one or all requests.
# If activated, the class writes protocol data into
# /tmp/req-.
#
# Use
#
- # ::xo::HttpCore instmixin add ::xo::HttpRequestTrace
+ # ::xo::HttpRequest instmixin add ::xo::HttpRequestTrace
#
# to activate trace for all requests,
# or mixin the class into a single request to trace it.
#
- 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"
+ 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}
}
- # 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} {
+ HttpRequest instproc set_default_port {protocol} {
switch $protocol {
http {my set port 80}
https {my set port 443}
}
}
- HttpCore instproc parse_url {} {
+ HttpRequest 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
@@ -240,29 +142,21 @@
}
}
- HttpCore instproc open_connection {} {
+ HttpRequest instproc open_connection {} {
my instvar host port S
- set S [socket -async $host $port]
+ set S [socket $host $port]
}
- HttpCore instproc set_encoding {
+ HttpRequest 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]} {
- [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
+ fconfigure [my set S] -translation $text_translation -encoding [string tolower $encoding]
} else {
fconfigure [my set S] -translation $text_translation
}
@@ -271,7 +165,7 @@
}
}
- HttpCore instproc init {} {
+ HttpRequest instproc init {} {
my instvar S post_data host port protocol
my destroy_on_cleanup
my set meta [list]
@@ -299,10 +193,6 @@
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"
@@ -316,62 +206,61 @@
}
my $method
} err]} {
- my cancel "error send $host [my port]: $err"
+ my cancel "error send $host $port: $err"
return
}
}
- HttpCore instproc GET {} {
+ HttpRequest instproc GET {} {
my instvar S
puts $S ""
- my request_done
+ my query_done
}
- HttpCore instproc POST {} {
+ HttpRequest 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 request_done
+ my query_done
}
- HttpCore instproc request_done {} {
+ HttpRequest instproc query_done {} {
my instvar S
flush $S
- my reply_first_line
+ my received_first_line
}
-
- HttpCore instproc close {} {
- my debug "--- closing socket"
+ HttpRequest instproc notify {method arg} {
+ if {[my exists request_manager]} {
+ [my request_manager] $method $arg [self]
+ }
+ }
+ HttpRequest instproc cancel {reason} {
+ my log "--- $reason"
catch {close [my set S]}
+ my notify done $reason
}
- HttpCore instproc cancel {reason} {
- my debug "--- $reason"
- my close
+ 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 finish {} {
- my close
- my debug "--- [my host] [my port] [my path] has finished"
- }
- HttpCore instproc getLine {var} {
+ HttpRequest 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 debug "--input pending, no full line"; return -1}
+ if {$n == -1} {my log "--input pending, no full line"; return -1}
+ #my log "got $response"
return $n
}
- HttpCore instproc reply_first_line {} {
+ HttpRequest instproc received_first_line {} {
my instvar S status_code
fconfigure $S -translation crlf
set n [my getLine response]
@@ -381,24 +270,24 @@
}
if {[regexp {^HTTP/([0-9.]+) +([0-9]+) *} $response _ \
responseHttpVersion status_code]} {
- my reply_first_line_done
+ my received_first_line_done
} else {
my log "--unexpected response '$response'"
my cancel unexpected-response
}
}
- HttpCore instproc reply_first_line_done {} {
+ HttpRequest instproc received_first_line_done {} {
my header
}
- HttpCore instproc header {} {
+ HttpRequest instproc header {} {
while {1} {
set n [my getLine response]
switch -exact -- $n {
-2 {my cancel premature-eof; return}
-1 {continue}
0 {break}
default {
- #my debug "--header $response"
+ #my log "--header $response"
if {[regexp -nocase {^content-length:(.+)$} $response _ length]} {
my set content_length [string trim $length]
} elseif {[regexp -nocase {^content-type:(.+)$} $response _ type]} {
@@ -410,11 +299,10 @@
}
}
}
- my reply_header_done
+ my received_header_done
}
- HttpCore instproc reply_header_done {} {
- # we have received the header, including potentially the
- # content_type of the returned data
+ HttpRequest instproc received_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]]
@@ -423,282 +311,56 @@
}
}
- 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]
- }
-
-
-
#
- # Synchronous (blocking) requests
+ # Asynchronous requests
#
- Class HttpRequest -superclass HttpCore -slots {
- Attribute timeout -type integer
+ Class AsyncHttpRequest -superclass HttpRequest -parameter {
+ {timeout 10000}
}
-
- 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 log "--a"
- my notify start_request
- my set_timeout
+ my set to_identifier [after [my set timeout] [self] cancel 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"} {
- my cancel_timeout
+ after cancel [my set to_identifier]
}
next
- my debug "--- canceled for $reason"
- my notify failure $reason
}
AsyncHttpRequest instproc finish {} {
- my log "--a"
- my cancel_timeout
+ after cancel [my set to_identifier]
next
- my debug "--- finished data [my set data]"
- my notify success [my set data]
}
- AsyncHttpRequest instproc request_done {} {
- my log "--a"
- my notify start_reply
- my set_timeout
+ AsyncHttpRequest instproc query_done {} {
my instvar S
flush $S
fconfigure $S -blocking false
- fileevent $S readable [list [self] reply_first_line]
+ fileevent $S readable [list [self] received_first_line]
}
- AsyncHttpRequest instproc reply_first_line_done {} {
- my log "--a"
- my set_timeout
- my instvar S
- fileevent $S readable [list [self] header]
+ AsyncHttpRequest instproc received_first_line_done {} {
+ fileevent [my set S] readable [list [self] header]
}
- 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
+ AsyncHttpRequest instproc received_header_done {} {
+ # 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] receive_reply_data]
+ fileevent [my set S] readable [list [self] received_data]
}
- AsyncHttpRequest instproc receive_reply_data {} {
- my log "--a"
+ AsyncHttpRequest instproc received_data {} {
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 debug "reveived [string length $block] bytes"
+ #my log "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
#
@@ -768,5 +430,5 @@
# To activate trace for all requests, uncomment the following line.
# To trace a single request, mixin ::xo::HttpRequestTrace into the request.
#
- # HttpCore instmixin add ::xo::HttpRequestTrace
+ # HttpRequest 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.2.1 -r1.2.2.2
--- openacs-4/packages/xotcl-core/tcl/ical-procs.tcl 18 Jun 2008 06:51:18 -0000 1.2.2.1
+++ openacs-4/packages/xotcl-core/tcl/ical-procs.tcl 20 Jun 2008 08:25:42 -0000 1.2.2.2
@@ -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 Lightning for Thunderbird).
+ calendar (sunbird, or the xul-file for thunderbird or firefox).
@author Gustaf Neumann
}
@@ -32,9 +32,6 @@
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
}
@@ -77,320 +74,4 @@
return $text
}
-}
-
-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"
- }
- }
-}
+}
\ No newline at end of file