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 -r1.72.2.11 -r1.72.2.12 --- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 11 Feb 2014 11:53:08 -0000 1.72.2.11 +++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 14 Feb 2014 18:20:43 -0000 1.72.2.12 @@ -3,9 +3,9 @@ if {$::tcl_version < 8.5 || ([regexp {8[.]5[.]([0-9]+)$} $::tcl_patchLevel _ minor] && $minor < 4) -} { - ns_log error "We require for this version of xotcl-core at least Tcl 8.5.4 (avail: Tcl $::tcl_patchLevel)" - return + } { + ns_log error "We require for this version of xotcl-core at least Tcl 8.5.4 (avail: Tcl $::tcl_patchLevel)" + return } package require xotcl::serializer @@ -40,21 +40,21 @@ # emulate slots up to a certain point namespace eval ::xo { ::xotcl::MetaSlot create ::xo::Attribute \ - -parameter { - {name "[namespace tail [::xotcl::self]]"} - {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]"} - {multivalued false} - {required false} - default - type - spec - pretty_name - {pretty_plural ""} - {datatype "text"} - constraint_values - help_text - validator - } + -parameter { + {name "[namespace tail [::xotcl::self]]"} + {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]"} + {multivalued false} + {required false} + default + type + spec + pretty_name + {pretty_plural ""} + {datatype "text"} + constraint_values + help_text + validator + } } } else { namespace eval ::xo { @@ -127,11 +127,11 @@ set object_type [my domain] if {[regexp {^::([^:]+)::} $object_type _ head]} { set tail [namespace tail $object_type] - set pretty_name "#$head.$tail-$name#" - #my log "--created pretty_name = $pretty_name" + set pretty_name "#$head.$tail-$name#" + #my log "--created pretty_name = $pretty_name" } else { error "Cannot determine automatically message key for pretty name. \ - Use namespaces for classes" + Use namespaces for classes" } } } @@ -186,11 +186,11 @@ array set names "" foreach c [concat $cl [$cl info heritage]] { foreach s [$c info slots] { - set n [namespace tail $s] - if {![info exists names($n)]} { - lappend so $s - set names($n) $s - } + set n [namespace tail $s] + if {![info exists names($n)]} { + lappend so $s + set names($n) $s + } } } return $so @@ -262,7 +262,7 @@ if {[ns_conn isconnected]} { set msg "[self]: $msg ([self callingclass]->[self callingproc])" if {$html} { - util_user_message -html -message $msg + util_user_message -html -message $msg } else { util_user_message -message $msg } @@ -317,7 +317,7 @@ ::xotcl::Object log "### Call Stack (level: command)" for {set i 0} {$i < $max} {incr i} { if {[catch {set s [uplevel $i self]} msg]} { - set s "" + set s "" } ::xotcl::Object log "### [format %5d -$i]:\t$s [info level [expr {-$i}]]" } @@ -367,7 +367,7 @@ # ns_log notice "--T :ttrace::isenabled" # set blueprint [ns_ictl get] # ns_ictl save [append blueprint [::Serializer serializeExportedMethods \ -# [::Serializer new -volatile]]] + # [::Serializer new -volatile]]] # unset blueprint # ns_log notice "--T [ns_ictl get]" #} @@ -406,25 +406,25 @@ ns_ictl ondelete ::xo::at_delete } -# proc trace_cleanup {args} { -# set name [lindex $args 1] -# #ns_log notice "*** cleanup <$args> '$name'" -# if {[::xotcl::Object isobject $name]} { -# ns_log notice "*** cleanup $name destroy" -# $name destroy -# } -# } + # proc trace_cleanup {args} { + # set name [lindex $args 1] + # #ns_log notice "*** cleanup <$args> '$name'" + # if {[::xotcl::Object isobject $name]} { + # ns_log notice "*** cleanup $name destroy" + # $name destroy + # } + # } } else { # register only once if {"::xo::freeconn" ni $registered} { if {[catch {ns_ictl trace freeconn ::xo::freeconn} errorMsg]} { - ns_log Warning "ns_ictl trace returned: $errorMsg" + ns_log Warning "ns_ictl trace returned: $errorMsg" } } if {"::xo::at_delete" ni [ns_ictl gettraces delete]} { if {[catch {ns_ictl ondelete ::xo::at_delete} errorMsg]} { - ns_log Warning "ns_ictl ondelete returned: $errorMsg" + ns_log Warning "ns_ictl ondelete returned: $errorMsg" } } @@ -541,7 +541,7 @@ set t1 [clock clicks -milliseconds] ns_log notice "ON DELETE done ([expr {$t1-$t0}]ms)" } - + # # ::xo::Module is very similar to a plain tcl namespace: When it is # created/recreated, it does not perform a cleanup of its @@ -677,32 +677,32 @@ ::xo::system_stats proc thread_info {pid tid} { set fn /proc/$pid/task/$tid/stat if {[file readable $fn]} { - set f [open $fn]; set s [read $f]; close $f + set f [open $fn]; set s [read $f]; close $f } elseif {[file readable /proc/$pid/task/$pid/stat]} { - set f [open /proc/$pid/task/$pid/stat]; set s [read $f]; close $f + set f [open /proc/$pid/task/$pid/stat]; set s [read $f]; close $f } else { - return "" + return "" } lassign $s tid comm state ppid pgrp session tty_nr tpgid flags minflt \ - cminflt majflt cmajflt utime stime cutime cstime priority nice \ - numthreads itrealval starttime vsize rss rsslim startcode endcode \ - startstack kstkesp kstkeip signal blocked sigignore sigcatch wchan \ - nswap cnswap ext_signal processor ... + cminflt majflt cmajflt utime stime cutime cstime priority nice \ + numthreads itrealval starttime vsize rss rsslim startcode endcode \ + startstack kstkesp kstkeip signal blocked sigignore sigcatch wchan \ + nswap cnswap ext_signal processor ... # utime and stimes are jiffies. Since Linux has HZ 100, we can # multiply the jiffies by 10 to obtain ms return [list utime [expr {$utime*10}] stime [expr {$stime*10}]] } } else { ::xo::system_stats proc thread_info {pid tid} { - return "" + return "" } } ::xo::system_stats proc gettid {} { set hex [ns_thread getid] foreach t [ns_info threads] { if {[lindex $t 2] eq $hex} { - return [list name [lindex $t 0] tid [lindex $t 7]] + return [list name [lindex $t 0] tid [lindex $t 7]] } } return "" @@ -749,13 +749,13 @@ set threadInfo [ns_info threads] if {[file readable /proc/$pid/statm] && [llength [lindex $threadInfo 0]] > 7} { foreach t $threadInfo { - array unset s - array set s [my thread_info $pid [lindex $t 7]] - if {[info exists s(stime)]} { - set group [my thread_classify [lindex $t 0]] - my aggregate $group $varnames(utime) $s(utime) - my aggregate $group $varnames(stime) $s(stime) - } + array unset s + array set s [my thread_info $pid [lindex $t 7]] + if {[info exists s(stime)]} { + set group [my thread_classify [lindex $t 0]] + my aggregate $group $varnames(utime) $s(utime) + my aggregate $group $varnames(stime) $s(stime) + } } } foreach group [array names utimes] { @@ -777,11 +777,11 @@ ::xo::broadcast proc send {cmd} { foreach thread_info [ns_info threads] { switch -glob -- [lindex $thread_info 0] { - -conn:* - - -sched:* { - set tid [lindex $thread_info 2] - nsv_lappend broadcast $tid $cmd - } + -conn:* - + -sched:* { + set tid [lindex $thread_info 2] + nsv_lappend broadcast $tid $cmd + } } } } @@ -798,152 +798,152 @@ set tid [ns_thread id] if {[nsv_exists broadcast $tid]} { foreach cmd [nsv_get broadcast $tid] { - ns_log notice "broadcast received {$cmd}" - if {[catch $cmd errorMsg]} { - ns_log notice "broadcast receive error: $errorMsg for cmd $cmd" - } + ns_log notice "broadcast received {$cmd}" + if {[catch $cmd errorMsg]} { + ns_log notice "broadcast receive error: $errorMsg for cmd $cmd" + } } my clear } } } proc ::xo::getObjectProperty {o what args} { - switch $what { - "mixin" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info mixin]} - return [$o info object mixin classes] - } - "instmixin" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info instmixin]} - return [$o info mixin classes] - } - "instproc" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info instprocs {*}$args]} - return [$o info methods -type scripted {*}$args] - } - "instcommand" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info instcommands {*}$args]} - return [$o info methods {*}$args] - } - "instforward" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info instforward {*}$args]} - return [$o info methods -type forwarder {*}$args] - } - "proc" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}$args]} - return [$o info object methods -type scripted {*}$args] - } - "command" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}$args]} - return [$o info object methods {*}$args] - } - "forward" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info forward {*}$args]} - return [$o info object methods -type forwarder {*}$args] - } - "slots" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info slots]} - return [$o info object methods -type forwarder] - } - "class" { - #if {"::xotcl::Object" in [$o info precedence]} {return [$o info class]} - return [$o info class] - } - "superclass" { - #if {"::xotcl::Object" in [$o info precedence]} {return [$o info superclass]} - return [$o info superclass] - } - "heritage" { - #if {"::xotcl::Object" in [$o info precedence]} {return [$o info heritage]} - return [$o info heritage] - } - "subclass" { - #if {"::xotcl::Object" in [$o info precedence]} {return [$o info subclass]} - return [$o info subclass] - } - "parameter" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info parameter]} - set result "" - foreach p [$o info configure parameters] {lappend result [$o info parameter name $p]} - return $result - } - "isclass" { - if {[info commands $o] eq ""} {return 0} - if {[catch {set p [$o info precedence]}]} {return 0} - if {"::xotcl::Object" in $p} {return [expr {"::xotcl::Class" in $p}]} - return [nsf::is class $o] - } - "isobject" { - if {[info commands $o] eq ""} {return 0} - if {[catch {set p [$o info precedence]}]} {return 0} - if {"::xotcl::Object" in $p} {return 1} - return [nsf::is object $o] - } - "instargs" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info instargs {*}$args]} - return [$o info method args {*}$args] - } - "args" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info args {*}$args]} - return [$o info object method args {*}$args] - } - "instargdefault" { - if {"::xotcl::Object" in [$o info precedence]} { - return [uplevel [list $o info instdefault {*}$args]] - } - lassign $args method arg varName - foreach p [$o info method parameters $method] { - lassign $p name default - if {$name eq $arg} { - uplevel [list set $varName $default] - return [expr {[llength $p] == 2}] - } - } - return 0 - } - "argdefault" { - if {"::xotcl::Object" in [$o info precedence]} { - return [uplevel [list $o info default {*}$args]] - } - lassign $args method arg varName - foreach p [$o info object method parameter $method] { - lassign $p name default - if {$name eq $arg} { - uplevel [list set $varName $default] - return [expr {[llength $p] == 2}] - } - } - return 0 - } - - "array-exists" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o array exists {*}$args]} - return [$o eval [list array exists :{*}$args]] - } - "array-get" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o array get {*}$args]} - return [$o eval [list array get :{*}$args]] - } - "array-set" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o array set {*}$args]} - return [$o eval [list array set :{*}$args]] - } - "set" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o set {*}$args]} - return [$o eval [list set :[lindex $args 0]]] - } - "isnxobject" { - if {[info commands ::nsf::dispatch] ne "" && [info commands $o] ne ""} { - return [::nsf::dispatch $o ::nsf::methods::object::info::hastype ::nx::Object] - } { - return 0 - } - } - default { - error "no idea how to return $what" - } + switch $what { + "mixin" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info mixin]} + return [$o info object mixin classes] } + "instmixin" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instmixin]} + return [$o info mixin classes] + } + "instproc" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instprocs {*}$args]} + return [$o info methods -type scripted {*}$args] + } + "instcommand" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instcommands {*}$args]} + return [$o info methods {*}$args] + } + "instforward" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instforward {*}$args]} + return [$o info methods -type forwarder {*}$args] + } + "proc" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}$args]} + return [$o info object methods -type scripted {*}$args] + } + "command" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}$args]} + return [$o info object methods {*}$args] + } + "forward" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info forward {*}$args]} + return [$o info object methods -type forwarder {*}$args] + } + "slots" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info slots]} + return [$o info object methods -type forwarder] + } + "class" { + #if {"::xotcl::Object" in [$o info precedence]} {return [$o info class]} + return [$o info class] + } + "superclass" { + #if {"::xotcl::Object" in [$o info precedence]} {return [$o info superclass]} + return [$o info superclass] + } + "heritage" { + #if {"::xotcl::Object" in [$o info precedence]} {return [$o info heritage]} + return [$o info heritage] + } + "subclass" { + #if {"::xotcl::Object" in [$o info precedence]} {return [$o info subclass]} + return [$o info subclass] + } + "parameter" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info parameter]} + set result "" + foreach p [$o info configure parameters] {lappend result [$o info parameter name $p]} + return $result + } + "isclass" { + if {[info commands $o] eq ""} {return 0} + if {[catch {set p [$o info precedence]}]} {return 0} + if {"::xotcl::Object" in $p} {return [expr {"::xotcl::Class" in $p}]} + return [nsf::is class $o] + } + "isobject" { + if {[info commands $o] eq ""} {return 0} + if {[catch {set p [$o info precedence]}]} {return 0} + if {"::xotcl::Object" in $p} {return 1} + return [nsf::is object $o] + } + "instargs" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instargs {*}$args]} + return [$o info method args {*}$args] + } + "args" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info args {*}$args]} + return [$o info object method args {*}$args] + } + "instargdefault" { + if {"::xotcl::Object" in [$o info precedence]} { + return [uplevel [list $o info instdefault {*}$args]] + } + lassign $args method arg varName + foreach p [$o info method parameters $method] { + lassign $p name default + if {$name eq $arg} { + uplevel [list set $varName $default] + return [expr {[llength $p] == 2}] + } + } + return 0 + } + "argdefault" { + if {"::xotcl::Object" in [$o info precedence]} { + return [uplevel [list $o info default {*}$args]] + } + lassign $args method arg varName + foreach p [$o info object method parameter $method] { + lassign $p name default + if {$name eq $arg} { + uplevel [list set $varName $default] + return [expr {[llength $p] == 2}] + } + } + return 0 + } + + "array-exists" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o array exists {*}$args]} + return [$o eval [list array exists :{*}$args]] + } + "array-get" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o array get {*}$args]} + return [$o eval [list array get :{*}$args]] + } + "array-set" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o array set {*}$args]} + return [$o eval [list array set :{*}$args]] + } + "set" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o set {*}$args]} + return [$o eval [list set :[lindex $args 0]]] + } + "isnxobject" { + if {[info commands ::nsf::dispatch] ne "" && [info commands $o] ne ""} { + return [::nsf::dispatch $o ::nsf::methods::object::info::hastype ::nx::Object] + } { + return 0 + } + } + default { + error "no idea how to return $what" + } + } } Index: openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl,v diff -u -r1.6.2.4 -r1.6.2.5 --- openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl 13 Oct 2013 18:15:13 -0000 1.6.2.4 +++ openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl 14 Feb 2014 18:20:43 -0000 1.6.2.5 @@ -50,8 +50,8 @@ [$scope do xo::getObjectProperty $obj isobject]} } -proc scope {} { if {[info exists ::xotcl::currentThread]} { - # we are in an xotcl thread; the body won't be accessible directly - return $::xotcl::currentThread + # we are in an xotcl thread; the body won't be accessible directly + return $::xotcl::currentThread } return "" @@ -73,7 +73,7 @@ #return "$scope$kind [self]" set script [info script] if {$script eq "" && [info exists ::xotcl::currentScript]} { - set script $::xotcl::currentScript + set script $::xotcl::currentScript } set root_dir [acs_root_dir] set root_length [string length $root_dir] @@ -85,9 +85,9 @@ } -proc object_link {{-noimg:boolean off} scope obj} { set link "" if {$noimg} { - return "$link$obj" + return "$link$obj" } else { - return "$obj$link\[i\]" + return "$obj$link\[i\]" } } -proc object_url {{-show_source 0} {-show_methods 1} scope obj} { @@ -99,38 +99,38 @@ } -proc proc_index {scope obj instproc proc_name} { if {$scope eq ""} { - return "$obj $instproc $proc_name" + return "$obj $instproc $proc_name" } else { - return "$scope $obj $instproc $proc_name" + return "$scope $obj $instproc $proc_name" } } -proc source_to_html {{-width 100} string} { set lines [list] foreach l [split $string \n] { - while {[string length $l] > $width} { - set pos [string last " \{" $l $width] - if {$pos>10} { - lappend lines "[string range $l 0 $pos-1] \\" - set l " [string range $l $pos end]" - } else { - # search for a match right of the target - set pos [string first " \{" $l $width] - if {$pos>10} { - lappend lines "[string range $l 0 $pos-1] \\" - set l " [string range $l $pos end]" - } else { - # last resort try to split around spaces - set pos [string last " " $l $width] - if {$pos>10} { - lappend lines "[string range $l 0 $pos-1] \\" - set l " [string range $l $pos end]" - } else { - break - } - } - } - } - lappend lines $l + while {[string length $l] > $width} { + set pos [string last " \{" $l $width] + if {$pos>10} { + lappend lines "[string range $l 0 $pos-1] \\" + set l " [string range $l $pos end]" + } else { + # search for a match right of the target + set pos [string first " \{" $l $width] + if {$pos>10} { + lappend lines "[string range $l 0 $pos-1] \\" + set l " [string range $l $pos end]" + } else { + # last resort try to split around spaces + set pos [string last " " $l $width] + if {$pos>10} { + lappend lines "[string range $l 0 $pos-1] \\" + set l " [string range $l $pos end]" + } else { + break + } + } + } + } + lappend lines $l } set string [join $lines \n] set html [ad_quotehtml $string] @@ -240,10 +240,10 @@ } ::xotcl::Class instproc ad_instproc { - {-private:switch false} - {-deprecated:switch false} - {-warn:switch false} - {-debug:switch false} + {-private:switch false} + {-deprecated:switch false} + {-warn:switch false} + {-debug:switch false} proc_name arguments doc body} { uplevel [list [self] instproc $proc_name $arguments $body] my __api_make_doc inst $proc_name @@ -290,7 +290,7 @@ array set elements [nsv_get api_library_doc $file_index] } set oldDoc [expr {[info exists elements(main)] ? \ - [lindex $elements(main) 0] : ""}] + [lindex $elements(main) 0] : ""}] set prefix "This file defines the following Objects and Classes" set entry [::xotcl::api object_link $scope [self]] if {![string match "*$prefix*" $oldDoc]} { @@ -349,3 +349,10 @@ A Class defined as a subclass of ::Test for testing the documentation stuff... } + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: 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 -r1.97.2.5 -r1.97.2.6 --- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 11 Feb 2014 11:53:08 -0000 1.97.2.5 +++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 14 Feb 2014 18:20:43 -0000 1.97.2.6 @@ -133,10 +133,10 @@ set sequenceName $sequence set nextval [::xo::dc get_value nextval "select nextval(:sequenceName)"] } elseif { [::xo::dc db_0or1row nextval_sequence { - select nextval(:sequence) as nextval - where (select relkind - from pg_class - where relname = :sequence) = 'S' + select nextval(:sequence) as nextval + where (select relkind + from pg_class + where relname = :sequence) = 'S' }]} { # # We do not have an according sequence-table. Use the system catalog to check @@ -712,7 +712,7 @@ set p [split $package_key_and_version_older_than] if {[llength $p] != 2} { error "package_key_and_version_older_than should be\ - of the form 'package_key version'" + of the form 'package_key version'" } lassign $p package_key version set installed_version [apm_highest_version_name $package_key] @@ -757,25 +757,25 @@ ::xotcl::Class create ::xo::db::Class \ -superclass ::xotcl::Class \ -parameter { - pretty_name - pretty_plural - {supertype acs_object} - table_name - id_column - {abstract_p f} - {name_method ""} - {object_type [self]} - {security_inherit_p t} - {auto_save false} - {with_table true} - {sql_package_name} + pretty_name + pretty_plural + {supertype acs_object} + table_name + id_column + {abstract_p f} + {name_method ""} + {object_type [self]} + {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 - the behavior common to all acs_object_types. The behavior common to - all acs_objects is defined by the class ::xo::db::Object. - - @see ::xo::db::Object + ::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 + the behavior common to all acs_object_types. The behavior common to + all acs_objects is defined by the class ::xo::db::Object. + + @see ::xo::db::Object } #::xo::db::Class set __default_superclass ::xo::db::Object ;# will be supported in XOTcl 1.6 @@ -876,16 +876,16 @@ set table_name [::xo::db::Class get_table_name -object_type $object_type] if {$table_name ne ""} { if {[catch { - ::xo::dc dml delete_instances "delete from $table_name" - if {$drop_table} { - ::xo::dc dml drop_table "drop table $table_name" - } + ::xo::dc dml delete_instances "delete from $table_name" + if {$drop_table} { + ::xo::dc dml drop_table "drop table $table_name" + } } errorMsg]} { - my log "error during drop_type" + my log "error during drop_type" } } ::xo::db::sql::acs_object_type drop_type \ - -object_type $object_type -cascade_p $cascade_p + -object_type $object_type -cascade_p $cascade_p return "" } @@ -928,7 +928,7 @@ -id_column $id_column \ -table_name $table_name \ -sql_package_name [namespace tail $classname] \ - -noinit + -noinit } else { #my log "--db we have a class $classname" } @@ -941,22 +941,22 @@ set slots "" foreach att_info $attributes { lassign $att_info attribute_name pretty_name pretty_plural datatype \ - default_value min_n_values max_n_values + default_value min_n_values max_n_values # ignore some erroneous definitions in the acs meta model if {[my exists exclude_attribute($table_name,$attribute_name)]} continue set defined_att($attribute_name) 1 set cmd [list ::xo::db::Attribute create $attribute_name \ - -pretty_name $pretty_name \ - -pretty_plural $pretty_plural \ - -datatype $datatype \ - -min_n_values $min_n_values \ - -max_n_values $max_n_values] + -pretty_name $pretty_name \ + -pretty_plural $pretty_plural \ + -datatype $datatype \ + -min_n_values $min_n_values \ + -max_n_values $max_n_values] if {$default_value ne ""} { - # if the default_value is "", we assume, no default - lappend cmd -default $default_value + # if the default_value is "", we assume, no default + lappend cmd -default $default_value } append slots $cmd \n } @@ -1056,7 +1056,7 @@ regexp {^[^a-zA-Z]+([a-zA-Z0-9_]+)\s} $line _ fq_name if {![info exists fq_name]} { ns_log notice "--***** Could not retrieve argument name for $proname\ - argument $n from line '$line' in $prosrc'" + argument $n from line '$line' in $prosrc'" set fq_name arg$n } set name $fq_name @@ -1380,12 +1380,12 @@ if {[my isclass $name]} { if {[$name exists object_type]} { # The specified class has an object_type defined; return it - return [$name object_type] + return [$name object_type] } if {![$name istype ::xo::db::Object]} { # The specified class is not subclass of ::xo::db::Object. # return acs_object in your desparation. - return acs_object + return acs_object } } # Standard mapping rules @@ -1466,7 +1466,7 @@ @return list of object_types } { return [::xo::dc list get_object_types \ - [my object_types_query -subtypes_first $subtypes_first]] + [my object_types_query -subtypes_first $subtypes_first]] } ::xo::db::Class ad_instproc create_object_type {} { @@ -1523,14 +1523,14 @@ } if {[self] ne "::xo::db::Object"} { if {[my exists id_column] && ![info exists db_slot($id_column)]} { - # create automatically the slot for the id column - my slots [subst { - ::xo::db::Attribute create $id_column \ - -pretty_name "ID" \ - -datatype integer \ + # create automatically the slot for the id column + my slots [subst { + ::xo::db::Attribute create $id_column \ + -pretty_name "ID" \ + -datatype integer \ -create_acs_attribute false - }] - set db_slot($id_column) [self]::slot::$id_column + }] + set db_slot($id_column) [self]::slot::$id_column } } #my log "--setting db_slot of [self] to [array names db_slot]" @@ -1545,14 +1545,14 @@ foreach {slot_name slot} [my array get db_slot] { set column_name [$slot column_name] set column_specs($column_name) \ - [$slot column_spec -id_column [expr {$column_name eq $id_column}]] + [$slot column_spec -id_column [expr {$column_name eq $id_column}]] } if {[array size column_specs]>0} { if {$table_name eq ""} {error "no table_name specified"} if {$id_column eq ""} {error "no id_column specified"} if {![info exists column_specs($id_column)]} { - error "no ::xo::db::Attribute slot for id_column '$id_column' specified" + error "no ::xo::db::Attribute slot for id_column '$id_column' specified" } set table_specs [list] foreach {att spec} [array get column_specs] {lappend table_specs " $att $spec"} @@ -1570,18 +1570,18 @@ foreach {slot_name slot} [my array get db_slot] { $slot instvar name column_name if {$column_name ne [my id_column]} { - lappend updates "$column_name = :$name" - lappend vars $name + lappend updates "$column_name = :$name" + lappend vars $name } } if {[llength $updates] == 0} return my instproc save {} [subst { ::xo::dc transaction { - next - my instvar object_id $vars - ::xo::dc dml update_[my table_name] {update [my table_name] - set [join $updates ,] where [my id_column] = :object_id - } + next + my instvar object_id $vars + ::xo::dc dml update_[my table_name] {update [my table_name] + set [join $updates ,] where [my id_column] = :object_id + } } }] } @@ -1596,14 +1596,14 @@ my log "ID insert in $__table_name, id = $__id = [my set $__id]" next foreach {__slot_name __slot} [[self class] array get db_slot] { - my instvar $__slot_name - if {[info exists $__slot_name]} { - lappend __vars $__slot_name - lappend __atts [$__slot column_name] - } + my instvar $__slot_name + if {[info exists $__slot_name]} { + lappend __vars $__slot_name + lappend __atts [$__slot column_name] + } } ::xo::dc dml insert_$__table_name "insert into $__table_name - ([join $__atts ,]) values (:[join $__vars ,:])" + ([join $__atts ,]) values (:[join $__vars ,:])" } } @@ -1622,7 +1622,7 @@ } if {[string length $sql_package_name] > 30} { error "SQL package_name '$sql_package_name' can be maximal 30 characters long!\ - Please specify a shorter sql_package_name in the class definition." + Please specify a shorter sql_package_name in the class definition." } if {$sql_package_name eq ""} { error "Cannot determine SQL package_name. Please specify it explicitely!" @@ -1644,12 +1644,12 @@ if {![regexp {^[[:alpha:]_][[:alnum:]_]*$} [my table_name]]} { error "Table name '[my table_name]' is unsafe in SQL: \ - Please specify a different table_name$table_name_error_tail." + Please specify a different table_name$table_name_error_tail." } if {[string length [my table_name]] > 30} { error "SQL table_name '[my table_name]' can be maximal 30 characters long!\ - Please specify a shorter table_name in the class definition." + Please specify a shorter table_name in the class definition." } if {![regexp {^[[:alpha:]_][[:alnum:]_]*$} [my id_column]]} { @@ -1676,7 +1676,7 @@ if {[my with_table]} { set table_definition [my table_definition] if {$table_definition ne ""} { - ::xo::db::require table [my table_name] $table_definition + ::xo::db::require table [my table_name] $table_definition } my mk_save_method @@ -1687,13 +1687,13 @@ ::xo::db::Class instproc get_context {package_id_var user_id_var ip_var} { my upvar \ - $package_id_var package_id \ - $user_id_var user_id \ - $ip_var ip + $package_id_var package_id \ + $user_id_var user_id \ + $ip_var ip if {![info exists package_id]} { if {[info commands ::xo::cc] ne ""} { - set package_id [::xo::cc package_id] + set package_id [::xo::cc package_id] } elseif {[ns_conn isconnected]} { set package_id [ad_conn package_id] } else { @@ -1702,7 +1702,7 @@ } if {![info exists user_id]} { if {[info commands ::xo::cc] ne ""} { - set user_id [::xo::cc user_id] + set user_id [::xo::cc user_id] } elseif {[ns_conn isconnected]} { set user_id [ad_conn user_id] } else { @@ -1711,9 +1711,9 @@ } if {![info exists ip]} { if {[ns_conn isconnected]} { - set ip [ns_conn peeraddr] + set ip [ns_conn peeraddr] } else { - set ip [ns_info address] + set ip [ns_info address] } } } @@ -1727,7 +1727,7 @@ my get_context package_id creation_user creation_ip set id [::xo::db::sql::acs_object new \ - -object_type [::xo::db::Class class_to_object_type [self]] \ + -object_type [::xo::db::Class class_to_object_type [self]] \ -title $object_title \ -package_id $package_id \ -creation_user $creation_user \ @@ -1763,13 +1763,13 @@ my get_context package_id creation_user creation_ip ::xo::dc transaction { set id [my new_acs_object \ - -package_id $package_id \ - -creation_user $creation_user \ - -creation_ip $creation_ip \ - ""] + -package_id $package_id \ + -creation_user $creation_user \ + -creation_ip $creation_ip \ + ""] #[self class] set during_fetch 1 if {[catch {my create ::$id {*}$args} errorMsg]} { - my log "Error: $errorMsg, $::errorInfo" + my log "Error: $errorMsg, $::errorInfo" } #[self class] unset during_fetch my initialize_acs_object ::$id $id @@ -1815,8 +1815,8 @@ method to avoid object name clashes. @destroy_on_cleanup If this flag is true, the objects (and ordered - composite) will be automatically destroyed on cleaup (typically - after the request was processed). + composite) will be automatically destroyed on cleaup (typically + after the request was processed). @initialize can be used to avoid full initialization, when a large series of of objects is loaded. Per default, these objects @@ -1841,37 +1841,37 @@ set sets [uplevel [list ::xo::dc sets -dbn $dbn [self proc] $sql]] foreach selection $sets { if {$named_objects} { - set object_name ::[ns_set get $selection $object_named_after] - set o [$object_class create $object_name] + set object_name ::[ns_set get $selection $object_named_after] + set o [$object_class create $object_name] } else { - set o [$object_class new] + set o [$object_class new] } if {$as_ordered_composite} { - $__result add $o + $__result add $o } else { - if {$destroy_on_cleanup} { - $o destroy_on_cleanup - } - lappend __result $o + if {$destroy_on_cleanup} { + $o destroy_on_cleanup + } + lappend __result $o } foreach {att val} [ns_set array $selection] {$o set $att $val} if {[$o exists object_type]} { - # set the object type if it looks like managed from XOTcl - if {[string match "::*" [set ot [$o set object_type]] ]} { - $o class $ot - } + # set the object type if it looks like managed from XOTcl + if {[string match "::*" [set ot [$o set object_type]] ]} { + $o class $ot + } } if {$initialize && [$o istype ::xo::db::Object]} { - if {![$o exists package_id]} { - if {[$o exists object_package_id]} { - $o set package_id [$o set object_package_id] - } else { - ns_log warning "[namespace tail [$o info class]] $o has no package_id and no object_package_id" - } - } - if {[catch {$o initialize_loaded_object} errorMsg]} { - ns_log error "$o initialize_loaded_object => [$o info vars] -> $errorMsg" - } + if {![$o exists package_id]} { + if {[$o exists object_package_id]} { + $o set package_id [$o set object_package_id] + } else { + ns_log warning "[namespace tail [$o info class]] $o has no package_id and no object_package_id" + } + } + if {[catch {$o initialize_loaded_object} errorMsg]} { + ns_log error "$o initialize_loaded_object => [$o info vars] -> $errorMsg" + } } #my log "--DB more = $continue [$o serialize]" } @@ -1890,15 +1890,15 @@ set tn [$cl table_name] if {$tn ne ""} { lappend tables $tn - #my log "--db_slots of $cl = [$cl array get db_slot]" - foreach {slot_name slot} [$cl array get db_slot] { + #my log "--db_slots of $cl = [$cl array get db_slot]" + foreach {slot_name slot} [$cl array get db_slot] { # avoid duplicate output names set name [$slot name] if {![info exists names($name)]} { lappend attributes [$slot attribute_reference $tn] } set names($name) 1 - } + } if {$cl ne [self]} { lappend join_expressions "$tn.[$cl id_column] = [my table_name].$id_column" } @@ -1943,16 +1943,16 @@ if {$tn ne ""} { lappend tables $tn - if {$all_attributes} { - foreach {slot_name slot} [$cl array get db_slot] { + if {$all_attributes} { + foreach {slot_name slot} [$cl array get db_slot] { # avoid duplicate output names set name [$slot name] if {![info exists names($name)]} { lappend select_attributes [$slot attribute_reference $tn] } set names($name) 1 - } - } + } + } if {$cl ne [self]} { lappend join_expressions "$tn.[$cl id_column] = [my table_name].$id_column" } @@ -1968,11 +1968,11 @@ } set sql [::xo::dc select \ - -vars [join $select_attributes ,] \ - -from "[join $tables ,] $from_clause" \ - -where [string trim "[join $join_expressions { and }] $where_clause"] \ - -orderby $orderby \ - -limit $limit -offset $offset] + -vars [join $select_attributes ,] \ + -from "[join $tables ,] $from_clause" \ + -where [string trim "[join $join_expressions { and }] $where_clause"] \ + -orderby $orderby \ + -limit $limit -offset $offset] return $sql } @@ -2047,10 +2047,10 @@ [my info class] get_context package_id creation_user creation_ip ::xo::dc transaction { set id [[my info class] new_acs_object \ - -package_id $package_id \ - -creation_user $creation_user \ - -creation_ip $creation_ip \ - ""] + -package_id $package_id \ + -creation_user $creation_user \ + -creation_ip $creation_ip \ + ""] [my info class] initialize_acs_object [self] $id my insert } @@ -2075,7 +2075,7 @@ {references ""} {min_n_values 1} {max_n_values 1} - {create_acs_attribute true} + {create_acs_attribute true} } ::xo::db::Attribute instproc create_attribute {} { @@ -2087,7 +2087,7 @@ attribute_name = :column_name and object_type = :object_type} 1]} { if {![::xo::db::Class object_type_exists_in_db -object_type $object_type]} { - $domain create_object_type + $domain create_object_type } ::xo::db::sql::acs_attribute create_attribute \ @@ -2124,7 +2124,7 @@ set sc [[my domain] info superclass] if {![$sc istype ::xo::db::Class]} {set sc ::xo::db::Object} append column_spec " REFERENCES [$sc table_name]([$sc id_column])\ - ON DELETE CASCADE" + ON DELETE CASCADE" } # # Constraints Index: openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl,v diff -u -r1.29.6.1 -r1.29.6.2 --- openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 11 Feb 2014 11:53:08 -0000 1.29.6.1 +++ openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 14 Feb 2014 18:20:44 -0000 1.29.6.2 @@ -1,4 +1,4 @@ -ad_library { +xad_library { Definition of a package manager for creating XOTcl package objects @author Gustaf Neumann (neumann@wu-wien.ac.at) @@ -31,7 +31,7 @@ and ppm.party_id = :party_id and ppm.privilege = :privilege } -limit 1] - ::xo::dc get_value get_package_id $sql + ::xo::dc get_value get_package_id $sql } else { ::xo::parameter get_package_id_from_package_key -package_key $package_key } @@ -45,17 +45,17 @@ my instvar package_key if {$include_unmounted} { set result [::xo::dc list get_xowiki_packages {select package_id \ - from apm_packages where package_key = :package_key}] + from apm_packages where package_key = :package_key}] } else { set result [::xo::dc list get_mounted_packages {select package_id \ - from apm_packages p, site_nodes s \ - where package_key = :package_key and s.object_id = p.package_id}] + from apm_packages p, site_nodes s \ + where package_key = :package_key and s.object_id = p.package_id}] } if {$closure} { foreach subclass [my info subclass] { - foreach id [$subclass instances -include_unmounted $include_unmounted -closure true] { - lappend result $id - } + foreach id [$subclass instances -include_unmounted $include_unmounted -closure true] { + lappend result $id + } } } return [lsort -integer $result] @@ -120,7 +120,7 @@ } else { my require -url $url $package_id } - + # # In case the login expired, we can force an early login to # prevent later login redirects, which can cause problems @@ -129,9 +129,9 @@ # might not require the real user_id. # #my msg "force [$package_id force_refresh_login] &&\ - # [::xo::cc set untrusted_user_id] != [::xo::cc user_id]" + # [::xo::cc set untrusted_user_id] != [::xo::cc user_id]" if {[$package_id force_refresh_login] && - [::xo::cc set untrusted_user_id] != [::xo::cc user_id]} { + [::xo::cc set untrusted_user_id] != [::xo::cc user_id]} { auth::require_login } @@ -201,7 +201,7 @@ # # get apm_package class #### missing in acs_attributes: instance_name, default_locale #::xo::db::Class get_class_from_db -object_type apm_package - + #ns_log notice [::xo::db::apm_package serialize] #ns_log notice ======================================= @@ -219,7 +219,7 @@ url {context ::xo::cc} package_url - {force_refresh_login false} + {force_refresh_login false} } ::xo::Package instforward query_parameter {%my set context} %proc @@ -237,7 +237,7 @@ #my log "--get_parameter <$attribute> <$default> returned <$param>" return $param } - + ::xo::Package instproc init args { my instvar id url set package_url [lindex [site_node::get_url_from_object_id -object_id $id] 0] @@ -333,7 +333,7 @@ eval [::xo::cc set __continuation] } else { if {[string length $text] > 1} { - set status_code [expr {[::xo::cc exists status_code] ? [::xo::cc set status_code] : 200}] + set status_code [expr {[::xo::cc exists status_code] ? [::xo::cc set status_code] : 200}] #my log "REPLY [my set delivery] 200 [my set mime_type]" [my set delivery] $status_code [my set mime_type] $text } @@ -374,7 +374,7 @@ #my log "--after adp" return $text } - + #ns_log notice [::xo::Package serialize] } 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 -r1.15.6.2 -r1.15.6.3 --- openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 11 Feb 2014 11:53:08 -0000 1.15.6.2 +++ openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 14 Feb 2014 18:20:44 -0000 1.15.6.3 @@ -160,16 +160,16 @@ # Methods on the parameter class object # parameter proc get_package_key_from_id { - -package_id:required - } { + -package_id:required + } { return [ns_cache eval xotcl_object_type_cache package_key-$package_id { ::xo::dc get_value get_package_key \ "select package_key from apm_packages where package_id = :package_id" }] } parameter proc get_package_id_from_package_key { - -package_key:required - } { + -package_key:required + } { return [ns_cache eval xotcl_object_type_cache package_id-$package_key { ::xo::dc get_value get_package_id \ [::xo::dc select -vars package_id -from apm_packages \ @@ -196,11 +196,11 @@ } parameter proc get_parameter_object { - -parameter_name:required - -package_id - -package_key - {-retry true} - } { + -parameter_name:required + -package_id + -package_key + {-retry true} + } { ::xo::PackageMgr instvar package_class if {![info exists package_key]} { set package_key [my get_package_key_from_id -package_id $package_id] @@ -264,10 +264,10 @@ } parameter proc get_from_package_key { - -package_key:required - -parameter:required - -default - } { + -package_key:required + -parameter:required + -default + } { set parameter_obj [my get_parameter_object -package_key $package_key -parameter_name $parameter] if {$parameter_obj eq ""} { if {[info exists default]} {return $default} @@ -280,17 +280,17 @@ } parameter proc get { - -package_id - -parameter:required - -default - {-retry true} - } { + -package_id + -parameter:required + -default + {-retry true} + } { if {![info exists package_id]} { # try to get the package id; # if everything fails, use kernel_id (to be compatible with trad. parameter::get) set package_id [expr {[info commands ::xo::cc] ne "" ? - [::xo::cc package_id] : - [ns_conn isconnected] ? [ad_conn package_id] : [ad_acs_kernel_id]}] + [::xo::cc package_id] : + [ns_conn isconnected] ? [ad_conn package_id] : [ad_acs_kernel_id]}] } set parameter_obj [my get_parameter_object -parameter_name $parameter -package_id $package_id -retry $retry] if {$parameter_obj ne ""} { @@ -357,20 +357,20 @@ -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 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 {} { # Get those parameter values, which are different from the default and # remember theses per package_id. xo::dc foreach get_non_default_values { select p.parameter_id, p.package_key, v.package_id, p.parameter_name, - p.default_value, v.attr_value + p.default_value, v.attr_value from apm_parameters p, apm_parameter_values v 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 notice "--p $parameter_id $package_key $package_id $parameter_name <$attr_value>" $parameter_id set_per_package_instance_value $package_id $attr_value } } @@ -381,9 +381,9 @@ # For the time being: catch changed parameter values # ad_proc -public -callback subsite::parameter_changed -impl xotcl-param-procs { - -package_id:required - -parameter:required - -value:required + -package_id:required + -parameter:required + -value:required } { Implementation of subsite::parameter_changed for xotcl param procs @@ -398,8 +398,8 @@ # set package_key [apm_package_key_from_id $package_id] set parameter_obj [::xo::parameter get_parameter_object \ - -package_key $package_key \ - -parameter_name $parameter] + -package_key $package_key \ + -parameter_name $parameter] if {$parameter_obj eq ""} { # We have still no parameter. There must be something significantly wrong. @@ -416,43 +416,43 @@ # # A few test cases # -# ns_log notice "xotcl-request-monitor.max-url-stats=[parameter get_from_package_key \ -# -package_key xotcl-request-monitor \ -# -parameter max-url-stats]" + # ns_log notice "xotcl-request-monitor.max-url-stats=[parameter get_from_package_key \ + # -package_key xotcl-request-monitor \ + # -parameter max-url-stats]" -# set cmd1 "::parameter::get_from_package_key \ -# -package_key xotcl-request-monitor \ -# -parameter max-url-stats" -# set cmd2 "::xo::parameter get_from_package_key \ -# -package_key xotcl-request-monitor \ -# -parameter max-url-stats" -# ns_log notice "GET_PACKAGE_KEY old: [time $cmd1 100], new: [time $cmd2 100]" + # set cmd1 "::parameter::get_from_package_key \ + # -package_key xotcl-request-monitor \ + # -parameter max-url-stats" + # set cmd2 "::xo::parameter get_from_package_key \ + # -package_key xotcl-request-monitor \ + # -parameter max-url-stats" + # ns_log notice "GET_PACKAGE_KEY old: [time $cmd1 100], new: [time $cmd2 100]" -# set pid 4906 -# set pname trend-elements -# ns_log notice "xotcl-request-monitor.$pname=[parameter get \ -# -package_id $pid -parameter $pname]" -# set cmd1 "::parameter::get -package_id $pid -parameter $pname" -# set cmd2 "::xo::parameter get -package_id $pid -parameter $pname" -# ns_log notice "GET old: [time $cmd1 100], new: [time $cmd2 100]" + # set pid 4906 + # set pname trend-elements + # ns_log notice "xotcl-request-monitor.$pname=[parameter get \ + # -package_id $pid -parameter $pname]" + # set cmd1 "::parameter::get -package_id $pid -parameter $pname" + # set cmd2 "::xo::parameter get -package_id $pid -parameter $pname" + # ns_log notice "GET old: [time $cmd1 100], new: [time $cmd2 100]" # # # # -# set p [parameter get_parameter_object -package_key xowiki -parameter_name dummy] -# ns_log notice "--p getobject => $p" -# if {$p eq ""} { -# set p [::xo::db::apm_parameter new_persistent_object \ -# -package_key "xowiki" \ -# -parameter_name "dummy" \ -# -default_value "testing" \ -# -description "Description of test parameter" \ -# -section_name ""] -# ns_log notice "--p created new parameter $p" -# } -# $p append default_value "1" -# $p save + # set p [parameter get_parameter_object -package_key xowiki -parameter_name dummy] + # ns_log notice "--p getobject => $p" + # if {$p eq ""} { + # set p [::xo::db::apm_parameter new_persistent_object \ + # -package_key "xowiki" \ + # -parameter_name "dummy" \ + # -default_value "testing" \ + # -description "Description of test parameter" \ + # -section_name ""] + # ns_log notice "--p created new parameter $p" + # } + # $p append default_value "1" + # $p save # $p delete } 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 -r1.9 -r1.9.2.1 --- openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 12 Aug 2013 20:01:06 -0000 1.9 +++ openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 14 Feb 2014 18:20:44 -0000 1.9.2.1 @@ -16,10 +16,10 @@ if {![::xotcl::Object isclass ::xotcl::RecreationClass]} { ::xotcl::Class create ::xotcl::RecreationClass -ad_doc {

This meta-class controlls the behavior of classes (and optionally - their instances), when the classes (or their instances) are + their instances), when the classes (or their instances) are overwritten by same named new objects; we call this situation a recreate of an object.

- +

Normally, when files with e.g. class definitions are sourced, the classes and objects are newly defined. When e.g. class definitions exists already in this file, these classes are @@ -42,7 +42,7 @@

  • reconfigure: reconfigure class (default 1)
  • reinit: run init after configure for this class (default unset)
  • instrecreate: handle recreate of class instances (default unset) - When this flag is set to 0, instreconfigure and instreinit are ignored. + When this flag is set to 0, instreconfigure and instreinit are ignored.
  • instreconfigure: reconfigure instances of this class (default 1)
  • instreinit: re-init instances of this class (default unset) @@ -54,43 +54,43 @@ {instreinit} } -superclass ::xotcl::Class \ -instproc recreate {obj args} { - #my log "### recreateclass instproc $obj <$args>" - # 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]} { - #my log "### no instrecreate for $obj <$args>" - next - return - } - if {[my exists instreconfigure]} { - # before we set defaults, we must unset vars - foreach var [$obj info vars] {$obj unset $var} - # set defaults and run configure + #my log "### recreateclass instproc $obj <$args>" + # 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]} { + #my log "### no instrecreate for $obj <$args>" + next + return + } + if {[my 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]} { - #my log "### instreinit for $obj <$args>" - $obj init - #my log "### instproc recreate $obj + init ..." - } + $obj configure {*}$args + #my log "### instproc recreate $obj + configure $args ..." + } + if {[my exists instreinit]} { + #my log "### instreinit for $obj <$args>" + $obj init + #my log "### instproc recreate $obj + init ..." + } } -proc recreate {obj args} { - #my log "### recreateclass proc $obj <$args>" - # 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]} { - # before we set defaults, we must unset vars - foreach var [$obj info vars] {$obj unset $var} - # set defaults and run configure + #my log "### recreateclass proc $obj <$args>" + # 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]} { + # 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]} { - $obj init - } + $obj configure {*}$args + } + if {[my exists reinit]} { + $obj init + } } ::Serializer exportObjects { @@ -173,4 +173,11 @@ my log "-- [self args]"; next } #::xotcl::Class instmixin RR -} \ No newline at end of file +} + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl,v diff -u -r1.21.2.2 -r1.21.2.3 --- openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 30 Sep 2013 11:38:40 -0000 1.21.2.2 +++ openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 14 Feb 2014 18:20:44 -0000 1.21.2.3 @@ -69,7 +69,7 @@ if {[my exists __children]} { #my log "--W destroying children [my set __children]" foreach c [my set __children] { - if {[my isobject $c]} {$c destroy} + if {[my isobject $c]} {$c destroy} } } #show_stack;my log "--W children murdered, now next, chlds=[my info children]" @@ -136,11 +136,11 @@ set yp [string first . $y] if {$xp == -1 && $yp == -1} { if {$x < $y} { - return -1 + return -1 } elseif {$x > $y} { - return 1 + return 1 } else { - return $def + return $def } } elseif {$xp == -1} { set yh [string range $y 0 $yp-1] @@ -153,14 +153,14 @@ set yh [string range $y 0 $yp] #puts "xh=$xh yh=$yh" if {$xh < $yh} { - return -1 + return -1 } elseif {$xh > $yh} { - return 1 + return 1 } else { - incr xp - incr yp - #puts "rest [string range $x $xp end] [string range $y $yp end]" - return [my __value_compare [string range $x $xp end] [string range $y $yp end] $def] + incr xp + incr yp + #puts "rest [string range $x $xp end] [string range $y $yp end]" + return [my __value_compare [string range $x $xp end] [string range $y $yp end] $def] } } } @@ -180,3 +180,9 @@ } } +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: 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 -r1.54.2.2 -r1.54.2.3 --- openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 5 Oct 2013 12:36:53 -0000 1.54.2.2 +++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 14 Feb 2014 18:20:44 -0000 1.54.2.3 @@ -89,15 +89,15 @@ # # search for autoimports: all commands are executed in the ... currently not needed # -# 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]" -# if {[$cl exists autoimport]} { -# my log "tdom IMPO [$cl autoimport] into $me" -# namespace eval ::xo::tmp [list namespace import -force [$cl autoimport]] -# } -# } -# #my log "tdom CMDS $level [lsort [info commands ::xo::tmp::*]]" + # 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]" + # if {[$cl exists autoimport]} { + # my log "tdom IMPO [$cl autoimport] into $me" + # namespace eval ::xo::tmp [list namespace import -force [$cl autoimport]] + # } + # } + # #my log "tdom CMDS $level [lsort [info commands ::xo::tmp::*]]" if {$createcmd ne ""} { # @@ -231,24 +231,24 @@ while {[regexp {^([^\x002]*)\x002\(\x001([^\x001]*)\x001\)\x002(.*)$} $text _ \ before key text]} { - append return_text $before - lassign [split $key .] package_key message_key - set url [export_vars -base $::xo::acs_lang_url/edit-localized-message { - {locale {[ad_conn locale]} } - package_key message_key - {return_url [ad_return_url]} - }] - if {[lang::message::message_exists_p [ad_conn locale] $key]} { - set type localized - } elseif { [lang::message::message_exists_p "en_US" $key] } { - set type us_only - } else { # message key is missing - set url [export_vars -base $::xo::acs_lang_url/localized-message-new { - {locale en_US } package_key message_key - {return_url [ad_return_url]} - }] - set type missing - } + append return_text $before + lassign [split $key .] package_key message_key + set url [export_vars -base $::xo::acs_lang_url/edit-localized-message { + {locale {[ad_conn locale]} } + package_key message_key + {return_url [ad_return_url]} + }] + if {[lang::message::message_exists_p [ad_conn locale] $key]} { + set type localized + } elseif { [lang::message::message_exists_p "en_US" $key] } { + set type us_only + } else { # message key is missing + set url [export_vars -base $::xo::acs_lang_url/localized-message-new { + {locale en_US } package_key message_key + {return_url [ad_return_url]} + }] + set type missing + } if {!$inline} { $obj lappend __localizer [::xo::Localizer new -type $type -key $key -url $url] } else { @@ -265,8 +265,8 @@ set obj [uplevel self] if {[$obj exists __localizer]} { foreach l [$obj set __localizer] { - $l render - $l destroy + $l render + $l destroy } } } @@ -276,56 +276,56 @@ Localizer instproc render {} { html::a -title [my key] -href [my url] { switch -- [my type] { - localized {set char o; set style "color: green"} + 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;"} } html::span -style $style {html::t $char} } } Localizer instproc render {} { - html::a -title [my key] -href [my url] { - set path /resources/acs-templating/xinha-nightly/plugins/ - switch -- [my 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::a -title [my key] -href [my url] { + set path /resources/acs-templating/xinha-nightly/plugins/ + switch -- [my 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 + } + } ## todo : make these checks only in trn mode (additional mixin) Class Drawable \ -superclass ::xo::tdom::AttributeManager \ -instproc _ {attr} { - my set $attr + my set $attr } \ -instproc render_localizer {} { } Class TRN-Mode \ -instproc _ {attr} { - return [::xo::localize [my set $attr]] + return [::xo::localize [my set $attr]] } \ -instproc render_localizer {} { - #my log "-- " - if {[my exists __localizer]} { - foreach l [my set __localizer] { - $l render - $l destroy - } - } - my set __localizer [list] + #my log "-- " + if {[my exists __localizer]} { + foreach l [my set __localizer] { + $l render + $l destroy + } + } + my set __localizer [list] } \ -instproc render-data args { - next - my render_localizer + next + my render_localizer } \ -instproc render args { - next - my render_localizer + next + my render_localizer } # @@ -349,9 +349,9 @@ # Class Table -superclass OrderedComposite \ -parameter [expr {[apm_version_names_compare [ad_acs_version] 5.3.0] == 1 ? - {{no_data "#xotcl-core.No_Data#"} {renderer TABLE3} name} : - {{no_data "#xotcl-core.No_Data#"} {renderer TABLE2} name} - }] + {{no_data "#xotcl-core.No_Data#"} {renderer TABLE3} name} : + {{no_data "#xotcl-core.No_Data#"} {renderer TABLE2} name} + }] Table instproc destroy {} { #my log "-- " @@ -395,11 +395,11 @@ set mixinname ${cl}::${renderer}::[namespace tail $child] if {[::xotcl::Object isclass $mixinname]} { #if {![$child istype ::xo::OrderedComposite::Child]} continue - $child instmixin $mixinname - if {$trn_mixin ne ""} {$child instmixin add $trn_mixin} - #my log "-- $child using instmixin <[$child info instmixin]>" + $child instmixin $mixinname + if {$trn_mixin ne ""} {$child instmixin add $trn_mixin} + #my log "-- $child using instmixin <[$child info instmixin]>" } else { - #my log "-- no mixin $mixinname" + #my log "-- no mixin $mixinname" } } Table::Line instmixin $trn_mixin @@ -416,166 +416,166 @@ set label [_ $message_key] } set value [string map {\" \\\" \n \r)} $label] + lappend line \"$value\" + } + append output [join $line ,] \n + foreach row [my children] { + set line [list] + foreach column [[self]::__columns children] { + if {[$column exists no_csv]} continue + set value [string map {\" \\\" \n \r} [$row set [$column set name]]] lappend line \"$value\" } append output [join $line ,] \n - foreach row [my children] { - set line [list] - foreach column [[self]::__columns children] { - if {[$column exists no_csv]} continue - set value [string map {\" \\\" \n \r} [$row set [$column set name]]] - lappend line \"$value\" - } - 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] - ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=\"$fn\"" - ns_return 200 text/csv $output } + #ns_return 200 text/plain $output + my instvar name + if {![my 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 +} - Class create Table::Line \ - -superclass ::xo::Drawable \ - -instproc attlist {name atts {extra ""}} { - set result [list] - foreach att $atts { - set varname $name.$att - if {[my exists $varname]} { - lappend result $att [::xo::localize [my set $varname]] - } - } - foreach {att val} $extra {lappend result $att $val} - return $result +Class create Table::Line \ + -superclass ::xo::Drawable \ + -instproc attlist {name atts {extra ""}} { + set result [list] + foreach att $atts { + set varname $name.$att + if {[my exists $varname]} { + lappend result $att [::xo::localize [my set $varname]] + } } - + foreach {att val} $extra {lappend result $att $val} + return $result + } - # - # Define elements of a Table - # - namespace eval ::xo::Table { - Class Action \ - -superclass ::xo::OrderedComposite::Child \ - -parameter {label url {tooltip {}}} - #-proc destroy {} { - # my log "-- DESTROY " - # show_stack - # next - # } - Class Field \ - -superclass ::xo::OrderedComposite::Child \ - -parameter {label {html {}} {orderby ""} name {richtext false} no_csv {CSSclass ""} {hide 0}} \ - -instproc init {} { - my set name [namespace tail [self]] - } \ - -instproc get-slots {} { - set slots [list -[my name]] - foreach subfield {richtext CSSclass} { - lappend slots [list -[my name].$subfield ""] - } - return $slots - } +# +# Define elements of a Table +# +namespace eval ::xo::Table { + Class Action \ + -superclass ::xo::OrderedComposite::Child \ + -parameter {label url {tooltip {}}} + #-proc destroy {} { + # my log "-- DESTROY " + # show_stack + # next + # } - Class BulkAction \ - -superclass ::xo::OrderedComposite::Child \ - -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 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] - } \ - -instproc get-slots {} { - ; + Class Field \ + -superclass ::xo::OrderedComposite::Child \ + -parameter {label {html {}} {orderby ""} name {richtext false} no_csv {CSSclass ""} {hide 0}} \ + -instproc init {} { + my set name [namespace tail [self]] + } \ + -instproc get-slots {} { + set slots [list -[my name]] + foreach subfield {richtext CSSclass} { + lappend slots [list -[my name].$subfield ""] } + return $slots + } - Class AnchorField \ - -superclass ::xo::Table::Field \ - -instproc get-slots {} { - set slots [list -[my name]] - foreach subfield {href title CSSclass} { - lappend slots [list -[my name].$subfield ""] - } - return $slots - } + Class BulkAction \ + -superclass ::xo::OrderedComposite::Child \ + -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 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] + } \ + -instproc get-slots {} { + ; + } - Class HiddenField \ - -superclass ::xo::Table::Field \ - -instproc get-slots {} { - return [list -[my name]] - } + Class AnchorField \ + -superclass ::xo::Table::Field \ + -instproc get-slots {} { + set slots [list -[my name]] + foreach subfield {href title CSSclass} { + lappend slots [list -[my name].$subfield ""] + } + return $slots + } - Class 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]] - foreach att {width height border title alt} { - if {[my exists $att]} { - lappend slots [list -[my name].$att [my $att]] - } else { - lappend slots [list -[my name].$att] - } - } - return $slots - } + Class HiddenField \ + -superclass ::xo::Table::Field \ + -instproc get-slots {} { + return [list -[my name]] + } - Class ImageAnchorField \ - -superclass ::xo::Table::ImageField \ - -instproc get-slots {} { - return [concat [next] -[my name].href ""] - } + Class 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]] + foreach att {width height border title alt} { + if {[my exists $att]} { + lappend slots [list -[my name].$att [my $att]] + } else { + lappend slots [list -[my name].$att] + } + } + return $slots + } - Class ImageField_EditIcon \ - -superclass ImageAnchorField -parameter { - {src /resources/acs-subsite/Edit16.gif} {width 16} {height 16} {border 0} - {title "[_ xotcl-core.edit_item]"} {alt "edit"} - } - - Class ImageField_AddIcon \ - -superclass ImageAnchorField -parameter { - {src /resources/acs-subsite/Add16.gif} {width 16} {height 16} {border 0} - {title "[_ xotcl-core.add_item]"} {alt "add"} - } + Class ImageAnchorField \ + -superclass ::xo::Table::ImageField \ + -instproc get-slots {} { + return [concat [next] -[my name].href ""] + } - Class ImageField_ViewIcon \ - -superclass ImageAnchorField -parameter { - {src /resources/acs-subsite/Zoom16.gif} {width 16} {height 16} {border 0} - {title "[_ xotcl-core.view_item]"} {alt "view"} - } - Class ImageField_DeleteIcon \ - -superclass ImageAnchorField -parameter { - {src /resources/acs-subsite/Delete16.gif} {width 16} {height 16} {border 0} - {title "[_ xotcl-core.delete_item]"} {alt "delete"} - } - - # export table elements - namespace export Field AnchorField HiddenField Action ImageField ImageAnchorField \ - ImageField_EditIcon ImageField_ViewIcon ImageField_DeleteIcon ImageField_AddIcon \ - BulkAction - } + Class ImageField_EditIcon \ + -superclass ImageAnchorField -parameter { + {src /resources/acs-subsite/Edit16.gif} {width 16} {height 16} {border 0} + {title "[_ xotcl-core.edit_item]"} {alt "edit"} + } + Class ImageField_AddIcon \ + -superclass ImageAnchorField -parameter { + {src /resources/acs-subsite/Add16.gif} {width 16} {height 16} {border 0} + {title "[_ xotcl-core.add_item]"} {alt "add"} + } + + Class ImageField_ViewIcon \ + -superclass ImageAnchorField -parameter { + {src /resources/acs-subsite/Zoom16.gif} {width 16} {height 16} {border 0} + {title "[_ xotcl-core.view_item]"} {alt "view"} + } + Class ImageField_DeleteIcon \ + -superclass ImageAnchorField -parameter { + {src /resources/acs-subsite/Delete16.gif} {width 16} {height 16} {border 0} + {title "[_ xotcl-core.delete_item]"} {alt "delete"} + } + + # export table elements + namespace export Field AnchorField HiddenField Action ImageField ImageAnchorField \ + ImageField_EditIcon ImageField_ViewIcon ImageField_DeleteIcon ImageField_AddIcon \ + BulkAction } +} + namespace eval ::xo::Table { # # Class for rendering ::xo::Table as the html TABLE # Class TABLE \ -superclass ::xo::Drawable \ -instproc init_renderer {} { - #my log "--" - my set __rowcount 0 + #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 @@ -585,14 +585,14 @@ html::tr -class list-button-bar { set cols [llength [[self]::__columns children]] html::td -colspan $cols -class list-button-bar { - set children [[self]::__actions children] - set last [lindex $children end] - foreach o $children { - $o render - if {$o ne $last} { - html::t -disableOutputEscaping "·" - } - } + set children [[self]::__actions children] + set last [lindex $children end] + foreach o $children { + $o render + if {$o ne $last} { + html::t -disableOutputEscaping "·" + } + } } } } @@ -621,7 +621,7 @@ TABLE instproc render-body {} { html::tr -class list-header { foreach o [[self]::__columns children] { - $o render + $o render } } set children [my children] @@ -630,15 +630,15 @@ } 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 ? + html::tr -class [expr {[my incr __rowcount]%2 ? [my set css.tr.odd-class] : [my set css.tr.even-class] }] { - foreach field [[self]::__columns children] { - html::td [concat [list class list] [$field html]] { - $field render-data $line - } - } - } + foreach field [[self]::__columns children] { + html::td [concat [list class list] [$field html]] { + $field render-data $line + } + } + } } } } @@ -673,10 +673,10 @@ Class create TABLE::Action \ -superclass ::xo::Drawable \ -instproc render {} { - html::a -class button -title [my _ tooltip] -href [my url] { - html::t [my _ label] - } - #my log "-- " + html::a -class button -title [my _ tooltip] -href [my url] { + html::t [my _ label] + } + #my log "-- " } #-proc destroy {} { # my log "-- DESTROY" @@ -700,9 +700,9 @@ TABLE::Field instproc render {} { html::th [concat [list class list] [my html]] { if {[my set orderby] eq ""} { - html::t [my _ label] + html::t [my _ label] } else { - my renderSortLabels + my renderSortLabels } my render_localizer ;# run this before th is closed } @@ -749,23 +749,23 @@ 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 [my name].href] && + [set href [$line set [my 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}] { - return [next] - } - } - next + return [next] + } + } + next } Class create TABLE::HiddenField \ -instproc render {} {;} \ -instproc render-data {line} {;} - - + + Class create TABLE::ImageField \ -superclass TABLE::Field \ -instproc render-data {line} { @@ -819,14 +819,14 @@ foreach o $actions { html::li -class "button" {$o render} } } } - } + } } \ -instproc render {} { - if {![my isobject [self]::__actions]} {my actions {}} - if {![my isobject [self]::__bulkactions]} {my __bulkactions {}} + if {![my isobject [self]::__actions]} {my actions {}} + if {![my isobject [self]::__bulkactions]} {my __bulkactions {}} set bulkactions [[self]::__bulkactions children] - html::div { - my render-actions + html::div { + my render-actions if {$bulkactions eq ""} { html::div -class table { html::table -class [my set css.table-class] {my render-body} @@ -840,7 +840,7 @@ } } } - } + } } @@ -900,9 +900,9 @@ # Object defaultMaster -proc decorate {node} { - $node appendFromScript { - set slave [tmpl::div] - } + $node appendFromScript { + set slave [tmpl::div] + } return $slave } @@ -981,10 +981,17 @@ } } if {$statements ne ""} { - append result \n "\n" + append result \n "\n" } } return $result } } -::xo::library source_dependent \ No newline at end of file +::xo::library source_dependent + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: 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 -r1.12.2.1 -r1.12.2.2 --- openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl 13 Oct 2013 18:15:14 -0000 1.12.2.1 +++ openacs-4/packages/xotcl-core/tcl/40-thread-mod-procs.tcl 14 Feb 2014 18:20:44 -0000 1.12.2.2 @@ -202,19 +202,19 @@ } nsv_set [self class] [self] $tid if {[my persistent]} { - my log "--created new persistent [self class] as $tid pid=[pid]" + my log "--created new persistent [self class] as $tid pid=[pid]" } else { - my log "--created new [self class] as $tid pid=[pid]" + my log "--created new [self class] as $tid pid=[pid]" } #my log "--THREAD DO send [self] epoch = [ns_ictl epoch]" if {[my lightweight]} { } elseif {![ns_ictl epoch]} { - #ns_log notice "--THREAD send [self] no epoch" - # We are during initialization. For some unknown reasons, XOTcl - # is not available in newly created threads, so we have to care - # for full initialization, including xotcl blueprint. - _ns_savenamespaces - set initcmd [ns_ictl get] + #ns_log notice "--THREAD send [self] no epoch" + # We are during initialization. For some unknown reasons, XOTcl + # is not available in newly created threads, so we have to care + # for full initialization, including xotcl blueprint. + _ns_savenamespaces + set initcmd [ns_ictl get] } append initcmd [my set initcmd] #ns_log notice "INIT $initcmd" @@ -263,16 +263,16 @@ # -instproc forward args { # set cp [self calledproc] # if { $cp eq "attach" -# || $cp eq "filter" -# || $cp eq "detachAll"} { -# next +# || $cp eq "filter" +# || $cp eq "detachAll"} { +# next # } elseif {$cp eq "destroy"} { -# eval [my attach] do [self] $cp $args -# my log "destroy" -# next +# eval [my attach] do [self] $cp $args +# my log "destroy" +# next # } else { -# my log "forwarding [my attach] do [self] $cp $args" -# eval [my attach] do [self] $cp $args +# my log "forwarding [my attach] do [self] $cp $args" +# eval [my attach] do [self] $cp $args # } # } -instproc init args { # my filter forward @@ -290,3 +290,9 @@ [my server] do [my serverobj] {*}$args } +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: 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 -r1.8 -r1.8.2.1 --- openacs-4/packages/xotcl-core/tcl/50-protocol-handler-procs.tcl 29 Jul 2013 08:44:14 -0000 1.8 +++ openacs-4/packages/xotcl-core/tcl/50-protocol-handler-procs.tcl 14 Feb 2014 18:20:44 -0000 1.8.2.1 @@ -97,7 +97,7 @@ ns_returnunauthorized return filter_return } - + # set common data for all kind of requests my initialize @@ -121,7 +121,7 @@ To change that, it would be necessary to register the filter before the request processor (currently, there - are no hooks for that). + are no hooks for that). } { set filter_url [my url]* set url [my url]/* @@ -178,15 +178,15 @@ DELETE LOCK UNLOCK OPTIONS REPORT } { - ns_register_filter preauth $method $filter_url [self] - ns_register_filter preauth $method $root [self] - ns_register_proc $method $url [self] handle_request - ns_register_proc $method $root [self] handle_request + ns_register_filter preauth $method $filter_url [self] + ns_register_filter preauth $method $root [self] + ns_register_proc $method $url [self] handle_request + ns_register_proc $method $root [self] handle_request - - #my log "--ns_register_filter preauth $method $filter_url [self]" - #my log "--ns_register_proc $method $url [self] handle_request" - } + + #my log "--ns_register_filter preauth $method $filter_url [self]" + #my log "--ns_register_proc $method $url [self] handle_request" + } ns_register_proc OPTIONS / ::xo::minimalProctocolHandler OPTIONS ns_register_proc PROPFIND / ::xo::minimalProctocolHandler PROPFIND } @@ -207,9 +207,9 @@ 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]'" + # userid=$user_id -ns_conn query '[ns_conn query]'" if {[my exists package]} { my set package_id [my get_package_id] } @@ -243,7 +243,7 @@ ProtocolHandler instproc multiStatus {body} { append _ {} \n \ - {} $body \n \n + {} $body \n \n } ProtocolHandler instproc multiStatusResonse { @@ -253,46 +253,46 @@ } { #my log "multiStatusResonse href $href propstats $propstats" append reply \n \ - {} \ - "\n$href\n" + {} \ + "\n$href\n" # The multi-status respons has 2 formats # - with (used in PROPFIND and PROPPATCH) # - without (used in other cases, e.g. DELETE, COPY, MOVE for collections) # http://www.webdav.org/specs/rfc4918.html#multi-status.response # foreach {props status} $propstats { if {$propstatus} { - append reply \n - if {[llength $props] > 0} { - append reply \n - foreach {name value} $props { - if {$value ne ""} { - append reply <$name>$value\n - } else { - append reply <$name/>\n - } - } - append reply \n - } else { - append reply \n - } - append reply $status\n\n + append reply \n + if {[llength $props] > 0} { + append reply \n + foreach {name value} $props { + if {$value ne ""} { + append reply <$name>$value\n + } else { + append reply <$name/>\n + } + } + append reply \n + } else { + append reply \n + } + append reply $status\n\n } else { - append reply $status\n + append reply $status\n } } append reply \n } ProtocolHandler instproc multiStatusError {status} { lappend davprops \ - D:getlastmodified "" \ - D:getcontentlength "" \ - D:creationdate "" \ - D:resourcetype "" + D:getlastmodified "" \ + D:getcontentlength "" \ + D:creationdate "" \ + D:resourcetype "" set r [my multiStatus [my multiStatusResonse \ - -href [ns_urldecode [ns_conn url]] \ - -propstats [list $davprops $status]]] + -href [ns_urldecode [ns_conn url]] \ + -propstats [list $davprops $status]]] my log multiStatusError=$r ns_return 207 text/xml $r } @@ -313,21 +313,21 @@ ns_set put [ns_conn outputheaders] Allow OPTIONS ns_return 200 text/plain {} } - + ProtocolHandler instproc PROPFIND {} { #my log "--ProtocolHandler PROPFIND [ns_conn content]" # when GET is not supported on this resource, the get* properties are not be sent # 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"] \ - D:supportedlock {} \ - D:lockdiscovery {} - - ns_return 207 text/xml [my multiStatus \ - [my multiStatusResonse \ - -href [my set uri] \ - -propstats [list $davprops "HTTP/1.1 200 OK"]]] + lp1:resourcetype \ + lp1:creationdate [my 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] \ + -propstats [list $davprops "HTTP/1.1 200 OK"]]] } ::xo::ProtocolHandler create ::xo::minimalProctocolHandler @@ -338,4 +338,12 @@ ::xo::minimalProctocolHandler proc PROPFIND {args} { my multiStatusError "HTTP/1.1 403 Forbidden" } -} \ No newline at end of file +} + + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: 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 -r1.47.2.7 -r1.47.2.8 --- openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 27 Jan 2014 09:59:13 -0000 1.47.2.7 +++ openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 14 Feb 2014 18:20:44 -0000 1.47.2.8 @@ -1,10 +1,10 @@ ad_library { - Routines for background delivery of files + Routines for background delivery of files - @author Gustaf Neumann (neumann@wu-wien.ac.at) - @creation-date 19 Nov 2005 - @cvs-id $Id$ + @author Gustaf Neumann (neumann@wu-wien.ac.at) + @creation-date 19 Nov 2005 + @cvs-id $Id$ } if {[info commands ::thread::mutex] eq ""} { @@ -76,10 +76,10 @@ set k ::runningBgJob([lindex $context 0]) if {[info exists $k]} { - set value [set $k] - ns_log notice "resubmit: canceling currently running request $context // closing $value" - lassign $value fd0 channel0 client_data0 filename0 - my end-delivery -client_data $client_data0 $filename0 $fd0 $channel0 -1 + set value [set $k] + ns_log notice "resubmit: canceling currently running request $context // closing $value" + lassign $value fd0 channel0 client_data0 filename0 + my end-delivery -client_data $client_data0 $filename0 $fd0 $channel0 -1 } set $k [list $fd $channel $client_data $filename] @@ -233,8 +233,8 @@ if {$sync || $content eq ""} { my log "close sync" if {$content ne ""} { - fconfigure $channel -translation binary -blocking true - puts -nonewline $channel $content + fconfigure $channel -translation binary -blocking true + puts -nonewline $channel $content } close $channel my destroy @@ -256,7 +256,7 @@ set content "" if {[my autoflush]} {flush $channel} if {[my exists finishWhenDone]} { - my close -sync true + my close -sync true } } else { set chunk [string range $content 0 $blocksize-1] @@ -279,11 +279,11 @@ set result [list] if {[info exists key]} { if {[info exists subscriptions($key)]} { - return [list $key $subscriptions($key)] + return [list $key $subscriptions($key)] } } elseif {[info exists subscriptions]} { foreach key [array names subscriptions] { - lappend result $key $subscriptions($key) + lappend result $key $subscriptions($key) } } } @@ -332,7 +332,7 @@ set smsg $msg } #my log "-- sending to subscriber for [my key] $smsg ch=[my channel] \ - # mode=[my mode], user_id [my user_id]" + # mode=[my mode], user_id [my user_id]" puts -nonewline [my channel] $smsg flush [my channel] } @@ -343,12 +343,12 @@ if {[info exists subscriptions($key)]} { set subs1 [list] foreach s $subscriptions($key) { - if {[catch {$s $method $argument} errMsg]} { - ns_log notice "error in $method to subscriber $s (key=$key): $errMsg" - $s destroy - } else { - lappend subs1 $s - } + if {[catch {$s $method $argument} errMsg]} { + ns_log notice "error in $method to subscriber $s (key=$key): $errMsg" + $s destroy + } else { + lappend subs1 $s + } } set subscriptions($key) $subs1 } @@ -443,7 +443,7 @@ fconfigure $fd -translation binary -encoding $encoding fconfigure [my channel] -translation binary -encoding $encoding fcopy $fd [my channel] -command \ - [list [self] end-delivery $filename $fd [my channel] $request] + [list [self] end-delivery $filename $fd [my channel] $request] } } ::HttpSpooler instproc end-delivery {filename fd ch request bytes args} { @@ -465,8 +465,8 @@ regexp {^([^:]+):(.*)$} $host _ host port my incr running xo::AsyncHttpRequest [self]::[my incr counter] \ - -host $host -port $port -path $path \ - -timeout [my timeout] -post_data $post_data -request_manager [self] + -host $host -port $port -path $path \ + -timeout [my timeout] -post_data $post_data -request_manager [self] } } @@ -506,195 +506,195 @@ {-delete false} {-content_disposition} status_code mime_type filename} { - Deliver the given file to the requestor in the background. This proc uses the - background delivery thread to send the file in an event-driven manner without - blocking a request thread. This is especially important when large files are - requested over slow (e.g. dial-ip) connections. -} { + Deliver the given file to the requestor in the background. This proc uses the + background delivery thread to send the file in an event-driven manner without + blocking a request thread. This is especially important when large files are + requested over slow (e.g. dial-ip) connections. + } { - #ns_setexpires 1000000 - #ns_log notice "expires-set $filename" - #ns_log notice "status_code = $status_code, filename=$filename" + #ns_setexpires 1000000 + #ns_log notice "expires-set $filename" + #ns_log notice "status_code = $status_code, filename=$filename" - if {![my isobject ::xo::cc]} { - ::xo::ConnectionContext require - } - set query [::xo::cc actual_query] - set use_h264 [expr {[string match "video/mp4*" $mime_type] && $query ne "" - && ([string match {*start=[1-9]*} $query] || [string match {*end=[1-9]*} $query]) - && [info command h264open] ne ""}] + if {![my isobject ::xo::cc]} { + ::xo::ConnectionContext require + } + set query [::xo::cc actual_query] + set use_h264 [expr {[string match "video/mp4*" $mime_type] && $query ne "" + && ([string match {*start=[1-9]*} $query] || [string match {*end=[1-9]*} $query]) + && [info command h264open] ne ""}] - if {[info commands ns_driversection] ne ""} { + if {[info commands ns_driversection] ne ""} { set use_writerThread [ns_config [ns_driversection] writerthreads 0] - } else { + } else { set use_writerThread 0 - } + } - if {[info exists content_disposition]} { - set fn [xo::backslash_escape \" $content_disposition] - ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=\"$fn\"" - } + if {[info exists content_disposition]} { + set fn [xo::backslash_escape \" $content_disposition] + ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=\"$fn\"" + } - if {$use_h264} { - if {0} { - # we have to obtain the size from the file; unfortunately, this - # requires a duplicate open+close of the h264 stream. If the - # application is performance sensitive, one might consider to use - # the possibly incorrect size form the file system instead (works - # perfectly for e.g. flowplayer) - if {[catch {set handle [h264open $filename $query]} errorMsg]} { - ns_log error "h264: error opening h264 channel for $filename $query: $errorMsg" - return + if {$use_h264} { + if {0} { + # we have to obtain the size from the file; unfortunately, this + # requires a duplicate open+close of the h264 stream. If the + # application is performance sensitive, one might consider to use + # the possibly incorrect size form the file system instead (works + # perfectly for e.g. flowplayer) + if {[catch {set handle [h264open $filename $query]} errorMsg]} { + ns_log error "h264: error opening h264 channel for $filename $query: $errorMsg" + return + } + set size [h264length $handle] + h264close $handle + } else { + set size [file size $filename] } - set size [h264length $handle] - h264close $handle } else { set size [file size $filename] } - } else { - set size [file size $filename] - } - # Make sure to set "connection close" for the reqests (in other - # words, don't allow keep-alive, which is does not make sense, when - # we close the connections manually in the bgdelivery thread). - # - if {$::xo::naviserver && !$use_writerThread} { - ns_conn keepalive 0 - } + # Make sure to set "connection close" for the reqests (in other + # words, don't allow keep-alive, which is does not make sense, when + # we close the connections manually in the bgdelivery thread). + # + if {$::xo::naviserver && !$use_writerThread} { + ns_conn keepalive 0 + } - set range [ns_set iget [ns_conn headers] range] - if {[regexp {bytes=(.*)$} $range _ range]} { - set ranges [list] - set bytes 0 - set pos 0 - foreach r [split $range ,] { - regexp {^(\d*)-(\d*)$} $r _ from to - if {$from eq ""} { - # The last $to bytes, $to must be specified; 'to' is - # differently interpreted as in the case, where from is - # non-empty - set from [expr {$size - $to}] - } else { - if {$to eq ""} {set to [expr {$size-1}]} + set range [ns_set iget [ns_conn headers] range] + if {[regexp {bytes=(.*)$} $range _ range]} { + set ranges [list] + set bytes 0 + set pos 0 + foreach r [split $range ,] { + regexp {^(\d*)-(\d*)$} $r _ from to + if {$from eq ""} { + # The last $to bytes, $to must be specified; 'to' is + # differently interpreted as in the case, where from is + # non-empty + set from [expr {$size - $to}] + } else { + if {$to eq ""} {set to [expr {$size-1}]} + } + set rangeSize [expr {1 + $to - $from}] + lappend ranges [list $from $to $rangeSize] + set pos [expr {$to + 1}] + incr bytes $rangeSize } - set rangeSize [expr {1 + $to - $from}] - lappend ranges [list $from $to $rangeSize] - set pos [expr {$to + 1}] - incr bytes $rangeSize + } else { + set ranges "" + set bytes $size } - } else { - set ranges "" - set bytes $size - } - #ns_log notice "Range=$range bytes=$bytes // $ranges" + #ns_log notice "Range=$range bytes=$bytes // $ranges" - # - # For the time being, we write the headers in a simplified version - # directly in the spooling thread to avoid the overhead of double - # h264opens. - # - if {!$use_h264} { # - # Add content-range header for range requests. + # For the time being, we write the headers in a simplified version + # directly in the spooling thread to avoid the overhead of double + # h264opens. # - if {[llength $ranges] == 1 && $status_code == 200} { - lassign [lindex $ranges 0] from to - if {$from <= $to && $size > $to} { - ns_set put [ns_conn outputheaders] Content-Range "bytes $from-$to/$size" - ns_log notice "given range <$range>, added header-field Content-Range: bytes $from-$to/$size // $ranges" - set status_code 206 - } else { - # A byte-content-range-spec with a byte-range-resp-spec whose - # last-byte-pos value is less than its first-byte-pos value, - # or whose instance-length value is less than or equal to its - # last-byte-pos value, is invalid. The recipient of an invalid - # byte-content-range-spec MUST ignore it and any content - # transferred along with it. - # - # See http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html (14.16) - # - ns_log notice "### ignore invalid <$range>, pos > size-1, Content-Range: bytes $from-$to/$size // $ranges" + if {!$use_h264} { + # + # Add content-range header for range requests. + # + if {[llength $ranges] == 1 && $status_code == 200} { + lassign [lindex $ranges 0] from to + if {$from <= $to && $size > $to} { + ns_set put [ns_conn outputheaders] Content-Range "bytes $from-$to/$size" + ns_log notice "given range <$range>, added header-field Content-Range: bytes $from-$to/$size // $ranges" + set status_code 206 + } else { + # A byte-content-range-spec with a byte-range-resp-spec whose + # last-byte-pos value is less than its first-byte-pos value, + # or whose instance-length value is less than or equal to its + # last-byte-pos value, is invalid. The recipient of an invalid + # byte-content-range-spec MUST ignore it and any content + # transferred along with it. + # + # See http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html (14.16) + # + ns_log notice "### ignore invalid <$range>, pos > size-1, Content-Range: bytes $from-$to/$size // $ranges" + } + } elseif {[llength $ranges]>1} { + ns_log warning "Multiple ranges are currently not supported, ignoring range request" } - } elseif {[llength $ranges]>1} { - ns_log warning "Multiple ranges are currently not supported, ignoring range request" + my write_headers $status_code $mime_type $bytes } - my write_headers $status_code $mime_type $bytes - } - if {$bytes == 0} { - # Tcl behaves different, when one tries to send 0 bytes via - # file_copy. So, we handle this special case here... - # There is actualy nothing to deliver.... - ns_set put [ns_conn outputheaders] "Content-Length" 0 - ns_return 200 $mime_type {} - return - } + if {$bytes == 0} { + # Tcl behaves different, when one tries to send 0 bytes via + # file_copy. So, we handle this special case here... + # There is actualy nothing to deliver.... + ns_set put [ns_conn outputheaders] "Content-Length" 0 + ns_return 200 $mime_type {} + return + } - if {$use_writerThread && !$use_h264} { + if {$use_writerThread && !$use_h264} { if {$status_code == 206} { - ns_log notice "ns_writer submitfile -offset $from -size $bytes $filename" - ns_writer submitfile -offset $from -size $bytes $filename + ns_log notice "ns_writer submitfile -offset $from -size $bytes $filename" + ns_writer submitfile -offset $from -size $bytes $filename } else { - ns_log notice "ns_writer submitfile $filename" - ns_writer submitfile $filename + ns_log notice "ns_writer submitfile $filename" + ns_writer submitfile $filename } return - } + } - set errorMsg "" - # Get the thread id and make sure the bgdelivery thread is already - # running. - set tid [my get_tid] - - # my log "+++ lock [my set bgmutex]" - ::thread::mutex lock [my set mutex] + set errorMsg "" + # Get the thread id and make sure the bgdelivery thread is already + # running. + set tid [my get_tid] + + # my log "+++ lock [my set bgmutex]" + ::thread::mutex lock [my set mutex] - # - # Transfer the channel to the bgdelivery thread and report errors - # in detail. - # - # Notice, that Tcl versions up to 8.5.4 have a bug in this area. - # If one uses an earlier version of Tcl, please apply: - # http://tcl.cvs.sourceforge.net/viewvc/tcl/tcl/generic/tclIO.c?r1=1.61.2.29&r2=1.61.2.30&pathrev=core-8-4-branch - # + # + # Transfer the channel to the bgdelivery thread and report errors + # in detail. + # + # Notice, that Tcl versions up to 8.5.4 have a bug in this area. + # If one uses an earlier version of Tcl, please apply: + # http://tcl.cvs.sourceforge.net/viewvc/tcl/tcl/generic/tclIO.c?r1=1.61.2.29&r2=1.61.2.30&pathrev=core-8-4-branch + # - catch { - set ch [ns_conn channel] - if {[catch {thread::transfer $tid $ch} innerError]} { - set channels_in_use "??" - catch {set channels_in_use [bgdelivery do file channels]} - ns_log error "thread transfer failed, channel=$ch, channels_in_use=$channels_in_use" - error $innerError + catch { + set ch [ns_conn channel] + if {[catch {thread::transfer $tid $ch} innerError]} { + set channels_in_use "??" + catch {set channels_in_use [bgdelivery do file channels]} + ns_log error "thread transfer failed, channel=$ch, channels_in_use=$channels_in_use" + error $innerError + } + } errorMsg + + ::thread::mutex unlock [my set mutex] + #ns_mutex unlock [my set bgmutex] + # my log "+++ unlock [my set bgmutex]" + + if {$errorMsg ne ""} { + error ERROR=$errorMsg } - } errorMsg - - ::thread::mutex unlock [my set mutex] - #ns_mutex unlock [my set bgmutex] - # my log "+++ unlock [my set bgmutex]" - - if {$errorMsg ne ""} { - error ERROR=$errorMsg + + if {$use_h264} { + #my log "MP4 q=[::xo::cc actual_query], h=[ns_set array [ns_conn outputheaders]]" + my do -async ::h264Spooler spool -delete $delete -channel $ch -filename $filename \ + -context [list [::xo::cc requestor],[::xo::cc url],$query [ns_conn start]] \ + -query $query \ + -client_data $client_data + } else { + #my log "FILE SPOOL $filename" + my do -async ::fileSpooler spool -ranges $ranges -delete $delete -channel $ch -filename $filename \ + -context [list [::xo::cc requestor],[::xo::cc url],$query [ns_conn start]] \ + -client_data $client_data + } + # + # set the length for the access log (which is written when the + # connection thread is done) + ns_conn contentsentlength $size ;# maybe overly optimistic } - - if {$use_h264} { - #my log "MP4 q=[::xo::cc actual_query], h=[ns_set array [ns_conn outputheaders]]" - my do -async ::h264Spooler spool -delete $delete -channel $ch -filename $filename \ - -context [list [::xo::cc requestor],[::xo::cc url],$query [ns_conn start]] \ - -query $query \ - -client_data $client_data - } else { - #my log "FILE SPOOL $filename" - my do -async ::fileSpooler spool -ranges $ranges -delete $delete -channel $ch -filename $filename \ - -context [list [::xo::cc requestor],[::xo::cc url],$query [ns_conn start]] \ - -client_data $client_data - } - # - # set the length for the access log (which is written when the - # connection thread is done) - ns_conn contentsentlength $size ;# maybe overly optimistic -} ad_proc -public ad_returnfile_background {{-client_data ""} status_code mime_type filename} { Deliver the given file to the requestor in the background. This proc uses the @@ -736,3 +736,10 @@ bgdelivery proc spooler_release {spooler} { my do -async $spooler release } + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/chat-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/chat-procs.tcl,v diff -u -r1.20.2.3 -r1.20.2.4 --- openacs-4/packages/xotcl-core/tcl/chat-procs.tcl 11 Feb 2014 11:53:08 -0000 1.20.2.3 +++ openacs-4/packages/xotcl-core/tcl/chat-procs.tcl 14 Feb 2014 18:20:44 -0000 1.20.2.4 @@ -10,11 +10,13 @@ Class Message -parameter {time user_id msg color} Class Chat -superclass ::xo::OrderedComposite \ -parameter { - chat_id - user_id - session_id - {mode default} - {encoder urlencode} {timewindow 600} {sweepinterval 600} + chat_id + user_id + session_id + {mode default} + {encoder urlencode} + {timewindow 600} + {sweepinterval 600} } Chat instproc init {} { @@ -29,7 +31,7 @@ my log "-- initialize $cls" $cls initialize_nsvs ::xo::clusterwide nsv_set $cls initialized \ - [ad_schedule_proc -thread "t" [my sweepinterval] $cls sweep_all_chats] + [ad_schedule_proc -thread "t" [my sweepinterval] $cls sweep_all_chats] } if {![nsv_exists $array-seen newest]} {::xo::clusterwide nsv_set $array-seen newest 0} if {![nsv_exists $array-color idx]} {::xo::clusterwide nsv_set $array-color idx 0} @@ -60,11 +62,11 @@ my log "-- msg=$msg" if {$get_new - && [info commands ::thread::mutex] ne "" - && [info commands ::bgdelivery] ne ""} { + && [info commands ::thread::mutex] ne "" + && [info commands ::bgdelivery] ne ""} { # we could use the streaming interface my broadcast_msg [Message new -volatile -time [clock seconds] \ - -user_id $user_id -msg $msg -color $color] + -user_id $user_id -msg $msg -color $color] } my register_nsvs $now.$user_id $user_id $msg $color [clock seconds] # this in any case a valid result, but only needed for the polling interface @@ -104,12 +106,12 @@ if {[nsv_get $array-seen newest]>$last} { #my log "--c must check $session_id: [nsv_get $array-seen newest] > $last" foreach {key value} [nsv_array get $array] { - lassign $value timestamp secs user msg color - if {$timestamp > $last} { - my add [Message new -time $secs -user_id $user -msg $msg -color $color] - } else { - my check_age $key [expr {($now - $timestamp) / 1000}] - } + lassign $value timestamp secs user msg color + if {$timestamp > $last} { + my add [Message new -time $secs -user_id $user -msg $msg -color $color] + } else { + my check_age $key [expr {($now - $timestamp) / 1000}] + } } ::xo::clusterwide nsv_set $array-seen $session_id $now #my log "--c setting session_id $session_id: $now" @@ -124,7 +126,7 @@ foreach {key value} [nsv_array get $array] { lassign $value timestamp secs user msg color if {[my check_age $key [expr {($now - $timestamp) / 1000}]]} { - my add [Message new -time $secs -user_id $user -msg $msg -color $color] + my add [Message new -time $secs -user_id $user -msg $msg -color $color] } } #my log "--c setting session_id $session_id: $now" @@ -141,11 +143,11 @@ ns_log Notice "--core-chat Checking: now=$now, timestamp=$timestamp, ago=$ago" # was 1200 if {$ago > 300} { - my add_msg -get_new false -uid $user "auto logout" - nsv_unset $array-last-activity $user - nsv_unset $array-login $user - nsv_unset $array-color $user - catch {::bgdelivery do ::Subscriber sweep chat-[my chat_id]} + my add_msg -get_new false -uid $user "auto logout" + nsv_unset $array-last-activity $user + nsv_unset $array-login $user + nsv_unset $array-color $user + catch {::bgdelivery do ::Subscriber sweep chat-[my chat_id]} } } my log "-- ending" @@ -181,9 +183,9 @@ set output "" foreach {user_id timestamp} [my active_user_list] { if {$user_id > 0} { - set diff [clock format [expr {[clock seconds] - $timestamp}] -format "%H:%M:%S" -gmt 1] - set userlink [my user_link -user_id $user_id] - append output "$userlink$diff\n" + set diff [clock format [expr {[clock seconds] - $timestamp}] -format "%H:%M:%S" -gmt 1] + set userlink [my user_link -user_id $user_id] + append output "$userlink$diff\n" } } return $output @@ -217,16 +219,16 @@ } Chat instproc user_name { user_id } { - acs_user::get -user_id $user_id -array user - return [expr {$user(screen_name) ne "" ? $user(screen_name) : $user(name)}] + acs_user::get -user_id $user_id -array user + return [expr {$user(screen_name) ne "" ? $user(screen_name) : $user(name)}] } Chat instproc user_link { -user_id -color } { if {$user_id > 0} { set name [my user_name $user_id] set url "/shared/community-member?user%5fid=$user_id" if {![info exists color]} { - set color [my user_color $user_id] + set color [my user_color $user_id] } set creator "$name" } elseif { $user_id == 0 } { @@ -241,9 +243,10 @@ Chat instproc noencode {string} {set string} Chat instproc encode {string} {my [my encoder] $string} Chat instproc json_encode {string} { - string map [list \n \\n {"} {\"} ' {\'}] $string ;#" + string map [list \n \\n {"} {\"} ' {\'}] $string ;\#" + # } - + Chat instproc json_encode_msg {msg} { set old [my encoder] my encoder noencode ;# just for user_link @@ -253,93 +256,93 @@ set text [my json_encode [$msg msg]] foreach var {userlink timeshort} {set $var [my json_encode [set $var]]} return [subst -nocommands {{'messages': [ - {'user':'$userlink', 'time': '$timeshort', 'msg':'$text'} - ]\n} - }] - } + {'user':'$userlink', 'time': '$timeshort', 'msg':'$text'} + ]\n} + }] + } - Chat instproc js_encode_msg {msg} { - set json [my json_encode_msg $msg] - return "\n" - } + } - Chat instproc broadcast_msg {msg} { - my log "--chat broadcast_msg $msg" - ::xo::clusterwide \ - bgdelivery send_to_subscriber chat-[my chat_id] [my json_encode_msg $msg] - } + Chat instproc broadcast_msg {msg} { + my log "--chat broadcast_msg $msg" + ::xo::clusterwide \ + bgdelivery send_to_subscriber chat-[my chat_id] [my 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 user_active $user_id]} { - my 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 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 user_active $user_id]} { + my 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 + set result "
    \n" + foreach child [my 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] + + append result "

    $timeshort " \ + "$userlink " \ + "[my encode $msg]

    \n" + } + append result "
    " + return $result + } - Chat instproc render {} { - my orderby time - set result "
    \n" - foreach child [my 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] + ############################################################################ + # Chat meta class, since we need to define general class-specific methods + ############################################################################ + Class create ChatClass -superclass ::xotcl::Class + ChatClass method sweep_all_chats {} { + my log "-- starting" + foreach nsv [nsv_names "[self]-*-seen"] { + if { [regexp "[self]-(\[0-9\]+)-seen" $nsv _ chat_id] } { + my log "--Chat_id $chat_id" + my new -volatile -chat_id $chat_id -user_id 0 -session_id 0 -init -sweeper + } + } + my log "-- ending" + } + + ChatClass method initialize_nsvs {} { + # read the last_activity information at server start into a nsv array + ::xo::dc foreach get_rooms { + select room_id, to_char(max(creation_date),'HH24:MI:SS YYYY-MM-DD') as last_activity + from chat_msgs group by room_id + } { + ::xo::clusterwide nsv_set [self]-$room_id-seen last [clock scan $last_activity] + } + } + + ChatClass method flush_messages {-chat_id:required} { + set array "[self]-$chat_id" + ::xo::clusterwide nsv_unset $array + ::xo::clusterwide nsv_unset $array-seen + ::xo::clusterwide nsv_unset $array-last-activity + } - append result "

    $timeshort " \ - "$userlink " \ - "[my encode $msg]

    \n" - } - append result "
    " - return $result - } - - ############################################################################ - # Chat meta class, since we need to define general class-specific methods - ############################################################################ - Class create ChatClass -superclass ::xotcl::Class - ChatClass method sweep_all_chats {} { - my log "-- starting" - foreach nsv [nsv_names "[self]-*-seen"] { - if { [regexp "[self]-(\[0-9\]+)-seen" $nsv _ chat_id] } { - my log "--Chat_id $chat_id" - my new -volatile -chat_id $chat_id -user_id 0 -session_id 0 -init -sweeper - } - } - my log "-- ending" - } - - ChatClass method initialize_nsvs {} { - # read the last_activity information at server start into a nsv array - ::xo::dc foreach get_rooms { - select room_id, to_char(max(creation_date),'HH24:MI:SS YYYY-MM-DD') as last_activity - from chat_msgs group by room_id - } { - ::xo::clusterwide nsv_set [self]-$room_id-seen last [clock scan $last_activity] - } - } - - ChatClass method flush_messages {-chat_id:required} { - set array "[self]-$chat_id" - ::xo::clusterwide nsv_unset $array - ::xo::clusterwide nsv_unset $array-seen - ::xo::clusterwide nsv_unset $array-last-activity - } - - ChatClass method init {} { - # default setting is set19 from http://www.graphviz.org/doc/info/colors.html - # per parameter settings in the chat package are available (param UserColors) - my set colors [list #1b9e77 #d95f02 #7570b3 #e7298a #66a61e #e6ab02 #a6761d #666666] - } + ChatClass method init {} { + # default setting is set19 from http://www.graphviz.org/doc/info/colors.html + # per parameter settings in the chat package are available (param UserColors) + my set colors [list #1b9e77 #d95f02 #7570b3 #e7298a #66a61e #e6ab02 #a6761d #666666] + } } # Index: openacs-4/packages/xotcl-core/tcl/cluster-init.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/cluster-init.tcl,v diff -u -r1.3 -r1.3.8.1 --- openacs-4/packages/xotcl-core/tcl/cluster-init.tcl 23 Dec 2008 11:34:59 -0000 1.3 +++ openacs-4/packages/xotcl-core/tcl/cluster-init.tcl 14 Feb 2014 18:20:44 -0000 1.3.8.1 @@ -27,11 +27,18 @@ array set node [site_node::get -url $url] if {$node(url) ne "/"} { ns_log notice "***\n*** WARNING: there appears a package mounted on\ - $url\n***Cluster configuration will not work\ - since there is a conflict with the aolserver filter with the same name!\n" + $url\n***Cluster configuration will not work\ + since there is a conflict with the aolserver filter with the same name!\n" } #ns_register_filter trace GET $url ::xo::Cluster ns_register_filter preauth GET $url ::xo::Cluster #ad_register_filter -priority 900 preauth GET $url ::xo::Cluster } + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl,v diff -u -r1.6.8.1 -r1.6.8.2 --- openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl 5 Oct 2013 12:36:53 -0000 1.6.8.1 +++ openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl 14 Feb 2014 18:20:45 -0000 1.6.8.2 @@ -113,25 +113,32 @@ # Cluster proc broadcast args { foreach server [my info instances] { - $server message {*}$args + $server message {*}$args } } Cluster instproc message args { my log "--cluster outgoing request to [my host]:[my port] // $args" -# set r [::xo::HttpRequest new -volatile \ -# -host [my host] -port [my port] \ -# -path [Cluster set url]?cmd=[ns_urlencode $args]] -# return [$r set data] + # set r [::xo::HttpRequest new -volatile \ + # -host [my host] -port [my port] \ + # -path [Cluster set url]?cmd=[ns_urlencode $args]] + # return [$r set data] set r [::xo::AsyncHttpRequest new -volatile \ - -host [my host] -port [my port] \ - -path [Cluster set url]?cmd=[ns_urlencode $args]] - -# ::bgdelivery do ::xo::AsyncHttpRequest new \ -# -host [my host] -port [my port] \ -# -path [Cluster set url]?cmd=[ns_urlencode $args] \ -# -mixin ::xo::AsyncHttpRequest::SimpleListener \ -# -proc finalize {obj status value} { my destroy } + -host [my host] -port [my port] \ + -path [Cluster set url]?cmd=[ns_urlencode $args]] + + # ::bgdelivery do ::xo::AsyncHttpRequest new \ + # -host [my host] -port [my port] \ + # -path [Cluster set url]?cmd=[ns_urlencode $args] \ + # -mixin ::xo::AsyncHttpRequest::SimpleListener \ + # -proc finalize {obj status value} { my destroy } } -} \ No newline at end of file +} + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: 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 -r1.50.2.6 -r1.50.2.7 --- openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 11 Feb 2014 11:53:08 -0000 1.50.2.6 +++ openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 14 Feb 2014 18:20:45 -0000 1.50.2.7 @@ -11,37 +11,37 @@ ::xotcl::Class create ::xo::db::CrClass \ -superclass ::xo::db::Class \ -parameter { - {supertype content_revision} - form - edit_form - {mime_type text/plain} - {storage_type "text"} - {folder_id -100} + {supertype content_revision} + form + edit_form + {mime_type text/plain} + {storage_type "text"} + {folder_id -100} } -ad_doc { -

    The meta class CrClass serves for a class of applications that mostly - store information in the content repository and that use a few - attributes adjoining this information. The class handles the open - acs object_type creation and the automatic creation of the - necessary tables based on instances of this meta-class.

    - -

    The definition of new types is handled in the constructor of - CrType through the method - create_object_type, - the removal of the - object type is handled through the method - drop_object_type - (requires that - all instances of this type are deleted).

    +

    The meta class CrClass serves for a class of applications that mostly + store information in the content repository and that use a few + attributes adjoining this information. The class handles the open + acs object_type creation and the automatic creation of the + necessary tables based on instances of this meta-class.

    + +

    The definition of new types is handled in the constructor of + CrType through the method + create_object_type, + the removal of the + object type is handled through the method + drop_object_type + (requires that + all instances of this type are deleted).

    -

    Each content item can be retrieved either through the - general method - - CrClass get_instance_from_db or through the "get_instance_from_db" method of - every subclass of CrItem. +

    Each content item can be retrieved either through the + general method + + CrClass get_instance_from_db or through the "get_instance_from_db" method of + every subclass of CrItem. -

    This Class is a meta-class providing methods for Classes - managing CrItems.

    - } +

    This Class is a meta-class providing methods for Classes + managing CrItems.

    + } # # Methods for the meta class @@ -57,15 +57,15 @@ } { set object_type [ns_cache eval xotcl_object_type_cache \ [expr {$item_id ? $item_id : $revision_id}] { - if {$item_id} { - ::xo::dc 1row get_class_from_item_id \ - "select content_type as object_type from cr_items where item_id=:item_id" - } else { - ::xo::dc 1row get_class_from_revision_id \ - "select object_type from acs_objects where object_id=:revision_id" - } - return $object_type - }] + if {$item_id} { + ::xo::dc 1row get_class_from_item_id \ + "select content_type as object_type from cr_items where item_id=:item_id" + } else { + ::xo::dc 1row get_class_from_revision_id \ + "select object_type from acs_objects where object_id=:revision_id" + } + return $object_type + }] } CrClass ad_proc get_instance_from_db { @@ -225,7 +225,7 @@ publish_status last_modified } if {[apm_version_names_compare [ad_acs_version] 5.2] > -1} { - CrClass lappend common_query_atts package_id + CrClass lappend common_query_atts package_id } CrClass instproc edit_atts {} { @@ -247,10 +247,10 @@ where content_type = :object_type } { ::xo::db::sql::content_folder unregister_content_type \ - -folder_id $folder_id \ - -content_type $object_type \ - -include_subtypes $include_subtypes - } + -folder_id $folder_id \ + -content_type $object_type \ + -include_subtypes $include_subtypes + } } CrClass ad_instproc folder_type { @@ -272,9 +272,9 @@ my instvar folder_id } ::xo::db::sql::content_folder ${operation}_content_type \ - -folder_id $folder_id \ - -content_type $object_type \ - -include_subtypes $include_subtypes + -folder_id $folder_id \ + -content_type $object_type \ + -include_subtypes $include_subtypes } CrClass ad_instproc create_object_type {} { @@ -372,7 +372,7 @@ # application class with the given default for mime_type. if {[self] ne "::xo::db::CrItem"} { my slots { - ::xotcl::Attribute create mime_type -default [my mime_type] + ::xotcl::Attribute create mime_type -default [my mime_type] } my db_slots } @@ -389,8 +389,8 @@ foreach {slot_name slot} [[my info superclass] array get db_slot] { # don't overwrite slots, unless the object_title (named title) if {![info exists db_slot($slot_name)] || - $slot eq "::xo::db::Object::slot::object_title"} { - set db_slot($slot_name) $slot + $slot eq "::xo::db::Object::slot::object_title"} { + set db_slot($slot_name) $slot } } my remember_long_text_slots @@ -434,19 +434,19 @@ } foreach {slot_name slot} [my array get db_slot] { switch -- $slot { - ::xo::db::CrItem::slot::text { - # We need the rule, since insert the handling of the sql - # attribute "text" is somewhat magic. On insert, one can use the - # automatic view with column_name "text, on queries, one has to use - # "data". Therefore, we cannot use simply -column_name for the slot. - lappend atts "n.data AS text" - } - ::xo::db::CrItem::slot::name { - lappend atts i.[$slot column_name] - } - default { - lappend atts n.[$slot column_name] - } + ::xo::db::CrItem::slot::text { + # We need the rule, since insert the handling of the sql + # attribute "text" is somewhat magic. On insert, one can use the + # automatic view with column_name "text, on queries, one has to use + # "data". Therefore, we cannot use simply -column_name for the slot. + lappend atts "n.data AS text" + } + ::xo::db::CrItem::slot::name { + lappend atts i.[$slot column_name] + } + default { + lappend atts n.[$slot column_name] + } } } if {$revision_id} { @@ -477,7 +477,7 @@ if {[apm_version_names_compare [ad_acs_version] 5.2] <= -1} { $object set package_id [::xo::dc get_value get_pid \ - "select package_id from cr_folders where folder_id = [$object set parent_id]"] + "select package_id from cr_folders where folder_id = [$object set parent_id]"] } #my log "--AFTER FETCH\n[$object serialize]" @@ -520,13 +520,13 @@ my get_context package_id creation_user creation_ip #my log "ID [self] create $args" if {[catch {set p [my create ::0 {*}$args]} errorMsg]} { - my log "Error: $errorMsg, $::errorInfo" + my log "Error: $errorMsg, $::errorInfo" } #my log "ID [::0 serialize]" set item_id [::0 save_new \ - -package_id $package_id \ - -creation_user $creation_user \ - -creation_ip $creation_ip] + -package_id $package_id \ + -creation_user $creation_user \ + -creation_ip $creation_ip] ::0 move ::$item_id ::$item_id destroy_on_cleanup return ::$item_id @@ -559,8 +559,8 @@ } { returns the SQL-query to select the CrItems of the specified object_type @select_attributes attributes for the sql query to be retrieved, in addition - to item_id, name, publish_status, object_type, and package_id - which are always returned + to item_id, name, publish_status, object_type, and package_id + which are always returned @param orderby for ordering the solution set @param where_clause clause for restricting the answer set @param with_subtypes return subtypes as well @@ -622,11 +622,11 @@ } set sql [::xo::dc select \ - -vars $attribute_selection \ - -from "$acs_objects_table cr_items ci, $base_table bt $from_clause" \ - -where [join $cond " and "] \ - -orderby $orderby \ - -limit $limit -offset $offset] + -vars $attribute_selection \ + -from "$acs_objects_table cr_items ci, $base_table bt $from_clause" \ + -where [join $cond " and "] \ + -orderby $orderby \ + -limit $limit -offset $offset] #my log "--sql=$sql" return $sql } @@ -648,17 +648,17 @@ method was called. } { set s [my instantiate_objects -sql \ - [my instance_select_query \ - -select_attributes $select_attributes \ - -from_clause $from_clause \ - -where_clause $where_clause \ - -orderby $orderby \ - -with_subtypes $with_subtypes \ - -folder_id $folder_id \ - -page_size $page_size \ - -page_number $page_number \ - -base_table $base_table \ - ]] + [my instance_select_query \ + -select_attributes $select_attributes \ + -from_clause $from_clause \ + -where_clause $where_clause \ + -orderby $orderby \ + -with_subtypes $with_subtypes \ + -folder_id $folder_id \ + -page_size $page_size \ + -page_number $page_number \ + -base_table $base_table \ + ]] return $s } @@ -670,42 +670,42 @@ -table_name cr_revisions -id_column revision_id \ -object_type content_revision \ -slots { - # - # The following attributes are from cr_revisions - # - ::xo::db::CrAttribute create item_id \ - -datatype integer \ - -pretty_name "Item ID" -pretty_plural "Item IDs" \ - -references "cr_items on delete cascade" - ::xo::db::CrAttribute create title \ - -sqltype varchar(1000) \ - -pretty_name "Title" -pretty_plural "Titles" - ::xo::db::CrAttribute create description \ - -sqltype varchar(1000) \ - -pretty_name "Description" -pretty_plural "Descriptions" - ::xo::db::CrAttribute create publish_date -datatype date - ::xo::db::CrAttribute create mime_type \ - -sqltype varchar(200) \ - -pretty_name "Mime Type" -pretty_plural "Mime Types" \ - -default text/plain -references cr_mime_types - ::xo::db::CrAttribute create nls_language \ - -sqltype varchar(50) \ - -pretty_name "Language" -pretty_plural "Languages" \ - -default en_US - # lob, content, content_length - # - # missing: attributes from cr_items - ::xo::db::CrAttribute create text \ - -pretty_name "Text" \ - -create_acs_attribute false - ::xo::db::CrAttribute create name \ - -pretty_name "Name" \ - -create_acs_attribute false + # + # The following attributes are from cr_revisions + # + ::xo::db::CrAttribute create item_id \ + -datatype integer \ + -pretty_name "Item ID" -pretty_plural "Item IDs" \ + -references "cr_items on delete cascade" + ::xo::db::CrAttribute create title \ + -sqltype varchar(1000) \ + -pretty_name "Title" -pretty_plural "Titles" + ::xo::db::CrAttribute create description \ + -sqltype varchar(1000) \ + -pretty_name "Description" -pretty_plural "Descriptions" + ::xo::db::CrAttribute create publish_date -datatype date + ::xo::db::CrAttribute create mime_type \ + -sqltype varchar(200) \ + -pretty_name "Mime Type" -pretty_plural "Mime Types" \ + -default text/plain -references cr_mime_types + ::xo::db::CrAttribute create nls_language \ + -sqltype varchar(50) \ + -pretty_name "Language" -pretty_plural "Languages" \ + -default en_US + # lob, content, content_length + # + # missing: attributes from cr_items + ::xo::db::CrAttribute create text \ + -pretty_name "Text" \ + -create_acs_attribute false + ::xo::db::CrAttribute create name \ + -pretty_name "Name" \ + -create_acs_attribute false } \ -parameter { - package_id - {parent_id -100} - {publish_status ready} + package_id + {parent_id -100} + {publish_status ready} } CrItem::slot::revision_id default 0 @@ -755,7 +755,7 @@ } else { ::xo::dc dml update_content "update cr_revisions \ set content = :content \ - where revision_id = :revision_id" + where revision_id = :revision_id" } } @@ -764,7 +764,7 @@ set domain [$slot domain] set sql "update [$domain table_name] \ set [$slot column_name] = :value \ - where [$domain id_column] = $revision_id" + where [$domain id_column] = $revision_id" ::xo::dc dml update_attribute_from_slot $sql } } else { @@ -841,7 +841,7 @@ } else { set sql "update [$domain table_name] \ set $att = :value \ - where [$domain id_column] = $revision_id" + where [$domain id_column] = $revision_id" ::xo::dc dml $att $sql } } @@ -855,9 +855,9 @@ if {$quoted} {set val $value} {set val :value} ::xo::dc dml update_content "update cr_revisions \ set $attribute = :val \ - where revision_id = :revision_id" + where revision_id = :revision_id" } - + CrItem instproc current_user_id {} { if {[my isobject ::xo::cc]} {return [::xo::cc user_id]} if {[ad_conn isconnected]} {return [ad_conn user_id]} @@ -894,10 +894,10 @@ foreach {__slot_name __slot} [[my info class] array get db_slot] { if { - $__slot eq "::xo::db::Object::slot::object_title" || - $__slot eq "::xo::db::CrItem::slot::name" || + $__slot eq "::xo::db::Object::slot::object_title" || + $__slot eq "::xo::db::CrItem::slot::name" || $__slot eq "::xo::db::CrItem::slot::publish_date" - } continue + } continue my instvar $__slot_name lappend __atts [$__slot column_name] lappend __vars $__slot_name @@ -911,7 +911,7 @@ set text [cr_create_content_file $item_id $revision_id $import_file] } ::xo::dc [::xo::dc insert-view-operation] revision_add \ - [[my info class] insert_statement $__atts $__vars] + [[my info class] insert_statement $__atts $__vars] my fix_content $revision_id $text @@ -944,19 +944,19 @@ ns_log notice "--OpenACS Version 5.2 or newer [ad_acs_version]" CrItem set content_item__new_args { -name $name -parent_id $parent_id -creation_user $creation_user \ - -creation_ip $creation_ip \ - -item_subtype "content_item" -content_type $object_type \ - -description $description -mime_type $mime_type -nls_language $nls_language \ - -is_live f -storage_type $storage_type -package_id $package_id + -creation_ip $creation_ip \ + -item_subtype "content_item" -content_type $object_type \ + -description $description -mime_type $mime_type -nls_language $nls_language \ + -is_live f -storage_type $storage_type -package_id $package_id } } else { ns_log notice "--OpenACS Version 5.1 or older [ad_acs_version]" CrItem set content_item__new_args { -name $name -parent_id $parent_id -creation_user $creation_user \ - -creation_ip $creation_ip \ - -item_subtype "content_item" -content_type $object_type \ - -description $description -mime_type $mime_type -nls_language $nls_language \ - -is_live f -storage_type $storage_type + -creation_ip $creation_ip \ + -item_subtype "content_item" -content_type $object_type \ + -description $description -mime_type $mime_type -nls_language $nls_language \ + -is_live f -storage_type $storage_type } } @@ -996,10 +996,10 @@ foreach {__slot_name __slot} [$__class array get db_slot] { #my log "--slot = $__slot" if { - $__slot eq "::xo::db::Object::slot::object_title" || - $__slot eq "::xo::db::CrItem::slot::name" || + $__slot eq "::xo::db::Object::slot::object_title" || + $__slot eq "::xo::db::CrItem::slot::name" || $__slot eq "::xo::db::CrItem::slot::publish_date" - } continue + } continue my instvar $__slot_name if {![info exists $__slot_name]} {set $__slot_name ""} lappend __atts [$__slot column_name] @@ -1012,8 +1012,8 @@ set revision_id [xo::dc nextval acs_object_id_seq] if {![my exists name] || $name eq ""} { - # we have an autonamed item, use a unique value for the name - set name [expr {[my exists __autoname_prefix] ? + # we have an autonamed item, use a unique value for the name + set name [expr {[my exists __autoname_prefix] ? "[my set __autoname_prefix]$revision_id" : $revision_id}] } if {$title eq ""} { @@ -1022,13 +1022,13 @@ } #my msg --[subst [[self class] set content_item__new_args]] set item_id [eval ::xo::db::sql::content_item new \ - [[self class] set content_item__new_args]] + [[self class] set content_item__new_args]] if {$storage_type eq "file"} { set text [cr_create_content_file $item_id $revision_id $import_file] } ::xo::dc [::xo::dc insert-view-operation] revision_add \ - [[my info class] insert_statement $__atts $__vars] + [[my info class] insert_statement $__atts $__vars] my fix_content $revision_id $text if {$live_p} { @@ -1094,8 +1094,8 @@ my instvar package_id set base [$package_id url] set sql [::xo::dc select \ - -map_function_names true \ - -vars "ci.name, r.revision_id as version_id,\ + -map_function_names true \ + -vars "ci.name, r.revision_id as version_id,\ person__name(o.creation_user) as author, \ o.creation_user as author_id, \ to_char(o.last_modified,'YYYY-MM-DD HH24:MI:SS') as last_modified_ansi,\ @@ -1104,56 +1104,56 @@ acs_permission__permission_p(r.revision_id,:user_id,'delete') as delete_p,\ r.content_length,\ content_revision__get_number(r.revision_id) as version_number " \ - -from "cr_items ci, cr_revisions r, acs_objects o" \ - -where "ci.item_id = :page_id and r.item_id = ci.item_id and o.object_id = r.revision_id + -from "cr_items ci, cr_revisions r, acs_objects o" \ + -where "ci.item_id = :page_id and r.item_id = ci.item_id and o.object_id = r.revision_id and exists (select 1 from acs_object_party_privilege_map m where m.object_id = r.revision_id and m.party_id = :user_id and m.privilege = 'read')" \ - -orderby "r.revision_id desc"] + -orderby "r.revision_id desc"] ::xo::dc foreach revisions_select $sql { if {$content_length < 1024} { - if {$content_length eq ""} {set content_length 0} - set content_size_pretty "[lc_numeric $content_length] [_ file-storage.bytes]" + if {$content_length eq ""} {set content_length 0} + set content_size_pretty "[lc_numeric $content_length] [_ file-storage.bytes]" } else { - set content_size_pretty "[lc_numeric [format %.2f [expr {$content_length/1024.0}]]] [_ file-storage.kb]" + set content_size_pretty "[lc_numeric [format %.2f [expr {$content_length/1024.0}]]] [_ file-storage.kb]" } set last_modified_ansi [lc_time_system_to_conn $last_modified_ansi] if {$version_id != $live_revision_id} { - set live_revision "Make this Revision Current" - set live_revision_icon /resources/acs-subsite/radio.gif + set live_revision "Make this Revision Current" + set live_revision_icon /resources/acs-subsite/radio.gif } else { - set live_revision "Current Live Revision" - set live_revision_icon /resources/acs-subsite/radiochecked.gif + set live_revision "Current Live Revision" + set live_revision_icon /resources/acs-subsite/radiochecked.gif } set live_revision_link [export_vars -base $base \ - {{m make-live-revision} {revision_id $version_id}}] + {{m make-live-revision} {revision_id $version_id}}] t1 add \ - -version_number $version_number: \ - -edit.href [export_vars -base $base {{revision_id $version_id}}] \ - -author $author \ - -content_size $content_size_pretty \ - -last_modified_ansi [lc_time_fmt $last_modified_ansi "%x %X"] \ - -description $description \ - -live_revision.src $live_revision_icon \ - -live_revision.title $live_revision \ - -live_revision.href $live_revision_link \ - -version_delete.href [export_vars -base $base \ - {{m delete-revision} {revision_id $version_id}}] \ - -version_delete.title [_ file-storage.Delete_Version] + -version_number $version_number: \ + -edit.href [export_vars -base $base {{revision_id $version_id}}] \ + -author $author \ + -content_size $content_size_pretty \ + -last_modified_ansi [lc_time_fmt $last_modified_ansi "%x %X"] \ + -description $description \ + -live_revision.src $live_revision_icon \ + -live_revision.title $live_revision \ + -live_revision.href $live_revision_link \ + -version_delete.href [export_vars -base $base \ + {{m delete-revision} {revision_id $version_id}}] \ + -version_delete.title [_ file-storage.Delete_Version] [t1 last_child] set payload(revision_id) $version_id if {$isAdmin} { - set show_revision_link [export_vars -base $base \ - {{m show-object} {revision_id $version_id}}] - [t1 last_child] set show show - [t1 last_child] set show.href $show_revision_link + set show_revision_link [export_vars -base $base \ + {{m show-object} {revision_id $version_id}}] + [t1 last_child] set show show + [t1 last_child] set show.href $show_revision_link } } @@ -1213,8 +1213,8 @@ -table_name "images" -id_column "image_id" \ -object_type image \ -slots { - ::xo::db::CrAttribute create width -datatype integer - ::xo::db::CrAttribute create height -datatype integer + ::xo::db::CrAttribute create width -datatype integer + ::xo::db::CrAttribute create height -datatype integer } # @@ -1235,14 +1235,14 @@ -datatype text -pretty_name "Description" -spec "textarea,cols=80,rows=2" # the package_id in folders is deprecated, the one in acs_objects should be used } \ -\ + \ -ad_doc { This is a generic class that represents a "cr_folder" XoWiki specific methods are currently directly mixed into all instances of this class. @see ::xowiki::Folder - } + } # TODO: the following block should not be necessary We should get # rid of the old "folder object" in xowiki and use parameter pages @@ -1275,7 +1275,7 @@ } { returns the SQL-query to select the CrItems of the specified object_type @select_attributes attributes for the sql query to be retrieved, in addition - to item_id, name, publish_status, object_type which are always returned + to item_id, name, publish_status, object_type which are always returned @param orderby for ordering the solution set @param where_clause clause for restricting the answer set @param with_subtypes return subtypes as well @@ -1341,11 +1341,11 @@ } set sql [::xo::dc select \ - -vars $attribute_selection \ - -from "$acs_objects_table cr_folders cf $from_clause" \ - -where [join $cond " and "] \ - -orderby $orderby \ - -limit $limit -offset $offset] + -vars $attribute_selection \ + -from "$acs_objects_table cr_folders cf $from_clause" \ + -where [join $cond " and "] \ + -orderby $orderby \ + -limit $limit -offset $offset] return $sql } @@ -1358,7 +1358,7 @@ Usually, the id of the item that is fetched from the database is used. However, XoWiki's "folder objects" (i.e. an ::xowiki::Object instance that can be used - to configure the respective instance) are created using the acs_object_id of the + to configure the respective instance) are created using the acs_object_id of the root folder of the xowiki instance, which is actually the id of another acs_object. Because of this, we cannot simply create the instances of CrFolder using the @@ -1422,8 +1422,8 @@ -description [my description] \ -parent_id $parent_id \ -package_id $package_id \ - -creation_user $creation_user \ - -creation_ip $creation_ip] + -creation_user $creation_user \ + -creation_ip $creation_ip] #parent_s has_child_folders attribute could have become outdated if { [my isobject ::$parent_id] } { ::$parent_id set has_child_folders t @@ -1448,10 +1448,10 @@ content::folder::update \ -folder_id $folder_id \ -attributes [list \ - [list name [my set name]] \ - [list label [my set label]] \ - [list description [my set description]]\ - ] + [list name [my set name]] \ + [list label [my set label]] \ + [list description [my set description]]\ + ] my get_context package_id user_id ip ::xo::dc 1row _ "select acs_object__update_last_modified(:folder_id,$user,'$ip')" } @@ -1503,13 +1503,13 @@ # the object from the cache; check if the object exists already # or create it. if {[my isobject $object]} { - # There would have been no need to call this method. We could + # There would have been no need to call this method. We could # raise an error here. - # my log "--!! $object exists already" + # my log "--!! $object exists already" } else { - # Create the object from the serialization and initialize it + # Create the object from the serialization and initialize it eval $serialized_object - if {$initialize} {$object initialize_loaded_object} + if {$initialize} {$object initialize_loaded_object} } } return $object @@ -1554,11 +1554,11 @@ set scalars {} foreach x [my info vars __*] { if {[my array exists $x]} { - lappend arrays $x [my array get $x] - my array unset $x + lappend arrays $x [my array get $x] + my array unset $x } { - lappend scalars $x [my set $x] - my unset $x + lappend scalars $x [my set $x] + my unset $x } } return [list $arrays $scalars] Index: openacs-4/packages/xotcl-core/tcl/generic-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/generic-procs.tcl,v diff -u -r1.94.6.2 -r1.94.6.3 --- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 11 Feb 2014 11:53:09 -0000 1.94.6.2 +++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 14 Feb 2014 18:20:45 -0000 1.94.6.3 @@ -30,11 +30,11 @@
    • fields: form elements as described in - ad_form. + ad_form.
    • data: data object (e.g. instance if CrItem)
    • folder_id: associated folder id
    • name: of this form, used for naming the template, - defaults to the object name + defaults to the object name
    • add_page_title: page title when adding content items
    • edit_page_title: page title when editing content items
    • with_categories: display form with categories (default false) @@ -119,7 +119,7 @@ -privilege $privilege } set edit_form_page_title [if {$privilege eq "create"} \ - {my add_page_title} {my edit_page_title}] + {my add_page_title} {my edit_page_title}] set context [list $edit_form_page_title] } @@ -167,7 +167,7 @@ ad_returnredirect $link ad_script_abort } - + Form ad_instproc generate { {-template "formTemplate"} {-export} 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 -r1.29.6.2 -r1.29.6.3 --- openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl 30 Sep 2013 11:38:41 -0000 1.29.6.2 +++ openacs-4/packages/xotcl-core/tcl/http-client-procs.tcl 14 Feb 2014 18:20:45 -0000 1.29.6.3 @@ -39,17 +39,17 @@ # (providing post_data causes the POST request). # # set r [::xo::HttpRequest new \ - # -url http://yourhost.yourdomain/yourpath \ - # -post_data [export_vars {var1 var2}] \ - # -content_type "application/x-www-form-urlencoded; charset=UTF-8"] + # -url http://yourhost.yourdomain/yourpath \ + # -post_data [export_vars {var1 var2}] \ + # -content_type "application/x-www-form-urlencoded; charset=UTF-8"] # # 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] + # -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 @@ -60,7 +60,7 @@ # 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 + # -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 @@ -99,8 +99,8 @@ # bgdelivery thread. # # ::bgdelivery do ::xo::AsyncHttpRequest new \ - # -url "https://oacs-dotlrn-conf2007.wu-wien.ac.at/conf2007/" \ - # -mixin ::xo::AsyncHttpRequest::SimpleListener + # -url "https://oacs-dotlrn-conf2007.wu-wien.ac.at/conf2007/" \ + # -mixin ::xo::AsyncHttpRequest::SimpleListener # -proc finalize {obj status value} { my destroy } # ###################### @@ -129,7 +129,7 @@ Attribute create method Attribute create post_data -default "" Attribute create content_type \ - -default "text/plain; charset=[ns_config ns/parameters OutputCharset iso-8859-1]" + -default "text/plain; charset=[ns_config ns/parameters OutputCharset iso-8859-1]" Attribute create request_header_fields -default {} Attribute create user_agent -default "xohttp/0.2" } @@ -228,12 +228,12 @@ # # (B) If the "charset" is omitted, certain default values apply (!): # - # (B.1) RFC 3023 text/* registrations default to us-ascii (!), - # and not iso-8859-1 (overruling RFC 2616). + # (B.1) RFC 3023 text/* registrations default to us-ascii (!), + # and not iso-8859-1 (overruling RFC 2616). # # (B.2) RFC 3023 application/* and non-text "+xml" registrations - # are to be left untreated (in our context, no encoding - # filtering is to be applied -> "binary") + # are to be left untreated (in our context, no encoding + # filtering is to be applied -> "binary") # # (B.3) RFC 2616 text/* registration (if not covered by B.1) # default to iso-8859-1 @@ -253,16 +253,16 @@ if {[regexp {^text/.*$|^.*/xml.*$|^.*\+xml.*$} $content_type]} { # Case (A): Check for an explicitly provided charset parameter if {[regexp {;\s*charset\s*=([^;]*)} $content_type _ charset]} { - set enc [ns_encodingforcharset [string trim $charset]] + set enc [ns_encodingforcharset [string trim $charset]] } # Case (B.1) if {$enc eq "" && [regexp {^text/xml.*$|text/.*\+xml.*$} $content_type]} { - set enc [ns_encodingforcharset us-ascii] + set enc [ns_encodingforcharset us-ascii] } # Case (B.3) if {$enc eq "" && [string match "text/*" $content_type]} { - set enc [ns_encodingforcharset iso-8859-1] + set enc [ns_encodingforcharset iso-8859-1] } } @@ -314,8 +314,8 @@ puts $S "Host: $host" puts $S "User-Agent: [my user_agent]" foreach {tag value} [my request_header_fields] { - #regsub -all \[\n\r\] $value {} value - #set tag [string trim $tag] + #regsub -all \[\n\r\] $value {} value + #set tag [string trim $tag] puts $S "$tag: $value" } my $method @@ -391,7 +391,7 @@ -1 {my finish; return} } if {[regexp {^HTTP/([0-9.]+) +([0-9]+) *} $response _ \ - responseHttpVersion status_code]} { + responseHttpVersion status_code]} { my reply_first_line_done } else { my cancel "unexpected-response '$response'" @@ -404,20 +404,20 @@ 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" - if {[regexp -nocase {^content-length:(.+)$} $response _ length]} { - my set content_length [string trim $length] - } elseif {[regexp -nocase {^content-type:(.+)$} $response _ type]} { - my set content_type [string trim $type] - } - if {[regexp -nocase {^([^:]+): *(.+)$} $response _ key value]} { - my lappend meta [string tolower $key] $value - } - } + -2 {my cancel premature-eof; return} + -1 {continue} + 0 {break} + default { + #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]} { + my set content_type [string trim $type] + } + if {[regexp -nocase {^([^:]+): *(.+)$} $response _ key value]} { + my lappend meta [string tolower $key] $value + } + } } } my reply_header_done @@ -474,40 +474,40 @@ set mutex [thread::mutex create] thread::mutex lock $mutex - + # start the asynchronous request my debug "--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] + -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] + my set_status $cond COND_WAIT_TIMEOUT + thread::cond wait $cond $mutex [my timeout] - set status [my get_status $cond] - my debug "status after cond-wait $status" + set status [my get_status $cond] + my debug "status after cond-wait $status" - if {$status ne "COND_WAIT_REFRESH"} break + if {$status ne "COND_WAIT_REFRESH"} break } if {$status eq "COND_WAIT_TIMEOUT"} { - my set_status $cond "COND_WAIT_CANCELED" + 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 + 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 + 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 @@ -521,11 +521,11 @@ # # my log "after core init, S?[my exists S]" if {[my exists S]} { - my send_request + my send_request } } } - + # # Asynchronous (non-blocking) requests # @@ -646,45 +646,45 @@ Class create AsyncHttpRequest::SimpleListener \ -instproc init {} { - my debug "INIT- NEXT=[self next]" - # register request object as its own request_manager - my request_manager [self] - next + my debug "INIT- NEXT=[self next]" + # register request object as its own request_manager + my request_manager [self] + next } -instproc start_request {payload obj} { - my debug "request $obj started" + my debug "request $obj started" } -instproc request_data {payload obj} { - my debug "partial or complete post" + my debug "partial or complete post" } -instproc start_reply {payload obj} { - my debug "reply $obj started" + my debug "reply $obj started" } -instproc reply_data {payload obj} { - my debug "partial or complete delivery" + my debug "partial or complete delivery" } -instproc finalize {obj status value} { - my debug "finalize $obj $status" - # this is called as a single method after success or failure - next + my debug "finalize $obj $status" + # this is called as a single method after success or failure + next } -instproc success {payload obj} { - my debug "[string length $payload] bytes payload" - #if {[string length $payload]<600} {my log payload=$payload} - # this is called as after a succesful request - my finalize $obj "JOB_COMPLETED" $payload + my debug "[string length $payload] bytes payload" + #if {[string length $payload]<600} {my log payload=$payload} + # this is called as after a succesful request + my finalize $obj "JOB_COMPLETED" $payload } -instproc failure {reason obj} { - my log "[self proc] [self args]" - my log "failed for '$reason'" - # this is called as after an unsuccesful request - my finalize $obj "JOB_FAILED" $reason + my log "[self proc] [self args]" + my log "failed for '$reason'" + # this is called as after an unsuccesful request + my finalize $obj "JOB_FAILED" $reason } -instproc unknown {method args} { - my log "[self proc] [self args]" - my log "UNKNOWN $method" + my log "[self proc] [self args]" + my log "UNKNOWN $method" } - + # Mixin class, used to turn instances of # AsyncHttpRequest into result callbacks # in the scope of bgdelivery, realising @@ -694,51 +694,51 @@ Class create AsyncHttpRequest::RequestManager \ -superclass AsyncHttpRequest::SimpleListener \ -slots { - Attribute create condition + Attribute create 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_REFRESH"} { - } - if {[my exists_status $condition] && - ( [my get_status $condition] eq "COND_WAIT_REFRESH" - || [my get_status $condition] eq "COND_WAIT_TIMEOUT") - } { + # 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_REFRESH"} { + } + if {[my exists_status $condition] && + ( [my get_status $condition] eq "COND_WAIT_REFRESH" + || [my get_status $condition] eq "COND_WAIT_TIMEOUT") + } { # Before, we had here one COND_WAIT_TIMEOUT, and once # COND_WAIT_REFRESH - my set_status $condition $status $value - catch {thread::cond notify $condition} - $obj debug "--- destroying after finish" - $obj destroy - } + 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} - } - + 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 debug "JOB start request $obj" - my set_cond_timeout + my debug "JOB start request $obj" + my set_cond_timeout } -instproc request_data {payload obj} { - my debug "JOB request data $obj [string length $payload]" - my set_cond_timeout + my debug "JOB request data $obj [string length $payload]" + my set_cond_timeout } -instproc start_reply {payload obj} { - my debug "JOB start reply $obj" - my set_cond_timeout + my debug "JOB start reply $obj" + my set_cond_timeout } -instproc reply_data {payload obj} { - my debug "JOB reply data $obj [string length $payload]" - my set_cond_timeout + my debug "JOB reply data $obj [string length $payload]" + my set_cond_timeout } @@ -805,10 +805,17 @@ catch {close [my set F]} next } - + # # 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 } + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: 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 -r1.9 -r1.9.2.1 --- openacs-4/packages/xotcl-core/tcl/ical-procs.tcl 31 Jul 2012 12:25:22 -0000 1.9 +++ openacs-4/packages/xotcl-core/tcl/ical-procs.tcl 14 Feb 2014 18:20:45 -0000 1.9.2.1 @@ -112,9 +112,9 @@ } if {![info exists value]} { if {[my exists $slot]} { - set value [my $slot] + set value [my $slot] } else { - return "" + return "" } } if {[info exists conv]} { @@ -128,20 +128,20 @@ ::xo::ical::VCALITEM instproc start_end {} { if {[my is_day_item]} { append result \ - [my tag -conv tcl_time_to_local_day dtstart] \ - [my tag -conv tcl_time_to_local_day dtend] + [my tag -conv tcl_time_to_local_day dtstart] \ + [my tag -conv tcl_time_to_local_day dtend] } else { append result \ - [my tag -conv tcl_time_to_utc dtstart] \ - [my tag -conv tcl_time_to_utc dtend] + [my tag -conv tcl_time_to_utc dtstart] \ + [my tag -conv tcl_time_to_utc dtend] } } ::xo::ical::VCALITEM instproc as_ical {} { set item_type [namespace tail [my info class]] append t "BEGIN:$item_type\r\n" \ - [my ical_body] \ - "END:$item_type\r\n" + [my ical_body] \ + "END:$item_type\r\n" return $t } @@ -174,31 +174,32 @@ # VJOURNAL: DRAFT, FINAL, CANCELLED append t \ - [my tag -conv tcl_time_to_utc -value $tcl_creation_date created] \ - [my tag -conv tcl_time_to_utc -value $tcl_last_modified last-modified] \ - [my tag -conv tcl_time_to_utc -value $tcl_stamp dtstamp] \ - [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 transp] \ - [my tag uid] \ - [my tag url] \ - [my tag geo] \ - [my tag priority] \ - [my tag sequence] \ - [my tag CLASS] \ - [my tag location] \ - [my tag status] \ - [my tag -conv text_to_ical description] \ - [my tag -conv text_to_ical summary] \ - [my tag -conv tcl_time_to_utc due] + [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 transp] \ + [my tag uid] \ + [my tag url] \ + [my tag geo] \ + [my tag priority] \ + [my tag sequence] \ + [my tag CLASS] \ + [my tag location] \ + [my tag status] \ + [my tag -conv text_to_ical description] \ + [my tag -conv text_to_ical summary] \ + [my tag -conv tcl_time_to_utc due] if {[my exists formatted_recurrences]} { append t [my set formatted_recurrences] } return $t } + # # VTODO # @@ -275,3 +276,10 @@ } } + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/install-check-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/install-check-procs.tcl,v diff -u -r1.4.8.1 -r1.4.8.2 --- openacs-4/packages/xotcl-core/tcl/install-check-procs.tcl 30 Sep 2013 11:38:41 -0000 1.4.8.1 +++ openacs-4/packages/xotcl-core/tcl/install-check-procs.tcl 14 Feb 2014 18:20:45 -0000 1.4.8.2 @@ -12,7 +12,7 @@ Please follow the install instructions on http://www.openacs.org/xowiki/xotcl-core" } elseif {$::xotcl::version < 1.5} { error " XOTcl 1.5 or newer required. You are using $::xotcl::version$::xotcl::patchlevel.\n\ - Please install a new version of XOTcl (see http://www.openacs.org/xowiki/xotcl-core)" + Please install a new version of XOTcl (see http://www.openacs.org/xowiki/xotcl-core)" } else { ns_log notice "XOTcl $::xotcl::version$::xotcl::patchlevel is installed on your system." } @@ -46,4 +46,12 @@ } } -} \ No newline at end of file +} + + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/policy-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/policy-procs.tcl,v diff -u -r1.22.2.2 -r1.22.2.3 --- openacs-4/packages/xotcl-core/tcl/policy-procs.tcl 11 Feb 2014 11:53:09 -0000 1.22.2.2 +++ openacs-4/packages/xotcl-core/tcl/policy-procs.tcl 14 Feb 2014 18:20:45 -0000 1.22.2.3 @@ -80,7 +80,7 @@ set condition [lindex $p 0] if {[llength $condition]>1} { # we have a condition - lassign $condition cond value + lassign $condition cond value if {[$object condition=$cond $query_context $value]} { return [my get_privilege [list [lrange $p 1 end]] $object $method] } @@ -109,10 +109,10 @@ #ns_log notice "---check [list $object info class]" set c [$object info class] foreach class [concat $c [$c info heritage]] { - set c [self]::[namespace tail $class] - if {![my isclass $c]} continue - set permission [my get_permission -check_classes false $class $method] - if {$permission ne ""} break + set c [self]::[namespace tail $class] + if {![my isclass $c]} continue + set permission [my get_permission -check_classes false $class $method] + if {$permission ne ""} break } } return $permission @@ -148,16 +148,16 @@ lassign [my get_privilege -query_context $ctx $permission $object $method] kind p #my msg "--privilege = $p kind = $kind" switch -- $kind { - primitive {return [my check_privilege -login false \ - -package_id $package_id -user_id $user_id \ - $p $object $method]} - complex { - lassign $p attribute privilege - set id [$object set $attribute] - #my msg "--p checking permission -object_id /$id/ -privilege $privilege -party_id $user_id\ - # ==> [::xo::cc permission -object_id $id -privilege $privilege -party_id $user_id]" - return [::xo::cc permission -object_id $id -privilege $privilege -party_id $user_id] - } + primitive {return [my check_privilege -login false \ + -package_id $package_id -user_id $user_id \ + $p $object $method]} + complex { + lassign $p attribute privilege + set id [$object set $attribute] + #my msg "--p checking permission -object_id /$id/ -privilege $privilege -party_id $user_id\ + # ==> [::xo::cc permission -object_id $id -privilege $privilege -party_id $user_id]" + return [::xo::cc permission -object_id $id -privilege $privilege -party_id $user_id] + } } } return 0 @@ -181,19 +181,19 @@ if {$permission ne ""} { lassign [my get_privilege $permission $object $method] kind p switch -- $kind { - primitive { - set allowed [my check_privilege \ - -user_id $user_id -package_id $package_id \ - $p $object $method] - set privilege $p - } - complex { - lassign $p attribute privilege - set id [$object set $attribute] - set allowed [::xo::cc permission -object_id $id \ - -privilege $privilege \ - -party_id $user_id] + primitive { + set allowed [my check_privilege \ + -user_id $user_id -package_id $package_id \ + $p $object $method] + set privilege $p } + complex { + lassign $p attribute privilege + set id [$object set $attribute] + set allowed [::xo::cc permission -object_id $id \ + -privilege $privilege \ + -party_id $user_id] + } } } @@ -202,18 +202,25 @@ if {!$allowed} { set untrusted_user_id [::xo::cc set untrusted_user_id] if {$permission eq ""} { - ns_log notice "enforce_permissions: no permission for $object->$method defined" + ns_log notice "enforce_permissions: no permission for $object->$method defined" } elseif {$user_id == 0 && $untrusted_user_id} { ns_log notice "enforce_permissions: force login, user_id=0 and untrusted_id=$untrusted_user_id" auth::require_login } else { - ns_log notice "enforce_permissions: $user_id doesn't have $privilege on $object" + ns_log notice "enforce_permissions: $user_id doesn't have $privilege on $object" } - ad_return_forbidden "[_ xotcl-core.permission_denied]" [_ xotcl-core.policy-error-insufficient_permissions] + ad_return_forbidden "[_ xotcl-core.permission_denied]" [_ xotcl-core.policy-error-insufficient_permissions] ad_script_abort } - + return $allowed } } + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/www/cache.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/cache.tcl,v diff -u -r1.5.6.1 -r1.5.6.2 --- openacs-4/packages/xotcl-core/www/cache.tcl 5 Dec 2013 08:11:19 -0000 1.5.6.1 +++ openacs-4/packages/xotcl-core/www/cache.tcl 14 Feb 2014 18:23:18 -0000 1.5.6.2 @@ -43,7 +43,7 @@ TableWidget t1 \ -actions [subst { - Action new -label Refresh -url [ad_conn url] -tooltip "Reload this page" + Action new -label Refresh -url [ad_conn url] -tooltip "Reload this page" }] \ -columns { AnchorField name -label "Name" @@ -96,3 +96,9 @@ } +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/www/show-class-graph.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/show-class-graph.tcl,v diff -u -r1.8.6.3 -r1.8.6.4 --- openacs-4/packages/xotcl-core/www/show-class-graph.tcl 5 Oct 2013 12:33:44 -0000 1.8.6.3 +++ openacs-4/packages/xotcl-core/www/show-class-graph.tcl 14 Feb 2014 18:23:18 -0000 1.8.6.4 @@ -87,7 +87,7 @@ set reduced_sc [list] foreach sc [$e info superclass] { if {$omit_base_classes && $sc eq "::xotcl::Object" - || $sc eq "::xotcl::Class"} continue + || $sc eq "::xotcl::Class"} continue lappend reduced_sc $sc } if {$reduced_sc eq {}} continue @@ -169,3 +169,11 @@ #set f [open $tmpnam.dot w]; puts $f $dot_code; close $f #file delete $tmpnam.dot + + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/www/show-object.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/show-object.tcl,v diff -u -r1.15.6.5 -r1.15.6.6 --- openacs-4/packages/xotcl-core/www/show-object.tcl 24 Sep 2013 20:17:46 -0000 1.15.6.5 +++ openacs-4/packages/xotcl-core/www/show-object.tcl 14 Feb 2014 18:23:18 -0000 1.15.6.6 @@ -22,18 +22,18 @@ # scope must be an object, otherwise something is wrong. # if {$scope ne "" && ![xo::getObjectProperty $scope isobject]} { - set isobject 0 + set isobject 0 } else { - set isobject [::xotcl::api isobject $scope $object] + set isobject [::xotcl::api isobject $scope $object] } if {$scope ne ""} { - auth::require_login + auth::require_login } if {!$isobject} { ad_return_complaint 1 "Unable to access object $object. - Might this be a temporary object?" + Might this be a temporary object?" ad_script_abort } @@ -67,17 +67,17 @@ { 0 "Hide Variables" } } } - }] +}] proc api_documentation {scope object kind method} { upvar show_methods show_methods set proc_index [::xotcl::api proc_index $scope $object $kind $method] if {[nsv_exists api_proc_doc $proc_index]} { set documentation [api_proc_documentation \ - -first_line_tag "

      " \ - -label "$kind $method" \ - $proc_index] + -first_line_tag "

      " \ + -label "$kind $method" \ + $proc_index] set result $documentation } else { if {$show_methods == 2} { @@ -224,7 +224,7 @@ } if { [info exists doc_elements(cvs-id)] } { append output "
      CVS Identification:\n
      \ - [ns_quotehtml [lindex $doc_elements(cvs-id) 0]]\n" + [ns_quotehtml [lindex $doc_elements(cvs-id) 0]]\n" } append output "\n" @@ -261,9 +261,9 @@ set output "
    • $out" if { $show_source } { append output \ - "
      " \
-	[api_tcl_to_html [::xotcl::api proc_index $scope $object $proc $m]] \
-
      + "
      " \
+        [api_tcl_to_html [::xotcl::api proc_index $scope $object $proc $m]] \
+
      } return $output } @@ -289,12 +289,12 @@ set out [api_documentation $scope $object instproc $m] if {$out ne ""} { append output "
    • $out" - if { $show_source } { - append output \ - "
      " \
-	      [api_tcl_to_html [::xotcl::api proc_index $scope $object instproc $m]] \
-
      - } + if { $show_source } { + append output \ + "
      " \
+              [api_tcl_to_html [::xotcl::api proc_index $scope $object instproc $m]] \
+
      + } } } } @@ -312,7 +312,7 @@ } if {$vars ne ""} { append output "

      Variables

      \n" \ - [::xotcl::api source_to_html $vars] \n + [::xotcl::api source_to_html $vars] \n } } @@ -324,11 +324,18 @@ set instances [string trimright $instances ", "] if {$instances ne ""} { append output "

      Instances

      \n" \ -
      \n \ - $instances \ -
      \n +
      \n \ + $instances \ +
      \n } } DO $s destroy + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: