Index: openacs-4/packages/acs-tcl/tcl/aolserver-3-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/aolserver-3-procs.tcl,v diff -u -r1.9 -r1.9.2.1 --- openacs-4/packages/acs-tcl/tcl/aolserver-3-procs.tcl 1 Oct 2017 12:16:05 -0000 1.9 +++ openacs-4/packages/acs-tcl/tcl/aolserver-3-procs.tcl 27 Aug 2024 10:06:37 -0000 1.9.2.1 @@ -1,7 +1,7 @@ ad_library { Contains procedures specific to AOLserver 3 (mostly recreating - functionality dropped from AOLserver 2). + functionality dropped from AOLserver 2). @creation-date 27 Feb 2000 @author Jon Salz [jsalz@arsdigita.com] @@ -17,92 +17,92 @@ upvar $valuebyref value if {[ns_set get $formdata $column.NULL] == "t"} { - set value "" - return 0 + set value "" + return 0 } set value [ns_set get $formdata $column] if { [string match $value ""] } { switch -- $type { - - date { - set value [ns_buildsqldate \ - [ns_set get $formdata $column.month] \ - [ns_set get $formdata $column.day] \ - [ns_set get $formdata $column.year]] - } - - time { - set value [ns_buildsqltime \ - [ns_set get $formdata $column.time] \ - [ns_set get $formdata $column.ampm]] - } - + + date { + set value [ns_buildsqldate \ + [ns_set get $formdata $column.month] \ + [ns_set get $formdata $column.day] \ + [ns_set get $formdata $column.year]] + } + + time { + set value [ns_buildsqltime \ + [ns_set get $formdata $column.time] \ + [ns_set get $formdata $column.ampm]] + } + datetime - - timestamp { - set value [ns_buildsqltimestamp \ - [ns_set get $formdata $column.month] \ - [ns_set get $formdata $column.day] \ - [ns_set get $formdata $column.year] \ - [ns_set get $formdata $column.time] \ - [ns_set get $formdata $column.ampm]] - } - - default { - } - } + timestamp { + set value [ns_buildsqltimestamp \ + [ns_set get $formdata $column.month] \ + [ns_set get $formdata $column.day] \ + [ns_set get $formdata $column.year] \ + [ns_set get $formdata $column.time] \ + [ns_set get $formdata $column.ampm]] + } + + default { + } + } } if { [string match $value ""] } { - return -1 + return -1 } else { - return 1 + return 1 } } proc ns_dbformvalueput {htmlform column type value} { switch -- $type { - date { - set retval [ns_formvalueput $htmlform $column.NULL f] - set retval [ns_formvalueput $retval $column.month \ - [ns_parsesqldate month $value]] - set retval [ns_formvalueput $retval $column.day \ - [ns_parsesqldate day $value]] - set retval [ns_formvalueput $retval $column.year \ - [ns_parsesqldate year $value]] - } + date { + set retval [ns_formvalueput $htmlform $column.NULL f] + set retval [ns_formvalueput $retval $column.month \ + [ns_parsesqldate month $value]] + set retval [ns_formvalueput $retval $column.day \ + [ns_parsesqldate day $value]] + set retval [ns_formvalueput $retval $column.year \ + [ns_parsesqldate year $value]] + } - time { - set retval [ns_formvalueput $htmlform $column.NULL f] - set retval [ns_formvalueput $retval $column.time \ - [ns_parsesqltime time $value]] - set retval [ns_formvalueput $retval $column.ampm \ - [ns_parsesqltime ampm $value]] + time { + set retval [ns_formvalueput $htmlform $column.NULL f] + set retval [ns_formvalueput $retval $column.time \ + [ns_parsesqltime time $value]] + set retval [ns_formvalueput $retval $column.ampm \ + [ns_parsesqltime ampm $value]] - } + } datetime - - timestamp { - set retval [ns_formvalueput $htmlform $column.NULL f] - set retval [ns_formvalueput $retval $column.month \ - [ns_parsesqltimestamp month $value]] - set retval [ns_formvalueput $retval $column.day \ - [ns_parsesqltimestamp day $value]] - set retval [ns_formvalueput $retval $column.year \ - [ns_parsesqltimestamp year $value]] - set retval [ns_formvalueput $retval $column.time \ - [ns_parsesqltimestamp time $value]] - set retval [ns_formvalueput $retval $column.ampm \ - [ns_parsesqltimestamp ampm $value]] - - } + timestamp { + set retval [ns_formvalueput $htmlform $column.NULL f] + set retval [ns_formvalueput $retval $column.month \ + [ns_parsesqltimestamp month $value]] + set retval [ns_formvalueput $retval $column.day \ + [ns_parsesqltimestamp day $value]] + set retval [ns_formvalueput $retval $column.year \ + [ns_parsesqltimestamp year $value]] + set retval [ns_formvalueput $retval $column.time \ + [ns_parsesqltimestamp time $value]] + set retval [ns_formvalueput $retval $column.ampm \ + [ns_parsesqltimestamp ampm $value]] - default { + } - set retval [ns_formvalueput $htmlform $column $value] - } + default { + + set retval [ns_formvalueput $htmlform $column $value] + } } return $retval } @@ -111,15 +111,15 @@ upvar $var updatebutton if { ![info exists updatebutton] } { - set updatebutton "" + set updatebutton "" } if { "" eq $updatebutton } { - db_with_handle db { - set updatebutton [ns_table value $db $table update_button_label] - } + db_with_handle db { + set updatebutton [ns_table value $db $table update_button_label] + } } if { "" eq $updatebutton } { - set updatebutton "Update Record" + set updatebutton "Update Record" } } @@ -132,7 +132,7 @@ # Tcl page support proc ns_putscript {conn ignored} { - ns_returnbadrequest $conn "Cannot PUT a script file" + ns_returnbadrequest $conn "Cannot PUT a script file" } # _ns_dateentrywidget is not very popular and is not @@ -157,7 +157,7 @@ } proc _ns_timeentrywidget {column} { - + set output " \ AM\ PM\ Index: openacs-4/packages/acs-tcl/tcl/user-extensions-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/user-extensions-procs.tcl,v diff -u -r1.7 -r1.7.2.1 --- openacs-4/packages/acs-tcl/tcl/user-extensions-procs.tcl 7 Aug 2017 23:48:00 -0000 1.7 +++ openacs-4/packages/acs-tcl/tcl/user-extensions-procs.tcl 27 Aug 2024 10:06:37 -0000 1.7.2.1 @@ -1,8 +1,7 @@ - ad_library { Procs to manage extensions to user data. - This calls the UserData service contract for allowing packages to be notified + This calls the UserData service contract for allowing packages to be notified of changes in user information. @author ben@openforce.net @@ -12,17 +11,17 @@ } namespace eval acs_user_extension { - + ad_proc -private dispatch { {-op:required} {-list_of_args:required} {-impl ""} } { - - Dispatches (calls the service contract routines) the requested - method so that the operation gets executed, and packages are - notified of changes in user information. + Dispatches (calls the service contract routines) the requested + method so that the operation gets executed, and packages are + notified of changes in user information. + } { if {$impl eq ""} { set extensions [list_extensions] @@ -47,7 +46,7 @@ } { Notifies packages when a new user is added to the system. - @see dispatch + @see dispatch } { dispatch -op UserNew -list_of_args [list $user_id] } @@ -56,8 +55,8 @@ {-user_id:required} } { Notifies packages when a user is approved. - - @see dispatch + + @see dispatch } { dispatch -op UserApprove -list_of_args [list $user_id] } @@ -66,18 +65,18 @@ {-user_id:required} } { Notifies packages when a user is deapproved. - - @see dispatch + + @see dispatch } { dispatch -op UserDeapprove -list_of_args [list $user_id] } ad_proc -public user_modify { {-user_id:required} } { - Notifies packages when a user is modified. - - @see dispatch + Notifies packages when a user is modified. + + @see dispatch } { dispatch -op UserModify -list_of_args [list $user_id] } @@ -87,7 +86,7 @@ } { Notifies packages when a user is deleted. - @see dispatch + @see dispatch } { dispatch -op UserDelete -list_of_args [list $user_id] } Index: openacs-4/packages/acs-tcl/tcl/xml-1-dom-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/xml-1-dom-procs.tcl,v diff -u -r1.11.2.4 -r1.11.2.5 --- openacs-4/packages/acs-tcl/tcl/xml-1-dom-procs.tcl 10 Jul 2023 08:43:13 -0000 1.11.2.4 +++ openacs-4/packages/acs-tcl/tcl/xml-1-dom-procs.tcl 27 Aug 2024 10:06:37 -0000 1.11.2.5 @@ -4,7 +4,7 @@ # # This file implements the Tcl language binding for the DOM - # the Document Object Model. Support for the core specification -# is given here. Layered support for specific languages, +# is given here. Layered support for specific languages, # such as HTML and XML, will be in separate modules. # # Copyright (c) 1998 Zveno Pty Ltd @@ -71,7 +71,7 @@ proc dom::GetHandle {type token varName} { if {![info exists $token]} { - return -code error "invalid token \"$token\"" + return -code error "invalid token \"$token\"" } upvar 1 $varName data @@ -134,220 +134,220 @@ switch -- $method { - hasFeature { + hasFeature { - if {[llength $args] != 2} { - return -code error "wrong number of arguments" - } + if {[llength $args] != 2} { + return -code error "wrong number of arguments" + } - # Later on, could use Tcl package facility - if {[regexp {create|destroy|parse|serialize|trim} [lindex $args 0]]} { - if {[lindex $args 1] eq "1.0" } { - return 1 - } else { - return 0 - } - } else { - return 0 - } + # Later on, could use Tcl package facility + if {[regexp {create|destroy|parse|serialize|trim} [lindex $args 0]]} { + if {[lindex $args 1] eq "1.0" } { + return 1 + } else { + return 0 + } + } else { + return 0 + } - } + } - create { + create { - # Bootstrap a document instance + # Bootstrap a document instance - switch [llength $args] { - 0 { - # Allocate unique document array name - set name [namespace current]::document[incr DOMImplementationCounter] - } - 1 { - # Use array name provided. Should check that it is safe. - set name [lindex $args 0] - unset -nocomplain $name - } - default { - return -code error "wrong number of arguments" - } - } + switch [llength $args] { + 0 { + # Allocate unique document array name + set name [namespace current]::document[incr DOMImplementationCounter] + } + 1 { + # Use array name provided. Should check that it is safe. + set name [lindex $args 0] + unset -nocomplain $name + } + default { + return -code error "wrong number of arguments" + } + } - set varPrefix ${name}var - set arrayPrefix ${name}arr + set varPrefix ${name}var + set arrayPrefix ${name}arr - array set $name [list counter 1 \ - node1 [list id node1 docArray $name \ - node:nodeType documentFragment \ - node:parentNode {} \ - node:childNodes ${varPrefix}1 \ - documentFragment:masterDoc node1 \ - document:implementation {} \ - document:xmldecl {version 1.0} \ - document:documentElement {} \ - document:doctype {} \ - ]] + array set $name [list counter 1 \ + node1 [list id node1 docArray $name \ + node:nodeType documentFragment \ + node:parentNode {} \ + node:childNodes ${varPrefix}1 \ + documentFragment:masterDoc node1 \ + document:implementation {} \ + document:xmldecl {version 1.0} \ + document:documentElement {} \ + document:doctype {} \ + ]] - # Initialise child node list - set ${varPrefix}1 {} + # Initialise child node list + set ${varPrefix}1 {} - # Return the new top-level node - return ${name}(node1) + # Return the new top-level node + return ${name}(node1) - } + } - destroy { + destroy { - # Cleanup a document + # Cleanup a document - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } - array set node [set [lindex $args 0]] + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } + array set node [set [lindex $args 0]] - # Patch from Gerald Lester + # Patch from Gerald Lester - ## - ## First release all the associated variables - ## - upvar #0 $node(docArray) docArray - for {set i 0} {$i < $docArray(counter)} {incr i} { - unset -nocomplain ${docArrayName}var$i - unset -nocomplain ${docArrayName}arr$i - } - - ## - ## Then release the main document array - ## - if {![info exists $node(docArray)]} { - return -code error "unable to destroy document" - } + ## + ## First release all the associated variables + ## + upvar #0 $node(docArray) docArray + for {set i 0} {$i < $docArray(counter)} {incr i} { + unset -nocomplain ${docArrayName}var$i + unset -nocomplain ${docArrayName}arr$i + } + + ## + ## Then release the main document array + ## + if {![info exists $node(docArray)]} { + return -code error "unable to destroy document" + } unset -nocomplain $node(docArray) - return {} + return {} - } + } - parse { + parse { - # This implementation allows use of either of two event-based, - # non-validating XML parsers: - # . TclXML Tcl-only parser (version 1.3 or higher) - # . TclExpat parser + # This implementation allows use of either of two event-based, + # non-validating XML parsers: + # . TclXML Tcl-only parser (version 1.3 or higher) + # . TclExpat parser - array set opts {-parser {} -progresscommand {} -chunksize 8196} - if {[catch {array set opts [lrange $args 1 end]}]} { - return -code error "bad configuration options" - } + array set opts {-parser {} -progresscommand {} -chunksize 8196} + if {[catch {array set opts [lrange $args 1 end]}]} { + return -code error "bad configuration options" + } - # Create a state array for this parse session - set state [namespace current]::parse[incr DOMImplementationCounter] - array set $state [array get opts -*] - array set $state [list progCounter 0] - set errorCleanup {} + # Create a state array for this parse session + set state [namespace current]::parse[incr DOMImplementationCounter] + array set $state [array get opts -*] + array set $state [list progCounter 0] + set errorCleanup {} - switch -- $opts(-parser) { - expat { - if {[catch {package require expat} version]} { - eval $errorCleanup - return -code error "expat extension is not available" - } - set parser [expat [namespace current]::xmlparser] - } - tcl { - if {[catch {package require xml 1.3} version]} { - eval $errorCleanup - return -code error "XML parser package is not available" - } - set parser [::xml::parser xmlparser] - } - default { - # Automatically determine which parser to use - if {[catch {package require expat} version]} { - if {[catch {package require xml 1.3} version]} { - eval $errorCleanup - return -code error "unable to load XML parser" - } else { - set parser [::xml::parser xmlparser] - } - } else { - set parser [expat [namespace current]::xmlparser] - } - } - } + switch -- $opts(-parser) { + expat { + if {[catch {package require expat} version]} { + eval $errorCleanup + return -code error "expat extension is not available" + } + set parser [expat [namespace current]::xmlparser] + } + tcl { + if {[catch {package require xml 1.3} version]} { + eval $errorCleanup + return -code error "XML parser package is not available" + } + set parser [::xml::parser xmlparser] + } + default { + # Automatically determine which parser to use + if {[catch {package require expat} version]} { + if {[catch {package require xml 1.3} version]} { + eval $errorCleanup + return -code error "unable to load XML parser" + } else { + set parser [::xml::parser xmlparser] + } + } else { + set parser [expat [namespace current]::xmlparser] + } + } + } - $parser configure \ - -elementstartcommand [namespace code [list ParseElementStart $state]] \ - -elementendcommand [namespace code [list ParseElementEnd $state]] \ - -characterdatacommand [namespace code [list ParseCharacterData $state]] \ - -processinginstructioncommand [namespace code [list ParseProcessingInstruction $state]] \ - -final true + $parser configure \ + -elementstartcommand [namespace code [list ParseElementStart $state]] \ + -elementendcommand [namespace code [list ParseElementEnd $state]] \ + -characterdatacommand [namespace code [list ParseCharacterData $state]] \ + -processinginstructioncommand [namespace code [list ParseProcessingInstruction $state]] \ + -final true - # TclXML has features missing from expat - catch { - $parser configure \ - -xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] \ - -doctypecommand [namespace code [list ParseDocType $state]] - } + # TclXML has features missing from expat + catch { + $parser configure \ + -xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] \ + -doctypecommand [namespace code [list ParseDocType $state]] + } - # Create top-level document - array set $state [list docNode [DOMImplementation create]] - array set $state [list current [lindex [array get $state docNode] 1]] + # Create top-level document + array set $state [list docNode [DOMImplementation create]] + array set $state [list current [lindex [array get $state docNode] 1]] - # Parse data - # Bug in TclExpat - doesn't handle non-final inputs - if {0 && [string length $opts(-progresscommand)]} { - $parser configure -final false - while {[string length [lindex $args 0]]} { - $parser parse [string range [lindex $args 0] 0 $opts(-chunksize)] - #set args [lreplace $args 0 0 \ + # Parse data + # Bug in TclExpat - doesn't handle non-final inputs + if {0 && [string length $opts(-progresscommand)]} { + $parser configure -final false + while {[string length [lindex $args 0]]} { + $parser parse [string range [lindex $args 0] 0 $opts(-chunksize)] + #set args [lreplace $args 0 0 \ # [string range [lindex $args 0] $opts(-chunksize) end]] lset args 0 [string range [lindex $args 0] $opts(-chunksize) end] - uplevel #0 $opts(-progresscommand) - } - $parser configure -final true - } elseif {[catch {$parser parse [lindex $args 0]} err]} { - catch {rename $parser {}} - unset -nocomplain $state - return -code error $err - } + uplevel #0 $opts(-progresscommand) + } + $parser configure -final true + } elseif {[catch {$parser parse [lindex $args 0]} err]} { + catch {rename $parser {}} + unset -nocomplain $state + return -code error $err + } - # Free data structures which are no longer required - catch {rename $parser {}} + # Free data structures which are no longer required + catch {rename $parser {}} - set doc [lindex [array get $state docNode] 1] - unset $state - return $doc + set doc [lindex [array get $state docNode] 1] + unset $state + return $doc - } + } - serialize { + serialize { - if {[llength $args] < 1} { - return -code error "wrong number of arguments" - } + if {[llength $args] < 1} { + return -code error "wrong number of arguments" + } - GetHandle documentFragment [lindex $args 0] node - return [eval [list Serialize:$node(node:nodeType)] $args] + GetHandle documentFragment [lindex $args 0] node + return [eval [list Serialize:$node(node:nodeType)] $args] - } + } - trim { + trim { - # Removes textNodes that only contain white space + # Removes textNodes that only contain white space - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - Trim [lindex $args 0] + Trim [lindex $args 0] - return {} + return {} - } + } - default { - return -code error "unknown method \"$method\"" - } + default { + return -code error "unknown method \"$method\"" + } } @@ -381,127 +381,127 @@ set result {} switch -- $method { - cget { - if {[llength $args] != 1} { - return -code error "too many arguments" - } - if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} { - return $node(document:$option) - } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} { - return $node(document:$option) - } else { - return -code error "unknown option \"[lindex $args 0]\"" - } - } - configure { - if {[llength $args] == 1} { - return [document cget $token [lindex $args 0]] - } elseif {[llength $args] % 2} { - return -code error "no value specified for option \"[lindex $args end]\"" - } else { - foreach {option value} $args { - if {[regexp [format {^-(%s)$} $documentOptionsRW] $option discard opt]} { - set node(document:$opt) $value - } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} { - return -code error "attribute \"$option\" is read-only" - } else { - return -code error "unknown option \"$option\"" - } - } - } + cget { + if {[llength $args] != 1} { + return -code error "too many arguments" + } + if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} { + return $node(document:$option) + } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} { + return $node(document:$option) + } else { + return -code error "unknown option \"[lindex $args 0]\"" + } + } + configure { + if {[llength $args] == 1} { + return [document cget $token [lindex $args 0]] + } elseif {[llength $args] % 2} { + return -code error "no value specified for option \"[lindex $args end]\"" + } else { + foreach {option value} $args { + if {[regexp [format {^-(%s)$} $documentOptionsRW] $option discard opt]} { + set node(document:$opt) $value + } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} { + return -code error "attribute \"$option\" is read-only" + } else { + return -code error "unknown option \"$option\"" + } + } + } - PutHandle $token node + PutHandle $token node - } + } - createElement { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + createElement { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - # Check that the element name is kosher - # BUG: The definition of 'Letter' here as ASCII letters - # is not sufficient. Also, CombiningChar and Extenders - # must be added. - if {![regexp {^[A-Za-z_:][-A-Za-z0-9._:]*$} [lindex $args 0]]} { - return -code error "invalid element name \"[lindex $args 0]\"" - } + # Check that the element name is kosher + # BUG: The definition of 'Letter' here as ASCII letters + # is not sufficient. Also, CombiningChar and Extenders + # must be added. + if {![regexp {^[A-Za-z_:][-A-Za-z0-9._:]*$} [lindex $args 0]]} { + return -code error "invalid element name \"[lindex $args 0]\"" + } - # Invoke internal factory function - set result [CreateElement $token [lindex $args 0] {}] + # Invoke internal factory function + set result [CreateElement $token [lindex $args 0] {}] - } - createDocumentFragment { - if {[llength $args]} { - return -code error "wrong number of arguments" - } + } + createDocumentFragment { + if {[llength $args]} { + return -code error "wrong number of arguments" + } - set result [CreateGeneric $token node:nodeType documentFragment] - } - createTextNode { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + set result [CreateGeneric $token node:nodeType documentFragment] + } + createTextNode { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - set result [CreateTextNode $token [lindex $args 0]] - } - createComment { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + set result [CreateTextNode $token [lindex $args 0]] + } + createComment { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - set result [CreateGeneric $token node:nodeType comment node:nodeValue [lindex $args 0]] - } - createCDATASection { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + set result [CreateGeneric $token node:nodeType comment node:nodeValue [lindex $args 0]] + } + createCDATASection { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - set result [CreateGeneric $token node:nodeType CDATASection node:nodeValue [lindex $args 0]] - } - createProcessingInstruction { - if {[llength $args] != 2} { - return -code error "wrong number of arguments" - } + set result [CreateGeneric $token node:nodeType CDATASection node:nodeValue [lindex $args 0]] + } + createProcessingInstruction { + if {[llength $args] != 2} { + return -code error "wrong number of arguments" + } - set result [CreateGeneric $token node:nodeType processingInstruction \ - node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]] - } - createAttribute { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + set result [CreateGeneric $token node:nodeType processingInstruction \ + node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]] + } + createAttribute { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]] - } - createEntity { - set result [CreateGeneric $token node:nodeType entity] - } - createEntityReference { - set result [CreateGeneric $token node:nodeType entityReference] - } + set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]] + } + createEntity { + set result [CreateGeneric $token node:nodeType entity] + } + createEntityReference { + set result [CreateGeneric $token node:nodeType entityReference] + } - createDocTypeDecl { - # This is not a standard DOM 1.0 method - if {[llength $args] < 1 || [llength $args] > 5} { - return -code error "wrong number of arguments" - } + createDocTypeDecl { + # This is not a standard DOM 1.0 method + if {[llength $args] < 1 || [llength $args] > 5} { + return -code error "wrong number of arguments" + } - lassign $args name extid dtd entities notations - set result [CreateDocType $token $name $extid $dtd $entities $notations] - } + lassign $args name extid dtd entities notations + set result [CreateDocType $token $name $extid $dtd $entities $notations] + } - getElementsByTagName { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + getElementsByTagName { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - return [Element:GetByTagName $token [lindex $args 0]] - } + return [Element:GetByTagName $token [lindex $args 0]] + } - default { - return -code error "unknown method \"$method\"" - } + default { + return -code error "unknown method \"$method\"" + } } @@ -527,13 +527,13 @@ proc dom::CreateElement {token name aList args} { if {[string length $token]} { - array set parent [set $token] - upvar #0 $parent(docArray) docArray - set docArrayName $parent(docArray) + array set parent [set $token] + upvar #0 $parent(docArray) docArray + set docArrayName $parent(docArray) } else { - array set opts $args - upvar #0 $opts(-docarray) docArray - set docArrayName $opts(-docarray) + array set opts $args + upvar #0 $opts(-docarray) docArray + set docArrayName $opts(-docarray) } set id node[incr docArray(counter)] @@ -543,12 +543,12 @@ # NB. normally we'd use Node:create here, # but inline it instead for performance set docArray($id) [list id $id docArray $docArrayName \ - node:parentNode $token \ - node:childNodes ${docArrayName}var$docArray(counter) \ - node:nodeType element \ - node:nodeName $name \ - node:nodeValue {} \ - element:attributeList ${docArrayName}arr$docArray(counter) \ + node:parentNode $token \ + node:childNodes ${docArrayName}var$docArray(counter) \ + node:nodeType element \ + node:nodeName $name \ + node:nodeValue {} \ + element:attributeList ${docArrayName}arr$docArray(counter) \ ] # Initialise associated variables @@ -562,36 +562,36 @@ if {[string length $token]} { - if {$parent(node:nodeType) eq "documentFragment" } { - if {$parent(id) == $parent(documentFragment:masterDoc)} { - if {[info exists parent(document:documentElement)] - && [string length $parent(document:documentElement)] - } { - unset docArray($id) - return -code error "document element already exists" - } else { + if {$parent(node:nodeType) eq "documentFragment" } { + if {$parent(id) == $parent(documentFragment:masterDoc)} { + if {[info exists parent(document:documentElement)] + && [string length $parent(document:documentElement)] + } { + unset docArray($id) + return -code error "document element already exists" + } else { - # Check against document type decl - if {[string length $parent(document:doctype)]} { - array set doctypedecl [set $parent(document:doctype)] - if {$name ne $doctypedecl(doctype:name) } { - return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\"" - } + # Check against document type decl + if {[string length $parent(document:doctype)]} { + array set doctypedecl [set $parent(document:doctype)] + if {$name ne $doctypedecl(doctype:name) } { + return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\"" + } - } else { - # Synthesize document type declaration - CreateDocType $token $name {} {} - # Resynchronise parent record - array set parent [set $token] - } + } else { + # Synthesize document type declaration + CreateDocType $token $name {} {} + # Resynchronise parent record + array set parent [set $token] + } - set parent(document:documentElement) $child - set $token [array get parent] - } - } - } + set parent(document:documentElement) $child + set $token [array get parent] + } + } + } - lappend $parent(node:childNodes) $child + lappend $parent(node:childNodes) $child } @@ -616,13 +616,13 @@ proc dom::CreateTextNode {token text args} { if {[string length $token]} { - array set parent [set $token] - upvar #0 $parent(docArray) docArray - set docArrayName $parent(docArray) + array set parent [set $token] + upvar #0 $parent(docArray) docArray + set docArrayName $parent(docArray) } else { - array set opts $args - upvar #0 $opts(-docarray) docArray - set docArrayName $opts(-docarray) + array set opts $args + upvar #0 $opts(-docarray) docArray + set docArrayName $opts(-docarray) } set id node[incr docArray(counter)] @@ -635,16 +635,16 @@ # Text nodes never have children, so don't create a variable set docArray($id) [list id $id docArray $docArrayName \ - node:parentNode $token \ - node:childNodes {} \ - node:nodeType textNode \ - node:nodeValue $text \ + node:parentNode $token \ + node:childNodes {} \ + node:nodeType textNode \ + node:nodeValue $text \ ] if {[string length $token]} { - # Update parent record - lappend $parent(node:childNodes) $child - set $token [array get parent] + # Update parent record + lappend $parent(node:childNodes) $child + set $token [array get parent] } return $child @@ -663,18 +663,18 @@ proc dom::CreateGeneric {token args} { if {[string length $token]} { - array set parent [set $token] - upvar #0 $parent(docArray) docArray - set docArrayName $parent(docArray) + array set parent [set $token] + upvar #0 $parent(docArray) docArray + set docArrayName $parent(docArray) } else { - array set opts $args - upvar #0 $opts(-docarray) docArray - set docArrayName $opts(-docarray) - array set tmp [array get opts] - foreach opt [array names tmp -*] { - unset tmp($opt) - } - set args [array get tmp] + array set opts $args + upvar #0 $opts(-docarray) docArray + set docArrayName $opts(-docarray) + array set tmp [array get opts] + foreach opt [array names tmp -*] { + unset tmp($opt) + } + set args [array get tmp] } set id node[incr docArray(counter)] @@ -684,16 +684,16 @@ # NB. normally we'd use Node:create here, # but inline it instead for performance set docArray($id) [eval list [list id $id docArray $docArrayName \ - node:parentNode $token \ - node:childNodes ${docArrayName}var$docArray(counter)] \ - $args + node:parentNode $token \ + node:childNodes ${docArrayName}var$docArray(counter)] \ + $args ] set ${docArrayName}var$docArray(counter) {} if {[string length $token]} { - # Update parent record - lappend $parent(node:childNodes) $child - set $token [array get parent] + # Update parent record + lappend $parent(node:childNodes) $child + set $token [array get parent] } return $child @@ -722,17 +722,17 @@ set child $doc(docArray)($id) set docArray($id) [list \ - id $id docArray $doc(docArray) \ - node:parentNode $token \ - node:childNodes {} \ - node:nodeType docType \ - node:nodeName {} \ - node:nodeValue {} \ - doctype:name $name \ - doctype:entities {} \ - doctype:notations {} \ - doctype:externalid $extid \ - doctype:internaldtd $dtd \ + id $id docArray $doc(docArray) \ + node:parentNode $token \ + node:childNodes {} \ + node:nodeType docType \ + node:nodeName {} \ + node:nodeValue {} \ + doctype:name $name \ + doctype:entities {} \ + doctype:notations {} \ + doctype:externalid $extid \ + doctype:internaldtd $dtd \ ] # NB. externalid and internaldtd are not standard DOM 1.0 attributes @@ -776,305 +776,305 @@ set result {} switch -glob -- $method { - cg* { - # cget + cg* { + # cget - # Some read-only configuration options are computed - if {[llength $args] != 1} { - return -code error "too many arguments" - } - if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} { - switch -- $option { - childNodes { - # How are we going to handle documentElement? - set result $node(node:childNodes) - } - firstChild { - upvar #0 $node(node:childNodes) children - switch -- $node(node:nodeType) { - documentFragment { - set result [lindex $children 0] - catch {set result $node(document:documentElement)} - } - default { - set result [lindex $children 0] - } - } - } - lastChild { - upvar #0 $node(node:childNodes) children - switch -- $node(node:nodeType) { - documentFragment { - set result [lindex $children end] - catch {set result $node(document:documentElement)} - } - default { - set result [lindex $children end] - } - } - } - previousSibling { - # BUG: must take documentElement into account - # Find the parent node - GetHandle node $node(node:parentNode) parent - upvar #0 $parent(node:childNodes) children - set idx [lsearch $children $token] - if {$idx >= 0} { - set sib [lindex $children [incr idx -1]] - if {[llength $sib]} { - set result $sib - } else { - set result {} - } - } else { - set result {} - } - } - nextSibling { - # BUG: must take documentElement into account - # Find the parent node - GetHandle node $node(node:parentNode) parent - upvar #0 $parent(node:childNodes) children - set idx [lsearch $children $token] - if {$idx >= 0} { - set sib [lindex $children [incr idx]] - if {[llength $sib]} { - set result $sib - } else { - set result {} - } - } else { - set result {} - } - } - attributes { - if {$node(node:nodeType) ne "element" } { - set result {} - } else { - set result $node(element:attributeList) - } - } - default { - return [GetField node(node:$option)] - } - } - } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} { - return [GetField node(node:$option)] - } else { - return -code error "unknown option \"[lindex $args 0]\"" - } - } - co* { - # configure + # Some read-only configuration options are computed + if {[llength $args] != 1} { + return -code error "too many arguments" + } + if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} { + switch -- $option { + childNodes { + # How are we going to handle documentElement? + set result $node(node:childNodes) + } + firstChild { + upvar #0 $node(node:childNodes) children + switch -- $node(node:nodeType) { + documentFragment { + set result [lindex $children 0] + catch {set result $node(document:documentElement)} + } + default { + set result [lindex $children 0] + } + } + } + lastChild { + upvar #0 $node(node:childNodes) children + switch -- $node(node:nodeType) { + documentFragment { + set result [lindex $children end] + catch {set result $node(document:documentElement)} + } + default { + set result [lindex $children end] + } + } + } + previousSibling { + # BUG: must take documentElement into account + # Find the parent node + GetHandle node $node(node:parentNode) parent + upvar #0 $parent(node:childNodes) children + set idx [lsearch $children $token] + if {$idx >= 0} { + set sib [lindex $children [incr idx -1]] + if {[llength $sib]} { + set result $sib + } else { + set result {} + } + } else { + set result {} + } + } + nextSibling { + # BUG: must take documentElement into account + # Find the parent node + GetHandle node $node(node:parentNode) parent + upvar #0 $parent(node:childNodes) children + set idx [lsearch $children $token] + if {$idx >= 0} { + set sib [lindex $children [incr idx]] + if {[llength $sib]} { + set result $sib + } else { + set result {} + } + } else { + set result {} + } + } + attributes { + if {$node(node:nodeType) ne "element" } { + set result {} + } else { + set result $node(element:attributeList) + } + } + default { + return [GetField node(node:$option)] + } + } + } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} { + return [GetField node(node:$option)] + } else { + return -code error "unknown option \"[lindex $args 0]\"" + } + } + co* { + # configure - if {[llength $args] == 1} { - return [document cget $token [lindex $args 0]] - } elseif {[llength $args] % 2} { - return -code error "no value specified for option \"[lindex $args end]\"" - } else { - foreach {option value} $args { - if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} { - set node(node:$opt) $value - } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} { - return -code error "attribute \"$option\" is read-only" - } else { - return -code error "unknown option \"$option\"" - } - } - } - } + if {[llength $args] == 1} { + return [document cget $token [lindex $args 0]] + } elseif {[llength $args] % 2} { + return -code error "no value specified for option \"[lindex $args end]\"" + } else { + foreach {option value} $args { + if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} { + set node(node:$opt) $value + } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} { + return -code error "attribute \"$option\" is read-only" + } else { + return -code error "unknown option \"$option\"" + } + } + } + } - in* { + in* { - # insertBefore + # insertBefore - # Previous and next sibling relationships are OK, - # because they are dynamically determined + # Previous and next sibling relationships are OK, + # because they are dynamically determined - if {[llength $args] < 1 || [llength $args] > 2} { - return -code error "wrong number of arguments" - } + if {[llength $args] < 1 || [llength $args] > 2} { + return -code error "wrong number of arguments" + } - GetHandle node [lindex $args 0] newChild - if {$newChild(docArray) ne $node(docArray) } { - return -code error "new node must be in the same document" - } + GetHandle node [lindex $args 0] newChild + if {$newChild(docArray) ne $node(docArray) } { + return -code error "new node must be in the same document" + } - switch [llength $args] { - 1 { - # Append as the last node - if {[string length $newChild(node:parentNode)]} { - node removeChild $newChild(node:parentNode) [lindex $args 0] - } - lappend $node(node:childNodes) [lindex $args 0] - set newChild(node:parentNode) $token - } - 2 { + switch [llength $args] { + 1 { + # Append as the last node + if {[string length $newChild(node:parentNode)]} { + node removeChild $newChild(node:parentNode) [lindex $args 0] + } + lappend $node(node:childNodes) [lindex $args 0] + set newChild(node:parentNode) $token + } + 2 { - GetHandle node [lindex $args 1] refChild - if {$refChild(docArray) ne $newChild(docArray) } { - return -code error "nodes must be in the same document" - } - set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]] - if {$idx < 0} { - return -code error "no such reference child" - } else { + GetHandle node [lindex $args 1] refChild + if {$refChild(docArray) ne $newChild(docArray) } { + return -code error "nodes must be in the same document" + } + set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]] + if {$idx < 0} { + return -code error "no such reference child" + } else { - # Remove from previous parent - if {[string length $newChild(node:parentNode)]} { - node removeChild $newChild(node:parentNode) [lindex $args 0] - } + # Remove from previous parent + if {[string length $newChild(node:parentNode)]} { + node removeChild $newChild(node:parentNode) [lindex $args 0] + } - # Insert into new node - set $node(node:childNodes) \ - [linsert [set $node(node:childNodes)] $idx [lindex $args 0]] - set newChild(node:parentNode) $token - } - } - } - PutHandle [lindex $args 0] newChild - } + # Insert into new node + set $node(node:childNodes) \ + [linsert [set $node(node:childNodes)] $idx [lindex $args 0]] + set newChild(node:parentNode) $token + } + } + } + PutHandle [lindex $args 0] newChild + } - rep* { + rep* { - # replaceChild + # replaceChild - if {[llength $args] != 2} { - return -code error "wrong number of arguments" - } + if {[llength $args] != 2} { + return -code error "wrong number of arguments" + } - GetHandle node [lindex $args 0] newChild - GetHandle node [lindex $args 1] oldChild + GetHandle node [lindex $args 0] newChild + GetHandle node [lindex $args 1] oldChild - # Find where to insert new child - set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]] - if {$idx < 0} { - return -code error "no such old child" - } + # Find where to insert new child + set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]] + if {$idx < 0} { + return -code error "no such old child" + } - # Remove new child from current parent - if {[string length $newChild(node:parentNode)]} { - node removeChild $newChild(node:parentNode) [lindex $args 0] - } + # Remove new child from current parent + if {[string length $newChild(node:parentNode)]} { + node removeChild $newChild(node:parentNode) [lindex $args 0] + } - #set $node(node:childNodes) \ - #[lreplace [set $node(node:childNodes)] $idx $idx [lindex $args 0]] + #set $node(node:childNodes) \ + #[lreplace [set $node(node:childNodes)] $idx $idx [lindex $args 0]] lset $node(node:childNodes) $idx [lindex $args 0] - set newChild(node:parentNode) $token + set newChild(node:parentNode) $token - # Update old child to reflect lack of parentage - set oldChild(node:parentNode) {} + # Update old child to reflect lack of parentage + set oldChild(node:parentNode) {} - PutHandle [lindex $args 1] oldChild - PutHandle [lindex $args 0] newChild + PutHandle [lindex $args 1] oldChild + PutHandle [lindex $args 0] newChild - set result [lindex $args 0] + set result [lindex $args 0] - } + } - rem* { + rem* { - # removeChild + # removeChild - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } - array set oldChild [set [lindex $args 0]] - if {$oldChild(docArray) != $node(docArray)} { - return -code error "node \"[lindex $args 0]\" is not a child" - } + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } + array set oldChild [set [lindex $args 0]] + if {$oldChild(docArray) != $node(docArray)} { + return -code error "node \"[lindex $args 0]\" is not a child" + } - # Remove the child from the parent - upvar #0 $node(node:childNodes) myChildren - if {[set idx [lsearch $myChildren [lindex $args 0]]] < 0} { - return -code error "node \"[lindex $args 0]\" is not a child" - } - set myChildren [lreplace $myChildren $idx $idx] + # Remove the child from the parent + upvar #0 $node(node:childNodes) myChildren + if {[set idx [lsearch $myChildren [lindex $args 0]]] < 0} { + return -code error "node \"[lindex $args 0]\" is not a child" + } + set myChildren [lreplace $myChildren $idx $idx] - # Update the child to reflect lack of parentage - set oldChild(node:parentNode) {} - set [lindex $args 0] [array get oldChild] + # Update the child to reflect lack of parentage + set oldChild(node:parentNode) {} + set [lindex $args 0] [array get oldChild] - set result [lindex $args 0] - } + set result [lindex $args 0] + } - ap* { + ap* { - # appendChild + # appendChild - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - # Add to new parent - node insertBefore $token [lindex $args 0] + # Add to new parent + node insertBefore $token [lindex $args 0] - } + } - hasChildNodes { - set result [Min 1 [llength [set $node(node:childNodes)]]] - } + hasChildNodes { + set result [Min 1 [llength [set $node(node:childNodes)]]] + } - cl* { - # cloneNode + cl* { + # cloneNode - set deep 0 - switch [llength $args] { - 0 { - } - 1 { - set deep [Boolean [lindex $args 0]] - } - default { - return -code error "too many arguments" - } - } + set deep 0 + switch [llength $args] { + 0 { + } + 1 { + set deep [Boolean [lindex $args 0]] + } + default { + return -code error "too many arguments" + } + } - switch -- $node(node:nodeType) { - element { - set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -docarray $node(docArray)] - if {$deep} { - foreach child [set $node(node:childNodes)] { - node appendChild $result [node cloneNode $child] - } - } - } - textNode { - set result [CreateTextNode {} $node(node:nodeValue) -docarray $node(docArray)] - } - document - - documentFragment - - default { - set result [CreateGeneric {} node:nodeType $node(node:nodeType) -docarray $node(docArray)] - if {$deep} { - foreach child [set $node(node:childNodes)] { - node appendChild $result [node cloneNode $child] - } - } - } - } + switch -- $node(node:nodeType) { + element { + set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -docarray $node(docArray)] + if {$deep} { + foreach child [set $node(node:childNodes)] { + node appendChild $result [node cloneNode $child] + } + } + } + textNode { + set result [CreateTextNode {} $node(node:nodeValue) -docarray $node(docArray)] + } + document - + documentFragment - + default { + set result [CreateGeneric {} node:nodeType $node(node:nodeType) -docarray $node(docArray)] + if {$deep} { + foreach child [set $node(node:childNodes)] { + node appendChild $result [node cloneNode $child] + } + } + } + } - } + } - ch* { - # children -- non-standard method + ch* { + # children -- non-standard method - # If this is a textNode, then catch the error - set result {} - catch {set result [set $node(node:childNodes)]} + # If this is a textNode, then catch the error + set result {} + catch {set result [set $node(node:childNodes)]} - } + } - pa* { - # parent -- non-standard method + pa* { + # parent -- non-standard method - return $node(node:parentNode) + return $node(node:parentNode) - } + } - default { - return -code error "unknown method \"$method\"" - } + default { + return -code error "unknown method \"$method\"" + } } @@ -1105,23 +1105,23 @@ # Create new node if {![info exists opts(-id)]} { - set opts(-id) node[incr docArray(counter)] + set opts(-id) node[incr docArray(counter)] } set docArray($opts(-id)) [list id $opts(-id) \ - docArray $parent(docArray) \ - node:parentNode $opts(-parent) \ - node:childNodes $parent(docArray)var$docArray(counter) \ - node:nodeType $opts(-type) \ - node:nodeName $opts(-name) \ - node:nodeValue $opts(-value) \ - element:attributeList $parent(docArray)arr$docArray(counter) \ + docArray $parent(docArray) \ + node:parentNode $opts(-parent) \ + node:childNodes $parent(docArray)var$docArray(counter) \ + node:nodeType $opts(-type) \ + node:nodeName $opts(-name) \ + node:nodeValue $opts(-value) \ + element:attributeList $parent(docArray)arr$docArray(counter) \ ] set $parent(docArray)var$docArray(counter) {} array set $parent(docArray)arr$docArray(counter) {} # Update parent node if {![info exists parent(document:documentElement)]} { - lappend parent(node:childNodes) [list [lindex $opts(-parent) 0] $opts(-id)] + lappend parent(node:childNodes) [list [lindex $opts(-parent) 0] $opts(-id)] } return $parent(docArray)($opts(-id)) @@ -1143,7 +1143,7 @@ upvar $token node foreach {key value} $args { - set node($key) $value + set node($key) $value } set $token [array get node] @@ -1178,111 +1178,111 @@ switch -- $method { - cget { - # Some read-only configuration options are computed - if {[llength $args] != 1} { - return -code error "too many arguments" - } - if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} { - switch -- $option { - tagName { - set result [lindex $node(node:nodeName) 0] - } - empty { - if {![info exists node(element:empty)]} { - return 0 - } else { - return $node(element:empty) - } - } - default { - return $node(node:$option) - } - } - } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} { - return $node(node:$option) - } else { - return -code error "unknown option \"[lindex $args 0]\"" - } - } - configure { - if {[llength $args] == 1} { - return [document cget $token [lindex $args 0]] - } elseif {[llength $args] % 2} { - return -code error "no value specified for option \"[lindex $args end]\"" - } else { - foreach {option value} $args { - if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} { - return -code error "attribute \"$option\" is read-only" - } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} { - return -code error "not implemented" - } else { - return -code error "unknown option \"$option\"" - } - } - } - } + cget { + # Some read-only configuration options are computed + if {[llength $args] != 1} { + return -code error "too many arguments" + } + if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} { + switch -- $option { + tagName { + set result [lindex $node(node:nodeName) 0] + } + empty { + if {![info exists node(element:empty)]} { + return 0 + } else { + return $node(element:empty) + } + } + default { + return $node(node:$option) + } + } + } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} { + return $node(node:$option) + } else { + return -code error "unknown option \"[lindex $args 0]\"" + } + } + configure { + if {[llength $args] == 1} { + return [document cget $token [lindex $args 0]] + } elseif {[llength $args] % 2} { + return -code error "no value specified for option \"[lindex $args end]\"" + } else { + foreach {option value} $args { + if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} { + return -code error "attribute \"$option\" is read-only" + } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} { + return -code error "not implemented" + } else { + return -code error "unknown option \"$option\"" + } + } + } + } - getAttribute { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + getAttribute { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - upvar #0 $node(element:attributeList) attrList - catch {set result $attrList([lindex $args 0])} + upvar #0 $node(element:attributeList) attrList + catch {set result $attrList([lindex $args 0])} - } + } - setAttribute { - if {[llength $args] == 0 || [llength $args] > 2} { - return -code error "wrong number of arguments" - } + setAttribute { + if {[llength $args] == 0 || [llength $args] > 2} { + return -code error "wrong number of arguments" + } - # TODO: Check that the attribute name is legal + # TODO: Check that the attribute name is legal - upvar #0 $node(element:attributeList) attrList - set attrList([lindex $args 0]) [lindex $args 1] + upvar #0 $node(element:attributeList) attrList + set attrList([lindex $args 0]) [lindex $args 1] - } + } - removeAttribute { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + removeAttribute { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - upvar #0 $node(element:attributeList) attrList - unset -nocomplain attrList([lindex $args 0]) + upvar #0 $node(element:attributeList) attrList + unset -nocomplain attrList([lindex $args 0]) - } + } - getAttributeNode { - } + getAttributeNode { + } - setAttributeNode { - } + setAttributeNode { + } - removeAttributeNode { - } + removeAttributeNode { + } - getElementsByTagName { - if {[llength $args] != 1} { - return -code error "wrong number of arguments" - } + getElementsByTagName { + if {[llength $args] != 1} { + return -code error "wrong number of arguments" + } - return [Element:GetByTagName $token [lindex $args 0]] - } + return [Element:GetByTagName $token [lindex $args 0]] + } - normalize { - if {[llength $args]} { - return -code error "wrong number of arguments" - } + normalize { + if {[llength $args]} { + return -code error "wrong number of arguments" + } - Element:Normalize node [set $node(node:childNodes)] - } + Element:Normalize node [set $node(node:childNodes)] + } - default { - return -code error "unknown method \"$method\"" - } + default { + return -code error "unknown method \"$method\"" + } } @@ -1309,22 +1309,22 @@ set result {} if {$node(node:nodeType) ne "documentFragment" } { - foreach child [set $node(node:childNodes)] { - unset -nocomplain childNode - array set childNode [set $child] - if {$childNode(node:nodeType) eq "element" - && [GetField childNode(node:nodeName)] eq $name - } { - lappend result $child - } - } + foreach child [set $node(node:childNodes)] { + unset -nocomplain childNode + array set childNode [set $child] + if {$childNode(node:nodeType) eq "element" + && [GetField childNode(node:nodeName)] eq $name + } { + lappend result $child + } + } } elseif {[llength $node(document:documentElement)]} { - # Document Element must exist and must be an element type node - unset -nocomplain childNode - array set childNode [set $node(document:documentElement)] - if {$childNode(node:nodeName) eq $name } { - set result $node(document:documentElement) - } + # Document Element must exist and must be an element type node + unset -nocomplain childNode + array set childNode [set $node(document:documentElement)] + if {$childNode(node:nodeName) eq $name } { + set result $node(document:documentElement) + } } return $result @@ -1347,40 +1347,40 @@ set textNode {} foreach n $nodes { - GetHandle node $n child - set cleanup {} + GetHandle node $n child + set cleanup {} - switch -- $child(node:nodeType) { - textNode { - if {[llength $textNode]} { - # Coalesce into previous node - append text(node:nodeValue) $child(node:nodeValue) - # Remove this child - upvar #0 $parent(node:childNodes) childNodes - set idx [lsearch $childNodes $n] - set childNodes [lreplace $childNodes $idx $idx] - unset $n - set cleanup {} + switch -- $child(node:nodeType) { + textNode { + if {[llength $textNode]} { + # Coalesce into previous node + append text(node:nodeValue) $child(node:nodeValue) + # Remove this child + upvar #0 $parent(node:childNodes) childNodes + set idx [lsearch $childNodes $n] + set childNodes [lreplace $childNodes $idx $idx] + unset $n + set cleanup {} - PutHandle $textNode text - } else { - set textNode $n - unset -nocomplain text - array set text [array get child] - } - } - element - - document - - documentFragment { - set textNode {} - Element:Normalize child [set $child(node:childNodes)] - } - default { - set textNode {} - } - } + PutHandle $textNode text + } else { + set textNode $n + unset -nocomplain text + array set text [array get child] + } + } + element - + document - + documentFragment { + set textNode {} + Element:Normalize child [set $child(node:childNodes)] + } + default { + set textNode {} + } + } - eval $cleanup + eval $cleanup } return {} @@ -1413,61 +1413,61 @@ switch -- $method { - cget { - # Some read-only configuration options are computed - if {[llength $args] != 1} { - return -code error "too many arguments" - } - if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} { - switch -- $option { - target { - set result [lindex $node(node:nodeName) 0] - } - default { - return $node(node:$option) - } - } - } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} { - switch -- $option { - data { - return $node(node:nodeValue) - } - default { - return $node(node:$option) - } - } - } else { - return -code error "unknown option \"[lindex $args 0]\"" - } - } - configure { - if {[llength $args] == 1} { - return [document cget $token [lindex $args 0]] - } elseif {[llength $args] % 2} { - return -code error "no value specified for option \"[lindex $args end]\"" - } else { - foreach {option value} $args { - if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} { - return -code error "attribute \"$option\" is read-only" - } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} { - switch -- $opt { - data { - set node(node:nodeValue) $value - } - default { - set node(node:$opt) $value - } - } - } else { - return -code error "unknown option \"$option\"" - } - } - } - } + cget { + # Some read-only configuration options are computed + if {[llength $args] != 1} { + return -code error "too many arguments" + } + if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} { + switch -- $option { + target { + set result [lindex $node(node:nodeName) 0] + } + default { + return $node(node:$option) + } + } + } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} { + switch -- $option { + data { + return $node(node:nodeValue) + } + default { + return $node(node:$option) + } + } + } else { + return -code error "unknown option \"[lindex $args 0]\"" + } + } + configure { + if {[llength $args] == 1} { + return [document cget $token [lindex $args 0]] + } elseif {[llength $args] % 2} { + return -code error "no value specified for option \"[lindex $args end]\"" + } else { + foreach {option value} $args { + if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} { + return -code error "attribute \"$option\" is read-only" + } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} { + switch -- $opt { + data { + set node(node:nodeValue) $value + } + default { + set node(node:$opt) $value + } + } + } else { + return -code error "unknown option \"$option\"" + } + } + } + } - default { - return -code error "unknown method \"$method\"" - } + default { + return -code error "unknown method \"$method\"" + } } @@ -1497,13 +1497,13 @@ array set node [set $token] if {"node1" ne $node(documentFragment:masterDoc) } { - return [eval [list Serialize:node $token] $args] + return [eval [list Serialize:node $token] $args] } else { - if {{} ne [GetField node(document:documentElement)] } { - return [eval Serialize:document [list $token] $args] - } else { - return -code error "document has no document element" - } + if {{} ne [GetField node(document:documentElement)] } { + return [eval Serialize:document [list $token] $args] + } else { + return -code error "document has no document element" + } } } @@ -1523,20 +1523,20 @@ array set node [set $token] if {![info exists node(document:documentElement)]} { - return -code error "document has no document element" + return -code error "document has no document element" } elseif {$node(document:doctype) eq ""} { - return -code error "no document type declaration given" + return -code error "no document type declaration given" } else { - array set doctype [set $node(document:doctype)] + array set doctype [set $node(document:doctype)] - # BUG: Want to serialize all children except for the - # document element, and then do the document element. + # BUG: Want to serialize all children except for the + # document element, and then do the document element. - # Bug fix: can't use Serialize:attributeList for XML declaration, - # since attributes must occur in a given order (XML 2.8 [23]) + # Bug fix: can't use Serialize:attributeList for XML declaration, + # since attributes must occur in a given order (XML 2.8 [23]) - return "\n\n[eval Serialize:element [list $node(document:documentElement)] $args]" + return "\n\n[eval Serialize:element [list $node(document:documentElement)] $args]" } } @@ -1555,7 +1555,7 @@ set result {} foreach ident $id { - append result { } \"$ident\" + append result { } \"$ident\" } return $result @@ -1576,11 +1576,11 @@ proc dom::Serialize:XMLDecl {attr attrList} { array set data $attrList if {![info exists data($attr)]} { - return {} + return {} } elseif {[string length $data($attr)]} { - return " $attr='$data($attr)'" + return " $attr='$data($attr)'" } else { - return {} + return {} } } @@ -1601,9 +1601,9 @@ set result {} foreach childToken [set $node(node:childNodes)] { - unset -nocomplain child - array set child [set $childToken] - append result [eval [list Serialize:$child(node:nodeType) $childToken] $args] + unset -nocomplain child + array set child [set $childToken] + append result [eval [list Serialize:$child(node:nodeType) $childToken] $args] } return $result @@ -1628,24 +1628,24 @@ set result {} set newline {} if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} { - append result \n - set newline \n + append result \n + set newline \n } append result "<$node(node:nodeName)" append result [Serialize:attributeList [array get $node(element:attributeList)]] if {![llength [set $node(node:childNodes)]]} { - append result />$newline + append result />$newline } else { - append result >$newline + append result >$newline - # Do the children - append result [eval Serialize:node [list $token] $args] + # Do the children + append result [eval Serialize:node [list $token] $args] - append result "$newline$node(node:nodeName)>$newline" + append result "$newline$node(node:nodeName)>$newline" } @@ -1715,12 +1715,12 @@ proc dom::Encode value { array set Entity { - $ $ - < < - > > - & & - \" " - ' ' + $ $ + < < + > > + & & + \" " + ' ' } regsub -all -- {([$<>&"'])} $value {$Entity(\1)} value @@ -1743,19 +1743,19 @@ set result {} foreach {name value} $l { - append result { } $name = + append result { } $name = - # Handle special characters - regsub -all < $value {\<} value + # Handle special characters + regsub -all < $value {\<} value - if {![string match "*\"*" $value]} { - append result \"$value\" - } elseif {![string match "*'*" $value]} { - append result '$value' - } else { - regsub -all \" $value {\"} value - append result \"$value\" - } + if {![string match "*\"*" $value]} { + append result \"$value\" + } elseif {![string match "*'*" $value]} { + append result '$value' + } else { + regsub -all \" $value {\"} value + append result \"$value\" + } } @@ -1786,20 +1786,20 @@ array set opts $args lappend state(current) \ - [CreateElement [lindex $state(current) end] $name $attrList] + [CreateElement [lindex $state(current) end] $name $attrList] if {[info exists opts(-empty)] && $opts(-empty)} { - # Flag this node as being an empty element - array set node [set [lindex $state(current) end]] - set node(element:empty) 1 - set [lindex $state(current) end] [array get node] + # Flag this node as being an empty element + array set node [set [lindex $state(current) end]] + set node(element:empty) 1 + set [lindex $state(current) end] [array get node] } # Temporary: implement -progresscommand here, because of broken parser if {[string length $state(-progresscommand)]} { - if {!([incr state(progCounter)] % $state(-chunksize))} { - uplevel #0 $state(-progresscommand) - } + if {!([incr state(progCounter)] % $state(-chunksize))} { + uplevel #0 $state(-progresscommand) + } } } @@ -1876,8 +1876,8 @@ array set xmldecl $node(document:xmldecl) array set xmldecl [list version $version \ - standalone $standalone \ - encoding $encoding \ + standalone $standalone \ + encoding $encoding \ ] set node(document:xmldecl) [array get xmldecl] @@ -1930,17 +1930,17 @@ switch -- $node(node:nodeType) { - textNode { - if {[string trim $node(node:nodeValue)] eq ""} { - node removeChild $node(node:parentNode) $nodeid - } - } + textNode { + if {[string trim $node(node:nodeValue)] eq ""} { + node removeChild $node(node:parentNode) $nodeid + } + } - default { - foreach child [set $node(node:childNodes)] { - Trim $child - } - } + default { + foreach child [set $node(node:childNodes)] { + Trim $child + } + } } Index: openacs-4/packages/acs-tcl/tcl/xml-2-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/xml-2-procs.tcl,v diff -u -r1.5.2.3 -r1.5.2.4 --- openacs-4/packages/acs-tcl/tcl/xml-2-procs.tcl 1 Feb 2021 10:51:09 -0000 1.5.2.3 +++ openacs-4/packages/acs-tcl/tcl/xml-2-procs.tcl 27 Aug 2024 10:06:37 -0000 1.5.2.4 @@ -8,24 +8,24 @@ # # Copyright (c) 1998,1999 Zveno Pty Ltd # http://www.zveno.com/ -# +# # Zveno makes this software and all associated data and documentation # ('Software') available free of charge for non-commercial purposes only. You # may make copies of the Software but you must include all of this notice on # any copy. -# +# # The Software was developed for research purposes and Zveno does not warrant # that it is error free or fit for any purpose. Zveno disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying the Software. # # Copyright (c) 1997 Australian National University (ANU). -# +# # ANU makes this software and all associated data and documentation # ('Software') available free of charge for non-commercial purposes only. You # may make copies of the Software but you must include all of this notice on # any copy. -# +# # The Software was developed for research purposes and ANU does not warrant # that it is error free or fit for any purpose. ANU disclaims any # liability for all claims, expenses, losses, damages and costs any user may @@ -48,7 +48,7 @@ # Convenience routine proc cl x { - return "\[$x\]" + return "\[$x\]" } # Define various regular expressions @@ -71,7 +71,7 @@ variable EntityPredef array set EntityPredef { - lt < gt > amp & quot \" apos ' + lt < gt > amp & quot \" apos ' } } @@ -108,36 +108,36 @@ variable ParserCounter if {[llength $args] > 0} { - set name [lindex $args 0] - set args [lreplace $args 0 0] + set name [lindex $args 0] + set args [lreplace $args 0 0] } else { - set name parser[incr ParserCounter] + set name parser[incr ParserCounter] } if {[namespace which [namespace current]::$name] ne {}} { - return -code error "unable to create parser object \"[namespace current]::$name\" command" + return -code error "unable to create parser object \"[namespace current]::$name\" command" } # Initialise state variable and object command upvar \#0 [namespace current]::$name parser set sgml_ns [namespace parent]::sgml array set parser [list name $name \ - -final 1 \ - -elementstartcommand ${sgml_ns}::noop \ - -elementendcommand ${sgml_ns}::noop \ - -characterdatacommand ${sgml_ns}::noop \ - -processinginstructioncommand ${sgml_ns}::noop \ - -externalentityrefcommand ${sgml_ns}::noop \ - -xmldeclcommand ${sgml_ns}::noop \ - -doctypecommand ${sgml_ns}::noop \ - -warningcommand ${sgml_ns}::noop \ - -statevariable [namespace current]::$name \ - -reportempty 0 \ - internaldtd {} \ + -final 1 \ + -elementstartcommand ${sgml_ns}::noop \ + -elementendcommand ${sgml_ns}::noop \ + -characterdatacommand ${sgml_ns}::noop \ + -processinginstructioncommand ${sgml_ns}::noop \ + -externalentityrefcommand ${sgml_ns}::noop \ + -xmldeclcommand ${sgml_ns}::noop \ + -doctypecommand ${sgml_ns}::noop \ + -warningcommand ${sgml_ns}::noop \ + -statevariable [namespace current]::$name \ + -reportempty 0 \ + internaldtd {} \ ] proc [namespace current]::$name {method args} \ - "eval ParseCommand $name \$method \$args" + "eval ParseCommand $name \$method \$args" eval ParseCommand [list $name] configure $args @@ -166,26 +166,26 @@ upvar \#0 [namespace current]::$parser state switch -- $method { - cget { - return $state([lindex $args 0]) - } - configure { - foreach {opt value} $args { - set state($opt) $value - } - } - parse { - ParseCommand_parse $parser [lindex $args 0] - } - reset { - if {[llength $args]} { - return -code error "too many arguments" - } - ParseCommand_reset $parser - } - default { - return -code error "unknown method \"$method\"" - } + cget { + return $state([lindex $args 0]) + } + configure { + foreach {opt value} $args { + set state($opt) $value + } + } + parse { + ParseCommand_parse $parser [lindex $args 0] + } + reset { + if {[llength $args]} { + return -code error "too many arguments" + } + ParseCommand_reset $parser + } + default { + return -code error "unknown method \"$method\"" + } } return {} @@ -210,25 +210,25 @@ set parent [namespace parent] if {"::" eq $parent } { - set parent {} + set parent {} } set tokenized [lrange \ - [${parent}::sgml::tokenise $xml \ - $tokExpr \ - $substExpr \ - -internaldtdvariable [namespace current]::${object}(internaldtd)] \ - 4 end] + [${parent}::sgml::tokenise $xml \ + $tokExpr \ + $substExpr \ + -internaldtdvariable [namespace current]::${object}(internaldtd)] \ + 4 end] eval ${parent}::sgml::parseEvent \ - [list $tokenized \ - -emptyelement [namespace code ParseEmpty] \ - -parseattributelistcommand [namespace code ParseAttrs]] \ - [array get parser -*command] \ - [array get parser -entityvariable] \ - [array get parser -reportempty] \ - -normalize 0 \ - -internaldtd [list $parser(internaldtd)] + [list $tokenized \ + -emptyelement [namespace code ParseEmpty] \ + -parseattributelistcommand [namespace code ParseAttrs]] \ + [array get parser -*command] \ + [array get parser -entityvariable] \ + [array get parser -reportempty] \ + -normalize 0 \ + -internaldtd [list $parser(internaldtd)] return {} } @@ -263,7 +263,7 @@ # attrs attribute string given in a tag # # Results: -# Returns a Tcl list representing the name-value pairs in the +# Returns a Tcl list representing the name-value pairs in the # attribute string # # A ">" occurring in the attribute list causes problems when parsing @@ -274,19 +274,19 @@ # did manage to parse and the remainder of the attribute list. proc xml::ParseAttrs attrs { - variable Wsp + variable Wsp variable Name set result {} while {[string length [string trim $attrs]]} { - if {[regexp ($Name)[cl $Wsp]*=[cl $Wsp]*("|')([cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} { - lappend result $attrName $value - } elseif {[regexp $Name[cl $Wsp]*=[cl $Wsp]*("|')[cl ^<]*\$ $attrs]} { - return -code error [list {unterminated attribute value} $result $attrs] - } else { - return -code error "invalid attribute list" - } + if {[regexp ($Name)[cl $Wsp]*=[cl $Wsp]*("|')([cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} { + lappend result $attrName $value + } elseif {[regexp $Name[cl $Wsp]*=[cl $Wsp]*("|')[cl ^<]*\$ $attrs]} { + return -code error [list {unterminated attribute value} $result $attrs] + } else { + return -code error "invalid attribute list" + } } return $result @@ -306,8 +306,8 @@ upvar \#0 [namespace current]::$object parser array set parser [list \ - -final 1 \ - internaldtd {} \ + -final 1 \ + internaldtd {} \ ] } Index: openacs-4/packages/acs-tcl/tcl/tcltrace-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/tcltrace-procs.tcl,v diff -u -r1.4.2.6 -r1.4.2.7 --- openacs-4/packages/acs-tcl/tcl/tcltrace-procs.tcl 1 Feb 2021 10:51:09 -0000 1.4.2.6 +++ openacs-4/packages/acs-tcl/tcl/tcltrace-procs.tcl 27 Aug 2024 10:08:01 -0000 1.4.2.7 @@ -13,92 +13,92 @@ namespace eval ::tcltrace { ad_proc -private before-ns_return { cmd op } { - - Execute this proc before ns_return is called. + + Execute this proc before ns_return is called. This proc saves the request in a file, which can be later used for validating the returned HTML. This works as well for admin pages, which can not be validated via web based HTML validators without giving away admin privileges. - @param cmd the full command as executed by Tcl - @param op the trace operation + @param cmd the full command as executed by Tcl + @param op the trace operation } { - lassign $cmd cmdname statuscode mimetype content - - if {[::parameter::get_from_package_key \ - -package_key acs-tcl \ - -parameter TclTraceSaveNsReturn \ - -default 0]} { - if {$statuscode == 200 - && $mimetype eq "text/html"} { - set name [ns_conn url] - regsub {/$} $name /index name - set fullname [ad_tmpdir]/ns_saved$name.html - ns_log notice "before-ns_return: save content of ns_return to file:$fullname" - set dirname [ad_file dirname $fullname] - if {![ad_file isdirectory $dirname]} { - file mkdir $dirname - } - set f [open $fullname w] - puts $f $content - close $f - } else { - ns_log notice "before-ns_return: ignore statuscode $statuscode mime-type $mimetype" - } - } + lassign $cmd cmdname statuscode mimetype content + + if {[::parameter::get_from_package_key \ + -package_key acs-tcl \ + -parameter TclTraceSaveNsReturn \ + -default 0]} { + if {$statuscode == 200 + && $mimetype eq "text/html"} { + set name [ns_conn url] + regsub {/$} $name /index name + set fullname [ad_tmpdir]/ns_saved$name.html + ns_log notice "before-ns_return: save content of ns_return to file:$fullname" + set dirname [ad_file dirname $fullname] + if {![ad_file isdirectory $dirname]} { + file mkdir $dirname + } + set f [open $fullname w] + puts $f $content + close $f + } else { + ns_log notice "before-ns_return: ignore statuscode $statuscode mime-type $mimetype" + } + } } - + ad_proc -private before-ns_log { cmd op } { - Execute this proc before ns_log is called + Execute this proc before ns_log is called - @param cmd the full command as executed by Tcl - @param op the trace operation + @param cmd the full command as executed by Tcl + @param op the trace operation } { - set msg [join [lassign $cmd cmdname severity]] - set severity [string totitle $severity] - if {![info exists ::__log_severities]} { - set ::__log_severities [::parameter::get_from_package_key \ - -package_key acs-tcl \ - -parameter TclTraceLogSeverities \ - -default ""] - } - if {$severity in $::__log_severities} { - # we do not want i18n raw strings substituted via ds_comment. - # Maybe we should add this substitution there.... - regsub -all -- {\#([a-zA-Z0-9._-]+)\#} $msg {\#\1\#} msg - catch {ds_comment "$cmdname $severity $msg"} - } else { - #catch {ds_comment "ignore $severity $msg"} - } + set msg [join [lassign $cmd cmdname severity]] + set severity [string totitle $severity] + if {![info exists ::__log_severities]} { + set ::__log_severities [::parameter::get_from_package_key \ + -package_key acs-tcl \ + -parameter TclTraceLogSeverities \ + -default ""] + } + if {$severity in $::__log_severities} { + # we do not want i18n raw strings substituted via ds_comment. + # Maybe we should add this substitution there.... + regsub -all -- {\#([a-zA-Z0-9._-]+)\#} $msg {\#\1\#} msg + catch {ds_comment "$cmdname $severity $msg"} + } else { + #catch {ds_comment "ignore $severity $msg"} + } } ad_proc -private before { {-details:boolean false} cmd op } { - + Generic trace proc for arbitrary commands. Simply reports calls to function (optionally with full context) to the error.log. @param details when set, use ad_log for reporting with full context @param cmd the full command as executed by Tcl - @param op the trace operation + @param op the trace operation } { set log_cmd [expr {$details_p ? "ad_log" : "ns_log"}] set abbrev_cmd [lmap w $cmd { regsub -all \n $w {\n} w - regsub -all \r $w {\r} w + regsub -all \r $w {\r} w if {[string length $w] > 100} { set w [string range $w 0 100]... } set w }] $log_cmd notice "trace: [join $abbrev_cmd { }]" } - + } Index: openacs-4/packages/acs-tcl/tcl/tdom-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/tdom-procs.tcl,v diff -u -r1.4 -r1.4.2.1 --- openacs-4/packages/acs-tcl/tcl/tdom-procs.tcl 7 Aug 2017 23:48:00 -0000 1.4 +++ openacs-4/packages/acs-tcl/tcl/tdom-procs.tcl 27 Aug 2024 10:08:01 -0000 1.4.2.1 @@ -15,7 +15,7 @@ @tdom::get_tag_value @tdom::get_attribute_value @tdom::get_node_xml - + } namespace eval tdom {} @@ -44,10 +44,10 @@ # Do a loop for the args. The first non null result is returned set node_object "" foreach node_name $args { - catch {set node_object [$parent_node_object getElementsByTagName "$node_name"]} - if {$node_object ne "" } { - return $node_object - } + catch {set node_object [$parent_node_object getElementsByTagName "$node_name"]} + if {$node_object ne "" } { + return $node_object + } } return $node_object @@ -84,10 +84,10 @@ set tag_value "" foreach tag_name $args { - catch {set tag_value [[$node_object getElementsByTagName "$tag_name"] text]} errormsg - if {[string trim $tag_value] ne "" } { - return $tag_value - } + catch {set tag_value [[$node_object getElementsByTagName "$tag_name"] text]} errormsg + if {[string trim $tag_value] ne "" } { + return $tag_value + } } return $tag_value 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.22.2.17 -r1.22.2.18 --- openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl 19 Aug 2024 14:40:01 -0000 1.22.2.17 +++ openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl 27 Aug 2024 10:15:52 -0000 1.22.2.18 @@ -593,7 +593,7 @@ # the serializer. # # The following extensions of the base classes are defined here: -# +# ::Serializer exportMethods { ::nx::Class method init ::xotcl::Object instproc ad_proc 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.41.2.59 -r1.41.2.60 --- openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 25 Aug 2024 17:05:12 -0000 1.41.2.59 +++ openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 27 Aug 2024 10:15:52 -0000 1.41.2.60 @@ -265,9 +265,9 @@ set r }] } - + #ns_log notice "======require_site_wide_info site_wide_instance_id -> <$site_wide_instance_id>" - + # # During install, no xo::cc is available, but it seems to be # needed for instantiating prototype pages. So provide a best @@ -288,7 +288,7 @@ } return ${:site_wide_info} } - + PackageMgr instproc configure_fresh_instance { {-package_id:required} {-parameter_page_info ""} 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.24.2.21 -r1.24.2.22 --- openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 27 Nov 2022 17:35:46 -0000 1.24.2.21 +++ openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 27 Aug 2024 10:15:52 -0000 1.24.2.22 @@ -1,7 +1,7 @@ ::xo::library doc { xotcl-core implementation for OpenACS package parameters. - + This functionality was backported to acs-tcl in OpenACS 5.10. The functions here are just for backward compatibility, in case these functions were called directly. @@ -325,8 +325,8 @@ [::xo::cc package_id] : [ns_conn isconnected] ? [ad_conn package_id] : $::acs::kernel_id}] } - - ad_log_deprecated proc "xo::parameter set_value -parameter $parameter" parameter::set_value + + ad_log_deprecated proc "xo::parameter set_value -parameter $parameter" parameter::set_value return [::parameter::set_value -package_id $package_id -parameter $parameter -value $value] set parameter_obj [:get_parameter_object -parameter_name $parameter -package_id $package_id] 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.68.2.19 -r1.68.2.20 --- openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 15 Jul 2024 11:41:30 -0000 1.68.2.19 +++ openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 27 Aug 2024 10:15:52 -0000 1.68.2.20 @@ -793,8 +793,8 @@ everything to ns_returnfile. } { #ns_log notice "ad_returnfile_background xo::use_h264 -> [xo::use_h264 $mime_type]" - - security::csp::add_static_resource_header -mime_type $mime_type + + security::csp::add_static_resource_header -mime_type $mime_type if {[xo::use_h264 $mime_type]} { bgdelivery returnfile -client_data $client_data $status_code $mime_type $filename } else { 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.13.2.4 -r1.13.2.5 --- openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl 13 Jan 2022 10:41:13 -0000 1.13.2.4 +++ openacs-4/packages/xotcl-core/tcl/cluster-procs.tcl 27 Aug 2024 10:15:52 -0000 1.13.2.5 @@ -31,7 +31,7 @@ } { ::acs::Cluster {*}$args } - + } ::xo::library source_dependent Index: openacs-4/packages/xotcl-core/tcl/context-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/context-procs.tcl,v diff -u -r1.75.2.42 -r1.75.2.43 --- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 29 Feb 2024 12:04:41 -0000 1.75.2.42 +++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 27 Aug 2024 10:15:52 -0000 1.75.2.43 @@ -383,7 +383,7 @@ ad_log_deprecated method "... requestor" "... requester" return [expr {[info exists :requester] ? ${:requester} : ${:requester}}] } - + ConnectionContext instproc lang {} { return [string range [:locale] 0 1] } 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.112.2.11 -r1.112.2.12 --- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 27 Feb 2023 18:40:21 -0000 1.112.2.11 +++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 27 Aug 2024 10:15:52 -0000 1.112.2.12 @@ -216,7 +216,7 @@ } { # set form name for adp file set :$template ${:name} - + set object_type [[${:data} info class] object_type] set object_name [expr {[${:data} exists name] ? [${:data} set name] : ""}] # :log "-- ${:data}, cl=[${:data} info class] [[${:data} info class] object_type]" @@ -328,11 +328,11 @@ Many parameters are homonymous to those for template::list::create and work in the same way, unless stated differently in this documentation. - + Despite the high number of object's members, most of them are there for backward compatibility with the procedural API and they seldom need to be specified. - + An example of instantiation could just look as this: # Must be an existing acs_object class on the system. Index: openacs-4/packages/xotcl-core/tcl/test/context-test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/test/context-test-procs.tcl,v diff -u -r1.1.2.1 -r1.1.2.2 --- openacs-4/packages/xotcl-core/tcl/test/context-test-procs.tcl 19 Aug 2022 12:11:54 -0000 1.1.2.1 +++ openacs-4/packages/xotcl-core/tcl/test/context-test-procs.tcl 27 Aug 2024 10:15:52 -0000 1.1.2.2 @@ -20,7 +20,7 @@ -parameter "" \ -user_id -1 \ -actual_query "a=1&b=2&name=dagobert&__name=duck" \ - + aa_true "exists xo::cc " {[info commands ::xo::cc] ne ""} ::xo::cc destroy_on_cleanup aa_log "xo::cc [::xo::cc serialize]" @@ -60,7 +60,7 @@ # Avoid script_abort when value constraint fails # set ::aa_test_noabort 1 - + foreach {pair expected} { {a:alpha ""} {expected alpha but got "1" for parameter "a"} } { Index: openacs-4/packages/xotcl-core/tcl/test/xotcl-core-db-tutorial-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/test/xotcl-core-db-tutorial-procs.tcl,v diff -u -r1.1.2.13 -r1.1.2.14 --- openacs-4/packages/xotcl-core/tcl/test/xotcl-core-db-tutorial-procs.tcl 9 Mar 2021 21:11:07 -0000 1.1.2.13 +++ openacs-4/packages/xotcl-core/tcl/test/xotcl-core-db-tutorial-procs.tcl 27 Aug 2024 10:15:52 -0000 1.1.2.14 @@ -1,4 +1,4 @@ -ad_library { +ad_library { Tests for the XOTcl db abstraction based on the XOTcl core tutorial. } 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.12.2.7 -r1.12.2.8 --- openacs-4/packages/xotcl-core/www/show-class-graph.tcl 6 Oct 2023 12:09:20 -0000 1.12.2.7 +++ openacs-4/packages/xotcl-core/www/show-class-graph.tcl 27 Aug 2024 10:15:52 -0000 1.12.2.8 @@ -30,7 +30,7 @@ exec $dot -T$format -O $dotfile set outfile $dotfile.$format - + } on error {errorMsg} { catch {close $F} ns_log warning "show-class-graph: dot returned $errorMsg"
Many parameters are homonymous to those for template::list::create and work in the same way, unless stated differently in this documentation. - +
Despite the high number of object's members, most of them are there for backward compatibility with the procedural API and they seldom need to be specified. - +
An example of instantiation could just look as this:
# Must be an existing acs_object class on the system. Index: openacs-4/packages/xotcl-core/tcl/test/context-test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/test/context-test-procs.tcl,v diff -u -r1.1.2.1 -r1.1.2.2 --- openacs-4/packages/xotcl-core/tcl/test/context-test-procs.tcl 19 Aug 2022 12:11:54 -0000 1.1.2.1 +++ openacs-4/packages/xotcl-core/tcl/test/context-test-procs.tcl 27 Aug 2024 10:15:52 -0000 1.1.2.2 @@ -20,7 +20,7 @@ -parameter "" \ -user_id -1 \ -actual_query "a=1&b=2&name=dagobert&__name=duck" \ - + aa_true "exists xo::cc " {[info commands ::xo::cc] ne ""} ::xo::cc destroy_on_cleanup aa_log "xo::cc [::xo::cc serialize]" @@ -60,7 +60,7 @@ # Avoid script_abort when value constraint fails # set ::aa_test_noabort 1 - + foreach {pair expected} { {a:alpha ""} {expected alpha but got "1" for parameter "a"} } { Index: openacs-4/packages/xotcl-core/tcl/test/xotcl-core-db-tutorial-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/test/xotcl-core-db-tutorial-procs.tcl,v diff -u -r1.1.2.13 -r1.1.2.14 --- openacs-4/packages/xotcl-core/tcl/test/xotcl-core-db-tutorial-procs.tcl 9 Mar 2021 21:11:07 -0000 1.1.2.13 +++ openacs-4/packages/xotcl-core/tcl/test/xotcl-core-db-tutorial-procs.tcl 27 Aug 2024 10:15:52 -0000 1.1.2.14 @@ -1,4 +1,4 @@ -ad_library { +ad_library { Tests for the XOTcl db abstraction based on the XOTcl core tutorial. } 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.12.2.7 -r1.12.2.8 --- openacs-4/packages/xotcl-core/www/show-class-graph.tcl 6 Oct 2023 12:09:20 -0000 1.12.2.7 +++ openacs-4/packages/xotcl-core/www/show-class-graph.tcl 27 Aug 2024 10:15:52 -0000 1.12.2.8 @@ -30,7 +30,7 @@ exec $dot -T$format -O $dotfile set outfile $dotfile.$format - + } on error {errorMsg} { catch {close $F} ns_log warning "show-class-graph: dot returned $errorMsg"
[::xo::cc serialize]