######################################################################
#
# wrapper.tcl
#
# This file defines wrapper procedures. These
# procedures are called by functions in jabberlib, and
# they in turn call the TclXML library functions.
#
# $Header$
#
#
######################################################################
#
# Here is a list of the procedures defined here:
#
if {0} {
proc wrapper:new {streamstartcmd streamendcmd parsecmd}
proc wrapper:free {id}
proc wrapper:parser {id args}
proc wrapper:reset {id}
proc wrapper:elementstart {id tagname varlist args}
proc wrapper:elementend {id tagname args}
proc wrapper:chdata {id chardata}
proc wrapper:xmlerror {id args}
proc wrapper:xmlcrypt {text}
proc wrapper:createxml {xmldata}
proc wrapper:createtag {tagname args}
proc wrapper:getattr {varlist attrname}
proc wrapper:isattr {varlist attrname}
proc wrapper:splitxml {xmldata vtag vvars visempty vchdata vchildren}
proc wrapper:streamheader {args}
proc wrapper:streamtrailer {}
}
#
#
######################################################################
#
set wrapper(list) ""
set wrapper(freeid) 0
######################################################################
proc wrapper:new {streamstartcmd streamendcmd parsecmd} {
variable wrapper
set id "wrap#$wrapper(freeid)"
incr wrapper(freeid)
lappend wrapper(list) $id
set wrapper($id,streamstartcmd) $streamstartcmd
set wrapper($id,streamendcmd) $streamendcmd
set wrapper($id,parsecmd) $parsecmd
set wrapper($id,parser) \
[::xml::parser "_parser_$id" \
-namespace \
-final 0 \
-elementstartcommand "[namespace current]::wrapper:elementstart [list $id]" \
-elementendcommand "[namespace current]::wrapper:elementend [list $id]" \
-characterdatacommand "[namespace current]::wrapper:chdata [list $id]"
# -errorcommand "[namespace current]::wrapper:xmlerror [list $id]"
]
if {[info commands ::$wrapper($id,parser)] == ""} {
set wrapper($id,parser) [namespace current]::$wrapper($id,parser)
}
set wrapper($id,stack) {}
return $id
}
######################################################################
proc wrapper:free {id} {
variable wrapper
if {[set ind [lsearch $wrapper(list) $id]] == -1} {
return -code error -errorinfo "No such wrapper: \"$id\""
}
set wrapper(list) [lreplace $wrapper(list) $ind $ind]
$wrapper($id,parser) free
array unset wrapper $id,*
}
######################################################################
proc wrapper:parser {id args} {
variable wrapper
if {[lsearch $wrapper(list) $id] == -1} {
return -code error -errorinfo "No such wrapper: \"$id\""
}
return [uplevel 1 "[list $wrapper($id,parser)] $args"]
}
######################################################################
proc wrapper:reset {id} {
variable wrapper
if {[lsearch $wrapper(list) $id] == -1} {
return -code error -errorinfo "No such wrapper: \"$id\""
}
$wrapper($id,parser) reset
$wrapper($id,parser) configure \
-final 0 \
-elementstartcommand "[namespace current]::wrapper:elementstart [list $id]" \
-elementendcommand "[namespace current]::wrapper:elementend [list $id]" \
-characterdatacommand "[namespace current]::wrapper:chdata [list $id]"
# -errorcommand "[namespace current]::wrapper:xmlerror [list $id]"
set wrapper($id,stack) {}
}
######################################################################
proc wrapper:elementstart {id tagname varlist args} {
variable wrapper
if {[lsearch $wrapper(list) $id] == -1} {
return -code error -errorinfo "No such wrapper: \"$id\""
}
foreach {attr val} $args {
switch -- $attr {
-namespace {lappend varlist xmlns $val}
}
}
set idx [string last : $tagname]
if {$idx >= 0} {
lappend varlist xmlns [string range $tagname 0 [expr {$idx - 1}]]
set tagname [string range $tagname [expr {$idx + 1}] end]
}
if {$wrapper($id,stack) == {}} {
set wrapper($id,level1tag) $tagname
uplevel #0 "$wrapper($id,streamstartcmd) [list $varlist]"
}
set wrapper($id,stack) \
[linsert $wrapper($id,stack) 0 \
[list $tagname $varlist {} "" "" ""]]
}
######################################################################
proc wrapper:elementend {id tagname args} {
variable wrapper
if {[lsearch $wrapper(list) $id] == -1} {
return -code error -errorinfo "No such wrapper: \"$id\""
}
set new_el [lindex $wrapper($id,stack) 0]
set tail [lrange $wrapper($id,stack) 1 end]
set len [llength $tail]
if {$len > 1} {
set head [lindex $tail 0]
#set subtail [lrange $tail 1 end]
set els [linsert [lindex $head 2] end $new_el]
set wrapper($id,stack) \
[lreplace $tail 0 0 \
[lreplace $head 2 2 $els]]
} elseif {$len == 1} {
uplevel \#0 $wrapper($id,parsecmd) [list $new_el]
set wrapper($id,stack) $tail
} else { # $len == 0
uplevel \#0 $wrapper($id,streamendcmd)
set wrapper($id,stack) $tail
}
}
######################################################################
proc wrapper:chdata {id chardata} {
variable wrapper
if {[lsearch $wrapper(list) $id] == -1} {
return -code error -errorinfo "No such wrapper: \"$id\""
}
set new_el [lindex $wrapper($id,stack) 0]
#set tail [lrange $wrapper($id,stack) 1 end]
set chdata "[lindex $new_el 3]$chardata"
set new_el [lreplace $new_el 3 3 $chdata]
set els [lindex $new_el 2]
if {$els == {}} {
set new_el [lreplace $new_el 4 4 "[lindex $new_el 4]$chardata"]
} else {
set els [lindex $new_el 2]
set last_el [lindex $els end]
set last_el [lreplace $last_el 5 5 "[lindex $last_el 5]$chardata"]
set els [lreplace $els end end $last_el]
set new_el [lreplace $new_el 2 2 $els]
}
set wrapper($id,stack) [lreplace $wrapper($id,stack) 0 0 $new_el]
}
######################################################################
#
# Called when there's an error with parsing XML.
#
proc wrapper:xmlerror {id args} {
variable wrapper
if {[lsearch $wrapper(list) $id] == -1} {
return -code error -errorinfo "No such wrapper: \"$id\""
}
LOG "XML Parsing Error: $args"
uplevel #0 $wrapper($id,streamendcmd)
}
######################################################################
proc wrapper:xmlcrypt {text} {
return [string map {& & < < > > \" " ' '
\x00 " " \x01 " " \x02 " " \x03 " "
\x04 " " \x05 " " \x06 " " \x07 " "
\x08 " " \x0B " "
\x0C " " \x0E " " \x0F " "
\x10 " " \x11 " " \x12 " " \x13 " "
\x14 " " \x15 " " \x16 " " \x17 " "
\x18 " " \x19 " " \x1A " " \x1B " "
\x1C " " \x1D " " \x1E " " \x1F " "} $text]
}
######################################################################
#
# This procedure converts (and returns) $xmldata to raw-XML
#
proc wrapper:createxml {xmldata {xmlns jabber:client}} {
set retext ""
set tagname [lindex $xmldata 0]
set vars [lindex $xmldata 1]
set subtags [lindex $xmldata 2]
set chdata [lindex $xmldata 3]
append retext "<$tagname"
foreach {attr value} $vars {
if {$attr == "xmlns"} {
if {$value == $xmlns} {
continue
} else {
set xmlns $value
}
}
append retext " $attr='[wrapper:xmlcrypt $value]'"
}
if {$chdata == "" && [llength $subtags] == 0} {
append retext "/>"
return $retext
} else {
append retext ">"
}
append retext [wrapper:xmlcrypt $chdata]
foreach subdata $subtags {
append retext [wrapper:createxml $subdata $xmlns]
}
append retext "</$tagname>"
return $retext
}
######################################################################
#
# This proc creates (and returns) xmldata of tag $tagname,
# with the parameters given.
#
# Parameters:
# -empty 0|1 Is this an empty tag? If $chdata
# and $subtags are empty, then whether
# to make the tag empty or not is decided
# here. (default: 1)
#
# -vars {attr1 value1 attr2 value2 ..} Vars is a list
# consisting of attr/value pairs, as shown.
#
# -chdata $chdata ChData of tag (default: ""), if you use
# this attr multiple times, new chdata will
# be appended to old one.
#
# -subtags $subchilds $subchilds is a list containing xmldatas
# of $tagname's subtags. (default: no sub-tags)
#
proc wrapper:createtag {tagname args} {
set isempty 1
set vars ""
set chdata ""
set subtags ""
foreach {attr val} $args {
switch -- $attr {
-empty {set isempty $val}
-vars {set vars $val}
-chdata {set chdata $chdata$val}
-subtags {set subtags $val}
}
}
set retext [list $tagname $vars $subtags $chdata "" ""]
return $retext
}
######################################################################
#
# This proc returns the value of $attr from varlist
#
proc wrapper:getattr {varlist attrname} {
foreach {attr val} $varlist {
if {$attr == $attrname} {return $val}
}
return ""
}
######################################################################
#
# This proc returns 1, or 0, depending on the attr exists in varlist or not
#
proc wrapper:isattr {varlist attrname} {
foreach {attr val} $varlist {
if {$attr == $attrname} {return 1}
}
return 0
}
######################################################################
#
# This proc splits the xmldata to 5 different variables.
#
proc wrapper:splitxml {xmldata vtag vvars visempty vchdata vchildren} {
set tag [lindex $xmldata 0]
set vars [lindex $xmldata 1]
set children [lindex $xmldata 2]
set chdata [lindex $xmldata 3]
uplevel 1 "set [list $vtag] [list $tag] \n \
set [list $vvars] [list $vars] \n \
set [list $visempty] 0 \n \
set [list $vchdata] [list $chdata] \n \
set [list $vchildren] [list $children]"
}
proc wrapper:get_subchdata {xmldata} {
lindex $xmldata 4
}
proc wrapper:get_fchdata {xmldata} {
lindex $xmldata 5
}
######################################################################
#
# This proc returns stream header
#
proc wrapper:streamheader {to args} {
set to [wrapper:xmlcrypt $to]
set xmlns_stream [wrapper:xmlcrypt "http://etherx.jabber.org/streams"]
set xmlns [wrapper:xmlcrypt "jabber:client"]
set lang ""
set version ""
foreach {opt val} $args {
switch -- $opt {
-xmlns:stream {
set xmlns_stream [wrapper:xmlcrypt $val]
}
-xmlns {
set xmlns [wrapper:xmlcrypt $val]
}
-xml:lang {
set lang " xml:lang='[wrapper:xmlcrypt $val]'"
}
-version {
set version " version='$val'"
}
}
}
return "<stream:stream xmlns:stream='$xmlns_stream'\
xmlns='$xmlns'$lang to='$to'$version>"
}
######################################################################
#
# This proc returns stream trailer
#
proc wrapper:streamtrailer {} {
return "</stream:stream>"
}