Gustaf Neumann
XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)
2017-08-06
@@ -43,7 +43,7 @@
BSD-Style
2
-
+
Index: openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl,v
diff -u -N -r1.11 -r1.12
--- openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 7 Aug 2017 23:48:30 -0000 1.11
+++ openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 21 Oct 2017 13:07:27 -0000 1.12
@@ -58,20 +58,20 @@
# the minimal reconfiguration is to set the class and remove methods
$obj class [self]
foreach p [$obj info procs] {$obj proc $p {} {}}
- if {![my exists instrecreate]} {
+ if {![info exists :instrecreate]} {
#my log "### no instrecreate for $obj <$args>"
next
return
}
- if {[my exists instreconfigure]} {
+ if {[info exists :instreconfigure]} {
# before we set defaults, we must unset vars
foreach var [$obj info vars] {$obj unset $var}
# set defaults and run configure
$obj set_instance_vars_defaults
$obj configure {*}$args
#my log "### instproc recreate $obj + configure $args ..."
}
- if {[my exists instreinit]} {
+ if {[info exists :instreinit]} {
#my log "### instreinit for $obj <$args>"
$obj init
#my log "### instproc recreate $obj + init ..."
@@ -81,14 +81,14 @@
# the minimal reconfiguration is to set the class and remove methods
$obj class [self]
foreach p [$obj info instprocs] {$obj instproc $p {} {}}
- if {[my exists reconfigure]} {
+ if {[info exists :reconfigure]} {
# before we set defaults, we must unset vars
foreach var [$obj info vars] {$obj unset $var}
# set defaults and run configure
$obj set_instance_vars_defaults
$obj configure {*}$args
}
- if {[my exists reinit]} {
+ if {[info exists :reinit]} {
$obj init
}
}
@@ -138,7 +138,7 @@
set cl [self]
foreach p [$obj info commands] {$obj proc $p {} {}}
foreach c [$obj info children] {
- my log "recreate destroy <$c destroy"
+ :log "recreate destroy <$c destroy"
$c destroy
}
foreach var [$obj info vars] {
@@ -149,7 +149,7 @@
$obj set_instance_vars_defaults
# we use uplevel to handle -volatile correctly
- set pos [my uplevel $obj configure $args]
+ set pos [:uplevel $obj configure $args]
if {"-init" ni $args} {
incr pos -1
$obj init {*}[lrange $args 0 $pos]
@@ -168,9 +168,9 @@
::xotcl::configure softrecreate true
Class create RR -instproc recreate args {
- my log "-- [self args]"; next
+ :log "-- [self args]"; next
} -instproc create args {
- my log "-- [self args]"; next
+ :log "-- [self args]"; next
}
#::xotcl::Class instmixin RR
}
Index: openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl,v
diff -u -N -r1.58 -r1.59
--- openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 7 Aug 2017 23:48:30 -0000 1.58
+++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 21 Oct 2017 13:07:27 -0000 1.59
@@ -65,13 +65,13 @@
# composite of objects, used e.g. in recursive renderings.
#
[self class] instvar stack
- set level [my incr_level]
+ set level [:incr_level]
#
# Create a new instance of the current class and configure it.
#
#my log "tdom START $level [self], cmd='$configurecmds'"
- set me [my new -destroy_on_cleanup {*}$configurecmds]
+ set me [:new -destroy_on_cleanup {*}$configurecmds]
#my log "tdom CREATED $level $me ([$me info class])"
#
@@ -90,9 +90,9 @@
#
# set class [$me info class]
# foreach cl [concat $class [$class info heritage]] {
- # my log "tdom EVAL $level ns=[namespace current] autoimport in $cl?[$cl exists autoimport]"
+ # :log "tdom EVAL $level ns=[namespace current] autoimport in $cl?[$cl exists autoimport]"
# if {[$cl exists autoimport]} {
- # my log "tdom IMPO [$cl autoimport] into $me"
+ # :log "tdom IMPO [$cl autoimport] into $me"
# namespace eval ::xo::tmp [list namespace import -force [$cl autoimport]]
# }
# }
@@ -119,7 +119,7 @@
}
#my log "tdom END $level [self] me=$me"
- set level [my incr_level -1]
+ set level [:incr_level -1]
return $me
}
@@ -145,9 +145,9 @@
} else {
set HTMLattribute $attribute
}
- #my msg "[my name] check for $attribute => [my exists $attribute]"
- if {[my exists $attribute]} {
- lappend pairs $HTMLattribute [my set $attribute]
+ #my msg "[:name] check for $attribute => [info exists :$attribute]"
+ if {[info exists :$attribute]} {
+ lappend pairs $HTMLattribute [set :$attribute]
}
}
return $pairs
@@ -169,9 +169,9 @@
} else {
set HTMLattribute $attribute
}
- #my msg "[my name] check for $attribute => [my exists $attribute]"
- if {[my uplevel [list info exists $attribute]]} {
- lappend pairs $HTMLattribute [my uplevel [list set $attribute]]
+ #my msg "[:name] check for $attribute => [info exists :$attribute]"
+ if {[:uplevel [list info exists $attribute]]} {
+ lappend pairs $HTMLattribute [:uplevel [list set $attribute]]
}
}
return $pairs
@@ -186,7 +186,7 @@
-parameter {{autorender true}}
::xo::tdom::Object instproc render {} {
- foreach o [my children] { $o render }
+ foreach o [:children] { $o render }
}
#
@@ -306,8 +306,8 @@
Class create Localizer -parameter {type key url}
Localizer instproc render {} {
- html::a -title [my key] -href [my url] {
- switch -- [my type] {
+ html::a -title [:key] -href [:url] {
+ switch -- [:type] {
localized {set char o; set style "color: green"}
us_only {set char *; set style "background-color: yellow; color: red;"}
missing {set char @; set style "background-color: red; color: white;"}
@@ -316,14 +316,14 @@
}
}
Localizer instproc render {} {
- html::a -title [my key] -href [my url] {
+ html::a -title [:key] -href [:url] {
set path /resources/acs-templating/xinha-nightly/plugins/
- switch -- [my type] {
+ switch -- [:type] {
localized {set img ImageManager/img/btn_ok.gif}
us_only {set img Filter/img/ed_filter.gif}
missing {set img LangMarks/img/en.gif}
}
- html::img -alt [my type] -src $path/$img -width 16 -height 16 -border 0
+ html::img -alt [:type] -src $path/$img -width 16 -height 16 -border 0
}
}
@@ -332,32 +332,32 @@
Class create Drawable \
-superclass ::xo::tdom::AttributeManager \
-instproc _ {attr} {
- my set $attr
+ set :$attr
} \
-instproc render_localizer {} {
}
Class create TRN-Mode \
-instproc _ {attr} {
- return [::xo::localize [my set $attr]]
+ return [::xo::localize [set :$attr]]
} \
-instproc render_localizer {} {
#my log "-- "
- if {[my exists __localizer]} {
- foreach l [my set __localizer] {
+ if {[info exists :__localizer]} {
+ foreach l ${:__localizer} {
$l render
$l destroy
}
}
- my set __localizer [list]
+ set :__localizer [list]
} \
-instproc render-data args {
next
- my render_localizer
+ :render_localizer
} \
-instproc render args {
next
- my render_localizer
+ :render_localizer
}
#
@@ -411,7 +411,7 @@
foreach c [$M children] {
lappend slots {*}[$c get-slots]
}
- my proc add $slots {
+ :proc add $slots {
set __self [::xo::Table::Line new]
foreach __v [info vars] {$__self set $__v [set $__v]}
next $__self
@@ -421,7 +421,7 @@
Table instproc render_with {renderer trn_mixin} {
#my log "-- renderer=$renderer"
set cl [self class]
- [self] mixin ${cl}::$renderer
+ :mixin ${cl}::$renderer
foreach child [$cl info classchildren] {
#my log "-- $child class [$child info class] "
set mixinname ${cl}::${renderer}::[namespace tail $child]
@@ -435,7 +435,7 @@
}
}
Table::Line instmixin $trn_mixin
- my init_renderer
+ :init_renderer
}
Table instproc write_csv {} {
@@ -451,7 +451,7 @@
lappend line \"$value\"
}
append output [join $line ,] \n
- foreach row [my children] {
+ foreach row [:children] {
set line [list]
foreach column [[self]::__columns children] {
if {[$column exists no_csv]} continue
@@ -461,9 +461,8 @@
append output [join $line ,] \n
}
#ns_return 200 text/plain $output
- my instvar name
- if {![my exists name]} {set name "table"}
- set fn [xo::backslash_escape \" $name.csv]
+ if {![info exists :name]} {set :name "table"}
+ set fn [xo::backslash_escape \" ${:name}.csv]
ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=\"$fn\""
ns_return 200 text/csv $output
}
@@ -474,8 +473,8 @@
set result [list]
foreach att $atts {
set varname $name.$att
- if {[my exists $varname]} {
- lappend result $att [::xo::localize [my set $varname]]
+ if {[info exists :$varname]} {
+ lappend result $att [::xo::localize [set :$varname]]
}
}
foreach {att val} $extra {lappend result $att $val}
@@ -491,7 +490,7 @@
-superclass ::xo::OrderedComposite::Child \
-parameter {label url {tooltip {}}}
#-proc destroy {} {
- # my log "-- DESTROY "
+ # :log "-- DESTROY "
# show_stack
# next
# }
@@ -500,12 +499,12 @@
-superclass ::xo::OrderedComposite::Child \
-parameter {label {html {}} {orderby ""} name {richtext false} no_csv {CSSclass ""} {hide 0}} \
-instproc init {} {
- my set name [namespace tail [self]]
+ set :name [namespace tail [self]]
} \
-instproc get-slots {} {
- set slots [list -[my name]]
+ set slots [list -[:name]]
foreach subfield {richtext CSSclass} {
- lappend slots [list -[my name].$subfield ""]
+ lappend slots [list -[:name].$subfield ""]
}
return $slots
}
@@ -515,14 +514,14 @@
-parameter {name id {html {}} {hide 0}} \
-instproc actions {cmd} {
#my init
- set grandParent [[my info parent] info parent]
- if {![my exists name]} {my set name [namespace tail [self]]}
+ set grandParent [[:info parent] info parent]
+ if {![info exists :name]} {set :name [namespace tail [self]]}
#set M [::xo::OrderedComposite create ${grandParent}::__bulkactions]
set M [::xo::OrderedComposite create ${grandParent}::__bulkactions -noinit]
namespace eval $M {namespace import -force ::xo::Table::*}
$M contains $cmd
$M set __belongs_to [self]
- $M set __identifier [my set name]
+ $M set __identifier ${:name}
} \
-instproc get-slots {} {
;
@@ -531,31 +530,31 @@
Class create AnchorField \
-superclass ::xo::Table::Field \
-instproc get-slots {} {
- set slots [list -[my name]]
+ set slots [list -[:name]]
foreach subfield {href title CSSclass} {
- lappend slots [list -[my name].$subfield ""]
+ lappend slots [list -[:name].$subfield ""]
}
return $slots
}
Class create HiddenField \
-superclass ::xo::Table::Field \
-instproc get-slots {} {
- return [list -[my name]]
+ return [list -[:name]]
}
Class create ImageField \
-parameter {src width height border title alt} \
-superclass ::xo::Table::Field \
-instproc get-slots {} {
- set slots [list -[my name]]
- lappend slots [list -[my name].src [my src]]
- lappend slots [list -[my name].CSSclass [my CSSclass]]
+ set slots [list -[:name]]
+ lappend slots [list -[:name].src [:src]]
+ lappend slots [list -[:name].CSSclass [:CSSclass]]
foreach att {width height border title alt} {
- if {[my exists $att]} {
- lappend slots [list -[my name].$att [my $att]]
+ if {[info exists :$att]} {
+ lappend slots [list -[:name].$att [my $att]]
} else {
- lappend slots [list -[my name].$att]
+ lappend slots [list -[:name].$att]
}
}
return $slots
@@ -564,7 +563,7 @@
Class create ImageAnchorField \
-superclass ::xo::Table::ImageField \
-instproc get-slots {} {
- return [concat [next] -[my name].href ""]
+ return [concat [next] -[:name].href ""]
}
Class create ImageField_EditIcon \
@@ -607,10 +606,10 @@
-superclass ::xo::Drawable \
-instproc init_renderer {} {
#my log "--"
- my set __rowcount 0
- my set css.table-class list
- my set css.tr.even-class list-even
- my set css.tr.odd-class list-odd
+ set :__rowcount 0
+ set :css.table-class list
+ set :css.tr.even-class list-even
+ set :css.tr.odd-class list-odd
}
TABLE instproc render-actions {} {
@@ -660,15 +659,15 @@
$o render
}
}
- set children [my children]
+ set children [:children]
if {[llength $children] == 0} {
- html::tr {html::td { html::t [my set no_data]}}
+ html::tr {html::td { html::t ${:no_data}}}
} else {
- foreach line [my children] {
- #my log "--LINE vars=[my info vars] cL: [[self class] info vars] r=[my renderer]"
- html::tr -class [expr {[my incr __rowcount]%2 ?
- [my set css.tr.odd-class] :
- [my set css.tr.even-class] }] {
+ foreach line [:children] {
+ #my log "--LINE vars=[:info vars] cL: [[self class] info vars] r=[:renderer]"
+ html::tr -class [expr {[incr :__rowcount]%2 ?
+ [:set css.tr.odd-class] :
+ [:set css.tr.even-class] }] {
foreach field [[self]::__columns children] {
html::td [concat [list class list] [$field html]] {
$field render-data $line
@@ -680,18 +679,18 @@
}
TABLE instproc render {} {
- if {![my isobject [self]::__actions]} {my actions {}}
- if {![my isobject [self]::__bulkactions]} {my bulkactions {}}
+ if {![:isobject [self]::__actions]} {my actions {}}
+ if {![:isobject [self]::__bulkactions]} {my bulkactions {}}
set bulkactions [[self]::__bulkactions children]
if {$bulkactions eq ""} {
- html::table -class [my set css.table-class] {
+ html::table -class [:set css.table-class] {
my render-actions
my render-body
}
} else {
set name [[self]::__bulkactions set __identifier]
html::form -name $name -method POST {
- html::table -class [my set css.table-class] {
+ html::table -class [:set css.table-class] {
my render-actions
my render-body
}
@@ -709,43 +708,43 @@
Class create TABLE::Action \
-superclass ::xo::Drawable \
-instproc render {} {
- html::a -class button -title [my _ tooltip] -href [my url] {
- html::t [my _ label]
+ html::a -class button -title [:_ tooltip] -href [:url] {
+ html::t [:_ label]
}
#my log "-- "
}
#-proc destroy {} {
- # my log "-- DESTROY"
+ # :log "-- DESTROY"
# show_stack
# next
#}
Class create TABLE::Field -superclass ::xo::Drawable
TABLE::Field instproc render-data {line} {
- $line instvar [list [my name].richtext richtext]
+ $line instvar [list [:name].richtext richtext]
if {![info exists richtext] || $richtext eq ""} {
- set richtext [my richtext]
+ set richtext [:richtext]
}
if {$richtext} {
- html::t -disableOutputEscaping [$line set [my name]]
+ html::t -disableOutputEscaping [$line set [:name]]
} else {
- html::t [$line set [my name]]
+ html::t [$line set [:name]]
}
}
TABLE::Field instproc render {} {
- html::th [concat [list class list] [my html]] {
- if {[my set orderby] eq ""} {
- html::t [my _ label]
+ html::th [concat [list class list] [:html]] {
+ if {${:orderby} eq ""} {
+ html::t [:_ label]
} else {
- my renderSortLabels
+ :renderSortLabels
}
- my render_localizer ;# run this before th is closed
+ :render_localizer ;# run this before th is closed
}
}
TABLE::Field instproc renderSortLabels {} {
- set field [my set orderby]
+ set field ${:orderby}
set lvl [template::adp_level]
if {$lvl ne ""} {
upvar #$lvl orderby orderby
@@ -776,7 +775,7 @@
}
set href [export_vars -base [ad_conn url] $query]
html::a -href $href -title $title {
- html::t [my _ label]
+ html::t [:_ label]
html::img -src $img -alt ""
}
}
@@ -785,12 +784,12 @@
Class create TABLE::AnchorField \
-superclass TABLE::Field \
-instproc render-data {line} {
- if {[$line exists [my name].href] &&
- [set href [$line set [my name].href]] ne ""} {
+ if {[$line exists [:name].href] &&
+ [set href [$line set [:name].href]] ne ""} {
# use the CSS class rather from the Field than not the line
- my instvar CSSclass
- $line instvar [list [my name].title title]
- html::a [my get_local_attributes href title {CSSclass class}] {
+ :instvar CSSclass
+ $line instvar [list [:name].title title]
+ html::a [:get_local_attributes href title {CSSclass class}] {
return [next]
}
}
@@ -805,31 +804,31 @@
Class create TABLE::ImageField \
-superclass TABLE::Field \
-instproc render-data {line} {
- $line instvar [list [my name].CSSclass CSSclass]
- html::a [my get_local_attributes href {style "border-bottom: none;"} {CSSclass class}] {
- html::img [$line attlist [my name] {src width height border title alt}] {}
+ $line instvar [list [:name].CSSclass CSSclass]
+ html::a [:get_local_attributes href {style "border-bottom: none;"} {CSSclass class}] {
+ html::img [$line attlist [:name] {src width height border title alt}] {}
}
$line render_localizer
}
Class create TABLE::ImageAnchorField \
-superclass TABLE::Field \
-instproc render-data {line} {
- set href [$line set [my name].href]
+ set href [$line set [:name].href]
if {$href ne ""} {
- #if {$line exists [my name].CSSclass} {set CSSclass [$line set [my name].CSSclass]}
- $line instvar [list [my name].CSSclass CSSclass]
- html::a [my get_local_attributes href {style "border-bottom: none;"} {CSSclass class}] {
- html::img [$line attlist [my name] {src width height border title alt}] {}
+ #if {$line exists [:name].CSSclass} {set CSSclass [$line set [:name].CSSclass]}
+ $line instvar [list [:name].CSSclass CSSclass]
+ html::a [:get_local_attributes href {style "border-bottom: none;"} {CSSclass class}] {
+ html::img [$line attlist [:name] {src width height border title alt}] {}
}
$line render_localizer
}
}
Class create TABLE::BulkAction -superclass ::xo::Drawable
TABLE::BulkAction instproc render {} {
- set name [my name]
- #my msg [my serialize]
+ set name [:name]
+ #my msg [:serialize]
html::th -class list {
html::input -type checkbox -name __bulkaction -id __bulkaction \
-title "Mark/Unmark all rows"
@@ -843,9 +842,9 @@
}
TABLE::BulkAction instproc render-data {line} {
- #my msg [my serialize]
- set name [my name]
- set value [$line set [my id]]
+ #my msg [:serialize]
+ set name [:name]
+ set value [$line set [:id]]
html::input -type checkbox -name $name -value $value \
-id "$name---[string map {/ _} $value]" \
-title "Mark/Unmark this row"
@@ -864,20 +863,20 @@
}
} \
-instproc render {} {
- if {![my isobject [self]::__actions]} {my actions {}}
- if {![my isobject [self]::__bulkactions]} {my __bulkactions {}}
+ if {![:isobject [self]::__actions]} {my actions {}}
+ if {![:isobject [self]::__bulkactions]} {my __bulkactions {}}
set bulkactions [[self]::__bulkactions children]
html::div {
my render-actions
if {$bulkactions eq ""} {
html::div -class table {
- html::table -class [my set css.table-class] {my render-body}
+ html::table -class [:set css.table-class] {my render-body}
}
} else {
set name [[self]::__bulkactions set __identifier]
html::form -name $name -action "" {
html::div -class table {
- html::table -class [my set css.table-class] {my render-body}
+ html::table -class [:set css.table-class] {my render-body}
my render-bulkactions
}
}
@@ -898,9 +897,9 @@
-superclass TABLE2 \
-instproc init_renderer {} {
next
- my set css.table-class list-table
- my set css.tr.even-class even
- my set css.tr.odd-class odd
+ set :css.table-class list-table
+ set :css.tr.even-class even
+ set :css.tr.odd-class odd
}
Class create TABLE3::Action -superclass TABLE::Action
@@ -916,7 +915,7 @@
-superclass ::xo::Table \
-instproc init {} {
set trn_mixin [expr {[lang::util::translator_mode_p] ?"::xo::TRN-Mode" : ""}]
- my render_with [my renderer] $trn_mixin
+ :render_with [:renderer] $trn_mixin
next
}
@@ -928,7 +927,7 @@
Class create ListWidget -superclass ::xo::OrderedComposite -instproc render {} {
html::ul -class plainlist {
- foreach o [my children] {
+ foreach o [:children] {
html::li {
$o render
}
@@ -1001,11 +1000,11 @@
Page proc header_stuff {} {
- foreach style [my sort_keys_by_value [array get ::_xo_need_style]] {
+ foreach style [:sort_keys_by_value [array get ::_xo_need_style]] {
template::head::add_style -style $style
}
set count 10
- foreach file [my sort_keys_by_value [array get ::_xo_need_css]] {
+ foreach file [:sort_keys_by_value [array get ::_xo_need_css]] {
template::head::add_css -href $file -media all -order [incr count]
}
if {[info exists ::_xo_js_order]} {
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.14 -r1.15
--- openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl 7 Aug 2017 23:48:30 -0000 1.14
+++ openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl 21 Oct 2017 13:07:27 -0000 1.15
@@ -14,7 +14,7 @@
::xotcl::THREAD create t1 {
Class create Counter -parameter {{value 1}}
- Counter instproc ++ {} {my incr value}
+ Counter instproc ++ {} {incr :value}
Counter create c1
Counter create c2
}
@@ -115,7 +115,6 @@
::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"
@@ -124,32 +123,32 @@
# is not available in newly created threads, so we have to care for it.
# We need only a partial initialization, to allow the exit handler
# to be defined.
- set initcmd {
+ set :initcmd {
package req XOTcl
namespace import -force ::xotcl::*
}
}
- append initcmd {
+ append :initcmd {
ns_thread name SELF
}
- append initcmd [subst {
- ::xotcl::Object setExitHandler [list [my exithandler]]
+ append :initcmd [subst {
+ ::xotcl::Object setExitHandler [list [:exithandler]]
}]
- regsub -all SELF $initcmd [self] initcmd
- append initcmd \n\
+ regsub -all SELF ${:initcmd} [self] :initcmd
+ append :initcmd \n\
[list set ::xotcl::currentScript [info script]] \n\
[list set ::xotcl::currentThread [self]] \n\
$cmd
- my set mutex [thread::mutex create]
- ns_log notice "mutex [my set mutex] created"
+ set :mutex [thread::mutex create]
+ ns_log notice "mutex ${:mutex} created"
next
}
::xotcl::THREAD ad_proc -private recreate {obj args} {
this method catches recreation of THREADs in worker threads
it reinitializes the thread according to the new definition.
} {
- my log "recreating [self] $obj, tid [$obj exists tid]"
+ :log "recreating [self] $obj, tid [$obj exists tid]"
if {![string match "::*" $obj]} { set obj ::$obj }
$obj set recreate 1
next
@@ -158,22 +157,22 @@
set tid [nsv_get [self] $obj]
::thread::send $tid [$obj set initcmd]
$obj set tid $tid
- my log "+++ content of thread $obj ($tid) redefined"
+ :log "+++ content of thread $obj ($tid) redefined"
}
}
::xotcl::THREAD instproc destroy {} {
- my log "destroy called"
- if {![my persistent] &&
+ :log "destroy called"
+ if {![:persistent] &&
[nsv_exists [self class] [self]]} {
set tid [nsv_get [self class] [self]]
set refcount [::thread::release $tid]
- my log "destroying thread object tid=$tid cnt=$refcount"
+ :log "destroying thread object tid=$tid cnt=$refcount"
if {$refcount == 0} {
- my log "thread terminated"
+ :log "thread terminated"
nsv_unset [self class] [self]
- thread::mutex destroy [my set mutex]
- my log "+++ mutex [my set mutex] destroyed"
+ thread::mutex destroy ${:mutex}
+ :log "+++ mutex ${:mutex} destroyed"
}
}
next
@@ -185,33 +184,33 @@
return [nsv_get [self class] [self]]
}
# start a small command in the thread
- my do info exists x
+ :do info exists x
# now we have the thread and can return the tid
- return [my set tid]
+ return ${:tid}
}
::xotcl::THREAD instproc do {-async:switch args} {
if {![nsv_exists [self class] [self]]} {
# lazy creation of a new slave thread
- thread::mutex lock [my set mutex]
+ thread::mutex lock ${:mutex}
#my check_blueprint
#my log "after lock"
if {![nsv_exists [self class] [self]]} {
- if {[my lightweight]} {
- my log "CREATE lightweight thread"
+ if {[:lightweight]} {
+ :log "CREATE lightweight thread"
set tid [::thread::create -thin]
} else {
set tid [::thread::create]
}
nsv_set [self class] [self] $tid
- if {[my persistent]} {
- my log "--created new persistent [self class] as $tid pid=[pid]"
+ if {[:persistent]} {
+ :log "--created new persistent [self class] as $tid pid=[pid]"
} else {
- my log "--created new [self class] as $tid pid=[pid]"
+ :log "--created new [self class] as $tid pid=[pid]"
}
#my log "--THREAD DO send [self] epoch = [ns_ictl epoch]"
- if {[my lightweight]} {
+ if {[:lightweight]} {
} elseif {![ns_ictl epoch]} {
#ns_log notice "--THREAD send [self] no epoch"
# We are during initialization. For some unknown reasons, XOTcl
@@ -220,27 +219,27 @@
_ns_savenamespaces
set initcmd [ns_ictl get]
}
- append initcmd [my set initcmd]
+ append initcmd ${:initcmd}
#ns_log notice "INIT $initcmd"
::thread::send $tid $initcmd
} else {
set tid [nsv_get [self class] [self]]
}
#my log "doing unlock"
- thread::mutex unlock [my set mutex]
+ thread::mutex unlock ${:mutex}
} else {
# target thread is already up and running
set tid [nsv_get [self class] [self]]
}
- if {![my exists tid]} {
+ if {![info exists :tid]} {
# this is the first call
- if {![my persistent] && ![my exists recreate]} {
+ if {![:persistent] && ![info exists :recreate]} {
# for a shared thread, we do ref-counting through preserve
set tid [nsv_get [self class] [self]]
- my log "THREAD::PRESERVE must preserve for sharing request-thread [pid] tid $tid"
+ :log "THREAD::PRESERVE must preserve for sharing request-thread [pid] tid $tid"
::thread::preserve $tid
}
- my set tid $tid
+ set :tid $tid
}
#my log "calling [self class] ($tid, [pid]) $args"
if {$async} {
@@ -254,7 +253,7 @@
# via request threads
#::xotcl::THREAD create t0 {
# Class create Counter -parameter {{value 1}}
-# Counter instproc ++ {} {my incr value}
+# Counter instproc ++ {} {incr :value}
#
# Counter create c1
# Counter create c2
@@ -271,17 +270,17 @@
# || $cp eq "detachAll"} {
# next
# } elseif {$cp eq "destroy"} {
-# eval [my attach] do [self] $cp $args
-# my log "destroy"
+# eval [:attach] do [self] $cp $args
+# :log "destroy"
# next
# } else {
-# my log "forwarding [my attach] do [self] $cp $args"
-# eval [my attach] do [self] $cp $args
+# :log "forwarding [:attach] do [self] $cp $args"
+# eval [:attach] do [self] $cp $args
# }
# } -instproc init args {
-# my filter forward
+# :filter forward
# } -proc detachAll {} {
-# foreach i [my info instances] {$i filter ""}
+# foreach i [:info instances] {$i filter ""}
# }
@@ -291,7 +290,7 @@
Class create ::xotcl::THREAD::Client -parameter {server {serverobj [self]}}
::xotcl::THREAD::Client instproc do args {
- [my server] do [my serverobj] {*}$args
+ [:server] do [:serverobj] {*}$args
}
#
Index: openacs-4/packages/xotcl-core/tcl/50-protocol-handler-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/50-protocol-handler-procs.tcl,v
diff -u -N -r1.10 -r1.11
--- openacs-4/packages/xotcl-core/tcl/50-protocol-handler-procs.tcl 7 Aug 2017 23:48:30 -0000 1.10
+++ openacs-4/packages/xotcl-core/tcl/50-protocol-handler-procs.tcl 21 Oct 2017 13:07:27 -0000 1.11
@@ -7,12 +7,12 @@
ProtocolHandler ad_instproc unknown {method args} {
Return connection information similar to ad_conn
} {
- my log "--[self class] unknown called with '$method' <$args>"
+ :log "--[self class] unknown called with '$method' <$args>"
switch -- [llength $args] {
- 0 {if {[my exists $method]} {return [my set method]}
+ 0 {if {[info exists :$method]} {return ${:method}}
return [ad_conn $method]
}
- 1 {my set method $args}
+ 1 {set :method $args}
default {my log "--[self class] ignoring <$method> <$args>"}
}
}
@@ -23,7 +23,7 @@
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"
+ :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
@@ -32,65 +32,63 @@
-username $user \
-authority_id [::auth::get_register_authority] \
-password $password]
- my debug "auth $user $password returned [array get auth]"
+ :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)"
+ :debug "auth status $auth(auth_status)"
ns_returnunauthorized
- my set user_id 0
+ set :user_id 0
return 0
}
}
- my debug "auth_check user_id='$auth(user_id)'"
+ :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]
+ set :user_id [ad_conn user_id]
}
ProtocolHandler ad_instproc initialize {} {
Setup connection object and authenticate user
} {
- my instvar uri method url 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]]
- if {[string length $uri] < [string length $url]} {append uri /}
- set url_regexp "^[my url]"
- regsub $url_regexp $uri {} uri
- if {![regexp {^[./]} $uri]} {set uri /$uri}
- #my log "--conn_setup: uri '$uri' my url='[my url]' con='[ns_conn url]'"
- my set_user_id
+ set :uri [ns_urldecode [ns_conn url]]
+ if {[string length ${:uri}] < [string length ${:url}]} {append :uri /}
+ set url_regexp "^${:url}"
+ regsub $url_regexp ${:uri} {} :uri
+ if {![regexp {^[./]} ${:uri}]} {set :uri /${:uri}}
+ #my log "--conn_setup: uri '${:uri}' my url='${:url}' con='[ns_conn url]'"
+ :set_user_id
- set method [string toupper [ns_conn method]]
- #my log "--conn_setup: uri '$uri' method $method"
- set urlv [split [string trimright $uri "/"] "/"]
- my set user_agent [ns_set iget [ns_conn headers] user-agent]
- set destination [ns_urldecode [ns_set iget [ns_conn headers] Destination]]
- if {$destination ne ""} {
- regsub {https?://[^/]+/} $destination {/} dest
- regsub $url_regexp $dest {} destination
- if {![regexp {^[./]} $destination]} {set destination /$destination}
+ set :method [string toupper [ns_conn method]]
+ #my log "--conn_setup: uri '${:uri}' method ${:method}"
+ set :urlv [split [string trimright ${:uri} "/"] "/"]
+ set :user_agent [ns_set iget [ns_conn headers] user-agent]
+ set :destination [ns_urldecode [ns_set iget [ns_conn headers] Destination]]
+ if {${:destination} ne ""} {
+ regsub {https?://[^/]+/} ${:destination} {/} dest
+ regsub $url_regexp $dest {} :destination
+ if {![regexp {^[./]} ${:destination}]} {set :destination /${:destination}}
}
- #my log "--conn_setup: method $method destination '$destination' uri '$uri'"
+ #my log "--conn_setup: method ${:method} destination '${:destination}' uri '${:uri}'"
}
ProtocolHandler ad_instproc preauth { args } {
Handle authorization. This method is called via ns_filter.
} {
#my log "--preauth args=<$args>"
- my instvar user_id
# Restrict to SSL if required
if { [security::RestrictLoginToSSLP] && ![security::secure_conn_p] } {
@@ -99,10 +97,10 @@
}
# set common data for all kind of requests
- my initialize
+ :initialize
# for now, require for every user authentification
- if {$user_id == 0} {
+ if {${:user_id} == 0} {
ns_returnunauthorized
return filter_return
}
@@ -123,9 +121,9 @@
filter before the request processor (currently, there
are no hooks for that).
} {
- set filter_url [my url]*
- set url [my url]/*
- set root [string trimright [my url] /]
+ set filter_url [:url]*
+ set url [:url]/*
+ set root [string trimright [:url] /]
#
# Methods defined by RFC 2086 (19.6.1 Additional Request Methods):
#
@@ -194,27 +192,24 @@
Initialize the given package and return the package_id
@return package_id
} {
- my instvar uri package
- $package initialize -url $uri
- #my log "--[my package] initialize -url $uri"
+ ${:package} initialize -url ${:uri}
+ #my log "-- ${:package} initialize -url ${:uri}"
return $package_id
}
ProtocolHandler ad_instproc handle_request { args } {
Process the incoming HTTP request. This method
could be overloaded by the application and
dispatches the HTTP requests.
- } {
- my instvar uri method user_id
-
- #my log "--handle_request method=$method uri=$uri\
- # userid=$user_id -ns_conn query '[ns_conn query]'"
- if {[my exists package] && $uri ne "/"} {
- # We don't call package-initialze for $uri = "/"
- my set package_id [my get_package_id]
+ } {
+ #my log "--handle_request method=${:method} uri=$uri\
+ # userid=${:user_id} -ns_conn query '[ns_conn query]'"
+ if {[info exists :package] && ${:uri} ne "/"} {
+ # We don't call package-initialze for ${:uri} = "/"
+ set :package_id [:get_package_id]
}
- if {[my procsearch $method] ne ""} {
- my $method
+ if {[:procsearch ${:method}] ne ""} {
+ my ${:method}
} else {
ns_return 404 text/plain "not implemented"
}
@@ -238,7 +233,7 @@
ProtocolHandler instproc tcl_time_to_http_date {datetime} {
# RFC2518 requires this e.g. for getlastmodified
if {$datetime eq ""} return ""
- return [my http_date [clock scan [::xo::db::tcl_date $datetime tz]]]
+ return [:http_date [clock scan [::xo::db::tcl_date $datetime tz]]]
}
ProtocolHandler instproc multiStatus {body} {
@@ -290,22 +285,22 @@
D:getcontentlength "" \
D:creationdate "" \
D:resourcetype ""
- set r [my multiStatus [my multiStatusResonse \
+ set r [:multiStatus [:multiStatusResonse \
-href [ns_urldecode [ns_conn url]] \
-propstats [list $davprops $status]]]
- my log multiStatusError=$r
+ :log multiStatusError=$r
ns_return 207 text/xml $r
}
#
# Some dummy HTTP methods
#
ProtocolHandler instproc GET {} {
- my log "--GET method"
- ns_return 200 text/plain GET-[my set uri]
+ :log "--GET method"
+ ns_return 200 text/plain GET-${:uri}
}
ProtocolHandler instproc PUT {} {
- my log "--PUT method [ns_conn content]"
+ :log "--PUT method [ns_conn content]"
ns_return 201 text/plain "received put with content-length [string length [ns_conn content]]"
}
@@ -320,13 +315,13 @@
# see http://www.webdav.org/specs/rfc4918.html, 9.1.5
lappend davprops \
lp1:resourcetype \
- lp1:creationdate [my tcl_time_to_iso8601 "2013-06-30 01:21:22.648325+02"] \
+ lp1:creationdate [:tcl_time_to_iso8601 "2013-06-30 01:21:22.648325+02"] \
D:supportedlock {} \
D:lockdiscovery {}
- ns_return 207 text/xml [my multiStatus \
- [my multiStatusResonse \
- -href [my set uri] \
+ ns_return 207 text/xml [:multiStatus \
+ [:multiStatusResonse \
+ -href ${:uri} \
-propstats [list $davprops "HTTP/1.1 200 OK"]]]
}
@@ -336,7 +331,7 @@
ns_return 200 text/plain {}
}
::xo::minimalProctocolHandler proc PROPFIND {args} {
- my multiStatusError "HTTP/1.1 403 Forbidden"
+ :multiStatusError "HTTP/1.1 403 Forbidden"
}
}
Index: openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl,v
diff -u -N -r1.53 -r1.54
--- openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 7 Oct 2017 18:26:54 -0000 1.53
+++ openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 21 Oct 2017 13:07:27 -0000 1.54
@@ -103,7 +103,7 @@
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
+ :deliver_ranges $ranges $client_data $filename $fd $channel
}
#ns_log notice "--- start of delivery of $filename (running:[array size ::running])"
set key $channel,$fd,$filename
@@ -141,7 +141,7 @@
}
fileSpooler proc tick {} {
if {[catch {my cleanup} errorMsg]} {ns_log error "Error during filespooler cleanup: $errorMsg"}
- my set to [after [my set tick_interval] [list [self] tick]]
+ set :to [after ${:tick_interval} [list [self] tick]]
}
fileSpooler tick
@@ -234,51 +234,49 @@
{verbose false}
}
::AsyncDiskWriter instproc log {msg} {
- if {[my verbose]} {ns_log notice "[self] --- $msg"}
+ if {[: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]"
+ set :channel [open $filename $mode]
+ set :content ""
+ set :filename $filename
+ fconfigure ${:channel} -translation binary -blocking false
+ :log "open ${:filename}"
}
::AsyncDiskWriter instproc close {{-sync false}} {
- my instvar content channel
- if {$sync || $content eq ""} {
- my log "close sync"
- if {$content ne ""} {
- fconfigure $channel -translation binary -blocking true
- puts -nonewline $channel $content
+ if {$sync || ${:content} eq ""} {
+ :log "close sync"
+ if {${:content} ne ""} {
+ fconfigure ${:channel} -translation binary -blocking true
+ puts -nonewline ${:channel} ${:content}
}
- close $channel
- my destroy
+ close ${:channel}
+ :destroy
} else {
- my log "close async"
- my set finishWhenDone 1
+ :log "close async"
+ set :finishWhenDone 1
}
}
::AsyncDiskWriter instproc async_write {block} {
- my append content $block
- fileevent [my set channel] writable [list [self] writeBlock]
+ append :content $block
+ fileevent ${: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
+ if {[string length ${:content}] < ${:blocksize}} {
+ puts -nonewline ${:channel} ${:content}
+ :log "write [string length ${:content}] bytes"
+ fileevent ${:channel} writable ""
+ set :content ""
+ if {[:autoflush]} {flush ${:channel}}
+ if {[info exists :finishWhenDone]} {
+ :close -sync true
}
} else {
- set chunk [string range $content 0 $blocksize-1]
- set content [string range $content $blocksize end]
- puts -nonewline $channel $chunk
- my log "write [string length $chunk] bytes ([string length $content] buffered)"
+ set chunk [string range ${:content} 0 ${:blocksize}-1]
+ set :content [string range ${:content} ${:blocksize} end]
+ puts -nonewline ${:channel} $chunk
+ :log "write [string length $chunk] bytes ([string length ${:content}] buffered)"
}
}
@@ -291,21 +289,20 @@
::xotcl::Class create Subscriber -parameter {key channel user_id mode}
Subscriber proc current {-key } {
- my instvar subscriptions
set result [list]
if {[info exists key]} {
- if {[info exists subscriptions($key)]} {
- return [list $key $subscriptions($key)]
+ if {[info exists :subscriptions($key)]} {
+ return [list $key [set :subscriptions($key)]]
}
- } elseif {[info exists subscriptions]} {
- foreach key [array names subscriptions] {
- lappend result $key $subscriptions($key)
+ } elseif {[info exists :subscriptions]} {
+ foreach key [array names :subscriptions] {
+ lappend result $key [set :subscriptions($key)]
}
}
}
Subscriber instproc close {} {
- set channel [my channel]
+ set channel [:channel]
#
# It is important to make the channel non-blocking for the close,
# since otherwise the close operation might block and bring all of
@@ -321,9 +318,9 @@
# destroys the instance. In this step the peer connection is close
# as well.
#
- set channel [my channel]
+ set channel [:channel]
if {[catch {set eof [eof $channel]}]} {set eof 1}
- my log "sweep [my channel] EOF $eof"
+ :log "sweep [:channel] EOF $eof"
if {$eof} {
error "connection $channel closed by peer"
}
@@ -339,9 +336,9 @@
}
Subscriber instproc send {msg} {
- #ns_log notice "SEND <$msg> [my mode]"
- my log ""
- if {[my mode] eq "scripted"} {
+ #ns_log notice "SEND <$msg> [:mode]"
+ :log ""
+ if {[:mode] eq "scripted"} {
set emsg [encoding convertto utf-8 $msg]
#ns_log notice "SEND data <$msg> encoded <$emsg>"
set smsg "\n"
}
Chat instproc broadcast_msg {msg} {
- my log "--chat broadcast_msg"
+ :log "--chat broadcast_msg"
::xo::clusterwide \
- bgdelivery send_to_subscriber chat-[my chat_id] [my json_encode_msg $msg]
+ bgdelivery send_to_subscriber chat-[:chat_id] [:json_encode_msg $msg]
}
Chat instproc subscribe {-uid} {
- set user_id [expr {[info exists uid] ? $uid : [my set user_id]}]
- set color [my user_color $user_id]
- bgdelivery subscribe chat-[my chat_id] "" [my mode]
- if {[my set login_messages_p] && ![my user_active $user_id]} {
- my broadcast_msg [Message new -volatile -time [clock seconds] \
+ set user_id [expr {[info exists uid] ? $uid : ${:user_id}}]
+ set color [:user_color $user_id]
+ bgdelivery subscribe chat-[:chat_id] "" [:mode]
+ if {${:login_messages_p} && ![:user_active $user_id]} {
+ :broadcast_msg [Message new -volatile -time [clock seconds] \
-user_id $user_id -color $color \
-msg [_ xotcl-core.has_entered_the_room] ]
}
#my get_all
}
Chat instproc render {} {
- my orderby time
+ :orderby time
set result "\n"
- foreach child [my children] {
+ foreach child [:children] {
set msg [$child msg]
set user_id [$child user_id]
set color [$child color]
set timelong [clock format [$child time]]
set timeshort [clock format [$child time] -format {[%H:%M:%S]}]
- set userlink [my user_link -user_id $user_id -color $color]
- ns_log notice "encode <$msg> using encoder [my encoder] gives <[my encode $msg]>"
+ set userlink [:user_link -user_id $user_id -color $color]
+ ns_log notice "encode <$msg> using encoder [:encoder] gives <[:encode $msg]>"
append result "
$timeshort " \
"$userlink " \
- "[my encode $msg]
\n"
+ "
[:encode $msg]\n"
}
append result "