simplify testing (Apache license for this stuff).
--- /dev/null
+2006-08-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * sm.tcl: Authentication via DIO to database.
+ * dio/*: Brought in modified DIO from Apache Rivet.
+
+2006-04-16 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * s2c.tcl: Refactored code to use a shared core set for the
+ * s2s.tcl: server-wide configuration data and logging.
+ * core.tcl:
+ * cmdloop.tcl:
+
+2005-01-15 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ijbridge.tcl: Added optional hourly chime code. Removed s2s
+ commented code.
+ * chime.tcl: Fixed the next chime calculation. Had eeevil bug.
+
+2005-01-15 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * chime.tcl: An hourly chime component. Sends a timestamp
+ message to a chatroom on the hour. Uses JCP.
+ * cmdloop.tcl: Utility library which permits a tclsh app to be
+ controlled via stdin or a socket.
+
+2004-12-09 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ijbridge.tcl: Various fixes to create a working jabber component
+ * ijbridge.conf: that bridges a MUC with an IRC channel.
+ * wrapper.tcl: Removed a debugging line.
+
+2004-12-08 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * jcp.tcl: NEW FILE: Jabber Component Protocol
+ * ijbridge.tcl: Now uses JCP instead of S2S
+ * wrapper.tcl: David Graveraux's modified tDOM using wrapper.
+
+2004-11-30 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ijbridge.conf.sample: NEW sample config file for ijbridge.
+ * ijbridge.tcl: Various nick presence cleanups.
+
+2004-11-28 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * pkgIndex.tcl: Added package index.
+ * ijbridge.tcl: Added reading commands from stdin under
+ unix. Under windows you can just run it in tkcon.
+
+2004-11-28 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ijbridge.tcl: Bridge script now links IRC and S2S successfully.
+
+2004-11-25 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * licence.terms: Added Tcl license document.
+ * ijbridge.tcl: Started playing with ijbridge to work the kinks
+ out of the s2s api.
+
+2004-11-25 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * TAG: ====== tagged xmppd-1-0-0 =====
+
+ * test-s2s.tcl: Test application code.
+ * s2s.tcl: Working version. This correctly validates and xmits and
+ recieves. Added a handler option that is called for all Jabber
+ stanzas. Moved application code into separate file so s2s can be a
+ package. Fixed recovery after a channel goes down.
+
+2004-11-24 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * s2s.tcl: Finally persuaded both sides to validate. Jabberd is
+ now prepared to talk to us (at least when _we_ initiate the
+ connection).
+
+2004-11-24 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * s2s.tcl: Redesigned to separate channels and sessions living on
+ top of channels. This permits multiple routes over a single socket
+ (which jabberd2 is doing). Close.
+
+2004-11-20 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * s2s.tcl: Still in progress. This version nicely keeps each
+ stream (in/out) separated but manages to use the same callbacks
+ quite simple. We are successully dealing with the outbound
+ connections (jabberd2 is happy) but we are not managing to handle
+ the inbound ones properly. This is because both all.tclers.tk and
+ tach.tclers.tk are coming in on the same channel. So we have to be
+ able to hook up multiple sessions per channel.
+
+2004-11-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * s2s.tcl: Still not complete. Reconfigured big time.
+
+2004-11-18 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * s2s.tcl: NEW file: Jabber server to server daemon.
--- /dev/null
+# cmdloop.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# $Id: cmdloop.tcl,v 1.2 2006/04/16 20:16:36 pat Exp $
+
+namespace eval ::cmdloop {
+ variable hosts_allow
+ if {![info exists hosts_allow]} {
+ set hosts_allow {127.0.0.1 ::1 82.33.96.128}
+ }
+
+ variable welcome
+ if {![info exists welcome]} {
+ set welcome "Hello %client %port"
+ }
+
+ variable cmds_deny
+ if {![info exists cmds_deny]} {
+ set cmds_deny {exit denied}
+ }
+}
+
+# cmdloop::Read --
+#
+# Reads commands from stdin and evaluates them. This permits
+# us to issue commands to the server while it is still
+# running. Suitable commands are ijbridge::presence and
+# ijbridge::say or ijbridge::xmit.
+#
+proc ::cmdloop::Read {chan ochan state} {
+ variable cmds_deny
+ upvar #0 $state input
+ if {![info exists input]} {set input {}}
+ if {[eof $chan]} {
+ puts $ochan "!! EOF $chan"
+ }
+ if {[gets $chan line] != -1} {
+ append input $line
+ if {[string length $input] > 0 && [info complete $input]} {
+ set cmd [lindex $input 0]
+ if {[lsearch -exact $cmds_deny $cmd] != -1} {
+ set res "$cmd command disabled"
+ } elseif {$cmd eq "puts" && [string match "sock*" $chan] \
+ && [llength $input] == 2} {
+ set res [lindex $input 1]
+ } else {
+ set code [catch {uplevel \#0 $input} res]
+ }
+ unset input
+ puts $ochan $res
+ }
+ }
+}
+
+# cmdloop::Accept --
+#
+# Setup the client channel for reading commands as we do
+# for stdin. Useful with tkcon's socket connection feature.
+#
+proc ::cmdloop::Accept {chan client port} {
+ # we could validate the client here.
+ if {[lsearch $::cmdloop::hosts_allow $client] == -1} {
+ puts $chan "Access denied"
+ close $chan
+ return
+ }
+ fconfigure $chan -blocking 0 -buffering line
+ puts $chan [welcome $client $port]
+ fileevent $chan readable \
+ [list ::cmdloop::Read $chan $chan ::cmdloop::state_$chan]
+}
+
+proc ::cmdloop::welcome {{client {}} {port {}}} {
+ variable welcome
+ return [string map [list %client $client %port $port] $welcome]
+}
+
+proc ::cmdloop::cmdloop {} {
+ variable welcome
+ puts [welcome]
+ puts -nonewline "> "
+ fconfigure stdin -blocking 0 -buffering line
+ fileevent stdin readable \
+ [list ::cmdloop::Read stdin stdout ::cmdloop::state_stdin]
+}
+
+proc ::cmdloop::listen {{myaddr 0.0.0.0} {port 5441}} {
+ variable Socket
+ if {$port ne {}} {
+ set Socket [socket -server ::cmdloop::Accept -myaddr $myaddr $port]
+ }
+}
+
+proc ::cmdloop::stop {} {
+ variable Socket
+ if {[info exists Socket]} {
+ catch {close $Socket}
+ }
+}
+
+# Local variables:
+# mode: tcl
+# End:
--- /dev/null
+# core.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# XMPP core utilities.
+#
+# RFC 3920 [http://www.ietf.org/rfc/rfc3920.txt]
+# RFC 3921 [http://www.ietf.org/rfc/rfc3921.txt]
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require xmppd::wrapper
+package require logger;# tcllib
+
+namespace eval ::xmppd {
+
+ variable version 0.1.0
+ variable rcsid {$Id: core.tcl,v 1.4 2006/04/17 09:41:51 pat Exp $}
+
+ namespace export configure cget xmlns jid Pop
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ domain {}
+ certfile {}
+ keyfile {}
+ modules {}
+ features {}
+ endpoints {}
+ loglevel warn
+ logfile {}
+ }
+ }
+
+ variable xmlns
+ if {![info exists xmlns]} {
+ array set xmlns {
+ client jabber:client
+ server jabber:server
+ dialback jabber:server:dialback
+ stream http://etherx.jabber.org/streams
+ streams urn:ietf:params:xml:ns:xmpp-streams
+ sasl urn:ietf:params:xml:ns:xmpp-sasl
+ tls urn:ietf:params:xml:ns:xmpp-tls
+ bind urn:ietf:params:xml:ns:xmpp-bind
+ stanzas urn:ietf:params:xml:ns:xmpp-stanzas
+ session urn:ietf:params:xml:ns:xmpp-session
+ xml http://www.w3.org/XML/1998/namespace
+ }
+ }
+
+}
+
+# -------------------------------------------------------------------------
+
+proc ::xmppd::xmlns {name} {
+ variable xmlns
+ return $xmlns($name)
+}
+
+proc ::xmppd::jid {part jid} {
+ set r {}
+ if {[regexp {^(?:([^@]*)@)?([^/]+)(?:/(.+))?} $jid \
+ -> node domain resource]} {
+ switch -exact -- $part {
+ node { set r $node }
+ domain { set r $domain }
+ resource { set r $resource }
+ !resource { set r ${node}@${domain} }
+ jid { set r $jid }
+ default {
+ return -code error "invalid part \"$part\":\
+ must be one of node, domain, resource or jid."
+ }
+ }
+ }
+ return $r
+}
+
+proc ::xmppd::cget {option} {
+ return [configure $option]
+}
+
+proc ::xmppd::configure {args} {
+ variable options
+ if {[llength $args] < 1} {
+ set r {}
+ foreach opt [lsort [array names options]] {
+ lappend r -$opt $options($opt)
+ }
+ foreach module $options(modules) {
+ set r [concat $r [${module}::_configure]]
+ }
+ return $r
+ }
+
+ set cget [expr {[llength $args] == 1 ? 1 : 0}]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -domain {
+ if {$cget} {
+ return $options(domain)
+ } else {
+ set options(domain) [Pop args 1]
+ }
+ }
+ -loglevel {
+ if {$cget} {
+ return $options(loglevel)
+ } else {
+ variable log
+ set options(loglevel) [Pop args 1]
+ if {![info exists log]} {
+ LogInit xmppd $options(loglevel)
+ } else {
+ ${log}::setlevel $options(loglevel)
+ }
+ }
+ }
+ -logfile {
+ if {$cget} {
+ return $options(logfile)
+ } else {
+ set options(logfile) [Pop args 1]
+ LogSetFile $options(logfile)
+ }
+ }
+ -certfile {
+ if {$cget} {
+ return $options(certfile)
+ } else {
+ set options(certfile) [Pop args 1]
+ }
+ }
+ -keyfile {
+ if {$cget} {
+ return $options(keyfile)
+ } else {
+ set options(keyfile) [Pop args 1]
+ }
+ }
+ -features {
+ if {$cget} { return $options(features) }
+ }
+ -modules {
+ if {$cget} { return $options(modules) }
+ }
+ -- { Pop args ; break }
+ default {
+ if {$cget} {
+ foreach module $options(modules) {
+ if {![catch {${module}::_configure $option} r]} {
+ return $r
+ }
+ }
+ return -code error "bad option \"$option\""
+ } else {
+ set value [Pop args 1]
+ set r 1
+ foreach module $options(modules) {
+ set r [catch {${module}::_configure $option $value} res]
+ if {! $r} { break }
+ }
+ if {$r} {
+ return -code error "bad option \"$option\""
+ }
+ }
+ }
+ }
+ Pop args
+ }
+ return
+}
+
+proc ::xmppd::register {type args} {
+ variable options
+ switch -exact -- $type {
+ module {
+ foreach module $args {
+ if {[lsearch -exact $options(modules) $module] == -1} {
+ lappend options(modules) $module
+ }
+ }
+ }
+
+ feature {
+ foreach {name uri} $args {
+ if {[string length $name] < 1} { return -code error "must provide a name" }
+ if {[string length $uri] < 1} {return -code error "must provide a value" }
+ array set f $options(features)
+ set f($name) $uri
+ set options(features) [array get f]
+ }
+ }
+
+ default {
+ return -code error "invalid type \"$type\": must be one of\
+ module or feature"
+ }
+ }
+}
+
+proc ::xmppd::route {from to xml} {
+ set domain [jid domain $to]
+ if {$domain eq [cget -domain]} {
+ xmppd::s2c::route $from $to $xml
+ } else {
+ xmppd::s2s::route -from $from -to $to $xml
+ }
+}
+
+# -------------------------------------------------------------------------
+# Logging functions
+
+proc ::xmppd::LogInit {service level} {
+ variable log
+ set log [logger::init $service]
+ ${log}::setlevel $level
+ proc ${log}::stdoutcmd {level text} {
+ variable service
+ variable logfile
+ set ts [clock format [clock seconds] -format {%H:%M:%S}]
+ if {[::info exists logfile] && $logfile ne ""} {
+ puts $logfile "\[$ts\] $level $text"
+ }
+ puts stderr $text
+ }
+}
+
+proc ::xmppd::LogSetFile {filename} {
+ variable log
+ if {[string length $filename] > 0} {
+ set code {
+ variable logfile
+ if {[::info exists logfile]} { ::catch {::close $logfile} }
+ set logfile [::open %FILE a+]
+ fconfigure $logfile -buffering line
+ puts $logfile [clock format [clock seconds] \
+ -format "---- %Y%m%dT%H:%M:%S [string repeat - 49]"]
+ }
+ namespace eval $log [string map [list %FILE $filename] $code]
+ }
+}
+
+proc ::xmppd::Log {component level msg} {
+ variable log
+ ${log}::${level} "$component: $msg"
+}
+
+# -------------------------------------------------------------------------
+# utility stuff
+
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::xmppd::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+
+# -------------------------------------------------------------------------
+
+namespace eval ::xmppd {
+ if {![info exists log]} {
+ LogInit xmppd $options(loglevel)
+ }
+}
+
+package provide xmppd::core $::xmppd::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
--- /dev/null
+# Jabber chime component configuration file
+#
+# You MUST modify this to suit your environment.
+
+# Local server name
+#
+JID chime.DOMAIN.NAME
+Resource chime
+
+JabberServer localhost
+JabberPort 5347
+Secret JCPPASSWORD
+
+# Details for the Jabber conference room to join to.
+#
+Conference MUC@CONFERENCE.DOMAIN.NAME
+
+# How noisy?
+# debug info notice warn error critical
+LogLevel notice
--- /dev/null
+#!/usr/bin/env tclsh
+# chime.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# A demo Jabber component.
+#
+# This component connects to a multi-user chat and issues a time message on
+# the hour each hour. It serves to illustrate how to create a component
+# using the tclxmppd jcp package.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+set auto_path [linsert $auto_path 0 \
+ [file join [file dirname [file dirname [info script]]]]]
+package require xmppd::jcp; # tclxmppd
+package require xmppd::wrapper; # jabberlib
+
+namespace eval ::chime {
+ variable version 1.0.0
+ variable rcsid {$Id: chime.tcl,v 1.3 2006/04/13 11:50:31 pat Exp $}
+
+ variable Options
+ if {![info exists Options]} {
+ array set Options {
+ JID {}
+ Name Chime
+ Resource chime
+ Conference {}
+
+ JabberServer {}
+ JabberPort 5347
+ Secret {}
+
+ LogLevel notice
+ LogFile {}
+ }
+ }
+
+ variable Component
+}
+
+# chime::start --
+#
+# Start the chime component. This uses the jabber component protocol
+# to connect to the server and schedules the chimes.
+# We join the chat by sending an appropriate presence message once
+# we are fully connected.
+#
+proc ::chime::start {} {
+ variable Options
+ variable Component
+ xmppd::jcp::configure \
+ -component $Options(JID) \
+ -secret $Options(Secret) \
+ -loglevel $Options(LogLevel) \
+ -handler [namespace current]::Handler
+ set Component [xmppd::jcp::create \
+ $Options(JabberServer) $Options(JabberPort)]
+
+ set jid "$Options(Name)@$Options(JID)/$Options(Resource)"
+ set nick "$Options(Conference)/$Options(Name)"
+ after 200 [list [namespace origin presence] $jid $nick \
+ available online {Hourly chime}]
+
+ chimes start
+ return
+}
+
+# chime::stop --
+#
+# Halt the chime component. We disconnect from the configures chat
+# by sending a presence unavailable and then destroy the component.
+#
+proc ::chime::stop {} {
+ variable Options
+ variable Component
+ chimes stop
+ set jid "$Options(Name)@$Options(JID)/$Options(Resource)"
+ set nick "$Options(Conference)/$Options(Name)"
+ presence $jid $nick unavailable
+ xmppd::jcp::destroy $Component
+}
+
+# chime::Handler --
+#
+# Jabber message routing. For this component, we don't need to
+# do anything as all we do is issue a time message on the hour.
+#
+proc ::chime::Handler {type attributes close value children} {
+ array set a {from {} to {} type {}}
+ array set a $attributes
+
+ switch -exact -- $type {
+ message {}
+ presence {}
+ iq {
+ switch -exact -- $a(type) {
+ get {
+ foreach child $children {
+ if {[wrapper::gettag $child] eq "query"} {
+ HandleIQ $child $a(id) $a(to) $a(from)
+ }
+ }
+ }
+ }
+ }
+ default {}
+ }
+ return
+}
+
+# chime::HandleIQ --
+#
+# I am sure some of this could be factored into the component package.
+# Basically all components should register for some minimal IQ handling
+# just to provide their name and version if nothing else.
+#
+proc ::chime::HandleIQ {child id self requester} {
+ variable Options
+ variable Component
+ variable version
+
+ set query [wrapper::getattribute $child xmlns]
+ set rsp {}
+ set parts {}
+ switch -exact -- $query {
+ jabber:iq:version {
+ lappend parts [list name {} 0 $Options(Name) {}]
+ lappend parts [list version {} 0 $version {}]
+ lappend parts [list os {} 0 "Tcl/[info patchlevel]" {}]
+ lappend qr [list query [list xmlns $query] 0 {} $parts]
+ set ra [list xmlns jabber:client type result id $id \
+ to $requester from $self]
+ set rsp [list iq $ra 0 {} $qr]
+ }
+ "http://jabber.org/protocol/disco#info" {
+ set node [wrapper::getattribute $child node]
+ if {[string length $node] == 0} {
+ lappend parts [list identity \
+ [list name $Options(Name) \
+ type text category gateway] 1 {} {}]
+ lappend parts [list feature {var jabber:iq:version} 1 {} {}]
+ lappend parts [list feature {var iq} 1 {} {}]
+ lappend parts [list feature {var message} 1 {} {}]
+ lappend parts [list feature {var "http://jabber.org/protocol/disco#info"} 1 {} {}]
+ lappend parts [list feature {var "http://jabber.org/protocol/disco#items"} 1 {} {}]
+
+ lappend qr [list query [list xmlns $query] 0 {} $parts]
+ set rsp [list iq [list xmlns jabber:client type result id $id \
+ to $requester from $self] 0 {} $qr]
+ }
+ }
+ default {
+ set rsp [RaiseIQ $query feature-not-implemented $id $self $requester]
+ }
+ }
+ if {$rsp ne {}} {
+ xmppd::jcp::route $Component [wrapper::createxml $rsp]
+ }
+ return
+}
+
+# chime::RaiseIQ --
+#
+# Raise an error response for invalid queries or for queries we do not intend
+# to handle.
+#
+proc ::chime::RaiseIQ {query type id self requester} {
+ lappend p [list $type {xmlns urn:ietf:params:xml:ns:xmpp-stanzas} 1 {} {}]
+ lappend qr [list query [list xmlns $query] 1 {} {}]
+ lappend qr [list error {type cancel code 501} 0 {} $p]
+ set ra [list xmlns jabber:client type error id $id \
+ to $requester from $self]
+ set rsp [list iq $ra 0 {} $qr]
+}
+
+# chime::presence --
+#
+# Send a jabber presence message
+#
+proc ::chime::presence {from to type {show {online}} {status {}} {user {}}} {
+ variable Component
+
+ set kids {} ; set hist {}
+ set ts [clock format [clock seconds] -format %Y%m%dT%H:%M:%S -gmt 1]
+ lappend hist [list history [list maxchars 0 maxstanzas 0] 1 "" {}]
+ lappend kids [list x {xmlns http://jabber.org/protocols/muc} 0 "" $hist]
+ if {$show ne {}} {
+ lappend kids [list show {} 0 $show {}]
+ }
+ if {$status ne {}} {
+ lappend kids [list status {
+ xmlns:xml http://www.w3.org/XML/1998/namespace
+ xml:lang en-GB
+ } 0 $status {}]
+ }
+ set attr [list from $from to $to xmlns jabber:client]
+ if {$type ne {}} {lappend attr type $type}
+
+ xmppd::jcp::route $Component \
+ [wrapper::createxml [list presence $attr 0 "" $kids]]
+ return
+}
+
+# chime::LoadConfig --
+#
+# This procedure reads a text file and updates the Options array
+# from the contents. Comments and blank lines are ignored. All
+# other lines must be a list of two elements, the first element
+# must be an item in the Options array.
+#
+proc ::chime::LoadConfig {{conf {}}} {
+ variable Options
+ if {$conf eq {}} {
+ set conf [file normalize [info script]]
+ set base [file rootname [file tail $conf]].conf
+ set conf [file join [file dirname $conf] $base]
+ }
+ if {[file exists $conf]} {
+ set f [open $conf r]
+ set n 0
+ while {![eof $f]} {
+ gets $f line
+ string trim $line
+ if {[string match "#*" $line]} continue
+ if {[string length $line] < 1} continue
+ if {[llength $line] != 2} {
+ return -code error "invalid config line $n: \"$line\""
+ }
+ if {![info exists Options([lindex $line 0])]} {
+ return -code error "invalid config option\
+ \"[lindex $line 0]\" at line $n"
+ }
+ set Options([lindex $line 0]) [lindex $line 1]
+ incr n
+ }
+ close $f
+ } else {
+ log warn "configuration file \"$conf\" could not be opened"
+ }
+ return
+}
+
+# chime::chimes --
+#
+# Manage the scheduling of chimes on the hour.
+#
+proc ::chime::chimes {cmd} {
+ variable ChimeId
+ switch -exact -- $cmd {
+ start {
+ set ChimeId [after [nextchime] [namespace origin bong]]
+ }
+ stop {
+ after cancel $ChimeId
+ }
+ default {
+ return -code error "invalid option \"$cmd\": rtfm"
+ }
+ }
+}
+
+# chime::nextchime --
+#
+# Calculate the number of milliseconds until the next hour.
+#
+proc ::chime::nextchime {} {
+ set t [clock format [clock scan "+1 hour"] -format "%Y%m%d %H:00:00"]
+ set delta [expr {([clock scan $t] - [clock seconds]) * 1000}]
+ if {$delta < 60000} {
+ puts stderr "error: chiming too fast"
+ set delta 60000
+ }
+ puts "Schedule chime in $delta milliseconds"
+ return $delta
+}
+
+# chime::bong --
+#
+# Issue a timestamp message to the connected chatroom.
+#
+proc ::chime::bong {} {
+ variable ChimeId
+ variable Options
+ variable Component
+
+ after cancel $ChimeId
+ set kids {}
+ set ts [clock format [clock seconds] -format %Y%m%dT%H:%M:%S -gmt 1]
+ puts "BONG at $ts"
+ lappend kids [list body {} 0 \
+ [clock format [clock seconds] -gmt 1] {}]
+ set from "$Options(Name)@$Options(JID)/$Options(Resource)"
+ set attr [list from $from to $Options(Conference) \
+ type groupchat xmlns "jabber:client"]
+ set xml [wrapper::createxml [list message $attr 0 "" $kids]]
+
+ xmppd::jcp::route $Component $xml
+ set ChimeId [after [nextchime] [namespace origin bong]]
+}
+
+proc ::chime::Main {} {
+ global tcl_platform tcl_interactive tcl_service tk_version
+ variable Options
+ LoadConfig
+
+ # Setup control stream.
+ if {$tcl_platform(platform) eq "unix"} {
+ set cmdloop [file join [file dirname [info script]] cmdloop.tcl]
+ if {[file exists $cmdloop]} {
+ puts "Loading $cmdloop"
+ source $cmdloop
+ set cmdloop::welcome "$Options(Name) v[set [namespace current]::version]"
+ append cmdloop::welcome "\nReady for input from %client %port"
+ cmdloop::cmdloop
+ #set cmdloop::hosts_allow {127.0.0.1 ::1}
+ #cmdloop::listen 127.0.0.1 5442;# could do 0.0.0.0 5441
+ } else {
+ puts "Command loop not available."
+ }
+ set tcl_interactive 1; # fake it so we can re-source this file
+ }
+
+ # Begin the component
+ start
+
+ # Loop forever, dealing with Wish or Tclsh
+ if {[info exists tk_version]} {
+ if {[tk windowingsystem] eq "win32"} { console show }
+ wm withdraw .
+ tkwait variable ::forever
+ stop
+ } else {
+ # Permit running as a Windows service.
+ if {![info exists tcl_service]} {
+ vwait ::forever
+ stop
+ }
+ }
+}
+
+if {!$tcl_interactive} {
+ set r [catch [linsert $argv 0 ::chime::Main] err]
+ if {$r} {puts $errorInfo}
+ exit $r
+}
--- /dev/null
+# dio.tcl -- implements a database abstraction layer.
+
+# Copyright 2002-2004 The Apache Software Foundation
+
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+
+# http://www.apache.org/licenses/LICENSE-2.0
+
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# $Id: dio.tcl 406282 2006-05-14 08:46:50Z davidw $
+
+package require Itcl
+
+if {[catch {package require Tclx}]} {
+ proc ::lempty lst {expr {[llength $lst] == 0}}
+}
+
+set auto_path [linsert $auto_path 0 [file dirname [info script]]]
+
+namespace eval ::DIO {
+
+proc handle {interface args} {
+ set obj \#auto
+ set first [lindex $args 0]
+ if {![lempty $first] && [string index $first 0] != "-"} {
+ set obj [lindex $args 0]
+ set args [lreplace $args 0 0]
+ }
+ uplevel \#0 package require dio_$interface
+ return [uplevel \#0 ::DIO::$interface $obj $args]
+}
+
+##
+# DATABASE CLASS
+##
+::itcl::class Database {
+ constructor {args} {
+ eval configure $args
+ }
+
+ destructor {
+ close
+ }
+
+ #
+ # result - generate a new DIO result object for the specified database
+ # interface, with key-value pairs that get configured into the new
+ # result object.
+ #
+ protected method result {interface args} {
+ return [eval uplevel \#0 ::DIO::${interface}Result \#auto $args]
+ }
+
+ #
+ # quote - given a string, return the same string with any single
+ # quote characters preceded by a backslash
+ #
+ method quote {string} {
+ regsub -all {'} $string {\'} string
+ return $string
+ }
+
+ #
+ # build_select_query - build a select query based on given arguments,
+ # which can include a table name, a select statement, switches to
+ # turn on boolean AND or OR processing, and possibly
+ # some key-value pairs that cause the where clause to be
+ # generated accordingly
+ #
+ protected method build_select_query {args} {
+
+ set bool AND
+ set first 1
+ set req ""
+ set myTable $table
+ set what "*"
+
+ # for each argument passed us...
+ # (we go by integers because we mess with the index based on
+ # what we find)
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ # fetch the argument we're currently processing
+ set elem [lindex $args $i]
+
+ switch -- [::string tolower $elem] {
+ "-and" {
+ # -and -- switch to AND-style processing
+ set bool AND
+ }
+
+ "-or" {
+ # -or -- switch to OR-style processing
+ set bool OR
+ }
+
+ "-table" {
+ # -table -- identify which table the query is about
+ set myTable [lindex $args [incr i]]
+ }
+
+ "-select" {
+ # -select -
+ set what [lindex $args [incr i]]
+ }
+
+ default {
+ # it wasn't -and, -or, -table, or -select...
+
+ # if the first character of the element is a dash,
+ # it's a field name and a value
+
+ if {[::string index $elem 0] == "-"} {
+ set field [::string range $elem 1 end]
+ set elem [lindex $args [incr i]]
+
+ # if it's the first field being processed, append
+ # WHERE to the SQL request we're generating
+ if {$first} {
+ append req " WHERE"
+ set first 0
+ } else {
+ # it's not the first variable in the comparison
+ # expression, so append the boolean state, either
+ # AND or OR
+ append req " $bool"
+ }
+
+ # convert any asterisks to percent signs in the
+ # value field
+ regsub -all {\*} $elem {%} elem
+
+ # if there is a percent sign in the value
+ # field now (having been there originally or
+ # mapped in there a moment ago), the SQL aspect
+ # is appended with a "field LIKE value"
+
+ if {[::string first {%} $elem] != -1} {
+ append req " $field LIKE [makeDBFieldValue $myTable $field $elem]"
+ } elseif {[regexp {^([<>]) *([0-9.]*)$} $elem _ fn val]} {
+ # value starts with <, or >, then space,
+ # and a something
+ append req " $field$fn$val"
+ } elseif {[regexp {^([<>]=) *([0-9.]*)$} $elem _ fn val]} {
+ # value starts with <= or >=, space, and something.
+ append req " $field$fn$val"
+ } else {
+ # otherwise it's a straight key=value comparison
+ append req " $field=[makeDBFieldValue $myTable $field $elem]"
+ }
+
+ continue
+ }
+ append req " $elem"
+ }
+ }
+ }
+ return "select $what from $myTable $req"
+ }
+
+ #
+ # build_insert_query -- given an array name, a list of fields, and
+ # possibly a table name, return a SQL insert statement inserting
+ # into the named table (or the object's table variable, if none
+ # is specified) for all of the fields specified, with their values
+ # coming from the array
+ #
+ protected method build_insert_query {arrayName fields {myTable ""}} {
+ upvar 1 $arrayName array
+
+ if {[lempty $myTable]} { set myTable $table }
+ set vals [::list]
+ set vars [::list]
+ foreach field $fields {
+ if {![info exists array($field)]} { continue }
+ lappend vars "$field"
+ lappend vals "[makeDBFieldValue $myTable $field $array($field)]"
+ }
+ return "insert into $myTable ([join $vars {,}]) VALUES ([join $vals {,}])"
+ }
+
+ #
+ # build_update_query -- given an array name, a list of fields, and
+ # possibly a table name, return a SQL update statement updating
+ # the named table (or using object's table variable, if none
+ # is named) for all of the fields specified, with their values
+ # coming from the array
+ #
+ # note that after use a where clause still neds to be added or
+ # you might update a lot more than you bargained for
+ #
+ protected method build_update_query {arrayName fields {myTable ""}} {
+ upvar 1 $arrayName array
+ if {[lempty $myTable]} { set myTable $table }
+ set string [::list]
+ foreach field $fields {
+ if {![info exists array($field)]} { continue }
+ lappend string "$field=[makeDBFieldValue $myTable $field $array($field)]"
+ }
+ return "update $myTable SET [join $string {,}]"
+ }
+
+ #
+ # lassign_array - given a list, an array name, and a variable number
+ # of arguments consisting of variable names, assign each element in
+ # the list, in turn, to elements corresponding to the variable
+ # arguments, into the named array. From TclX.
+ #
+ protected method lassign_array {list arrayName args} {
+ upvar 1 $arrayName array
+ foreach elem $list field $args {
+ set array($field) $elem
+ }
+ }
+
+ #
+ # configure_variable - given a variable name and a string, if the
+ # string is empty return the variable name, otherwise set the
+ # variable to the string.
+ #
+ protected method configure_variable {varName string} {
+ if {[lempty $string]} { return [cget -$varName] }
+ configure -$varName $string
+ }
+
+ #
+ # build_where_key_clause - given a list of one or more key fields and
+ # a corresponding list of one or more key values, construct a
+ # SQL where clause that boolean ANDs all of the key-value pairs
+ # together.
+ #
+ protected method build_key_where_clause {myKeyfield myKey} {
+ ## If we're not using multiple keyfields, just return a simple
+ ## where clause.
+ if {[llength $myKeyfield] < 2} {
+ return " WHERE $myKeyfield = [makeDBFieldValue $table $myKeyfield $myKey]"
+ }
+
+ # multiple fields, construct it as a where-and
+ set req " WHERE 1 = 1"
+ foreach field $myKeyfield key $myKey {
+ append req " AND $field=[makeDBFieldValue $table $field $key]"
+ }
+ return $req
+ }
+
+ ##
+ ## makekey -- Given an array containing a key-value pairs and
+ # an optional list of key fields (we use the object's keyfield
+ # if none is specified)...
+ #
+ # if we're doing auto keys, create and return a new key,
+ # otherwise if it's a single key, just return its value
+ # from the array, else if it's multiple keys, return all their
+ # values as a list
+ ##
+ method makekey {arrayName {myKeyfield ""}} {
+ if {[lempty $myKeyfield]} { set myKeyfield $keyfield }
+ if {[lempty $myKeyfield]} {
+ return -code error "No -keyfield specified in object"
+ }
+ upvar 1 $arrayName array
+
+ ## If we're not using multiple keyfields, we want to check and see
+ ## if we're using auto keys. If we are, create a new key and
+ ## return it. If not, just return the value of the single keyfield
+ ## in the array.
+ if {[llength $myKeyfield] < 2} {
+ if {$autokey} {
+ set array($myKeyfield) [$this nextkey]
+ } else {
+ if {![info exists array($myKeyfield)]} {
+ return -code error \
+ "${arrayName}($myKeyfield) does not exist"
+ }
+ }
+ return $array($myKeyfield)
+ }
+
+ ## We're using multiple keys. Return a list of all the keyfield
+ ## values.
+ foreach field $myKeyfield {
+ if {![info exists array($field)]} {
+ return -code error "$field does not exist in $arrayName"
+ }
+ lappend key $array($field)
+ }
+ return $key
+ }
+
+ method destroy {} {
+ ::itcl::delete object $this
+ }
+
+ #
+ # string - execute a SQL request and only return a string of one row.
+ #
+ method string {req} {
+ set res [exec $req]
+ set val [$res next -list]
+ $res destroy
+ return $val
+ }
+
+ #
+ # list - execute a request and return a list of the first element of each
+ # row returned.
+ #
+ method list {req} {
+ set res [exec $req]
+ set list ""
+ $res forall -list line {
+ lappend list [lindex $line 0]
+ }
+ $res destroy
+ return $list
+ }
+
+ #
+ # array - execute a request and setup an array containing elements
+ # with the field names as the keys and the first row results as
+ # the values
+ #
+ method array {req arrayName} {
+ upvar 1 $arrayName $arrayName
+ set res [exec $req]
+ set ret [$res next -array $arrayName]
+ $res destroy
+ return $ret
+ }
+
+ #
+ # forall - execute a SQL select and iteratively fill the named array
+ # with elements named with the matching field names, containing the
+ # matching values, executing the specified code body for each, in turn.
+ #
+ method forall {req arrayName body} {
+ upvar 1 $arrayName $arrayName
+
+ set res [exec $req]
+
+ $res forall -array $arrayName {
+ uplevel 1 $body
+ }
+
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+
+ set ret [$res numrows]
+ $res destroy
+ return $ret
+ }
+
+ #
+ # table_check - internal method to populate the data array with
+ # a -table element containing the table name, a -keyfield element
+ # containing the key field or list of key fields, and a list of
+ # key-value pairs to get set into the data table.
+ #
+ # afterwards, it's an error if -table or -keyfield hasn't somehow been
+ # determined.
+ #
+ protected method table_check {list {tableVar myTable} {keyVar myKeyfield}} {
+ upvar 1 $tableVar $tableVar $keyVar $keyVar
+ set data(-table) $table
+ set data(-keyfield) $keyfield
+ ::array set data $list
+
+ if {[lempty $data(-table)]} {
+ return -code error "-table not specified in DIO object"
+ }
+ if {[lempty $data(-keyfield)]} {
+ return -code error "-keyfield not specified in DIO object"
+ }
+
+ set $tableVar $data(-table)
+ set $keyVar $data(-keyfield)
+ }
+
+ #
+ # key_check - given a list of key fields and a list of keys, it's
+ # an error if there aren't the same number of each, and if it's
+ # autokey, there can't be more than one key.
+ #
+ protected method key_check {myKeyfield myKey} {
+ if {[llength $myKeyfield] < 2} { return }
+ if {$autokey} {
+ return -code error "Cannot have autokey and multiple keyfields"
+ }
+ if {[llength $myKeyfield] != [llength $myKey]} {
+ return -code error "Bad key length."
+ }
+ }
+
+ #
+ # fetch - given a key (or list of keys) an array name, and some
+ # extra key-value arguments like -table and -keyfield, fetch
+ # the key into the array
+ #
+ method fetch {key arrayName args} {
+ table_check $args
+ key_check $myKeyfield $key
+ upvar 1 $arrayName $arrayName
+ set req "select * from $myTable"
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [$this exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+ set return [expr [$res numrows] > 0]
+ $res next -array $arrayName
+ $res destroy
+ return $return
+ }
+
+ #
+ # store - given an array containing key-value pairs and optional
+ # arguments like -table and -keyfield, insert or update the
+ # corresponding table entry.
+ #
+ method store {arrayName args} {
+ table_check $args
+ upvar 1 $arrayName $arrayName $arrayName array
+ if {[llength $myKeyfield] > 1 && $autokey} {
+ return -code error "Cannot have autokey and multiple keyfields"
+ }
+
+ set key [makekey $arrayName $myKeyfield]
+ set req "select * from $myTable"
+ append req [build_key_where_clause $myKeyfield $key]
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+ set numrows [$res numrows]
+ set fields [$res fields]
+ $res destroy
+
+ if {$numrows} {
+ set req [build_update_query array $fields $myTable]
+ append req [build_key_where_clause $myKeyfield $key]
+ } else {
+ set req [build_insert_query array $fields $myTable]
+ }
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+ $res destroy
+ return 1
+ }
+
+ #
+ # update - a pure update, without store's somewhat clumsy
+ # efforts to see if it needs to be an update rather than
+ # an insert
+ #
+ method update {arrayName args} {
+ table_check $args
+ upvar 1 $arrayName $arrayName $arrayName array
+
+ set key [makekey $arrayName $myKeyfield]
+
+ set fields [::array names array]
+ set req [build_update_query array $fields $myTable]
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+
+ # this doesn't work on postgres, you've got to use cmdRows,
+ # we need to figure out what to do with this
+ set numrows [$res numrows]
+ $res destroy
+ return $numrows
+ }
+
+ #
+ # update_with_explicit_key - an update where the key is specified
+ # as an argument to the proc rather than being dug out of the array
+ #
+ # this is a kludge until we come up with a better way to
+ # solve the problem of updating a row where we actually
+ # want to change the value of a key field
+ #
+ method update_with_explicit_key {key arrayName args} {
+ table_check $args
+ key_check $myKeyfield $key
+ upvar 1 $arrayName $arrayName $arrayName array
+
+ set fields [::array names array]
+ set req [build_update_query array $fields $myTable]
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+
+ # this doesn't work on postgres, you've got to use cmdRows,
+ # we need to figure out what to do with this
+ set numrows [$res numrows]
+ $res destroy
+ return $numrows
+ }
+
+ #
+ # insert - a pure insert, without store's somewhat clumsy
+ # efforts to see if it needs to be an update rather than
+ # an insert -- this shouldn't require fields, it's broken
+ #
+ method insert {table arrayName} {
+ upvar 1 $arrayName $arrayName $arrayName array
+ set req [build_insert_query array [::array names array] $table]
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+ $res destroy
+ return 1
+ }
+
+ #
+ # delete - delete matching record from the specified table
+ #
+ method delete {key args} {
+ table_check $args
+ set req "delete from $myTable"
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+
+ set return [$res numrows]
+ $res destroy
+ return $return
+ }
+
+ #
+ # keys - return all keys in a tbale
+ #
+ method keys {args} {
+ table_check $args
+ set req "select * from $myTable"
+ set obj [$this exec $req]
+
+ set keys ""
+ $obj forall -array a {
+ lappend keys [makekey a $myKeyfield]
+ }
+ $obj destroy
+
+ return $keys
+ }
+
+ #
+ # search - construct and execute a SQL select statement using
+ # build_select_query style and return the result handle.
+ #
+ method search {args} {
+ set req [eval build_select_query $args]
+ return [exec $req]
+ }
+
+ #
+ # count - return a count of the specified (or current) table.
+ #
+ method count {args} {
+ table_check $args
+ return [string "select count(*) from $myTable"]
+ }
+
+ method makeDBFieldValue {table_name field_name val} {
+ return "'[quote $val]'"
+ }
+
+ method registerSpecialField {table_name field_name type} {
+ set specialFields(${table_name}@${field_name}) $type
+ }
+
+ ##
+ ## These are methods which should be defined by each individual database
+ ## interface class.
+ ##
+ method open {args} {}
+ method close {args} {}
+ method exec {args} {}
+ method nextkey {args} {}
+ method lastkey {args} {}
+ method now {} {}
+
+ ##
+ ## Functions to get and set public variables.
+ ##
+ method interface {{string ""}} { configure_variable interface $string }
+ method errorinfo {{string ""}} { configure_variable errorinfo $string }
+ method db {{string ""}} { configure_variable db $string }
+ method table {{string ""}} { configure_variable table $string }
+ method keyfield {{string ""}} { configure_variable keyfield $string }
+ method autokey {{string ""}} { configure_variable autokey $string }
+ method sequence {{string ""}} { configure_variable sequence $string }
+ method user {{string ""}} { configure_variable user $string }
+ method pass {{string ""}} { configure_variable pass $string }
+ method host {{string ""}} { configure_variable host $string }
+ method port {{string ""}} { configure_variable port $string }
+
+ protected variable specialFields
+
+ public variable interface ""
+ public variable errorinfo ""
+
+ public variable db ""
+ public variable table ""
+ public variable sequence ""
+
+ public variable user ""
+ public variable pass ""
+ public variable host ""
+ public variable port ""
+
+ public variable keyfield "" {
+ if {[llength $keyfield] > 1 && $autokey} {
+ return -code error "Cannot have autokey and multiple keyfields"
+ }
+ }
+
+ public variable autokey 0 {
+ if {[llength $keyfield] > 1 && $autokey} {
+ return -code error "Cannot have autokey and multiple keyfields"
+ }
+ }
+
+} ; ## ::itcl::class Database
+
+#
+# DIO Result object
+#
+::itcl::class Result {
+ constructor {args} {
+ eval configure $args
+ }
+
+ destructor { }
+
+ method destroy {} {
+ ::itcl::delete object $this
+ }
+
+ #
+ # configure_variable - given a variable name and a string, if the
+ # string is empty return the variable name, otherwise set the
+ # variable to the string.
+ #
+ protected method configure_variable {varName string} {
+ if {[lempty $string]} { return [cget -$varName] }
+ configure -$varName $string
+ }
+
+ #
+ # lassign_array - given a list, an array name, and a variable number
+ # of arguments consisting of variable names, assign each element in
+ # the list, in turn, to elements corresponding to the variable
+ # arguments, into the named array. From TclX.
+ #
+ protected method lassign_array {list arrayName args} {
+ upvar 1 $arrayName array
+ foreach elem $list field $args {
+ set array($field) $elem
+ }
+ }
+
+ #
+ # seek - set the current row ID (our internal row cursor, if you will)
+ # to the specified row ID
+ #
+ method seek {newrowid} {
+ set rowid $newrowid
+ }
+
+ method cache {{size "all"}} {
+ set cacheSize $size
+ if {$size == "all"} { set cacheSize $numrows }
+
+ ## Delete the previous cache array.
+ catch {unset cacheArray}
+
+ set autostatus $autocache
+ set currrow $rowid
+ set autocache 1
+ seek 0
+ set i 0
+ while {[next -list list]} {
+ if {[incr i] >= $cacheSize} { break }
+ }
+ set autocache $autostatus
+ seek $currrow
+ set cached 1
+ }
+
+ #
+ # forall -- walk the result object, executing the code body over it
+ #
+ method forall {type varName body} {
+ upvar 1 $varName $varName
+ set currrow $rowid
+ seek 0
+ while {[next $type $varName]} {
+ uplevel 1 $body
+ }
+ set rowid $currrow
+ return
+ }
+
+ method next {type {varName ""}} {
+ set return 1
+ if {![lempty $varName]} {
+ upvar 1 $varName var
+ set return 0
+ }
+
+ catch {unset var}
+
+ set list ""
+ ## If we have a cached result for this row, use it.
+ if {[info exists cacheArray($rowid)]} {
+ set list $cacheArray($rowid)
+ } else {
+ set list [$this nextrow]
+ if {[lempty $list]} {
+ if {$return} { return }
+ set var ""
+ return 0
+ }
+ if {$autocache} { set cacheArray($rowid) $list }
+ }
+
+ incr rowid
+
+ switch -- $type {
+ "-list" {
+ if {$return} {
+ return $list
+ } else {
+ set var $list
+ }
+ }
+ "-array" {
+ if {$return} {
+ foreach field $fields elem $list {
+ lappend var $field $elem
+ }
+ return $var
+ } else {
+ eval lassign_array [list $list] var $fields
+ }
+ }
+ "-keyvalue" {
+ foreach field $fields elem $list {
+ lappend var -$field $elem
+ }
+ if {$return} { return $var }
+ }
+
+ default {
+ incr rowid -1
+ return -code error \
+ "In-valid type: must be -list, -array or -keyvalue"
+ }
+ }
+ return [expr [lempty $list] == 0]
+ }
+
+ method resultid {{string ""}} { configure_variable resultid $string }
+ method fields {{string ""}} { configure_variable fields $string }
+ method rowid {{string ""}} { configure_variable rowid $string }
+ method numrows {{string ""}} { configure_variable numrows $string }
+ method error {{string ""}} { configure_variable error $string }
+ method errorcode {{string ""}} { configure_variable errorcode $string }
+ method errorinfo {{string ""}} { configure_variable errorinfo $string }
+ method autocache {{string ""}} { configure_variable autocache $string }
+
+ public variable resultid ""
+ public variable fields ""
+ public variable rowid 0
+ public variable numrows 0
+ public variable error 0
+ public variable errorcode 0
+ public variable errorinfo ""
+ public variable autocache 1
+
+ protected variable cached 0
+ protected variable cacheSize 0
+ protected variable cacheArray
+
+} ; ## ::itcl::class Result
+
+} ; ## namespace eval DIO
+
+package provide DIO 1.0
--- /dev/null
+# dio_Mysql.tcl -- Mysql backend.
+
+# Copyright 2002-2004 The Apache Software Foundation
+
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+
+# http://www.apache.org/licenses/LICENSE-2.0
+
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# $Id: dio_Mysql.tcl 406282 2006-05-14 08:46:50Z davidw $
+
+package provide dio_Mysql 0.1
+
+namespace eval DIO {
+ ::itcl::class Mysql {
+ inherit Database
+
+ constructor {args} {eval configure $args} {
+ if { [catch {package require Mysqltcl}] \
+ && [catch {package require mysqltcl}] \
+ && [catch {package require mysql} ] } {
+ return -code error "No MySQL Tcl package available"
+ }
+
+ eval configure $args
+
+ if {[lempty $db]} {
+ if {[lempty $user]} {
+ set user $::env(USER)
+ }
+ set db $user
+ }
+ }
+
+ destructor {
+ close
+ }
+
+ method open {} {
+ set command "mysqlconnect"
+
+ if {![lempty $user]} { lappend command -user $user }
+ if {![lempty $pass]} { lappend command -password $pass }
+ if {![lempty $port]} { lappend command -port $port }
+ if {![lempty $host]} { lappend command -host $host }
+
+ if {[catch $command error]} { return -code error $error }
+
+ set conn $error
+
+ if {![lempty $db]} { mysqluse $conn $db }
+ }
+
+ method close {} {
+ if {![info exists conn]} { return }
+ catch {mysqlclose $conn}
+ unset conn
+ }
+
+ method exec {req} {
+ if {![info exists conn]} { open }
+
+ set cmd mysqlexec
+ set sqlcmd [::string tolower [::string range $req 0 5]]
+ if {[::string compare $sqlcmd "select"] == 0} { set cmd mysqlsel }
+
+ set errorinfo ""
+ set req [::string map [::list "\\" "\\\\"] $req]
+ if {[catch {$cmd $conn $req} error]} {
+ set errorinfo $error
+ set obj [result Mysql -resultid [::list $conn] \
+ -errorcode 1 -errorinfo [::list $error]]
+ return $obj
+ }
+ if {[catch {mysqlcol $conn -current name} fields]} { set fields "" }
+ set obj [result Mysql -resultid [::list $conn] \
+ -numrows [::list $error] -fields [::list $fields]]
+ if {[$obj error]} { set errorinfo [$obj errorinfo] }
+ return $obj
+ }
+
+ method lastkey {} {
+ if {![info exists conn]} { return }
+ return [mysqlinsertid $conn]
+ }
+
+ method quote {string} {
+ if {![catch {mysqlescape $string} result]} { return $result }
+ return [string map {"'" "''"} $string]
+ }
+
+ method sql_limit_syntax {limit {offset ""}} {
+ if {[lempty $offset]} {
+ return " LIMIT $limit"
+ }
+ return " LIMIT [expr $offset - 1],$limit"
+ }
+
+ method handle {} {
+ if {![info exists conn]} { open }
+
+ return $conn
+ }
+
+ method makeDBFieldValue {table_name field_name val {convert_to {}}} {
+ if {[info exists specialFields(${table_name}@${field_name})]} {
+ switch $specialFields(${table_name}@${field_name}) {
+ DATE {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format {%Y-%m-%d}]
+ return "DATE_FORMAT('$my_val', '%Y-%m-%d')"
+ }
+ DATETIME {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format {%Y-%m-%d %T}]
+ return "DATE_FORMAT('$my_val', '%Y-%m-%d %T')"
+ }
+ NOW {
+ switch $convert_to {
+ SECS {
+ if {[::string compare $val "now"] == 0} {
+ set secs [clock seconds]
+ set my_val [clock format $secs -format {%Y%m%d%H%M%S}]
+ return $my_val
+ } else {
+ return "DATE_FORMAT(session_update_time,'%Y%m%d%H%i%S')"
+ }
+ }
+ default {
+ if {[::string compare $val, "now"] == 0} {
+ set secs [clock seconds]
+ } else {
+ set secs [clock scan $val]
+ }
+ set my_val [clock format $secs -format {%Y-%m-%d %T}]
+ return "DATE_FORMAT('$my_val', '%Y-%m-%d %T')"
+ }
+ }
+ }
+ default {
+ # no special code for that type!!
+ return "'[quote $val]'"
+ }
+ }
+ } else {
+ return "'[quote $val]'"
+ }
+ }
+
+ public variable db "" {
+ if {[info exists conn]} {
+ mysqluse $conn $db
+ }
+ }
+
+ public variable interface "Mysql"
+ private variable conn
+
+ } ; ## ::itcl::class Mysql
+
+ ::itcl::class MysqlResult {
+ inherit Result
+
+ constructor {args} {
+ eval configure $args
+ if {"$resultid" == ""} {
+ return -code error "no valid result id present"
+ }
+ }
+
+ destructor {
+
+ }
+
+ method nextrow {} {
+ return [mysqlnext $resultid]
+ }
+
+ } ; ## ::itcl::class MysqlResult
+
+}
--- /dev/null
+# dio_Mysql.tcl -- Mysql backend.
+
+# Copyright 2006 The Apache Software Foundation
+
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+
+# http://www.apache.org/licenses/LICENSE-2.0
+
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# $Id: dio_Oracle.tcl 265421 2004-10-29 20:17:54Z karl $
+
+package provide dio_Oracle 0.1
+
+namespace eval DIO {
+ ::itcl::class Oracle {
+ inherit Database
+
+ constructor {args} {eval configure $args} {
+ if {[catch {package require Oratcl}]} {
+ return -code error "No Oracle Tcl package available"
+ }
+
+ eval configure $args
+
+ if {[lempty $db]} {
+ if {[lempty $user]} {
+ set user $::env(USER)
+ }
+ set db $user
+ }
+ }
+
+ destructor {
+ close
+ }
+
+ method open {} {
+ set command "::oralogon"
+
+ if {![lempty $user]} { append command " $user" }
+ if {![lempty $pass]} { append command "/$pass" }
+ if {![lempty $host]} { append command "@$host" }
+ if {![lempty $port]} { append command -port $port }
+
+ if {[catch $command error]} { return -code error $error }
+
+ set conn $error
+
+ if {![lempty $db]} {
+ # ??? mysqluse $conn $db
+ }
+ }
+
+ method close {} {
+ if {![info exists conn]} { return }
+ catch {::oraclose $conn}
+ unset conn
+ }
+
+ method exec {req} {
+ if {![info exists conn]} { open }
+
+ set _cur [::oraopen $conn]
+ set cmd ::orasql
+ set is_select 0
+ if {[::string tolower [lindex $req 0]] == "select"} {
+ set cmd ::orasql
+ set is_select 1
+ }
+ set errorinfo ""
+#puts "ORA:$is_select:$req:<br>"
+ if {[catch {$cmd $_cur $req} error]} {
+#puts "ORA:error:$error:<br>"
+ set errorinfo $error
+ catch {::oraclose $_cur}
+ set obj [result $interface -error 1 -errorinfo [::list $error]]
+ return $obj
+ }
+ if {[catch {::oracols $_cur name} fields]} { set fields "" }
+ ::oracommit $conn
+ set my_fields $fields
+ set fields [::list]
+ foreach field $my_fields {
+ set field [::string tolower $field]
+ lappend fields $field
+ }
+ set error [::oramsg $_cur rows]
+ set res_cmd "result"
+ lappend res_cmd $interface -resultid $_cur
+ lappend res_cmd -numrows [::list $error] -fields [::list $fields]
+ lappend res_cmd -fetch_first_row $is_select
+ set obj [eval $res_cmd]
+ if {!$is_select} {
+ ::oraclose $_cur
+ }
+ return $obj
+ }
+
+ method lastkey {} {
+ if {![info exists conn]} { return }
+ return [mysqlinsertid $conn]
+ }
+
+ method quote {string} {
+ regsub -all {'} $string {\'} string
+ return $string
+ }
+
+ method sql_limit_syntax {limit {offset ""}} {
+ # temporary
+ return ""
+ if {[lempty $offset]} {
+ return " LIMIT $limit"
+ }
+ return " LIMIT [expr $offset - 1],$limit"
+ }
+
+ method handle {} {
+ if {![info exists conn]} { open }
+ return $conn
+ }
+
+ method makeDBFieldValue {table_name field_name val {convert_to {}}} {
+ if {[info exists specialFields(${table_name}@${field_name})]} {
+ switch $specialFields(${table_name}@${field_name}) {
+ DATE {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format {%Y-%m-%d}]
+ return "to_date('$my_val', 'YYYY-MM-DD')"
+ }
+ DATETIME {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format {%Y-%m-%d %T}]
+ return "to_date('$my_val', 'YYYY-MM-DD HH24:MI:SS')"
+ }
+ NOW {
+ switch $convert_to {
+ SECS {
+ if {[::string compare $val "now"] == 0} {
+ set secs [clock seconds]
+ set my_val [clock format $secs -format {%Y%m%d%H%M%S}]
+ return $my_val
+ } else {
+ return "to_char($field_name, 'YYYYMMDDHH24MISS')"
+ }
+ }
+ default {
+ if {[::string compare $val "now"] == 0} {
+ set secs [clock seconds]
+ } else {
+ set secs [clock scan $val]
+ }
+ set my_val [clock format $secs -format {%Y-%m-%d %T}]
+ return "to_date('$my_val', 'YYYY-MM-DD HH24:MI:SS')"
+ }
+ }
+ }
+ default {
+ # no special cod for that type!!
+ return "'[quote $val]'"
+ }
+ }
+ } else {
+ return "'[quote $val]'"
+ }
+ }
+
+ public variable db "" {
+ if {[info exists conn]} {
+ mysqluse $conn $db
+ }
+ }
+
+ public variable interface "Oracle"
+ private variable conn
+ private variable _cur
+
+ } ; ## ::itcl::class Mysql
+
+ ::itcl::class OracleResult {
+ inherit Result
+
+ public variable fetch_first_row 0
+ private variable _data ""
+ private variable _have_first_row 0
+
+ constructor {args} {
+ eval configure $args
+ if {$fetch_first_row} {
+ if {[llength [nextrow]] == 0} {
+ set _have_first_row 0
+ numrows 0
+ } else {
+ set _have_first_row 1
+ numrows 1
+ }
+ }
+ set fetch_first_row 0
+ }
+
+ destructor {
+ if {[string length $resultid] > 0} {
+ catch {::oraclose $resultid}
+ }
+ }
+
+ method nextrow {} {
+ if {[string length $resultid] == 0} {
+ return [::list]
+ }
+ if {$_have_first_row} {
+ set _have_first_row 0
+ return $_data
+ }
+ set ret [::orafetch $resultid -datavariable _data]
+ switch $ret {
+ 0 {
+ return $_data
+ }
+ 1403 {
+ ::oraclose $resultid
+ set resultid ""
+ return [::list]
+ }
+ default {
+ # FIXME!! have to handle error here !!
+ return [::list]
+ }
+ }
+ }
+ } ; ## ::itcl::class OracleResult
+
+}
--- /dev/null
+# dio_Postgresql.tcl -- Postgres backend.
+
+# Copyright 2002-2004 The Apache Software Foundation
+
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+
+# http://www.apache.org/licenses/LICENSE-2.0
+
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# $Id: dio_Postgresql.tcl 418793 2006-07-03 15:51:57Z karl $
+
+package provide dio_Postgresql 0.1
+
+namespace eval DIO {
+ ::itcl::class Postgresql {
+ inherit Database
+
+ constructor {args} {eval configure $args} {
+ package require Pgtcl
+ set_conn_defaults
+ eval configure $args
+ }
+
+ destructor {
+ close
+ }
+
+ ## Setup our variables with the default conninfo from Postgres.
+ private method set_conn_defaults {} {
+ foreach list [pg_conndefaults] {
+ set var [lindex $list 0]
+ set val [lindex $list end]
+ switch -- $var {
+ "dbname" { set db $val }
+ default { set $var $val }
+ }
+ }
+ }
+
+ method open {} {
+ set command "pg_connect"
+
+ set info ""
+ if {![lempty $user]} { append info " user=$user" }
+ if {![lempty $pass]} { append info " password=$pass" }
+ if {![lempty $host]} { append info " host=$host" }
+ if {![lempty $port]} { append info " port=$port" }
+ if {![lempty $db]} { append info " dbname=$db" }
+
+ if {![lempty $info]} { append command " -conninfo [::list $info]" }
+
+ if {[catch $command error]} { return -code error $error }
+
+ set conn $error
+ }
+
+ method close {} {
+ if {![info exists conn]} { return }
+ pg_disconnect $conn
+ unset conn
+ }
+
+ method exec {req} {
+ if {![info exists conn]} { open }
+
+ set command pg_exec
+ if {[catch {$command $conn $req} result]} { return -code error $result }
+
+ set errorinfo ""
+ set obj [result Postgresql -resultid $result]
+ if {[$obj error]} { set errorinfo [$obj errorinfo] }
+ return $obj
+ }
+
+ method nextkey {} {
+ return [$this string "select nextval( '$sequence' )"]
+ }
+
+ method lastkey {} {
+ return [$this string "select last_value from $sequence"]
+ }
+
+ method sql_limit_syntax {limit {offset ""}} {
+ set sql " LIMIT $limit"
+ if {![lempty $offset]} { append sql " OFFSET $offset" }
+ return $sql
+ }
+
+ #
+ # handle - return the internal database handle, in the postgres
+ # case, the postgres connection handle
+ #
+ method handle {} {
+ if {![info exists conn]} { open }
+ return $conn
+ }
+
+ ## If they change DBs, we need to close the connection and re-open it.
+ public variable db "" {
+ if {[info exists conn]} {
+ close
+ open
+ }
+ }
+
+ public variable interface "Postgresql"
+ private variable conn
+
+ } ; ## ::itcl::class Postgresql
+
+ #
+ # PostgresqlResult object -- superclass of ::DIO::Result object
+ #
+ #
+ ::itcl::class PostgresqlResult {
+ inherit Result
+
+ constructor {args} {
+ eval configure $args
+
+ if {[lempty $resultid]} {
+ return -code error "No resultid specified while creating result"
+ }
+
+ set numrows [pg_result $resultid -numTuples]
+ set fields [pg_result $resultid -attributes]
+ set errorcode [pg_result $resultid -status]
+ set errorinfo [pg_result $resultid -error]
+
+ # if numrows is zero, see if cmdrows returned anything and if it
+ # did, put that in in place of numrows, hiding a postgresql
+ # idiosyncracy from DIO
+ if {$numrows == 0} {
+ set cmdrows [pg_result $resultId -cmdTuples]
+ if {$cmdrows != ""} {
+ set numrows $cmdrows
+ }
+ }
+
+ if {$errorcode != "PGRES_COMMAND_OK" \
+ && $errorcode != "PGRES_TUPLES_OK"} { set error 1 }
+
+ ## Reconfigure incase we want to overset the default values.
+ eval configure $args
+ }
+
+ destructor {
+ pg_result $resultid -clear
+ }
+
+ method clear {} {
+ pg_result $resultid -clear
+ }
+
+ method nextrow {} {
+ if {$rowid >= $numrows} { return }
+ return [pg_result $resultid -getTuple $rowid]
+ }
+
+ } ; ## ::itcl::class PostgresqlResult
+
+}
--- /dev/null
+# dio_Sqlite.tcl -- DIO interface for sqlite
+
+# Copyright 2004 The Apache Software Foundation
+
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+
+# http://www.apache.org/licenses/LICENSE-2.0
+
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# $Id: dio_Sqlite.tcl 265487 2005-06-06 12:08:49Z karl $
+
+package provide dio_Sqlite 0.1
+
+namespace eval DIO {
+ variable sqlite_seq -1
+
+ catch { ::itcl::delete class Sqlite }
+
+ ::itcl::class Sqlite {
+ inherit Database
+
+ private variable dbcmd ""
+ constructor {args} {eval configure $args} {
+ if { [catch {package require sqlite3}] \
+ && [catch {package require sqlite}] } {
+ return -code error "failed to find a suitable sqlite package"
+ }
+ eval configure $args
+ }
+
+ destructor {
+ close
+ }
+
+ method open {} {
+ variable ::DIO::sqlite_seq
+ if {$dbcmd != ""} { return }
+ set dbcmd dbcmd[incr sqlite_seq]
+ ::sqlite3 $dbcmd $db
+ set dbcmd [namespace which $dbcmd]
+ }
+
+ method close {} {
+ catch { $dbcmd close }
+ }
+
+ method exec {req} {
+ open
+
+ if {[$dbcmd complete $req] == 0} {
+ append req ";"
+ if {[$dbcmd complete $req] == 0} {
+ return -code error "Incomplete SQL"
+ }
+ }
+
+ set obj [::DIO::SqliteResult #auto -request $req -dbcmd $dbcmd]
+
+ # If it's a select statement, defer caching of results.
+ if {[regexp {^[^[:graph:]]*([[:alnum:]]*)} $req _ word]} {
+ if {"[::string tolower $word]" == "select"} {
+ return [namespace which $obj]
+ }
+ }
+
+ # Actually perform the query
+ $obj cache
+ return [namespace which $obj]
+ }
+
+ method list {req} {
+ open
+
+ set result ""
+ $dbcmd eval $req a {
+ lappend result $a([lindex $a(*) 0])
+ }
+ return $result
+ }
+
+ method sql_limit_syntax {limit {offset ""}} {
+ set sql " LIMIT $limit"
+ if {![lempty $offset]} { append sql " OFFSET $offset" }
+ return $sql
+ }
+
+ ## If they change DBs, we need to close the database. It'll be reopened
+ ## on the first exec
+ public variable db "" {
+ if {"$dbcmd" != ""} {
+ close
+ set dbcmd ""
+ }
+ }
+ }
+
+ catch { ::itcl::delete class SqliteResult }
+
+ # Not inheriting Result because there's just too much stuff that needs
+ # to be re-done when you're deferring execution
+ ::itcl::class SqliteResult {
+ constructor {args} {
+ eval configure $args
+
+ if {"$request" == "--"} {
+ return -code error "No SQL code provided for result"
+ }
+
+ if {"$dbcmd" == "--"} {
+ return -code error "No SQLite DB command provided"
+ }
+ }
+
+ destructor {
+ clear
+ }
+
+ method clear {} {
+ set cache {}
+ set cache_loaded 0
+ }
+
+ method destroy {} {
+ ::itcl::delete object $this
+ }
+
+ method resultid {args} {
+ if [llength $args] {
+ set resultid [lindex $args 0]
+ }
+ if ![info exists resultid] {
+ return $request
+ }
+ return $resultid
+ }
+
+ method numrows {args} {
+ if [llength $args] {
+ set numrows [lindex $args 0]
+ }
+ if ![info exists numrows] {
+ if ![load_cache] { return 0 }
+ }
+ return $numrows
+ }
+
+ method fields {args} {
+ if [llength $args] {
+ set fields [lindex $args 0]
+ }
+ if ![info exists fields] {
+ if ![load_cache] { return {} }
+ }
+ return $fields
+ }
+
+ method errorcode {args} {
+ if [llength $args] {
+ set errorcode [lindex $args 0]
+ }
+ if ![info exists errorcode] {
+ check_ok
+ }
+ return $errorcode
+ }
+
+ method error {args} {
+ if [llength $args] {
+ set error [lindex $args 0]
+ }
+ if ![info exists error] {
+ check_ok
+ }
+ return $error
+ }
+
+ method errorinfo {args} {
+ if [llength $args] {
+ set errorinfo [lindex $args 0]
+ }
+ if ![info exists errorinfo] {
+ check_ok
+ }
+ if $error {
+ return $errorinfo
+ }
+ return ""
+ }
+
+ method autocache {args} {
+ if [llength $args] {
+ set autocache $args
+ }
+ return $autocache
+ }
+
+ method cache {} {
+ load_cache
+ }
+
+ protected method load_cache {} {
+ if {$error_exists} { return 0 }
+ if {$cache_loaded} { return 1 }
+ if [catch {
+ set numrows 0
+ # Doing a loop here because it's the only way to get the fields
+ $dbcmd eval $request a {
+ incr numrows
+ set names $a(*)
+ set row {}
+ foreach field $names {
+ lappend row $a($field)
+ }
+ lappend cache $row
+ }
+ if {[info exists names] && ![info exists fields]} {
+ set fields $names
+ }
+ } err] {
+ return [check_ok 1 $err]
+ }
+ set cache_loaded 1
+ return [check_ok 0]
+ }
+
+ method forall {type varname body} {
+ upvar 1 $varname var
+ if $cache_loaded {
+ foreach row $cache {
+ setvar $type var $row
+ uplevel 1 $body
+ }
+ } else {
+ set numrows 0
+ $dbcmd eval $request a {
+ incr numrows
+ set names $a(*)
+ set row {}
+ foreach field $names {
+ lappend row $a($field)
+ }
+ if $autocache {
+ lappend cache $row
+ }
+ if ![info exists fields] {
+ set fields $names
+ }
+ setvar $type var $row
+ uplevel 1 $body
+ }
+ if $autocache {
+ set cache_loaded 1
+ check_ok 0
+ }
+ }
+ }
+
+ method next {type varname} {
+ if ![load_cache] { return -1 }
+ if {$rowid + 1 > $numrows} { return -1 }
+ upvar 1 $varname var
+ incr rowid
+ setvar $type var [lindex $cache $rowid]
+ return $rowid
+ }
+
+ protected method setvar {type varname row} {
+ upvar 1 $varname var
+ switch -- $type {
+ -list {
+ set var $row
+ }
+ -array {
+ foreach name $fields value $row {
+ set var($name) $value
+ }
+ }
+ -keyvalue {
+ set var {}
+ foreach name $fields value $row {
+ lappend var -$name $value
+ }
+ }
+ default {
+ return -code error "Unknown type $type"
+ }
+ }
+ }
+
+ protected method check_ok {{val -1} {info ""}} {
+ if {$error_checked} { return [expr !$error] }
+ if {$val < 0} {
+ set val [catch {$dbcmd onecolumn $request} info]
+ }
+ set error $val
+ set errorcode $val
+ set error_checked 1
+ set error_exists $val
+ if {$val > 0} {
+ set errorinfo $info
+ } else {
+ set rowid -1
+ }
+ return [expr !$val]
+ }
+
+ public variable autocache 0
+ public variable error
+ public variable errorcode
+ public variable errorinfo
+ public variable fields
+ public variable numrows
+ public variable resultid
+ public variable rowid -1
+
+ public variable request "--"
+ public variable dbcmd "--"
+
+ protected variable cache
+ protected variable cache_loaded 0
+ protected variable error_checked 0
+ protected variable error_exists 0
+ } ; ## ::itcl::class SqliteResult
+}
--- /dev/null
+# diodisplay.tcl --
+
+# Copyright 2002-2004 The Apache Software Foundation
+
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+
+# http://www.apache.org/licenses/LICENSE-2.0
+
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+#
+# $Id: diodisplay.tcl 374757 2006-02-03 21:45:54Z karl $
+#
+
+package require Itcl
+package require DIO
+package require form
+
+package provide DIODisplay 1.0
+
+catch { ::itcl::delete class DIODisplay }
+
+::itcl::class ::DIODisplay {
+ constructor {args} {
+ eval configure $args
+ load_response
+
+ if {[lempty $DIO]} {
+ return -code error "You must specify a DIO object"
+ }
+
+ if {[lempty $form]} {
+ set form [namespace which [::form #auto -defaults response]]
+ }
+
+ set document [env DOCUMENT_NAME]
+
+ if {[info exists response(num)] \
+ && ![lempty $response(num)]} {
+ set pagesize $response(num)
+ }
+
+ read_css_file
+ }
+
+ destructor {
+ if {$cleanup} { do_cleanup }
+ }
+
+ method destroy {} {
+ ::itcl::delete object $this
+ }
+
+ #
+ # configvar - a convenient helper for creating methods that can
+ # set and fetch one of the object's variables
+ #
+ method configvar {varName string} {
+ if {[lempty $string]} { return [set $varName] }
+ configure -$varName $string
+ }
+
+ #
+ # is_function - return true if name is known to be a function
+ # such as Search List Add Edit Delete Details Main Save DoDelete Cancel
+ # etc.
+ #
+ method is_function {name} {
+ if {[lsearch $functions $name] > -1} { return 1 }
+ if {[lsearch $allfunctions $name] > -1} { return 1 }
+ return 0
+ }
+
+ #
+ # do_cleanup - clean up our field subobjects, DIO objects, forms, and the
+ # like.
+ #
+ method do_cleanup {} {
+ ## Destroy all the fields created.
+ foreach field $allfields { catch { $field destroy } }
+
+ ## Destroy the DIO object.
+ catch { $DIO destroy }
+
+ ## Destroy the form object.
+ catch { $form destroy }
+ }
+
+ #
+ # handle_error - emit an error message
+ #
+ method handle_error {error} {
+ puts "<B>An error has occurred processing your request</B>"
+ puts "<PRE>"
+ puts "$error"
+ puts ""
+ puts "$::errorInfo"
+ puts "</PRE>"
+ }
+
+ #
+ # read_css_file - parse and read in a CSS file so we can
+ # recognize CSS info and emit it in appropriate places
+ #
+ method read_css_file {} {
+ if {[lempty $css]} { return }
+ if {[catch {open [virtual_filename $css]} fp]} { return }
+ set contents [read $fp]
+ close $fp
+ array set tmpArray $contents
+ foreach class [array names tmpArray] {
+ set cssArray([string toupper $class]) $tmpArray($class)
+ }
+ }
+
+ #
+ # get_css_class - figure out which CSS class we want to use.
+ # If class exists, we use that. If not, we use default.
+ #
+ method get_css_class {tag default class} {
+
+ # if tag.class exists, use that
+ if {[info exists cssArray([string toupper $tag.$class])]} {
+ return $class
+ }
+
+ # if .class exists, use that
+ if {[info exists cssArray([string toupper .$class])]} {
+ return $class
+ }
+
+ # use the default
+ return $default
+ }
+
+ #
+ # parse_css_class - given a class and the name of an array, parse
+ # the named CSS class (read from the style sheet) and return it as
+ # key-value pairs in the named array.
+ #
+ method parse_css_class {class arrayName} {
+
+ # if we don't have an entry for the specified glass, give up
+ if {![info exists cssArray($class)]} {
+ return
+ }
+
+ # split CSS entry on semicolons, for each one...
+ upvar 1 $arrayName array
+ foreach line [split $cssArray($class) \;] {
+
+ # trim leading and trailing spaces
+ set line [string trim $line]
+
+ # split the line on a colon into property and value
+ lassign [split $line :] property value
+
+ # map the property to space-trimmed lowercase and
+ # space-trim the value, then store in the passed array
+ set property [string trim [string tolower $property]]
+ set value [string trim $value]
+ set array($property) $value
+ }
+ }
+
+ #
+ # button_image_src - return the value of the image-src element in
+ # the specified class (from the CSS style sheet), or an empty
+ # string if there isn't one.
+ #
+ method button_image_src {class} {
+ set class [string toupper input.$class]
+ parse_css_class $class array
+ if {![info exists array(image-src)]} {
+ return
+ }
+ return $array(image-src)
+ }
+
+ # state - return a list of name-value pairs that represents the current
+ # state of the query, which can be used to properly populate links
+ # outside DIOdisplay.
+ method state {} {
+ set state {}
+ foreach fld {mode query by how sort num page} {
+ if [info exists response($fld)] {
+ lappend state $fld $response($fld)
+ }
+ }
+ return $state
+ }
+
+ method show {} {
+
+ # if there's a mode in the response array, use that, else set
+ # mode to Main
+ set mode Main
+ if {[info exists response(mode)]} {
+ set mode $response(mode)
+ }
+
+ # if there is a style sheet defined, emit HTML to reference it
+ if {![lempty $css]} {
+ puts "<LINK REL=\"stylesheet\" TYPE=\"text/css\" HREF=\"$css\">"
+ }
+
+ # put out the table header
+ puts {<TABLE WIDTH="100%" CLASS="DIO">}
+ puts "<TR>"
+ puts {<TD VALIGN="center" CLASS="DIO">}
+
+ # if mode isn't Main and persistentmain is set (the default),
+ # run Main
+ if {$mode != "Main" && $persistentmain} {
+ Main
+ }
+
+ if {![is_function $mode]} {
+ puts "In-valid function"
+ return
+ }
+
+ if {[catch "$this $mode" error]} {
+ handle_error $error
+ }
+
+ puts "</TD>"
+ puts "</TR>"
+ puts "</TABLE>"
+
+ if {$cleanup} { destroy }
+ }
+
+ method showview {} {
+ puts {<TABLE CLASS="DIOView">}
+ set row 0
+ foreach field $fields {
+ $field showview [lindex {"" "Alt"} $row]
+ set row [expr 1 - $row]
+ }
+ puts "</TABLE>"
+ }
+
+ #
+ # showform_prolog - emit a form for inserting a new record
+ #
+ # response(by) will contain whatever was in the "where" field
+ # response(query) will contain whatever was in the "is" field
+ #
+ method showform_prolog {{args ""}} {
+ get_field_values array
+
+ eval $form start $args
+ foreach fld [array names hidden] {
+ $form hidden $fld -value $hidden($fld)
+ }
+ $form hidden mode -value Save
+ $form hidden DIODfromMode -value $response(mode)
+ $form hidden DIODkey -value [$DIO makekey array]
+ puts {<TABLE CLASS="DIOForm">}
+ }
+
+ method showform_epilog {} {
+ set save [button_image_src DIOFormSaveButton]
+ set cancel [button_image_src DIOFormCancelButton]
+
+ puts "</TABLE>"
+
+ puts "<TABLE>"
+ puts "<TR>"
+ puts "<TD>"
+ if {![lempty $save]} {
+ $form image save -src $save -class DIOFormSaveButton
+ } else {
+ $form submit save.x -value "Save" -class DIOFormSaveButton
+ }
+ puts "</TD>"
+ puts "<TD>"
+ if {![lempty $cancel]} {
+ $form image cancel -src $cancel -class DIOFormSaveButton
+ } else {
+ $form submit cancel.x -value "Cancel" -class DIOFormCancelButton
+ }
+ puts "</TD>"
+ puts "</TR>"
+ puts "</TABLE>"
+
+ $form end
+ }
+
+ #
+ # showform - emit a form for inserting a new record
+ #
+ # response(by) will contain whatever was in the "where" field
+ # response(query) will contain whatever was in the "is" field
+ #
+ method showform {} {
+ showform_prolog
+
+ # emit each field
+ foreach field $fields {
+ showform_field $field
+ }
+
+ showform_epilog
+ }
+
+ # showform_field - emit the form field for the specified field using
+ # the showform method of the field. If the user has typed something
+ # into the search field and it matches the fields being emitted,
+ # use that value as the default
+ #
+ method showform_field {field} {
+ if {[info exists response(by)] && $response(by) == [$field text]} {
+ if {![$field readonly] && $response(query) != ""} {
+ $field value $response(query)
+ }
+ }
+ $field showform
+ }
+
+ method page_buttons {end {count 0}} {
+ if {$pagesize <= 0} { return }
+
+ if {![info exists response(page)]} { set response(page) 1 }
+
+ set pref DIO$end
+ if {!$count} {
+ set count [$DIOResult numrows]
+ }
+
+ set pages [expr ($count + $pagesize - 1) / $pagesize]
+
+ if {$pages <= 1} {
+ return
+ }
+
+ set first [expr $response(page) - 4]
+ if {$first > $pages - 9} {
+ set first [expr $pages - 9]
+ }
+ if {$first > 1} {
+ lappend pagelist 1 1
+ if {$first > 3} {
+ lappend pagelist ".." 0
+ } elseif {$first > 2} {
+ lappend pagelist 2 2
+ }
+ } else {
+ set first 1
+ }
+ set last [expr $response(page) + 4]
+ if {$last < 9} {
+ set last 9
+ }
+ if {$last > $pages} {
+ set last $pages
+ }
+ for {set i $first} {$i <= $last} {incr i} {
+ lappend pagelist $i $i
+ }
+ if {$last < $pages} {
+ if {$last < $pages - 2} {
+ lappend pagelist ".." 0
+ } elseif {$last < $pages - 1} {
+ incr last
+ lappend pagelist $last $last
+ }
+ lappend pagelist $pages $pages
+ }
+
+ foreach {n p} $pagelist {
+ if {$p == 0 || $p == $response(page)} {
+ lappend navbar $n
+ } else {
+ set html {<A HREF="}
+ append html "$document?mode=$response(mode)"
+ foreach var {query by how sort num} {
+ if {[info exists response($var)]} {
+ append html "&$var=$response($var)"
+ }
+ }
+ foreach fld [array names hidden] {
+ append html "&$fld=$hidden($fld)"
+ }
+ append html "&page=$p\">$n</A>"
+ lappend navbar $html
+ }
+ }
+
+ if {"$end" == "Bottom"} {
+ puts "<BR/>"
+ }
+ set class [get_css_class TABLE DIONavButtons ${pref}NavButtons]
+ puts "<TABLE WIDTH=\"100%\" CLASS=\"$class\">"
+ puts "<TR>"
+ puts "<TD>"
+ if {"$end" == "Top"} {
+ puts "$count rows, go to page"
+ } else {
+ puts "Go to page"
+ }
+ foreach link $navbar {
+ puts "$link "
+ }
+ puts "</TD>"
+ if {"$end" == "Top" && $pages>10} {
+ set f [::form #auto]
+ $f start
+ foreach fld [array names hidden] {
+ $f hidden $fld -value $hidden($fld)
+ }
+ foreach fld {mode query by how sort num} {
+ if [info exists response($fld)] {
+ $f hidden $fld -value $response($fld)
+ }
+ }
+ puts "<TD ALIGN=RIGHT>"
+ puts "Jump directly to"
+ $f text page -size 4 -value $response(page)
+ $f submit submit -value "Go"
+ puts "</TD>"
+ $f end
+ }
+ puts "</TR>"
+ puts "</TABLE>"
+ if {"$end" == "Top"} {
+ puts "<BR/>"
+ }
+ }
+
+
+ method rowheader {{total 0}} {
+ set fieldList $fields
+ if {![lempty $rowfields]} { set fieldList $rowfields }
+
+ set rowcount 0
+
+ puts <P>
+
+ if {$topnav} { page_buttons Top $total }
+
+ puts {<TABLE BORDER WIDTH="100%" CLASS="DIORowHeader">}
+ puts "<TR CLASS=DIORowHeader>"
+ foreach field $fieldList {
+ set text [$field text]
+ set sorting $allowsort
+ ## If sorting is turned off, or this field is not in the
+ ## sortfields, we don't display the sort option.
+ if {$sorting && ![lempty $sortfields]} {
+ if {[lsearch $sortfields $field] < 0} {
+ set sorting 0
+ }
+ }
+ if {$sorting && [info exists response(sort)]} {
+ if {"$response(sort)" == "$field"} {
+ set sorting 0
+ }
+ }
+
+ if {!$sorting} {
+ set html $text
+ } else {
+ set html {<A HREF="}
+ append html "$document?mode=$response(mode)"
+ foreach var {query by how num} {
+ if {[info exists response($var)]} {
+ append html "&$var=$response($var)"
+ }
+ }
+ foreach fld [array names hidden] {
+ append html "&$fld=$hidden($fld)"
+ }
+ append html "&sort=$field\">$text</A>"
+ }
+ set class [get_css_class TH DIORowHeader DIORowHeader-$field]
+ puts "<TH CLASS=\"$class\">$html</TH>"
+ }
+
+ if {![lempty $rowfunctions] && "$rowfunctions" != "-"} {
+ puts {<TH CLASS="DIORowHeaderFunctions">Functions</TH>}
+ }
+ puts "</TR>"
+ }
+
+ method showrow {arrayName} {
+ upvar 1 $arrayName a
+
+ incr rowcount
+ set alt ""
+ if {$alternaterows && ![expr $rowcount % 2]} { set alt Alt }
+
+ set fieldList $fields
+ if {![lempty $rowfields]} { set fieldList $rowfields }
+
+ puts "<TR>"
+ foreach field $fieldList {
+ set class [get_css_class TD DIORowField$alt DIORowField$alt-$field]
+ set text ""
+ if {[info exists a($field)]} {
+ set text $a($field)
+ if [info exists filters($field)] {
+ set text [$filters($field) $text]
+ }
+ }
+ if ![string length $text] {
+ set text " "
+ }
+ puts "<TD CLASS=\"$class\">$text</TD>"
+ }
+
+ if {![lempty $rowfunctions] && "$rowfunctions" != "-"} {
+ set f [::form #auto]
+ puts "<TD NOWRAP CLASS=\"DIORowFunctions$alt\">"
+ $f start
+ foreach fld [array names hidden] {
+ $f hidden $fld -value $hidden($fld)
+ }
+ $f hidden query -value [$DIO makekey a]
+ if {[llength $rowfunctions] > 1} {
+ $f select mode -values $rowfunctions -class DIORowFunctionSelect$alt
+ $f submit submit -value "Go" -class DIORowFunctionButton$alt
+ } else {
+ set func [lindex $rowfunctions 0]
+ $f hidden mode -value $func
+ $f submit submit -value $func -class DIORowFunctionButton$alt
+ }
+ puts "</TD>"
+ $f end
+ }
+
+ puts "</TR>"
+ }
+
+ method rowfooter {{total 0}} {
+ puts "</TABLE>"
+
+ if {$bottomnav} { page_buttons Bottom $total }
+ }
+
+ ## Define a new function.
+ method function {name} {
+ lappend allfunctions $name
+ }
+
+ ## Define a field in the object.
+ method field {name args} {
+ import_keyvalue_pairs data $args
+ lappend fields $name
+ lappend allfields $name
+
+ set class DIODisplayField
+ if {[info exists data(type)]} {
+ if {![lempty [::itcl::find classes *DIODisplayField_$data(type)]]} {
+ set class DIODisplayField_$data(type)
+ }
+
+ }
+
+ eval $class $name -name $name -display $this -form $form $args
+ set FieldTextMap([$name text]) $name
+ }
+
+ method fetch {key arrayName} {
+ upvar 1 $arrayName $arrayName
+ set result [$DIO fetch $key $arrayName]
+ set error [$DIO errorinfo]
+ if {![lempty $error]} { return -code error $error }
+ return $result
+ }
+
+ method store {arrayName} {
+ upvar 1 $arrayName array
+ set result [$DIO store array]
+ set error [$DIO errorinfo]
+ if {![lempty $error]} { return -code error $error }
+ return $result
+ }
+
+ method update_with_explicit_key {key arrayName} {
+ upvar 1 $arrayName array
+ set result [$DIO update_with_explicit_key $key array]
+ set error [$DIO errorinfo]
+ if {![lempty $error]} {return -code error $error}
+ return $result
+ }
+
+ method delete {key} {
+ set result [$DIO delete $key]
+ set error [$DIO errorinfo]
+ if {![lempty $error]} { return -code error $error }
+ return $result
+ }
+
+ method pretty_fields {list} {
+ foreach field $list {
+ lappend fieldList [$field text]
+ }
+ return $fieldList
+ }
+
+ method set_field_values {arrayName} {
+ upvar 1 $arrayName array
+
+ # for all the elements in the specified array, try to invoke
+ # the element as an object, invoking the method "value" to
+ # set the value to the specified value
+ foreach var [array names array] {
+ #if {[catch { $var value $array($var) } result] == 1} {}
+ if {[catch { $var configure -value $array($var) } result] == 1} {
+ }
+ }
+ }
+
+ method get_field_values {arrayName} {
+ upvar 1 $arrayName array
+
+ foreach field $allfields {
+
+ # for some reason the method for getting the value doesn't
+ # work for boolean values, which inherit DIODisplayField,
+ # something to do with configvar
+ #set array($field) [$field value]
+ set array($field) [$field cget -value]
+ }
+ }
+
+ method DisplayRequest {query} {
+ set DIOResult [eval $DIO search -select "count(*)" $query]
+ if [$DIOResult numrows] {
+ $DIOResult next -array a
+ set total $a(count)
+ } else {
+ set total 0
+ }
+ $DIOResult destroy
+ set DIOResult ""
+
+ append query [sql_order_by_syntax]
+ append query [sql_limit_syntax]
+ set DIOResult [eval $DIO search $query]
+
+ if {[$DIOResult numrows] <= 0} {
+ puts "Could not find any matching records."
+ $DIOResult destroy
+ set DIOResult ""
+ return
+ }
+
+ rowheader $total
+
+ $DIOResult forall -array a {
+ showrow a
+ }
+
+ rowfooter $total
+
+ $DIOResult destroy
+ set DIOResult ""
+ }
+
+ method Main {} {
+ puts "<TABLE BORDER=0 WIDTH=100% CLASS=DIOForm><TR>"
+
+ set selfunctions {}
+ foreach f $functions {
+ if {"$f" != "List"} {
+ lappend selfunctions $f
+ } else {
+ set f [::form #auto]
+ $f start
+ foreach fld [array names hidden] {
+ $f hidden $fld -value $hidden($fld)
+ }
+ $f hidden mode -value "List"
+ $f hidden query -value ""
+ puts "<TD CLASS=DIOForm ALIGN=CENTER VALIGN=MIDDLE WIDTH=0%>"
+ $f submit submit -value "Show All" -class DIORowFunctionButton
+ puts "</TD>"
+ $f end
+ }
+ }
+
+ puts "<TD CLASS=DIOForm VALIGN=MIDDLE WIDTH=100%>"
+ $form start
+ puts " "
+
+ foreach fld [array names hidden] {
+ $form hidden $fld -value $hidden($fld)
+ }
+
+ if {[llength $selfunctions] > 1} {
+ $form select mode -values $selfunctions -class DIOMainFunctionsSelect
+ puts "where"
+ } else {
+ puts "Where"
+ }
+
+ set useFields $fields
+ if {![lempty $searchfields]} { set useFields $searchfields }
+
+ $form select by -values [pretty_fields $useFields] \
+ -class DIOMainSearchBy
+
+ if [string match {[Ss]earch} $selfunctions] {
+ $form select how -values {"=" "<" "<=" ">" ">="}
+ } else {
+ puts "is"
+ }
+
+ if [info exists response(query)] {
+ $form text query -value $response(query) -class DIOMainQuery
+ } else {
+ $form text query -value "" -class DIOMainQuery
+ }
+
+ if {[llength $selfunctions] > 1} {
+ $form submit submit -value "GO" -class DIOMainSubmitButton
+ } else {
+ $form hidden mode -value $selfunctions
+ $form submit submit -value $selfunctions -class DIOMainSubmitButton
+ }
+ puts "</TD></TR>"
+
+ if {![lempty $numresults]} {
+ puts "<TR><TD CLASS=DIOForm>Results per page: "
+ $form select num -values $numresults -class DIOMainNumResults
+ puts "</TD></TR>"
+ }
+
+ $form end
+ puts "</TABLE>"
+ }
+
+ method sql_order_by_syntax {} {
+ if {[info exists response(sort)] && ![lempty $response(sort)]} {
+ return " ORDER BY $response(sort)"
+ }
+
+ if {![lempty $defaultsortfield]} {
+ return " ORDER BY $defaultsortfield"
+ }
+ }
+
+ method sql_limit_syntax {} {
+ if {$pagesize <= 0} { return }
+
+ set offset ""
+ if {[info exists response(page)]} {
+ set offset [expr ($response(page) - 1) * $pagesize]
+ }
+ return [$DIO sql_limit_syntax $pagesize $offset]
+ }
+
+
+ method Search {} {
+ set searchField $FieldTextMap($response(by))
+
+ set what $response(query)
+ if {[info exists response(how)] && [string length $response(how)]} {
+ set what "$response(how)$what"
+ }
+
+ DisplayRequest "-$searchField $what"
+ }
+
+ method List {} {
+ DisplayRequest ""
+ }
+
+ method Add {} {
+ showform
+ }
+
+ method Edit {} {
+ if {![fetch $response(query) array]} {
+ puts "That record does not exist in the database."
+ return
+ }
+
+ set_field_values array
+
+ showform
+ }
+
+ ##
+ ## When we save, we want to set all the fields' values and then get
+ ## them into a new array. We do this because we want to clean any
+ ## unwanted variables out of the array but also because some fields
+ ## have special handling for their values, and we want to make sure
+ ## we get the right value.
+ ##
+ method Save {} {
+ if {[info exists response(cancel.x)]} {
+ Cancel
+ return
+ }
+
+ ## We need to see if the key exists. If they are adding a new
+ ## entry, we just want to see if the key exists. If they are
+ ## editing an entry, we need to see if they changed the keyfield
+ ## while editing. If they didn't change the keyfield, there's no
+ ## reason to check it.
+ if {$response(DIODfromMode) == "Add"} {
+ set key [$DIO makekey response]
+ fetch $key a
+ } else {
+ set key $response(DIODkey)
+ set newkey [$DIO makekey response]
+
+ ## If we have a new key, and the newkey doesn't exist in the
+ ## database, we are moving this record to a new key, so we
+ ## need to delete the old key.
+ if {$key != $newkey} {
+ if {![fetch $newkey a]} {
+ # no record already exists with the new key,
+ # do a special update
+ set_field_values response
+ get_field_values updateArray
+ update_with_explicit_key $key updateArray
+ headers redirect $document
+ return
+ }
+ }
+ }
+
+ # if we got here and array "a" exists, they're trying to alter a key
+ # to a key that already exists
+ if {[array exists a]} {
+ puts "That record already exists in the database."
+ return
+ }
+
+ set_field_values response
+ get_field_values storeArray
+ store storeArray
+ headers redirect $document
+ }
+
+ method Delete {} {
+ if {![fetch $response(query) array]} {
+ puts "That record does not exist in the database."
+ return
+ }
+
+ if {!$confirmdelete} {
+ DoDelete
+ return
+ }
+
+ puts "<CENTER>"
+ puts {<TABLE CLASS="DIODeleteConfirm">}
+ puts "<TR>"
+ puts {<TD COLSPAN=2 CLASS="DIODeleteConfirm">}
+ puts "Are you sure you want to delete this record from the database?"
+ puts "</TD>"
+ puts "</TR>"
+ puts "<TR>"
+ puts {<TD ALIGN="center" CLASS="DIODeleteConfirmYesButton">}
+ set f [::form #auto]
+ $f start
+ foreach fld [array names hidden] {
+ $f hidden $fld -value $hidden($fld)
+ }
+ $f hidden mode -value DoDelete
+ $f hidden query -value $response(query)
+ $f submit submit -value Yes -class DIODeleteConfirmYesButton
+ $f end
+ puts "</TD>"
+ puts {<TD ALIGN="center" CLASS="DIODeleteConfirmNoButton">}
+ set f [::form #auto]
+ $f start
+ foreach fld [array names hidden] {
+ $f hidden $fld -value $hidden($fld)
+ }
+ $f submit submit -value No -class "DIODeleteConfirmNoButton"
+ $f end
+ puts "</TD>"
+ puts "</TR>"
+ puts "</TABLE>"
+ puts "</CENTER>"
+ }
+
+ method DoDelete {} {
+ delete $response(query)
+
+ headers redirect $document
+ }
+
+ method Details {} {
+ if {![fetch $response(query) array]} {
+ puts "That record does not exist in the database."
+ return
+ }
+
+ set_field_values array
+
+ showview
+ }
+
+ method Cancel {} {
+ headers redirect $document
+ }
+
+ ###
+ ## Define variable functions for each variable.
+ ###
+
+ method fields {{list ""}} {
+ if {[lempty $list]} { return $fields }
+ foreach field $list {
+ if {[lsearch $allfields $field] < 0} {
+ return -code error "Field $field does not exist."
+ }
+ }
+ set fields $list
+ }
+
+ method searchfields {{list ""}} {
+ if {[lempty $list]} { return $searchfields }
+ foreach field $list {
+ if {[lsearch $allfields $field] < 0} {
+ return -code error "Field $field does not exist."
+ }
+ }
+ set searchfields $list
+ }
+
+ method rowfields {{list ""}} {
+ if {[lempty $list]} { return $rowfields }
+ foreach field $list {
+ if {[lsearch $allfields $field] < 0} {
+ return -code error "Field $field does not exist."
+ }
+ }
+ set rowfields $list
+ }
+
+ method filter {field {value ""}} {
+ if [string length $value] {
+ set filters($field) [uplevel 1 [list namespace which $value]]
+ } else {
+ if [info exists filters($field)] {
+ return $filters($field)
+ } else {
+ return ""
+ }
+ }
+ }
+
+ method hidden {name {value ""}} {
+ if [string length $value] {
+ set hidden($name) $value
+ } else {
+ if [info exists hidden($name)] {
+ return $hidden($name)
+ } else {
+ return ""
+ }
+ }
+ }
+
+ method DIO {{string ""}} { configvar DIO $string }
+ method DIOResult {{string ""}} { configvar DIOResult $string }
+
+ method title {{string ""}} { configvar title $string }
+ method functions {{string ""}} { configvar functions $string }
+ method pagesize {{string ""}} { configvar pagesize $string }
+ method form {{string ""}} { configvar form $string }
+ method cleanup {{string ""}} { configvar cleanup $string }
+ method confirmdelete {{string ""}} { configvar confirmdelete $string }
+
+ method css {{string ""}} { configvar css $string }
+ method persistentmain {{string ""}} { configvar persistentmain $string }
+ method alternaterows {{string ""}} { configvar alternaterows $string }
+ method allowsort {{string ""}} { configvar allowsort $string }
+ method sortfields {{string ""}} { configvar sortfields $string }
+ method topnav {{string ""}} { configvar topnav $string }
+ method bottomnav {{string ""}} { configvar bottomnav $string }
+ method numresults {{string ""}} { configvar numresults $string }
+ method defaultsortfield {{string ""}} { configvar defaultsortfield $string }
+
+ method rowfunctions {{string ""}} { configvar rowfunctions $string }
+
+ ## OPTIONS ##
+
+ public variable DIO ""
+ public variable DIOResult ""
+
+ public variable title ""
+ public variable fields ""
+ public variable searchfields ""
+ public variable functions "Search List Add Edit Delete Details"
+ public variable pagesize 25
+ public variable form ""
+ public variable cleanup 1
+ public variable confirmdelete 1
+
+ public variable css "diodisplay.css" {
+ if {![lempty $css]} {
+ catch {unset cssArray}
+ read_css_file
+ }
+ }
+
+ public variable persistentmain 1
+ public variable alternaterows 1
+ public variable allowsort 1
+ public variable sortfields ""
+ public variable topnav 1
+ public variable bottomnav 1
+ public variable numresults ""
+ public variable defaultsortfield ""
+
+ public variable rowfields ""
+ public variable rowfunctions "Details Edit Delete"
+
+ public variable response
+ public variable cssArray
+ public variable document ""
+ public variable allfields ""
+ public variable FieldTextMap
+ public variable allfunctions {
+ Search
+ List
+ Add
+ Edit
+ Delete
+ Details
+ Main
+ Save
+ DoDelete
+ Cancel
+ }
+
+ private variable rowcount
+ private variable filters
+ private variable hidden
+
+} ; ## ::itcl::class DIODisplay
+
+catch { ::itcl::delete class ::DIODisplayField }
+
+#
+# DIODisplayField object -- defined for each field we're displaying
+#
+::itcl::class ::DIODisplayField {
+
+ constructor {args} {
+ ## We want to simulate Itcl's configure command, but we want to
+ ## check for arguments that are not variables of our object. If
+ ## they're not, we save them as arguments to the form when this
+ ## field is displayed.
+ import_keyvalue_pairs data $args
+ foreach var [array names data] {
+ if {![info exists $var]} {
+ lappend formargs -$var $data($var)
+ } else {
+ set $var $data($var)
+ }
+ }
+
+ # if text (field description) isn't set, prettify the actual
+ # field name and use that
+ if {[lempty $text]} { set text [pretty [split $name _]] }
+ }
+
+ destructor {
+
+ }
+
+ method destroy {} {
+ ::itcl::delete object $this
+ }
+
+ #
+ # get_css_class - ask the parent DIODIsplay object to look up
+ # a CSS class entry
+ #
+ method get_css_class {tag default class} {
+ return [$display get_css_class $tag $default $class]
+ }
+
+ #
+ # get_css_tag -- set tag to select or textarea if type is select
+ # or textarea, else to input
+ #
+ method get_css_tag {} {
+ switch -- $type {
+ "select" {
+ set tag select
+ }
+ "textarea" {
+ set tag textarea
+ }
+ default {
+ set tag input
+ }
+ }
+ }
+
+ #
+ # pretty -- prettify a list of words by uppercasing the first letter
+ # of each word
+ #
+ method pretty {string} {
+ set words ""
+ foreach w $string {
+ lappend words \
+ [string toupper [string index $w 0]][string range $w 1 end]
+ }
+ return [join $words " "]
+ }
+
+ method configvar {varName string} {
+ if {[lempty $string]} { return [set $varName] }
+ configure -$varName $string
+ }
+
+ #
+ # showview - emit a table row of either DIOViewRow, DIOViewRowAlt,
+ # DIOViewRow-fieldname (this object's field name), or
+ # DIOViewRowAlt-fieldname, a table data field of either
+ # DIOViewHeader or DIOViewHeader-fieldname, and then a
+ # value of class DIOViewField or DIOViewField-fieldname
+ #
+ method showview {{alt ""}} {
+ set class [get_css_class TR DIOViewRow$alt DIOViewViewRow$alt-$name]
+ puts "<TR CLASS=\"$class\">"
+
+ set class [get_css_class TD DIOViewHeader DIOViewHeader-$name]
+ puts "<TD CLASS=\"$class\">$text:</TD>"
+
+ set class [get_css_class TD DIOViewField DIOViewField-$name]
+ puts "<TD CLASS=\"$class\">$value</TD>"
+
+ puts "</TR>"
+ }
+
+ #
+ # showform -- like showview, creates a table row and table data, but
+ # if readonly isn't set, emits a form field corresponding to the type
+ # of this field
+ #
+ method showform {} {
+ puts "<TR>"
+
+ set class [get_css_class TD DIOFormHeader DIOFormHeader-$name]
+ puts "<TD CLASS=\"$class\">$text:</TD>"
+
+ set class [get_css_class TD DIOFormField DIOFormField-$name]
+ puts "<TD CLASS=\"$class\">"
+ if {$readonly} {
+ puts "$value"
+ } else {
+ set tag [get_css_tag]
+ set class [get_css_class $tag DIOFormField DIOFormField-$name]
+
+ if {$type == "select"} {
+ $form select $name -values $values -value $value -class $class
+ } else {
+ eval $form $type $name -value [list $value] $formargs -class $class
+ }
+ }
+ puts "</TD>"
+ puts "</TR>"
+ }
+
+ # methods that give us method-based access to get and set the
+ # object's variables...
+ method display {{string ""}} { configvar display $string }
+ method form {{string ""}} { configvar form $string }
+ method formargs {{string ""}} { configvar formargs $string }
+ method name {{string ""}} { configvar name $string }
+ method text {{string ""}} { configvar text $string }
+ method type {{string ""}} { configvar type $string }
+ method value {{string ""}} { configvar value $string }
+ method readonly {{string ""}} { configvar readonly $string }
+
+ public variable display ""
+ public variable form ""
+ public variable formargs ""
+
+ # values - for fields of type "select" only, the values that go in
+ # the popdown (or whatever) selector
+ public variable values ""
+
+ # name - the field name
+ public variable name ""
+
+ # text - the description text for the field. if not specified,
+ # it's constructed from a prettified version of the field name
+ public variable text ""
+
+ # value - the default value of the field
+ public variable value ""
+
+ # type - the data type of the field
+ public variable type "text"
+
+ # readonly - if 1, we don't allow the value to be changed
+ public variable readonly 0
+
+} ; ## ::itcl::class DIODisplayField
+
+catch { ::itcl::delete class ::DIODisplayField_boolean }
+
+#
+# DIODisplayField_boolen -- superclass of DIODisplayField that overrides
+# a few methods to specially handle booleans
+#
+::itcl::class ::DIODisplayField_boolean {
+ inherit ::DIODisplayField
+
+ constructor {args} {eval configure $args} {
+ eval configure $args
+ }
+
+ method add_true_value {string} {
+ lappend trueValues $string
+ }
+
+ #
+ # showform -- emit a form field for a boolean
+ #
+ method showform {} {
+ puts "<TR>"
+
+ set class [get_css_class TD DIOFormHeader DIOFormHeader-$name]
+ puts "<TD CLASS=\"$class\">$text:</TD>"
+
+ set class [get_css_class TD DIOFormField DIOFormField-$name]
+ puts "<TD CLASS=\"$class\">"
+ if {$readonly} {
+ if {[boolean_value]} {
+ puts $true
+ } else {
+ puts $false
+ }
+ } else {
+ if {[boolean_value]} {
+ $form default_value $name $true
+ } else {
+ $form default_value $name $false
+ }
+ eval $form radiobuttons $name \
+ -values [list "$true $false"] $formargs
+ }
+ puts "</TD>"
+ puts "</TR>"
+ }
+
+ #
+ # showview -- emit a view for a boolean
+ #
+ method showview {{alt ""}} {
+ set class [get_css_class TR DIOViewRow$alt DIOViewRow$alt-$name]
+ puts "<TR CLASS=\"$class\">"
+
+ set class [get_css_class TD DIOViewHeader DIOViewHeader-$name]
+ puts "<TD CLASS=\"$class\">$text:</TD>"
+
+ set class [get_css_class TD DIOViewField DIOViewField-$name]
+ puts "<TD CLASS=\"$class\">"
+ if {[boolean_value]} {
+ puts $true
+ } else {
+ puts $false
+ }
+ puts "</TD>"
+
+ puts "</TR>"
+ }
+
+ #
+ # boolean_value -- return 1 if value is found in the values list, else 0
+ #
+ method boolean_value {} {
+ set val [string tolower $value]
+ if {[lsearch -exact $values $val] > -1} { return 1 }
+ return 0
+ }
+
+ method value {{string ""}} { configvar value $string }
+
+ public variable true "Yes"
+ public variable false "No"
+ public variable values "1 y yes t true on"
+
+ public variable value "" {
+ if {[boolean_value]} {
+ set value $true
+ } else {
+ set value $false
+ }
+ }
+
+} ; ## ::itcl::class ::DIODisplayField_boolean
+
+
--- /dev/null
+package ifneeded DIO 1.0 [list source [file join $dir dio.tcl]]
+package ifneeded DIODisplay 1.0 [list source [file join $dir diodisplay.tcl]]
+package ifneeded dio_Mysql 0.2 [list source [file join $dir dio_Mysql.tcl]]
+package ifneeded dio_Postgresql 0.1 [list source [file join $dir dio_Postgresql.tcl]]
+package ifneeded dio_Sqlite 0.1 [list source [file join $dir dio_Sqlite.tcl]]
+package ifneeded dio_Oracle 0.2 [list source [file join $dir dio_Oracle.tcl]]
--- /dev/null
+# jcp.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# JEP-0114 - Jabber Component Protocol
+#
+
+package require wrapper; # jabberlib
+package require sha1; # tcllib
+package require logger; # tcllib
+
+namespace eval ::xmppd {}
+namespace eval ::xmppd::jcp {
+ variable version 1.0.0
+ variable rcsid {$Id: jcp.tcl,v 1.2 2004/12/08 15:22:11 pat Exp $}
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ component component.example.com
+ secret secret
+ loglevel debug
+ handler {}
+ }
+ }
+
+
+ variable log
+ if {![info exists log]} {
+ set log [logger::init jcp]
+ ${log}::setlevel $options(loglevel)
+ namespace eval $log {
+ variable logfile ""
+ #set logfile [open s2s.log a+]
+ #fconfigure $logfile -buffering line
+ #puts $logfile [string repeat - 72]
+ }
+ proc ${log}::stdoutcmd {level text} {
+ variable service
+ variable logfile
+ set ts [clock format [clock seconds] -format {%H:%M:%S}]
+ if {$logfile != {}} {
+ puts $logfile "\[$ts\] $level $text"
+ }
+ puts stderr $text
+ }
+ proc Log {level msg} {variable log; ${log}::${level} $msg}
+ }
+
+}
+
+proc ::xmppd::jcp::configure {args} {
+ variable options
+ variable log
+ if {[llength $args] < 1} {
+ set r {}
+ foreach opt [lsort [array names options]] {
+ lappend r -$opt $options($opt)
+ }
+ return $r
+ }
+
+ set cget [expr {[llength $args] == 1 ? 1 : 0}]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -component {
+ if {$cget} {
+ return $options(component)
+ } else {
+ set options(component) [Pop args 1]
+ }
+ }
+ -secret {
+ if {$cget} {
+ return $options(secret)
+ } else {
+ set options(secret) [Pop args 1]
+ }
+ }
+ -loglevel {
+ if {$cget} {
+ return $options(loglevel)
+ } else {
+ set options(loglevel) [Pop args 1]
+ ${log}::setlevel $options(loglevel)
+ }
+ }
+ -handler {
+ if {$cget} {
+ return $options(handler)
+ } else {
+ set options(handler) [Pop args 1]
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ set opts [join [lsort [array names options]] ", -"]
+ return -code error "bad option \"$option\":\
+ must be one of -$opts"
+ }
+ }
+ Pop args
+ }
+ return
+}
+
+#
+# component::join target as me
+proc ::xmppd::jcp::create {server {port 5347}} {
+ variable options
+ set sock [socket -async $server $port]
+ set id [namespace current]::[string map {sock jcp} $sock]
+ upvar #0 $id state
+ set state(sock) $sock
+ set state(server) $server
+ set state(component) $options(component)
+ set state(parser) [wrapper::new \
+ [list [namespace current]::OnOpenStream $id] \
+ [list [namespace current]::OnCloseStream $id] \
+ [list [namespace current]::OnInput $id] \
+ [list [namespace current]::OnError $id]]
+ fconfigure $sock -buffering none -blocking 0 \
+ -encoding utf-8 -translation lf
+ fileevent $sock writable [list [namespace current]::Write $id]
+ fileevent $sock readable [list [namespace current]::Read $id]
+ return $id
+}
+
+proc ::xmppd::jcp::destroy {Component} {
+ upvar #0 $Component state
+ WriteTo $state(sock) "</stream:stream>"
+ OnCloseStream $Component
+ return
+}
+
+proc ::xmppd::jcp::route {Component msg} {
+ upvar #0 $Component state
+ WriteTo $state(sock) $msg
+}
+
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::xmppd::jcp::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+proc ::xmppd::jcp::WriteTo {chan data} {
+ Log debug "> $chan $data"
+ puts -nonewline $chan $data
+}
+
+proc ::xmppd::jcp::Write {Component} {
+ upvar #0 $Component state
+ fileevent $state(sock) writable {}
+ set xml "<?xml version='1.0' encoding='utf-8'?>"
+ append xml "<stream:stream xmlns='jabber:component:accept'"
+ append xml " xmlns:stream='http://etherx.jabber.org/streams'"
+ append xml " to='$state(component)'>"
+ WriteTo $state(sock) $xml
+}
+
+proc ::xmppd::jcp::Read {Component} {
+ upvar #0 $Component state
+ if {[eof $state(sock)]} {
+ fileevent $state(sock) readable {}
+ Log notice "! $state(sock) END OF FILE"
+ OnCloseStream $Component
+ return
+ }
+ set xml [read $state(sock)]
+ Log debug "< $state(sock) $xml"
+ wrapper::parse $state(parser) $xml
+}
+
+proc ::xmppd::jcp::OnOpenStream {Component args} {
+ variable options
+ upvar #0 $Component state
+ Log debug "OPEN $Component $args"
+ array set a $args
+ if {[info exists a(id)]} {
+ # JEP0114 3 (2): Server replies with stream header plus stream id.
+ # We must reply with the handshake hash.
+ set state(streamid) $a(id)
+ set reply [sha1::sha1 $state(streamid)$options(secret)]
+ set xml "<handshake>$reply</handshake>"
+ WriteTo $state(sock) $xml
+ } else {
+ Log notice "?????????"
+ }
+}
+
+proc ::xmppd::jcp::OnCloseStream {Component} {
+ upvar #0 $Component state
+ Log debug "CLOSE $Component"
+ catch {close $state(sock)}
+ wrapper::reset $state(parser)
+ unset state
+}
+
+proc ::xmppd::jcp::OnErrorStream {Component code args} {
+ upvar #0 $Component state
+ Log debug "ERROR $Component $code $args"
+ WriteTo $state(sock) "</stream:stream>"
+ OnCloseStream $Component
+}
+
+proc ::xmppd::jcp::OnInput {Component xmllist} {
+ variable options
+ upvar #0 $Component state
+ Log debug "INPUT $Component $xmllist"
+
+ foreach {cmd attr close value children} $xmllist break
+ array set a {xmlns {} from {} to {}}
+ array set a $attr
+
+ switch -exact -- $cmd {
+ features {
+ Log notice "? features $xmllist"
+ }
+ result {
+ Log notice "? result $xmllist"
+ }
+ verify {
+ Log notice "? verify $xmllist"
+ }
+ iq -
+ message -
+ presence {
+ if {$options(handler) ne {}} {
+ eval $options(handler) $xmllist
+ } else {
+ Log error "! No handler defined for \"$cmd\" stanzas"
+ }
+ }
+ default {
+ Log notice "- \"$cmd\" $xmllist"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+package provide xmppd::jcp $::xmppd::jcp::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+This software is copyrighted by Patrick Thoyts.
+The following terms apply to all files associated with the software unless
+explicitly disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
--- /dev/null
+# pkgIndex.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
+#
+# Declare tclxmppd packages.
+#
+# $Id: pkgIndex.tcl,v 1.1 2004/11/28 10:20:34 pat Exp $
+
+package ifneeded xmppd::core 1.0.0 [list source [file join $dir core.tcl]]
+package ifneeded xmppd::s2s 1.0.0 [list source [file join $dir s2s.tcl]]
+package ifneeded xmppd::s2c 1.0.0 [list source [file join $dir s2c.tcl]]
+package ifneeded xmppd::sm 1.0.0 [list source [file join $dir sm.tcl]]
+package ifneeded xmppd::jcp 1.0.0 [list source [file join $dir jcp.tcl]]
+package ifneeded xmppd::wrapper 1.0.0 [list source [file join $dir wrapper.tcl]]
--- /dev/null
+# s2c.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# A Tcl implementation of the Jabber server-to-client protocol.
+# See http://www.jabber.org/
+#
+# RFC 3920 [http://www.ietf.org/rfc/rfc3921.txt]
+# RFC 3921 [http://www.ietf.org/rfc/rfc3921.txt]
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require xmppd::core; # tclxmppd
+package require uuid; # tcllib
+package require sha1; # tcllib
+package require base64; # tcllib
+package require SASL; # tcllib 1.8
+package require dns 1.2.1; # tcllib 1.8
+# optional
+package require tls; # tls
+catch {package require Iocpsock}; # win32 ipv6 support
+
+
+namespace eval ::xmppd {}
+namespace eval ::xmppd::s2c {
+
+ variable version 1.0.0
+ variable rcsid {$Id: s2c.tcl,v 1.5 2006/04/17 10:14:47 pat Exp $}
+
+ namespace export start stop
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ s2c:address {0.0.0.0 5222 :: 5222}
+ s2c:handler {}
+ s2c:authenticate {}
+ }
+ }
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+
+ namespace import -force ::xmppd::configure ::xmppd::cget \
+ ::xmppd::Pop ::xmppd::xmlns ::xmppd::jid
+}
+
+# -------------------------------------------------------------------------
+
+proc ::xmppd::s2c::start {} {
+ variable listeners
+ if {![info exists listeners]} {set listeners {}}
+ set scmd ::socket
+ if {[llength [info commands ::socket2]] > 0} { set scmd ::socket2 }
+ foreach {addr port} [cget -s2c:address] {
+ if {[ip::is ipv6 $addr] && [package provide Iocpsock] == {}} {
+ continue
+ }
+ set srv [$scmd -server [namespace current]::Accept -myaddr $addr $port]
+ lappend listeners $srv
+ Log notice "XMPP s2c listening on $addr:$port ($srv)"
+ }
+ return
+}
+
+proc ::xmppd::s2c::stop {} {
+ variable listeners
+ foreach Channel [info vars [namespace current]::channel*] {
+ Close $Channel
+ }
+ foreach srv $listeners {
+ catch {
+ set info [fconfigure $srv -sockname]
+ close $srv
+ Log notice "XMPP s2c stopped listening on [lindex $info 0]:[lindex $info 2]"
+ } msg
+ puts stderr $msg
+ }
+ set listeners {}
+ return
+}
+
+# -------------------------------------------------------------------------
+
+proc ::xmppd::s2c::_configure {args} {
+ variable options
+ if {[llength $args] < 1} {
+ set r {}
+ foreach opt [lsort [array names options]] {
+ lappend r -$opt $options($opt)
+ }
+ return $r
+ }
+
+ set cget [expr {[llength $args] == 1 ? 1 : 0}]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -s2c:address {
+ if {$cget} {
+ return $options(s2c:address)
+ } else {
+ set options(s2c:address) [Pop args 1]
+ }
+ }
+ -s2c:handler {
+ if {$cget} {
+ return $options(s2c:handler)
+ } else {
+ set options(s2c:handler) [Pop args 1]
+ }
+ }
+ -s2c:authenticate {
+ if {$cget} {
+ return $options(s2c:authenticate)
+ } else {
+ set options(s2c:authenticate) [Pop args 1]
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ return -code error "bad option \"$option\""
+ }
+ }
+ Pop args
+ }
+ return
+}
+
+proc ::xmppd::s2c::route {from to xml} {
+ # find the right channel and put the xml on it.
+ # if there is no channel then it's probably time to support
+ # stored messages.
+ set Channel [FindChannel $to]
+ if {$Channel ne {}} {
+ WriteTo $Channel $xml
+ } else {
+ # FIX ME: create an error and route it to the from jid.
+ Log warn "FIX handling stanzas to disconnected clients"
+ }
+}
+
+# xmppd::s2c::Accept --
+#
+# The Accept procedure is run in response to a new client connection.
+# We create a Channel array to hold all information required to
+# maintain the communications with this client.
+#
+proc ::xmppd::s2c::Accept {chan clientaddr clientport} {
+ variable options
+ Log notice "XMPP s2c accept connect from $clientaddr:$clientport on $chan"
+ set Channel [CreateChannel]
+ upvar #0 $Channel channel
+ set channel(address) $clientaddr
+ set channel(port) $clientport
+ set channel(sock) $chan
+ set channel(state) connected
+ set channel(parser) \
+ [wrapper::new \
+ [list [namespace current]::OnOpenStream $Channel] \
+ [list [namespace current]::OnCloseStream $Channel] \
+ [list [namespace current]::OnInput $Channel] \
+ [list [namespace current]::OnError $Channel] \
+ -namespace 0]
+
+ fconfigure $chan -translation binary -encoding utf-8 \
+ -buffering none -blocking 0
+ fileevent $chan readable [list [namespace current]::Read $Channel]
+}
+
+# xmppd::s2c::CreateChannel --
+#
+# Create a new channel to manage information about a client connection
+# Any per-connection status will be kept here (eg: locale)
+#
+proc ::xmppd::s2c::CreateChannel {} {
+ variable uid
+ set Channel [namespace current]::channel[incr uid]
+ array set $Channel {
+ sock {} address {} port {} jid {} parser {}
+ resource {} state unconnected lang en
+ }
+ return $Channel
+}
+
+# Find a channel by target jid
+proc ::xmppd::s2c::FindChannel {jid} {
+ set r {}
+ set jid [jid !resource $jid]
+ foreach Channel [info vars [namespace current]::channel*] {
+ upvar #0 $Channel channel
+ if {$channel(jid) eq $jid} {
+ lappend r $Channel
+ }
+ }
+ return $r
+}
+
+# xmppd::s2c::Write --
+#
+# Called when the client channnel becomes writable for the first time.
+# We begin basic XMPP comms initialization from the server side.
+# FIX ME: in s2c this could be done in the first OpenStream handler.
+#
+proc ::xmppd::s2c::Write {Channel} {
+ upvar #0 $Channel channel
+ fileevent $channel(sock) writable {}
+ set xml "<?xml version='1.0' encoding='utf-8'?>"
+ append xml "<stream:stream xmlns='jabber:client'"
+ append xml " xmlns:stream='http://etherx.jabber.org/streams'"
+ append xml " version='1.0'>"
+ WriteTo $Channel $xml
+}
+
+# xmppd::s2c::Read --
+#
+# Any data available on the client channel is read here and passed to
+# the XML parser which will then call to the registered handler
+# procedures.
+#
+proc ::xmppd::s2c::Read {Channel} {
+ upvar #0 $Channel channel
+ if {[eof $channel(sock)]} {
+ fileevent $channel(sock) readable {}
+ Log warn "- EOF on $Channel ($channel(sock))"
+ OnCloseStream $Channel
+ }
+ set xml [read $channel(sock)]
+ if {[string length [string trim $xml]] > 0} {
+ Log debug "< $Channel $xml"
+ wrapper::parse $channel(parser) $xml
+ }
+}
+
+# xmppd::s2c::WriteTo --
+#
+# Send a chunk of data to the client (with logging).
+#
+proc ::xmppd::s2c::WriteTo {Channel data} {
+ upvar #0 $Channel channel
+ Log debug "> $Channel $data"
+ puts -nonewline $channel(sock) $data
+}
+
+# Raise --
+#
+# Raise a stream error and close the route.
+#
+proc ::xmppd::s2c::Raise {Channel type {text ""}} {
+ upvar #0 $Channel channel
+ set xml "<stream:error>"
+ append xml "<$type xmlns='[xmlns streams]'/>"
+ if {$text ne ""} {
+ append xml "<text xml:lang='$channel(lang)'\
+ xmlns='[xmlns streams]'>[xmlquote $text]</text>"
+ }
+ append xml "</stream:error>"
+ WriteTo $Channel $xml
+ Close $Channel
+}
+
+# xmppd::s2c::Log
+#
+#
+#
+proc ::xmppd::s2c::Log {level msg} {
+ ::xmppd::Log s2c $level $msg
+}
+
+# Error --
+#
+# Generate the XML body for an error stanza. See section 9.3.2
+#
+proc ::xmppd::s2c::Error {Channel error type {text ""}} {
+ upvar #0 $Channel channel
+ set xml "<error type='$type'>"
+ append xml "<$error xmlns='[xmlns stanzas]'/>"
+ if {$text ne ""} {
+ append xml "<text xml:lang='$channel(lang)' xmlns='xmlns stanzas]'>[xmlquote $text]</text>"
+ }
+ append xml "</error>"
+ return $xml
+}
+
+# Close --
+#
+# Shut down a route. We close the channel and clear up our state.
+#
+# FIX ME: we need to clean up the parser state too -- we currently
+# leak the parsers resources.
+#
+proc ::xmppd::s2c::Close {Channel} {
+ WriteTo $Channel "</stream:stream>"
+ OnCloseStream $Channel
+}
+
+proc xmppd::s2c::xmlquote {s} {
+ variable xmlmap
+ if {![info exists xmlmap]} {
+ set xmlmap {"&" "&" "<" "<" ">" ">" "\"" """ "'" "'"}
+ for {set n 0} {$n < 32} {incr n} {
+ lappend xmlmap [format %c $n] [format "&#%02x;" $n]
+ }
+ }
+ string map $xmlmap $s
+}
+
+# -------------------------------------------------------------------------
+
+proc ::xmppd::s2c::OnOpenStream {Channel args} {
+ variable options
+ upvar #0 $Channel channel
+
+ # RFC3920 4.4.1: no version means assume 0.0
+ array set attr {version 0.0}
+ array set attr $args
+ Log debug "OPENSTREAM $channel(sock) [array get attr]"
+
+ set channel(id) [string map {- {}} [uuid::uuid generate]]
+
+ set xml "<?xml version='1.0' encoding='utf-8'?>"
+ append xml "<stream:stream xmlns='[xmlns client]'\
+ xmlns:stream='[xmlns stream]'\
+ id='$channel(id)' from='[cget -domain]' version='1.0'>"
+
+ # RFC3920 4.6: Stream Features
+ if {$attr(version) >= 1.0} {
+ append xml "<stream:features>"
+ # Check for previous SASL negotiation
+ if {$channel(state) eq "authorized"} {
+ # RFC3920 7: Resource binding
+ append xml "<bind xmlns='[xmlns bind]'/>"
+
+ # Include any registered xmppd features
+ # This may need extending if there are more complex features to do.
+ foreach {name uri} [cget -features] {
+ append xml "<$name xmlns='$uri'/>"
+ }
+ } else {
+ if {[package provide tls] ne {} \
+ && $channel(state) eq "connected" \
+ && [file exists [cget -certfile]] \
+ && [file exists [cget -keyfile]]} {
+ append xml "<starttls xmlns='[xmlns tls]'/>"
+ }
+ # RFC3920 6.1: Use of SASL
+ append xml "<mechanisms xmlns='[xmlns sasl]'>"
+ append xml "<mechanism>DIGEST-MD5</mechanism>"
+ append xml "<mechanism>PLAIN</mechanism>"
+ append xml "</mechanisms>"
+ }
+ append xml "</stream:features>"
+ }
+ WriteTo $Channel $xml
+}
+
+proc ::xmppd::s2c::OnCloseStream {Channel} {
+ upvar #0 $Channel channel
+
+ #foreach Session [FindSession channel $Channel] {
+ # Log debug "closed session $Session"
+ # unset $Session
+ #}
+
+ catch {close $channel(sock)}
+ wrapper::reset $channel(parser)
+ catch {unset channel} msg
+ Log notice "- $Channel closed: $msg"
+}
+
+proc ::xmppd::s2c::OnError {Channel code args} {
+ Log error "- $Channel error $code"
+ WriteTo $Channel "</stream:stream>"
+ OnCloseStream $Channel
+}
+
+# For xmpp service: authzid (login) is the jid authid (username)
+# is the jid node.
+proc ::xmppd::s2c::SASLCallback {Channel context command args} {
+ variable options
+ upvar #0 $Channel channel
+ switch -exact -- $command {
+ password {
+ #Log debug "SASL retrieve password for authid [lindex $args 0] '$args'"
+ set channel(jid) [lindex $args 0]@[cget -domain]
+ return [eval [linsert $args 0 [cget -s2c:authenticate]]]
+ }
+ realm { return [cget -domain] }
+ default {
+ return -code error "SASL callback $command used. Implement it"
+ }
+ }
+}
+
+proc ::xmppd::s2c::SASLSuccess {Channel} {
+ upvar #0 $Channel channel
+ SASL::cleanup $channel(sasl)
+ set channel(state) authorized
+ WriteTo $Channel "<success xmlns='[xmlns sasl]'/>"
+ wrapper::reset $channel(parser)
+}
+
+proc ::xmppd::s2c::SASLFailure {Channel msg} {
+ set xml "<failure xmlns='[xmlns sasl]'><temporary-auth-failure/>"
+ if {$msg ne ""} {
+ append xml "<text>[xmlquote $msg]</text>"
+ }
+ append xml "</failure>"
+ WriteTo $Channel $xml
+ Close $Channel
+}
+
+proc ::xmppd::s2c::OnInput {Channel xmllist} {
+ variable options
+ upvar #0 $Channel channel
+
+ foreach {cmd attr close value children} $xmllist break
+ array set a {xmlns {} from {} to {}}
+ array set a $attr
+
+ switch -exact -- $cmd {
+ starttls {
+ Log debug "- starttls $xmllist"
+ if {[package provide tls] eq {}} {
+ set xml "<failure xmlns='[xmlns tls]'><temporary-auth-failure/></failure>"
+ WriteTo $Channel $xml
+ Close $Channel
+ } else {
+ set xml "<proceed xmlns='[xmlns tls]'/>"
+ set channel(state) tls
+ WriteTo $Channel $xml
+ flush $channel(sock)
+ wrapper::reset $channel(parser)
+ tls::import $channel(sock) -server 1 -tls1 1 -ssl3 1 -ssl2 0 \
+ -keyfile [cget -keyfile] -certfile [cget -certfile]
+ }
+ }
+
+ auth {
+ Log debug "- auth $xmllist"
+ if {$a(xmlns) eq [xmlns sasl]} {
+ set channel(sasl) \
+ [SASL::new -service xmpp -type server \
+ -mechanism $a(mechanism) \
+ -callback [list [namespace origin SASLCallback] $Channel]]
+ if {[catch {set more [SASL::step $channel(sasl) [base64::decode $value]]} err]} {
+ SASLFailure $Channel $err
+ } else {
+ if {$more} {
+ set xml "<challenge xmlns='[xmlns sasl]'>[base64::encode -maxlen 0 [SASL::response $channel(sasl)]]</challenge>"
+ WriteTo $Channel $xml
+ } else {
+ SASLSuccess $Channel
+ }
+ }
+ } else {
+ # FIX ME
+ Raise $Channel fix-me-error
+ }
+ }
+ response {
+ Log debug "- response $xmllist"
+ if {[info exists channel(sasl)] && $channel(sasl) ne ""} {
+ if {[catch {set more [SASL::step $channel(sasl) [base64::decode $value]]} err]} {
+ SASLFailure $Channel $err
+ } else {
+ if {$more} {
+ set xml "<challenge xmlns='[xmlns sasl]'>[base64::encode -maxlen 0 [SASL::response $channel(sasl)]]</challenge>"
+ WriteTo $Channel $xml
+ } else {
+ SASLSuccess $Channel
+ }
+ }
+ } else {
+ Raise $Channel unsupported-stanza-type
+ }
+ }
+
+ abort {
+ Log debug "- abort $xmllist"
+ if {[info exists channel(sasl)] && $channel(sasl) ne ""} {
+ unset channel(sasl)
+ set xml "<failure xmlns='[xmlns sasl]'><aborted/></failure>"
+ WriteTo $Channel $xml
+ Close $Channel
+ } else {
+ Raise $Channel unsupported-stanza-type
+ }
+ }
+
+
+ iq {
+ Log debug "- iq $xmllist { $channel(state) }"
+ if {$channel(state) eq "authorized"} {
+ set bind [lindex [wrapper::getchildwithtaginnamespace \
+ $xmllist bind [xmlns bind]] 0]
+ Log debug "[string repeat - 60]\n$bind\n[string repeat - 60]\n"
+ if {$bind ne {}} {
+ set channel(state) bound
+ set rsrc [lindex [wrapper::getchildswithtag $bind resource] 0]
+ set channel(resource) [wrapper::getcdata $rsrc]
+ Log debug "[string repeat - 60]\n$channel(resource):$rsrc\n[string repeat - 60]\n"
+ if {$channel(resource) eq ""} {
+ set channel(resource) [base64::encode -maxlen 0 [uuid::generate]]
+ }
+ set jid $channel(jid)/$channel(resource)
+ set xml "<iq type='result' id='$a(id)'><bind\
+ xmlns='[xmlns bind]'><jid>$jid</jid></bind></iq>"
+ WriteTo $Channel $xml
+ return
+ } else {
+ Raise $Channel not-authorized
+ return
+ }
+ }
+ Routing $Channel $xmllist
+ }
+
+ message -
+ presence {
+ Routing $Channel $xmllist
+ }
+
+ default {
+ Log debug "- event $xmllist"
+ Raise $Channel unsupported-stanza-type
+ }
+ }
+}
+
+proc ::xmppd::s2c::Routing {Channel xmllist} {
+ # Ensure we always have a from attribute (clients don't have to send one)
+ if {[wrapper::getattribute $xmllist from] eq ""} {
+ upvar #0 $Channel channel
+ set attr [wrapper::getattrlist $xmllist]
+ set jid $channel(jid)
+ if {$channel(resource) ne ""} { append jid /$channel(resource) }
+ set attr [wrapper::setattr $attr from $jid]
+ set xmllist [wrapper::setattrlist $xmllist $attr]
+ }
+
+ Log debug "Routing: $xmllist"
+
+ # stanzas addressed to this server need to be passed to the handler
+ # as do stanzas with no 'to' jid. The rest are routed.
+ set to [wrapper::getattribute $xmllist to]
+ set from [wrapper::getattribute $xmllist from]
+ if {$to eq "" || $to eq [cget -domain]} {
+ Log debug "Routing calling local handler"
+ CallHandler $Channel $xmllist
+ } else {
+ Log debug "Routing route $from $to"
+ xmppd::route $from $to [wrapper::createxml $xmllist]
+ }
+}
+
+proc ::xmppd::s2c::CallHandler {Channel xmllist} {
+ set tag [wrapper::gettag $xmllist]
+ set handler [cget -s2c:handler]
+ if {$handler ne ""} {
+ if {[catch {$handler $xmllist} err]} {
+ Log error "s2c:handler error: $err"
+ }
+ } else {
+ Log error "No handler defined for \"$tag\" stanza"
+ set t [list internal-server-error [list xmlns [xmlns stanzas]] 1]
+ set e [list error {type cancel} 0 {} [list $t]]
+ set r [list $tag {} 0 {} [list $e]]
+ set a [list type error from [wrapper::getattribute $xmllist to] \
+ to [wrapper::getattribute $xmllist from]]
+ if {[set id [wrapper::getattribute $xmllist id]] ne ""} {
+ set a [wrapper::setattr $a id $id]
+ }
+ set r [wrapper::setattrlist $r $a]
+ WriteTo $Channel [wrapper::createxml $r]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+if {[llength [info commands ::xmppd::register]] > 0} {
+ ::xmppd::register module xmppd::s2c
+}
+
+package provide xmppd::s2c $::xmppd::s2c::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
--- /dev/null
+# s2s.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# A Tcl implementation of the Jabber server-to-server protocol.
+# See http://www.jabber.org/
+#
+# RFC 3920 [http://www.ietf.org/rfc/rfc3921.txt]
+# RFC 3921 [http://www.ietf.org/rfc/rfc3921.txt]
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require xmppd::core; # tclxmppd
+package require uuid; # tcllib
+package require sha1; # tcllib
+package require logger; # tcllib
+package require dns 1.2.1; # tcllib 1.8
+
+namespace eval ::xmppd {}
+namespace eval ::xmppd::s2s {
+
+ variable version 1.0.0
+ variable rcsid {$Id: s2s.tcl,v 1.15 2006/04/17 10:14:47 pat Exp $}
+
+ namespace export start stop route
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ s2s:secret secret
+ s2s:address {0.0.0.0 5269 :: 5269}
+ s2s:handler {}
+ }
+ }
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+
+ # Select the first nameserver available (if any)
+ foreach ns [dns::nameservers] {
+ if {[ip::is ipv6 $ns]} { continue }
+ dns::configure -nameserver $ns -protocol tcp
+ break
+ }
+
+ namespace import -force ::xmppd::configure ::xmppd::cget \
+ ::xmppd::Pop ::xmppd::xmlns ::xmppd::jid
+}
+
+# -------------------------------------------------------------------------
+
+proc ::xmppd::s2s::start {} {
+ variable listeners
+ if {![info exists listeners]} {set listeners {}}
+ set scmd ::socket
+ if {[llength [info commands ::socket2]] > 0} { set scmd ::socket2 }
+ foreach {addr port} [cget -s2s:address] {
+ if {[ip::is ipv6 $addr] && [package provide Iocpsock] == {}} {
+ continue
+ }
+ set srv [$scmd -server [namespace current]::Accept -myaddr $addr $port]
+ lappend listeners $srv
+ Log notice "XMPP s2s listening on $addr:$port"
+ }
+ return
+}
+
+proc ::xmppd::s2s::stop {} {
+ variable listeners
+ foreach Channel [info vars [namespace current]::channel*] {
+ Close $Channel
+ }
+ foreach srv $listeners {
+ catch {
+ set info [fconfigure $srv -sockname]
+ close $srv
+ Log notice "XMPP s2s stopped listening on [lindex $info 0]:[lindex $info 2]"
+ } msg
+ puts stderr $msg
+ }
+ set listeners {}
+ return
+}
+
+# -------------------------------------------------------------------------
+
+proc ::xmppd::s2s::_configure {args} {
+ variable options
+ if {[llength $args] < 1} {
+ set r {}
+ foreach opt [lsort [array names options]] {
+ lappend r -$opt $options($opt)
+ }
+ return $r
+ }
+
+ set cget [expr {[llength $args] == 1 ? 1 : 0}]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -s2s:secret {
+ if {$cget} {
+ return $options(s2s:secret)
+ } else {
+ set options(s2s:secret) [Pop args 1]
+ }
+ }
+ -s2s:address {
+ if {$cget} {
+ return $options(s2s:address)
+ } else {
+ set options(s2s:address) [Pop args 1]
+ }
+ }
+ -s2s:handler {
+ if {$cget} {
+ return $options(s2s:handler)
+ } else {
+ set options(s2s:handler) [Pop args 1]
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ return -code error "bad option \"$option\""
+ }
+ }
+ Pop args
+ }
+ return
+}
+
+proc ::xmppd::s2s::route {args} {
+ array set opts {-from {} -to {}}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -to -
+ -from {
+ set jid [jid domain [Pop args 1]]
+ if {[string length $jid] > 0} {
+ puts "$option jid: '$jid'"
+ set opts($option) $jid
+ }
+ }
+ -- { Pop args; break }
+ default { break }
+ }
+ Pop args
+ }
+
+ foreach opt {-from -to} {
+ if {[string length $opts($opt)] < 1} {
+ return -code error "invalid argument \"$opt\":\
+ valid jids are required for both -from and -to"
+ }
+ }
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: must be\
+ \"route -from jid -to jid xml\""
+ }
+ set data [lindex $args 0]
+ if {[string length $data] < 1} {
+ Log warn "[lindex [info level 0] 0] no data to send!"
+ return
+ }
+
+ Queue $opts(-from) $opts(-to) $data
+ return
+}
+
+# look up the IP address for the server of a given JID.
+# This uses the DNS SRV records as described in RFC3920 and
+# falls back to DNS A record resolution if no SRV records.
+proc ::xmppd::s2s::resolve {jid} {
+ set hostname [jid domain $jid]
+ set result {}
+ set port 5269
+ foreach srvd {"_xmpp-server._tcp" "_jabber._tcp"} {
+ set tok [dns::resolve "${srvd}.${hostname}" -type SRV]
+ if {[dns::status $tok] eq "ok"} {
+ set answers {}
+ foreach rr [dns::result $tok] {
+ array set res $rr
+ if {[info exists res(type)] \
+ && $res(type) eq "SRV" \
+ && [llength $res(rdata)] > 0} {
+ lappend answers $res(rdata)
+ }
+ }
+ lsort -index 1 $answers
+ array set rrr [lindex $answers 0]
+ set port $rrr(port)
+ if {[ip::version $rrr(target)] == -1} {
+ set hostname $rrr(target)
+ } else {
+ set result [list $rrr(target) $port]
+ }
+ }
+ dns::cleanup $tok
+ if {[llength $result] > 0} {break}
+ }
+
+ if {[llength $result] == 0} {
+ set tok [dns::resolve $hostname -type A]
+ if {[dns::status $tok] eq "ok"} {
+ set result [list [dns::address $tok] $port]
+ }
+ dns::cleanup $tok
+ }
+
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Holds info about a socket stream.
+# The from and to items are temporary as routes are held on session objects.
+# Once the session is created, we erase the from and to items.
+proc ::xmppd::s2s::CreateChannel {} {
+ variable uid
+ set Channel [namespace current]::channel[incr uid]
+ array set $Channel {sock {} address {} port {} from {} to {} parser {}}
+ return $Channel
+}
+
+# Find a session for a given route
+proc ::xmppd::s2s::FindChannel {dir addr} {
+ foreach Channel [info vars [namespace current]::channel*] {
+ upvar #0 $Channel channel
+ if {$channel(dir) eq $dir && $channel(address) eq $addr} {
+ return $Channel
+ }
+ }
+ return {}
+}
+
+proc ::xmppd::s2s::ListChannels {} {
+ set r {}
+ foreach Channel [info vars [namespace current]::channel*] {
+ upvar #0 $Channel channel
+ lappend r [list [namespace tail $Channel] \
+ $channel(dir) $channel(address)]
+ }
+ return $r
+}
+
+proc ::xmppd::s2s::ListSessions {} {
+ set r {}
+ foreach Session [info vars [namespace current]::session*] {
+ upvar #0 $Session session
+ lappend r [list [namespace tail $Session] \
+ $session(from) $session(to) \
+ [namespace tail $session(channel)]]
+ }
+ return $r
+}
+
+proc ::xmppd::s2s::CreateSession {} {
+ variable uid
+ set Session [namespace current]::session[incr uid]
+ array set $Session {
+ chan {} from {} to {} id {} state new
+ queue {} after {} key {} parser {}
+ }
+ return $Session
+}
+
+# Find a session for a given route
+proc ::xmppd::s2s::FindSession {op args} {
+ set r {}
+ switch -exact -- $op {
+ id {
+ set id [lindex $args 0]
+ foreach Session [info vars [namespace current]::session*] {
+ upvar #0 $Session session
+ if {[info exists session(id)] && $session(id) eq $id} {
+ lappend r $Session
+ break
+ }
+ }
+ }
+ name {
+ foreach {from to} $args break
+ foreach Session [info vars [namespace current]::session*] {
+ upvar #0 $Session session
+ if {[info exists session(from)] && $session(from) eq $from
+ && [info exists session(to)] && $session(to) eq $to} {
+ lappend r $Session
+ Log debug " Found session $r: $from -> $to"
+ break
+ }
+ }
+ }
+ channel {
+ set Channel [lindex $args 0]
+ foreach Session [info vars [namespace current]::session*] {
+ upvar #0 $Session session
+ if {[info exists session(channel)]
+ && $session(channel) eq $Channel} {
+ lappend r $Session
+ }
+ }
+ }
+ default {
+ return -code error "invalid operation \"$op\":\
+ must be one of \"id\", \"name\" or \"channel\""
+ }
+ }
+ return $r
+}
+
+proc ::xmppd::s2s::Queue {from to data} {
+ Log debug "Queue message -from $from -to $to"
+ # Either find an open session or open a new one.
+ set Session [FindSession name $from $to]
+ if {[llength $Session] < 1} {
+ set Channel [Open $from $to]
+ set [set Channel](queue) $data
+ } else {
+ # Queue our message for transmission by this session.
+ upvar #0 $Session session
+ lappend session(queue) $data
+ # schedule xmit if not already scheduled.
+ if {[llength $session(queue)] == 1} {
+ set session(after) \
+ [after 10 [list [namespace current]::Flush $Session]]
+ }
+ }
+ return
+}
+
+proc ::xmppd::s2s::Flush {Session} {
+ upvar #0 $Session session
+ if {![info exists session]} {return}
+ if {[info exists session(channel)]} {
+ upvar #0 $session(channel) channel
+ catch {after cancel $session(after)}
+ if {$session(state) eq "valid"} {
+ set data [lindex $session(queue) 0]
+ if {![catch {WriteTo $session(channel) $data} err]} {
+ Pop session(queue)
+ }
+ }
+ }
+ if {[llength $session(queue)] != 0} {
+ set session(after) \
+ [after 1000 [list [namespace current]::Flush $Session]]
+ }
+ return
+}
+
+# Open
+# Opens a new connection to a jabber server and creates our session state
+#
+# TODO: check for config details per remote site?
+# use DNS to look for the SRV resources.
+proc ::xmppd::s2s::Open {from to} {
+
+ # First, resolve the hostname. If possible we can re-use a connection that
+ # already exists.
+
+ if {[llength [set addr [resolve $to]]] < 1} {
+ return -code error "hostname invalid: \"$to\" failed to resolve ip address"
+ }
+
+ set Channel [FindChannel out [lindex $addr 0]]
+ if {[llength $Channel] < 1} {
+ set Channel [CreateChannel]
+ upvar #0 $Channel channel
+ set channel(dir) out
+ set channel(address) [lindex $addr 0]
+ set channel(port) [lindex $addr 1]
+ set channel(from) $from
+ set channel(to) $to
+ set channel(parser) \
+ [wrapper::new \
+ [list [namespace current]::OnOpenStream $Channel] \
+ [list [namespace current]::OnCloseStream $Channel] \
+ [list [namespace current]::OnInput $Channel] \
+ [list [namespace current]::OnError $Channel] \
+ -namespace 0]
+
+ set sock [socket -async $channel(address) $channel(port)]
+ set channel(sock) $sock
+ fconfigure $sock -buffering none -blocking 0 \
+ -encoding utf-8 -translation lf
+ fileevent $sock writable [list [namespace current]::Write $Channel]
+ fileevent $sock readable [list [namespace current]::Read $Channel]
+ }
+
+ return $Channel
+}
+
+proc ::xmppd::s2s::Accept {chan clientaddr clientport} {
+ variable options
+ Log notice "XMPP s2s accept connect from $clientaddr:$clientport on $chan"
+ # RFC3920 8.3(5): The remote server opens a stream back here based upon
+ # the domain name we provided.
+ set Channel [CreateChannel]
+ upvar #0 $Channel channel
+ set channel(dir) in
+ set channel(address) $clientaddr
+ set channel(port) $clientport
+ set channel(sock) $chan
+ set channel(parser) \
+ [wrapper::new \
+ [list [namespace current]::OnOpenStream $Channel] \
+ [list [namespace current]::OnCloseStream $Channel] \
+ [list [namespace current]::OnInput $Channel] \
+ [list [namespace current]::OnError $Channel] \
+ -namespace 0]
+
+ fconfigure $chan -translation binary -encoding utf-8 \
+ -buffering none -blocking 0
+ fileevent $chan readable [list [namespace current]::Read $Channel]
+}
+
+proc ::xmppd::s2s::Write {Channel} {
+ upvar #0 $Channel channel
+ fileevent $channel(sock) writable {}
+ set xml "<?xml version='1.0' encoding='utf-8'?>"
+ append xml "<stream:stream xmlns='[xmlns server]'"
+ append xml " xmlns:stream='[xmlns stream]'"
+ append xml " xmlns:db='[xmlns dialback]'"
+ append xml " version='1.0'>"
+ WriteTo $Channel $xml
+}
+
+proc ::xmppd::s2s::Read {Channel} {
+ upvar #0 $Channel channel
+ if {[eof $channel(sock)]} {
+ fileevent $channel(sock) readable {}
+ Log warn "- EOF on $Channel ($channel(sock))"
+ OnCloseStream $Channel
+ }
+ set xml [read $channel(sock)]
+ if {[string length [string trim $xml]] > 0} {
+ Log debug "< $channel(sock) $xml"
+ wrapper::parse $channel(parser) $xml
+ }
+}
+
+proc ::xmppd::s2s::WriteTo {Channel data} {
+ upvar #0 $Channel channel
+ Log debug "> $channel(sock) $data"
+ puts -nonewline $channel(sock) $data
+}
+
+
+# Raise --
+#
+# Raise a stream error and close the route.
+#
+proc ::xmppd::s2s::Raise {Channel type args} {
+ # FIX ME - close just the session!?
+ set xml "<stream:error><$type xmlns='[xmlns streams]'/>"
+ WriteTo $Channel $xml
+ Close $Channel
+}
+
+# Close --
+#
+# Shut down a route. We close the channel and clear up our state.
+#
+# FIX ME: we need to clean up the parser state too -- we currently
+# leak the parsers resources.
+#
+proc ::xmppd::s2s::Close {Channel} {
+ # FIX ME - this probably should just close a session.
+ WriteTo $Channel "</stream:stream>"
+ OnCloseStream $Channel
+}
+
+# xmppd::s2s::Log
+#
+#
+#
+proc ::xmppd::s2s::Log {level msg} {
+ ::xmppd::Log s2s $level $msg
+}
+# -------------------------------------------------------------------------
+
+proc ::xmppd::s2s::OnOpenStream {Channel args} {
+ variable options
+ upvar #0 $Channel channel
+
+ array set attr {version 0.0}
+ array set attr $args
+ Log debug "OPENSTREAM $channel(sock) [array get attr]"
+
+ if {[info exists attr(id)]} {
+
+ # RFC3920 8.3(3): Remote server sends up a unique session id.
+ # The from and to elements are optional here.
+ # We must reject invalid namespace.
+ #if {![info exists attr(xmlns)]
+ # || $attr(xmlns) ne "http://etherx.jabber.org/streams"} {
+ # return [Raise $Channel invalid-namespace]
+ #}
+ set Session [CreateSession]
+ upvar #0 $Session session
+ set session(channel) $Channel
+ set session(from) $channel(from)
+ set session(to) $channel(to)
+ set session(id) $attr(id)
+ if {[info exists channel(queue)]} {
+ set session(queue) [list $channel(queue)]
+ }
+ set channel(from) {}; # clean up temporary channel items
+ set channel(to) {}; #
+ set channel(queue) {}
+
+
+ # RFC3920 8.3(4): The Originating Server (us) sends a dialback key
+ # to the Receiving Server (them)
+ #
+ # JID-0185: Dialback key generation and validation
+ #
+ set key "$session(id):$session(to):$session(from):[cget -s2s:secret]"
+ set session(key) [sha1::sha1 $key]
+
+ set xml "<db:result xmlns:db='[xmlns dialback]'\
+ to='$session(to)' from='$session(from)'>$session(key)</db:result>"
+ set session(state) dialback
+ WriteTo $Channel $xml
+
+ } else {
+
+ # RFC3920 8.3(6): The Receiving Server (them) sends the Authoritative
+ # Server (us) a stream header. From and to are
+ # optional. We MUST reject invalid namespaces.
+ # implemented wrong - check that the stream namespace is correct.
+ #if {![info exists attr(xmlns)] || $attr(xmlns) ne [xmlns stream]} {
+ # return [Raise $Channel invalid-namespace]
+ #}
+
+ # RFC3920 8.3(7): The Authoritative Server (us) sends the Receiving
+ # Server (them) a stream header - with a session id
+ # We don't have enough info to create a session, so we store the
+ # id on the channel
+ set channel(id) [string map {- {}} [uuid::uuid generate]]
+
+ set xml "<?xml version='1.0' encoding='utf-8'?>"
+ append xml "<stream:stream xmlns='[xmlns server]'\
+ xmlns:db='[xmlns dialback]' xmlns:stream='[xmlns stream]'\
+ id='$channel(id)' version='1.0'>"
+
+ # RFC3920 4.6: Stream Features
+ if {$attr(version) >= 1.0} {
+ append xml "<stream:features>"
+ # FIX ME: provide tls support then add the feature here
+ append xml "</stream:features>"
+ }
+ WriteTo $Channel $xml
+ }
+}
+
+proc ::xmppd::s2s::OnCloseStream {Channel} {
+ upvar #0 $Channel channel
+
+ foreach Session [FindSession channel $Channel] {
+ Log debug "closed session $Session"
+ unset $Session
+ }
+
+ catch {close $channel(sock)}
+ wrapper::reset $channel(parser)
+ catch {unset channel} msg
+ Log notice "- $Channel closed: $msg"
+}
+
+proc ::xmppd::s2s::OnError {Channel code args} {
+ Log error "- $Channel error $code"
+ WriteTo $Channel "</stream:stream>"
+ OnCloseStream $Channel
+}
+
+proc ::xmppd::s2s::OnInput {Channel xmllist} {
+ variable options
+ upvar #0 $Channel channel
+
+ Log debug "- Input $xmllist"
+ foreach {cmd attr close value children} $xmllist break
+ array set a {xmlns {} from {} to {}}
+ array set a $attr
+
+ switch -exact -- $cmd {
+ features {
+ Log debug "- features $xmllist"
+ }
+ result {
+
+ # RFC3920 8.3: All stanzas MUST include both to and from
+ if {$a(from) eq "" || $a(to) eq ""} {
+ Raise $Channel improper-addressing
+ }
+
+ if {$a(xmlns:db) eq [xmlns dialback]} {
+
+ if {[info exists a(type)]} {
+ # RFC3920 8.3(10): The Receiving Server (them) informs the
+ # Originating Server (us)of the result.
+ set Session [FindSession name $a(from) $a(to)]
+ if {$Session eq {}} {
+ return [Raise $Channel invalid-from]
+ }
+ upvar #0 $Session session
+ set session(state) $a(type)
+ return
+ }
+
+ # RFC3290 8.3(4): The Originating Server (them) sends a
+ # dialback key to the Receiving Server (us)
+ #
+ if {![info exists channel(id)]} {
+ Log error "Argh - no channel id!!"
+ return
+ }
+ set Session [CreateSession]
+ upvar #0 $Session session
+ set session(id) $channel(id)
+ set session(state) dialback
+ set session(channel) $Channel
+ set session(from) $a(from)
+ set session(to) $a(to)
+ set session(key) $value
+
+ # We need to send this key on the out channel with the
+ # out session id, from and to.
+ set Out [FindSession name $a(to) $a(from)]
+ if {$Out ne {}} {
+ upvar #0 $Out out
+ set xml "<db:verify xmlns:db='[xmlns dialback]'\
+ from='$a(to)' to='$a(from)'\
+ id='$session(id)'>$session(key)</db:verify>"
+ WriteTo $out(channel) $xml
+ } else {
+ Log debug "- Creating new out channel to $a(from)"
+ Open $a(to) $a(from)
+ }
+
+ } else {
+ Log error "unespected 'result' namespace'"
+ }
+ }
+ verify {
+ Log debug "- verify $xmllist"
+
+ # RFC3920 8.3: All stanzas MUST include both to and from
+ if {$a(from) eq "" || $a(to) eq ""} {
+ Raise $Channel improper-addressing
+ }
+
+ set Session [FindSession id $a(id)]
+ if {$Session eq {}} {
+ # Raise invalid-id ??
+ Log error "Failed to find session for '$a(id)'"
+ return
+ }
+ upvar #0 $Session session
+ if {$session(from) eq {}} {
+ set session(from) $a(from)
+ set session(to) $a(to)
+ }
+
+ if {![info exists a(type)]} {
+
+ # RFC3920 8.3(8): The Receiving Server (them) sends the
+ # Authoritative Server (us) a request for
+ # verification of a key. This is the id we
+ # recieved in step 3 and its key. So we are
+ # validating the out channel using data
+ # recieved on the in channel.
+ # Lets check the logic
+ if {$Channel eq $session(channel)} {
+ Log error "LOGIC FAILURE"
+ }
+ # RFC 3920 8.3(9): Check the key against the out session
+ set session(state) invalid
+ if {$session(key) eq $value} {
+ set session(state) valid
+ Flush $Session
+ }
+ set xml "<db:verify xmlns:db='[xmlns dialback]'\
+ from='$session(from)' to='$session(to)'\
+ id='$session(id)' type='$session(state)'/>"
+ WriteTo $Channel $xml
+
+ } else {
+
+ # RFC3920 8.3(9): The Authoritative Server (them) verifies the
+ # valididy of the key and posts a message to
+ # the Recieving Server (us).
+ set session(state) $a(type)
+ if {$session(state) eq "valid"} {
+
+ set Peer [FindSession name $a(to) $a(from)]
+ if {$Peer ne {}} {
+ upvar #0 $Peer peer
+
+ Log debug "* sess: [array get session]"
+ Log debug "* peer: [array get peer]"
+
+ set xml "<db:result xmlns:db='[xmlns dialback]'\
+ from='$peer(from)' to='$peer(to)'\
+ type='$a(type)'/>"
+
+ WriteTo $session(channel) $xml
+ } else {
+ # We need to create an outbound connection to go with
+ # this.
+ #Open $a(to) $a(from)
+ # IMPOSSIBLE??
+ Log error "ARGH: 8.3(10) this isnt supposed to happen"
+ }
+
+ } else {
+ Close $Channel
+ }
+ }
+ }
+
+ iq -
+ message -
+ presence {
+ set domain [jid domain $a(to)]
+ if {$domain eq [cget -domain]} {
+ xmppd::route $a(from) $a(to) [wrapper::createxml $xmllist]
+ } else {
+ # error I should think unless we have components
+ if {[set handler [cget -s2s:handler]] ne {}} {
+ eval $handler $xmllist
+ } else {
+ Log error "No handler defined for \"$cmd\" stanzas"
+ }
+ }
+ }
+
+ default {
+ Log debug "- event $xmllist"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+if {[llength [info commands ::xmppd::register]] > 0} {
+ ::xmppd::register module xmppd::s2s
+}
+
+package provide xmppd::s2s $::xmppd::s2s::version
+
+# -------------------------------------------------------------------------
--- /dev/null
+# sm.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# XMPP IM session manager.
+#
+# This module covers management of instant messaging session, roster and
+# XMPP subscription management.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require xmppd::core; # tclxmppd
+package require DIO; # Rivet database access library
+
+namespace eval ::xmppd {
+ namespace eval sm {
+ variable version 1.0.0
+ variable rcsid {$Id$}
+
+ #namespace export
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ sm:database ""
+ sm:db:type Sqlite
+ sm:db:host localhost
+ sm:db:user ""
+ sm:db:pass ""
+ }
+ }
+
+ variable uid
+ if {![info exists uid]} { set uid 0 }
+
+ namespace import -force ::xmppd::configure ::xmppd::cget \
+ ::xmppd::Pop ::xmppd::xmlns ::xmppd::jid ::xmppd::Log
+ }
+}
+
+# s2c channels have a jid and a resource item. However the channel could get closed
+# underneath the session (maybe).
+#
+# Sessions are tied to active resurces - that means the JID MUST have a resource.
+#
+# state: active (after session establishment) available (after initial presence)
+# show: one of dnd chat
+#
+proc ::xmppd::sm::CreateSession {jid} {
+ # Find the s2c channel corresponding to the JID in question
+ set Channel {}
+ set resource [jid resource $jid]
+ foreach chan [xmppd::s2c::FindChannel $jid] {
+ if {[info exists [set chan](resource)] \
+ && [string equal [set [set chan](resource)] $resource]} {
+ set Channel $chan
+ }
+ }
+ if {[llength $Channel] != 1} {
+ return -code error "invalid jid - no channel found"
+ }
+
+ variable uid
+ set Session [namespace current]::session[incr uid]
+ upvar #0 $Channel channel
+ array set $Session [list state active preference 0 show {} status {} \
+ channel $Channel jid $channel(jid) resource $channel(resource)]
+
+ if {[info exists channel(session)]} {
+ # do something about it - we are replacing a session on the same channel?
+ }
+ set channel(session) $Session
+ return $Session
+}
+
+proc ::xmppd::sm::ListSessions {} {
+ set r {}
+ foreach Session [info vars [namespace current]::session*] {
+ upvar #0 $Session session
+ lappend r [list [namespace tail $Session] $session(state) [namespace tail $session(Channel)]]
+ }
+ return $r
+}
+
+proc ::xmppd::sm::FindSession {op args} {
+ set r {}
+ switch -exact -- $op {
+ jid {
+ set jid [xmppd::jid !resource [lindex $args 0]]
+ foreach Session [info vars [namespace current]::session*] {
+ upvar #0 $Session session
+ if {$session(jid) eq $jid} {
+ lappend r $Session
+ }
+ }
+ }
+ default {
+ return -code error "invalid option \"$op\": must be one of jid"
+ }
+ }
+ return $r
+}
+
+proc ::xmppd::sm::_configure {args} {
+ variable options
+ if {[llength $args] < 1} {
+ set r {}
+ foreach opt [lsort [array names options]] {
+ lappend r -$opt $options($opt)
+ }
+ return $r
+ }
+
+ set cget [expr {[llength $args] == 1 ? 1 : 0}]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -sm:database {
+ if {$cget} {
+ return $options(sm:database)
+ } else {
+ set options(sm:database) [Pop args 1]
+ }
+ }
+ -sm:db:type {
+ if {$cget} {
+ return $options(sm:db:type)
+ } else {
+ set options(sm:db:type) [Pop args 1]
+ }
+ }
+ -sm:db:host {
+ if {$cget} {
+ return $options(sm:db:host)
+ } else {
+ set options(sm:db:host) [Pop args 1]
+ }
+ }
+ -sm:db:user {
+ if {$cget} {
+ return $options(sm:db:user)
+ } else {
+ set options(sm:db:user) [Pop args 1]
+ }
+ }
+ -sm:db:pass {
+ if {$cget} {
+ return $options(sm:db:pass)
+ } else {
+ set options(sm:db:pass) [Pop args 1]
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ return -code error "bad option \"$option\""
+ }
+ }
+ Pop args
+ }
+ return
+}
+
+proc ::xmppd::sm::start {} {
+ variable db
+ if {![info exists db]} {
+ set db [DIO::handle [cget -sm:db:type] [namespace current]::db \
+ -host [cget -sm:db:host] \
+ -user [cget -sm:db:user] \
+ -pass [cget -sm:db:pass] \
+ -db [cget -sm:database]]
+ # Check for table already present
+ set r [$db exec {SELECT COUNT(username) FROM authreg;}]
+ if {[$r errorcode] != 0} {
+ puts "Creating databases"
+ set tables(authreg) {username VARCHAR(256),realm VARCHAR(256),
+ password VARCHAR(256),token VARCHAR(10),sequence INTEGER, hash VARCHAR(40)}
+ set tables(roster) {username VARCHAR(256),jid TEXT,state INTEGER}
+ foreach table [array names tables] {
+ set r [$db exec "CREATE TABLE $table ($tables($table));"]
+ if {[$r errorcode] != 0} {
+ return -code error [$r errorinfo]
+ }
+ }
+ set r [$db exec "CREATE INDEX idx_authreg ON authreg(username);"]
+ if {[$r errorcode] != 0} {
+ return -code error [$r errorinfo]
+ }
+ }
+ }
+ return
+}
+
+proc ::xmppd::sm::stop {} {
+ variable db
+ if {[info exists db]} {
+ $db close
+ rename [namespace current]::db {}
+ unset db
+ }
+}
+
+proc ::xmppd::sm::authuser {authid realm} {
+ variable db
+ if {![info exists db]} {
+ return -code error "unexpected: xmppd::sm::start not called"
+ }
+ Log debug "Authenticating $authid $realm..."
+ set r [$db exec "SELECT username,realm,password FROM authreg\
+ WHERE username=[SqlQuote $authid] AND realm=[SqlQuote $realm];"]
+ if {[$r errorcode]} {
+ Log debug "... auth failure [$r errorinfo]"
+ return -code error [$r errorinfo]
+ } else {
+ set res ""
+ $r forall -array f {
+ set res $f(password)
+ }
+ }
+ return $res
+}
+
+proc ::xmppd::sm::SqlQuote {s} {return "'[string map {"'" "''"} $s]'"}
+
+# -------------------------------------------------------------------------
+
+if {[llength [info commands ::xmppd::register]] > 0} {
+ ::xmppd::register module xmppd::sm
+}
+
+package provide xmppd::sm $::xmppd::sm::version
+
+# -------------------------------------------------------------------------
--- /dev/null
+# ctalk.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Simple Jabber text-mode client.
+#
+# This is a simple text-only XMPP client application. You need to have
+# installed jlib (from the Coccinella project - as used by tkchat) and we
+# need some tcllib modules too (SASL, md5, sha1). You might also want to
+# have tls installed but this is not required.
+#
+# $Id$
+
+package require SASL; # tcllib
+package require tls; # tls
+package require sha1; # tcllib
+package require jlib; # jlib
+
+namespace eval ctalk {
+ variable version 1.0.0
+ variable rcsid {$Id$}
+
+ variable App
+ if {![info exists App]} {
+ array set App {
+ user patthoyts
+ server patthoyts.tk
+ password secret
+ connect localhost:5222
+ resource ctalk
+ keepalive 10
+ }
+ }
+}
+
+proc ::ctalk::Log {msg} {
+ set t [clock format [clock seconds] -format "%H:%M:%S"]
+ puts "$t: $msg"
+}
+
+proc ::ctalk::Print {msg} {
+ set t [clock format [clock seconds] -format "%H:%M:%S"]
+ puts "$t: $msg"
+}
+
+proc ::ctalk::Connect {} {
+ variable App
+ set roster [::roster::roster [namespace origin RosterCallback]]
+ set App(conn) [::jlib::new $roster [namespace origin ClientCallback] \
+ -iqcommand [namespace origin IqCallback] \
+ -messagecommand [namespace origin MessageCallback] \
+ -presencecommand [namespace origin PresenceCallback] \
+ -keepalivesecs $App(keepalive)]
+ ::jlib::iq_register $App(conn) get jabber:iq:version \
+ [namespace origin IqVersionCallback] 40
+
+
+ foreach {host port} [split $App(connect) :] break
+ if {$port eq {}} { set port 5222 }
+ set sock [socket $host $port]
+ $App(conn) setsockettransport $sock
+ $App(conn) openstream $App(server) \
+ -cmd [namespace origin ConnectCallback] \
+ -socket $sock -version 1.0
+}
+
+proc ::ctalk::Stop {} {
+ variable App
+ $App(conn) closestream
+}
+
+proc ::ctalk::ConnectCallback {tok args} {
+ variable App
+ upvar ${tok}::lib lib
+ fconfigure $lib(sock) -encoding utf-8
+ jlib::auth_sasl $tok $App(user) $App(resource) $App(password) \
+ [namespace origin LoginCallback]
+}
+
+proc ::ctalk::LoginCallback {tok type msg} {
+ switch -- $type {
+ result {
+ # RFC3921:5.1.1 Initial presence (unless this is done by jlib)
+ $tok send_presence
+ }
+ error {
+ Log "# login $type $msg"
+ Stop
+ }
+ default {
+ Log "! undefined type \"$type\" in LoginCallback"
+ }
+ }
+}
+
+proc ::ctalk::ClientCallback {tok cmd args} {
+ array set a {-body {} -errormsg {}}
+ array set a $args
+ switch -- $cmd {
+ connect {
+ Log "* Connected"
+ }
+ disconnect {
+ Log "* Disconnect"
+ # cleanup and schedule reconnect
+ }
+ networkerror {
+ Log "* Network error: $a(-body)"
+ #cleanup and schedule reconnect
+ }
+ streamerror {
+ Log "* Stream error: $a(-errormsg)"
+ # exit
+ }
+ default {
+ Log "* $cmd $args"
+ }
+ }
+}
+
+proc ::ctalk::RosterCallback {roster what {jid {}} args} {
+ Log "= roster $what $jid $args"
+}
+
+proc ::ctalk::IqVersionCallback {tok from iq args} {
+ variable version
+ array set a {-id 0}
+ array set a $args
+ set ver [list [wrapper::createtag name -chdata "CTalk"] \
+ [wrapper::createtag version -chdata $version] \
+ [wrapper::createtag os -chdata "Tcl [info patchlevel]"]]
+ set x [wrapper::createtag query -attrlist {xmlns jabber:iq:version} \
+ -subtags $ver]
+ jlib::send_iq $tok "result" [list $x] -id $a(-id) -to $from
+ return 1
+}
+
+proc ::ctalk::PresenceCallback {tok type args} {
+ if {[catch [linsert $args 0 PresenceCallback2 $tok $type] err]} {
+ Log "Error: $err"
+ }
+}
+
+proc ::ctalk::PresenceCallback2 {tok type args} {
+ array set a {-from {} -to {} -status {}}
+ array set a $args
+ Log "< presence $type $a(-from) $a(-to) $a(-status)"
+}
+
+proc ::ctalk::IqCallback {tok type args} {
+ if {[catch [linsert $args 0 IqCallback2 $tok $type] err]} {
+ Log "Error: $err"
+ }
+}
+
+proc ::ctalk::IqCallback2 {tok type args} {
+ array set a {-from {} -to {}}
+ array set a $args
+ Log "< iq $type $a(-from) $a(-to)"
+}
+
+proc ::ctalk::MessageCallback {tok type args} {
+ if {[catch [linsert $args 0 MessageCallback2 $tok $type] err]} {
+ Log "Error: $err"
+ }
+}
+
+proc ::ctalk::MessageCallback2 {tok type args} {
+ array set a {-from {} -to {} -subject {} -body {}}
+ array set a $args
+ switch -exact -- $type {
+ chat {
+ Print "$a(-from) $a(-body)"
+ }
+ normal {
+ Print "$a(-from) \"$a(-subject)\"\n $a(-body)"
+ }
+ default {
+ Log "< message $type $a(-from) $a(-to) $args"
+ }
+ }
+}
+
+proc ::ctalk::jid {part jid} {
+ set r {}
+ if {[regexp {^(?:([^@]*)@)?([^/]+)(?:/(.+))?} $jid \
+ -> node domain resource]} {
+ switch -exact -- $part {
+ node { set r $node }
+ domain { set r $domain }
+ resource { set r $resource }
+ !resource { set r ${node}@${domain} }
+ jid { set r $jid }
+ default {
+ return -code error "invalid part \"$part\":\
+ must be one of node, domain, resource or jid."
+ }
+ }
+ }
+ return $r
+}
+
+interp alias {} jid {} ::ctalk::jid
+
+proc say {to message} {
+ variable ::ctalk::App
+ if {[jid node $to] eq {}} {
+ set to $to@$App(server)
+ }
+ $App(conn) send_message $to -type chat -body $message
+}
+
+proc ::ctalk::Main {} {
+ global tcl_platform tcl_interactive tcl_service tk_version
+ #LoadConfig
+
+ # Setup control stream.
+ if {$tcl_platform(platform) eq "unix"} {
+ set cmdloop [file join [file dirname [info script]] .. cmdloop.tcl]
+ puts "Load $cmdloop"
+ if {[file exists $cmdloop]} {
+ source $cmdloop
+ set cmdloop::welcome "CTalk XMPP client"
+ append cmdloop::welcome "\nReady for input"
+ cmdloop::cmdloop
+ }
+ set tcl_interactive 1; # fake it so we can re-source this file
+ }
+
+ # Start the app
+ Connect
+
+ # Loop forever, dealing with Wish or Tclsh
+ if {[info exists tk_version]} {
+ if {[tk windowingsystem] eq "win32"} { console show }
+ wm withdraw .
+ tkwait variable ::forever
+ Stop
+ } else {
+ # Permit running as a Windows service.
+ if {![info exists tcl_service]} {
+ vwait ::forever
+ Stop
+ }
+ }
+}
+
+if {!$tcl_interactive} {
+ set r [catch [linsert $argv 0 ::ctalk::Main] err]
+ if {$r} {puts $errorInfo}
+ exit $r
+}
\ No newline at end of file
--- /dev/null
+-----BEGIN RSA PRIVATE KEY-----
+MIICXAIBAAKBgQC7BYRnAMynksrH7PDIJstZFtLErj20UIwdyC1p//ieAdPAVwH7
+R/L9tIKem6t534tI6fVupr5qxuh3GGuhCLi34ExLnXNZ14GAUWU3hxQd5kv2iunc
+CuXtJez64TWOjUcCgFBHs0A1BBcLVZ8Gm4uyJHngqN74VKbHW7ruDgXQBQIDAQAB
+AoGAMwA+Kxi8trYBNqQWxX5O1eyzbY9WpGWS0ExWliGH2w8Ef986Wxwz15vyQu6Q
+xJuBkFC87X/rTZMQsemm8DNAq+zXBqP1MIS3rWoYNTnpFZ+q2jD/0zO4Dk5CRhHC
+l72NFtuOQwLg2I9S3RYL/utG4uE+fM51oXMB08fDMhDFLAECQQDcMJGpJybJF+9b
+ghewoCq4UG/6/RZ4zLS/aHswZzBEXYPyN8U8LgV02FYsw9FYHLKOPPWBSHFuek2q
+ZEapt1qVAkEA2XAESD08/6CKSertKEvZYrA2LXX+W57ObSfYjoiPVBKvP2luvSWA
+sFAtWrBHfnrxQst/8IxxsLoDwQ1nKcKzsQJBAK3RbXshm/2M9ne/Z6IXngGoBe4V
+UmMD/f9HpE+edbzSMbHJEtsh3U7S5Jwr7Jto9A9S0d8/58N1qs/CnwGk600CQDMs
+adWWlASVg/Zhk+8n6sGPNzD71CE7/tkxx4XEHfdrblM+PRHHAcJ9HC97zVe3F5Dg
+0/uJEjjFjpygyubJLAECQCli3+r+GNDHkWLmKSmCPYyfHnct7aj+OtXaAyMzmvuf
+T24xoVx3eW/L+VbjJZrG4gJD7oS/kCGK6GbFSq4n9Ro=
+-----END RSA PRIVATE KEY-----
+-----BEGIN CERTIFICATE-----
+MIIC/zCCAmigAwIBAgICEAMwDQYJKoZIhvcNAQEEBQAwgYcxCzAJBgNVBAYTAkdC
+MRAwDgYDVQQIEwdFbmdsYW5kMRAwDgYDVQQHEwdCcmlzdG9sMQ0wCwYDVQQKEwRQ
+VENBMQ0wCwYDVQQLEwRQVENBMRUwEwYDVQQDEwxQYXRUaG95dHMgQ0ExHzAdBgkq
+hkiG9w0BCQEWEHBhdEBwYXR0aG95dHMudGswHhcNMDQxMjI3MDMyODM5WhcNMDUx
+MjI3MDMyODM5WjCBmDELMAkGA1UEBhMCVUsxEDAOBgNVBAgTB0VuZ2xhbmQxEDAO
+BgNVBAcTB0JyaXN0b2wxGDAWBgNVBAoTD1pTcGxhdCBTb2Z0d2FyZTENMAsGA1UE
+CxMESU1BUDEbMBkGA1UEAxMSYmlua3kucGF0dGhveXRzLnRrMR8wHQYJKoZIhvcN
+AQkBFhBwYXRAcGF0dGhveXRzLnRrMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB
+gQC7BYRnAMynksrH7PDIJstZFtLErj20UIwdyC1p//ieAdPAVwH7R/L9tIKem6t5
+34tI6fVupr5qxuh3GGuhCLi34ExLnXNZ14GAUWU3hxQd5kv2iuncCuXtJez64TWO
+jUcCgFBHs0A1BBcLVZ8Gm4uyJHngqN74VKbHW7ruDgXQBQIDAQABo2cwZTAfBgNV
+HSMEGDAWgBTzxlZEukGfET5PIWZrPiH+KiXHwzA0BgNVHSUELTArBggrBgEFBQcD
+AQYIKwYBBQUHAwIGCisGAQQBgjcKAwMGCWCGSAGG+EIEATAMBgNVHRMBAf8EAjAA
+MA0GCSqGSIb3DQEBBAUAA4GBACsa74efIz3SvTxsIY/9hBWUA7+iO/A5NgZaAe/J
+b0gM0rLzTIy/gzz+j6c3EBdxBxmwopMOiwLKJKSpShK0+aGGv8bMrixjFGJ/NIrp
+ZygotZLqgi37Cmy/ckcZV93B2eRE6tG8Ui86KAfadtYUTkpJMcckPwaNweYwlxx4
+5LAx
+-----END CERTIFICATE-----
--- /dev/null
+# jabbberd.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Sample Jabber server.
+#
+# This aims to test out the tclxmppd framework by making it possible
+# to try various Jabber clients against this implementation.
+# We will work towards a full RFC3920 and RFC3921 compliant framework.
+#
+# $Id$
+
+set auto_path [linsert $auto_path 0 \
+ [file dirname [file dirname [info script]]]]
+
+package require xmppd::core
+package require xmppd::s2s
+package require xmppd::s2c
+package require xmppd::sm
+
+# handler gets called with the xmllist from wrapper.
+proc Handler {xmllist} {
+ array set a [list to [xmppd::cget -domain] from {} id {}]
+ array set a [wrapper::getattrlist $xmllist]
+
+ switch -exact -- [set type [wrapper::gettag $xmllist]] {
+ iq {
+ # RFC3921 3: Session Establishment
+ set sx [wrapper::getchildwithtaginnamespace $xmllist \
+ session [xmppd::xmlns session]]
+ if {[llength $sx] > 0} {
+ # FIX ME: create a Jabberd session for this connected resource
+ # we can return an error here or disconnect a previous
+ # session. Do a 'sm' module for this?
+ if {[catch {
+ set Session [xmppd::sm::CreateSession $a(from)]
+ set r [list iq [list type result to $a(from) from $a(to) id $a(id)] 1 {} {}]
+ } err]} {
+ set rc {}
+ lappend rc [list session [list xmlns [xmppd::xmlns session]] 1 {} {}]
+ lappend rc [list error {type wait} 0 {} \
+ [list [list internal-server-error [list xmlns [xmppd::xmlns stanzas]] 1 {} {}]]]
+ set r [list iq [list type error to $a(from) from $a(to) id $a(id)] 1 {} $rc]
+ }
+ xmppd::route $a(to) $a(from) [wrapper::createxml $r]
+ return
+ }
+
+ set xml "<iq xmlns='jabber:client' id='$a(id)' to='$a(from)'\
+ from='$a(from)' type='error'><error\
+ xmlns='[xmppd::xmlns stanzas]'/></iq>"
+ xmppd::route $a(to) $a(from) $xml
+ }
+
+ presence {
+ set Session [xmppd::sm::FindSession jid $a(from)]
+ if {[llength $Session] > 0} {
+ set Session [lindex $Session 0]
+ upvar #0 $Session session
+ # Initial presence - feed to sm for broadcast etc
+ # - should be an sm method.
+ if {$session(state) eq "active"} {
+ set session(state) available
+ }
+ set ps [lindex [wrapper::getchildswithtag $xmllist show] 0]
+ if {$ps ne {}} {
+ set session(show) [wrapper::getcdata $ps]
+ }
+ set ps [lindex [wrapper::getchildswithtag $xmllist priority] 0]
+ if {$ps ne {}} {
+ set priority [wrapper::getcdata $ps]
+ if {[string is integer $priority]} {
+ set session(priority) $priority
+ }
+ }
+ } else {
+ Log debug "Hp $xmllist"
+ }
+ }
+
+ message {
+ Log debug "Hm $xmllist"
+ }
+
+ default {
+ Log debug "Hd $xmllist"
+ }
+ }
+}
+
+proc Log {level msg} { puts stderr "$level: $msg" }
+
+proc LoadConfig {} {
+ # FIX ME: should load from a .conf file
+ set cert [file join [file dirname [info script]] jabberd.pem]
+ set db [file join [file dirname [info script]] jabberd.db]
+ xmppd::configure \
+ -domain patthoyts.tk \
+ -loglevel debug \
+ -logfile xmppd.log \
+ -certfile $cert \
+ -keyfile $cert \
+ -s2c:handler ::Handler \
+ -s2c:authenticate ::xmppd::sm::authuser \
+ -sm:db:type Sqlite \
+ -sm:database $db
+
+ xmppd::register feature session [xmppd::xmlns session]
+}
+
+proc start {} {
+ ::xmppd::s2s::start
+ ::xmppd::s2c::start
+ ::xmppd::sm::start
+}
+
+proc stop {} {
+ ::xmppd::sm::stop
+ ::xmppd::s2c::stop
+ ::xmppd::s2s::stop
+}
+
+# -------------------------------------------------------------------------
+
+proc Main {} {
+ global tcl_platform tcl_interactive tcl_service tk_version
+ LoadConfig
+
+ # Setup control stream.
+ if {$tcl_platform(platform) eq "unix"} {
+ set cmdloop [file join [file dirname [info script]] .. cmdloop.tcl]
+ puts "Load $cmdloop"
+ if {[file exists $cmdloop]} {
+ source $cmdloop
+ set cmdloop::welcome "Tcl XMPPD Test Server"
+ append cmdloop::welcome "\nReady for input from %client %port"
+ cmdloop::cmdloop
+ set cmdloop::hosts_allow {127.0.0.1 ::1}
+ cmdloop::listen 0.0.0.0 5448;# could do 0.0.0.0 5441
+ }
+ set tcl_interactive 1; # fake it so we can re-source this file
+ }
+
+ # Begin the component
+ start
+
+ # Loop forever, dealing with Wish or Tclsh
+ if {[info exists tk_version]} {
+ if {[tk windowingsystem] eq "win32"} { console show }
+ wm withdraw .
+ tkwait variable ::forever
+ stop
+ } else {
+ # Permit running as a Windows service.
+ if {![info exists tcl_service]} {
+ vwait ::forever
+ stop
+ }
+ }
+}
+
+if {!$tcl_interactive} {
+ set r [catch [linsert $argv 0 ::Main] err]
+ if {$r} {puts $errorInfo}
+ exit $r
+}
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+################################################################################
+#
+# wrapper.tcl
+#
+# This file defines wrapper procedures. These
+# procedures are called by functions in jabberlib, and
+# they in turn call the TclXML library functions.
+#
+# Seems to be originally written by Kerem HADIMLI, with additions
+# from Todd Bradley. Completely rewritten from scratch by Mats Bengtsson.
+# The algorithm for building parse trees has been completely redesigned.
+# Only some structures and API names are kept essentially unchanged.
+#
+# $Id: wrapper.tcl,v 1.2 2004/12/09 09:12:55 pat Exp $
+#
+# ########################### INTERNALS ########################################
+#
+# The whole parse tree is stored as a hierarchy of lists as:
+#
+# parent = {tag attrlist isempty cdata {child1 child2 ...}}
+#
+# where the childs are in turn a list of identical structure:
+#
+# child1 = {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+# child2 = {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+#
+# etc.
+#
+# ########################### USAGE ############################################
+#
+# NAME
+# wrapper::new - a wrapper for the TclXML parser.
+# SYNOPSIS
+# wrapper::new streamstartcmd streamendcmd parsecmd errorcmd
+# OPTIONS
+# none
+# COMMANDS
+# wrapper::reset wrapID
+# wrapper::createxml xmllist
+# wrapper::createtag tagname ?args?
+# wrapper::getattr attrlist attrname
+# wrapper::setattr attrlist attrname value
+# wrapper::parse id xml
+# wrapper::xmlcrypt chdata
+# wrapper::gettag xmllist
+# wrapper::getattrlist xmllist
+# wrapper::getisempty xmllist
+# wrapper::getcdata xmllist
+# wrapper::getchildren xmllist
+# wrapper::getattribute xmllist attrname
+# wrapper::setattrlist xmllist attrlist
+# wrapper::setcdata xmllist cdata
+# wrapper::splitxml xmllist tagVar attrVar cdataVar childVar
+#
+# ########################### LIMITATIONS ######################################
+#
+# Mixed elements of character data and elements are not working.
+#
+# ########################### CHANGES ##########################################
+#
+# 0.* by Kerem HADIMLI and Todd Bradley
+# 1.0a1 complete rewrite, and first release by Mats Bengtsson
+# 1.0a2 a few fixes
+# 1.0a3 wrapper::reset was not right, -ignorewhitespace,
+# -defaultexpandinternalentities
+# 1.0b1 added wrapper::parse command, configured for expat,
+# return break at stream end
+# 1.0b2 fix to make parser reentrant
+# 030910 added accessor functions to get/set xmllist elements
+# 031103 added splitxml command
+
+package require tdom 0.8
+
+namespace eval wrapper {
+
+ # The public interface.
+ namespace export what
+
+ # Keep all internal data in this array, with 'id' as first index.
+ variable wrapper
+ variable debug 1
+
+ # Running id that is never reused; start from 0.
+ set wrapper(freeid) 0
+
+ # Keep all 'id's in this list.
+ set wrapper(list) {}
+
+ variable xmldefaults {-isempty 1 -attrlist {} -chdata {} -subtags {}}
+}
+
+# wrapper::new --
+#
+# Contains initializations needed for the wrapper.
+# Sets up callbacks via the XML parser.
+#
+# Arguments:
+# streamstartcmd: callback when level one start tag received
+# streamendcmd: callback when level one end tag received
+# parsecmd: callback when level two end tag received
+# errorcmd callback when receiving an error from the XML parser.
+# Must all be fully qualified names.
+#
+# Results:
+# A unique wrapper id.
+
+proc wrapper::new {streamstartcmd streamendcmd parsecmd errorcmd args} {
+ variable wrapper
+ variable debug
+
+ if {$debug > 1} {
+ puts "wrapper::new"
+ }
+
+ set parseropt "-namespace"
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -namespace {
+ if {[lindex $args 1] == 0} {
+ set parseropt ""
+ }
+ set args [lrange $args 1 end]
+ }
+ }
+ set args [lrange $args 1 end]
+ }
+
+ # Handle id of the 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,errorcmd) $errorcmd
+
+ # Create the actual XML parser. It is created in our present namespace,
+ # at least for the tcl parser!!!
+ set wrapper($id,parser) [eval [linsert $parseropt 0 xml::parser]]
+ set wrapper($id,class) "expat"
+ $wrapper($id,parser) configure \
+ -final 0 \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id] \
+ -ignorewhitespace 1
+
+ puts "parser namespace handling: [$wrapper($id,parser) cget -namespace]"
+
+ # Current level; 0 before root tag; 1 just after root tag, 2 after
+ # command tag, etc.
+ set wrapper($id,level) 0
+ set wrapper($id,levelonetag) {}
+
+ # Level 1 is the main tag, <stream:stream>, and level 2
+ # is the command tag, such as <message>. We don't handle level 1 xmldata.
+ set wrapper($id,tree,2) {}
+ return $id
+}
+
+# wrapper::parse --
+#
+# For parsing xml.
+#
+# Arguments:
+# id: the wrapper id.
+# xml: raw xml data to be parsed.
+#
+# Results:
+# none.
+
+proc wrapper::parse {id xml} {
+ variable wrapper
+
+ # This is not as innocent as it looks; the 'tcl' parser proc is created in
+ # the creators namespace (wrapper::), but the 'expat' parser ???
+ set parser $wrapper($id,parser)
+ parsereentrant $parser $xml
+ return {}
+}
+
+# Reentrant xml parser wrapper. This ought to go in the parser!
+
+namespace eval wrapper {
+
+ # A reference counter for reentries.
+ variable refcount 0
+
+ # Stack for xml.
+ variable stack ""
+}
+
+# wrapper::parsereentrant --
+#
+# Forces parsing to be serialized in an event driven environment.
+# If we read xml from socket and happen to trigger a read (and parse)
+# event right from an element callback, everyhting will be out of sync.
+#
+# Arguments:
+# p: the parser.
+# xml: raw xml data to be parsed.
+#
+# Results:
+# none.
+
+proc wrapper::parsereentrant {p xml} {
+ variable refcount
+ variable stack
+
+ incr refcount
+ if {$refcount == 1} {
+
+ # This is the main entry: do parse original xml.
+ $p parse $xml
+
+ # Parse everything on the stack (until empty?).
+ while {[string length $stack] > 0} {
+ set tmpstack $stack
+ set stack ""
+ $p parse $tmpstack
+ }
+ } else {
+
+ # Reentry, put on stack for delayed execution.
+ append stack $xml
+ }
+ incr refcount -1
+ return {}
+}
+
+# wrapper::elementstart --
+#
+# Callback proc for all element start.
+#
+# Arguments:
+# id: the wrapper id.
+# tagname: the element (tag) name.
+# attrlist: list of attributes {key value key value ...}
+# args: additional arguments given by the parser.
+#
+# Results:
+# none.
+
+proc wrapper::elementstart {id tagname attrlist args} {
+ variable wrapper
+ variable debug
+
+ if {$debug > 1} {
+ puts "wrapper::elementstart id=$id, tagname=$tagname, \
+ attrlist='$attrlist', args=$args"
+ }
+
+ # Check args, to see if empty element and/or namespace.
+ # Put xmlns in attribute list.
+ array set argsarr $args
+ set isempty 0
+ if {[info exists argsarr(-empty)]} {
+ set isempty $argsarr(-empty)
+ }
+ if {[info exists argsarr(-namespacedecls)]} {
+ lappend attrlist xmlns [lindex $argsarr(-namespacedecls) 0]
+ }
+
+ if {[set ndx [string last : $tagname]] != -1} {
+ set ns [string range $tagname 0 [expr {$ndx - 1}]]
+ set tagname [string range $tagname [incr ndx] end]
+ lappend attrlist xmlns $ns
+ if {$debug > 1} {
+ puts " exploded [list $ns $tagname]"
+ }
+ }
+
+ if {$wrapper($id,level) == 0} {
+
+ # We got a root tag, such as <stream:stream>
+ set wrapper($id,level) 1
+ set wrapper($id,levelonetag) $tagname
+ set wrapper($id,tree,1) [list $tagname $attrlist $isempty {} {}]
+
+ # Do the registered callback at the global level.
+ uplevel #0 $wrapper($id,streamstartcmd) $attrlist
+
+ } else {
+
+ # This is either a level 2 command tag, such as 'presence', 'iq', or 'message',
+ # or we have got a new tag beyond level 2.
+ # It is time to start building the parse tree.
+ set level [incr wrapper($id,level)]
+ set wrapper($id,tree,$level) [list $tagname $attrlist $isempty {} {}]
+ }
+}
+
+# wrapper::elementend --
+#
+# Callback proc for all element ends.
+#
+# Arguments:
+# id: the wrapper id.
+# tagname: the element (tag) name.
+# args: additional arguments given by the parser.
+#
+# Results:
+# none.
+
+proc wrapper::elementend {id tagname args} {
+ variable wrapper
+ variable debug
+
+ if {$debug > 1} {
+ puts "wrapper::elementend id=$id, tagname=$tagname, \
+ args='$args', level=$wrapper($id,level)"
+ }
+
+ # Check args, to see if empty element
+ set isempty 0
+ set ind [lsearch $args {-empty}]
+ if {$ind >= 0} {
+ set isempty [lindex $args [expr {$ind + 1}]]
+ }
+ if {$wrapper($id,level) == 1} {
+
+ # End of the root tag (</stream:stream>).
+ # Do the registered callback at the global level.
+ uplevel #0 $wrapper($id,streamendcmd)
+
+ incr wrapper($id,level) -1
+
+ # We are in the middle of parsing, need to break.
+ reset $id
+ return -code 3
+ } else {
+
+ # We are finshed with this child tree.
+ set childlevel $wrapper($id,level)
+
+ # Insert the child tree in the parent tree.
+ set level [incr wrapper($id,level) -1]
+ append_child $id $level $wrapper($id,tree,$childlevel)
+
+ if {$level == 1} {
+
+ # We've got an end tag of a command tag, and it's time to
+ # deliver our parse tree to the registered callback proc.
+ uplevel #0 "$wrapper($id,parsecmd) [list $wrapper($id,tree,2)]"
+ }
+ }
+}
+
+# wrapper::append_child --
+#
+# Inserts a child element data in level temp data.
+#
+# Arguments:
+# id: the wrapper id.
+# level: the parent level, child is level+1.
+# childtree: the tree to append.
+#
+# Results:
+# none.
+
+proc wrapper::append_child {id level childtree} {
+ variable wrapper
+ variable debug
+
+ if {$debug > 1} {
+ puts "wrapper::append_child id=$id, level=$level, childtree='$childtree'"
+ }
+
+ # Get child list at parent level (level).
+ set childlist [lindex $wrapper($id,tree,$level) 4]
+ lappend childlist $childtree
+
+ # Build the new parent tree.
+ set wrapper($id,tree,$level) [lreplace $wrapper($id,tree,$level) 4 4 \
+ $childlist]
+}
+
+# wrapper::chdata --
+#
+# Appends character data to the tree level xml chdata.
+# It makes also internal entity replacements on character data.
+# Callback from the XML parser.
+#
+# Arguments:
+# id: the wrapper id.
+# chardata: the character data.
+#
+# Results:
+# none.
+
+proc wrapper::chdata {id chardata} {
+ variable wrapper
+ variable debug
+
+ if {$debug > 2} {
+ puts "wrapper::chdata id=$id, chardata='$chardata', \
+ level=$wrapper($id,level)"
+ }
+ set level $wrapper($id,level)
+
+ # If we receive CHDATA before any root element,
+ # or after the last root element, discard.
+ if {$level <= 0} {
+ return
+ }
+ set chdata [lindex $wrapper($id,tree,$level) 3]
+
+ # Make standard entity replacements.
+ append chdata [xmldecrypt $chardata]
+ set wrapper($id,tree,$level) \
+ [lreplace $wrapper($id,tree,$level) 3 3 "$chdata"]
+}
+
+# wrapper::reset --
+#
+# Resets the wrapper and XML parser to be prepared for a fresh new
+# document.
+# If done while parsing be sure to return a break (3) from callback.
+#
+# Arguments:
+# id: the wrapper id.
+#
+# Results:
+# none.
+
+proc wrapper::reset {id} {
+ variable wrapper
+ variable debug
+
+ if {$debug > 1} {
+ puts "wrapper::reset id=$id"
+ }
+
+ if {0} {
+
+ # This resets the actual XML parser. Not sure this is actually needed.
+ $wrapper($id,parser) reset
+ if {$debug > 1} {
+ puts " wrapper::reset configure parser"
+ }
+
+ $wrapper($id,parser) configure \
+ -final 0 \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id] \
+ -ignorewhitespace 1
+
+ }
+
+ # Cleanup internal state vars.
+ set lev 2
+ while {[info exists wrapper($id,tree,$lev)]} {
+ unset wrapper($id,tree,$lev)
+ incr lev
+ }
+
+ # Reset also our internal wrapper to its initial position.
+ set wrapper($id,level) 0
+ set wrapper($id,levelonetag) {}
+ set wrapper($id,tree,2) {}
+}
+
+# wrapper::xmlerror --
+#
+# Callback from the XML parser when error received. Resets wrapper,
+# and makes a 'streamend' command callback.
+#
+# Arguments:
+# id: the wrapper id.
+#
+# Results:
+# none.
+
+proc wrapper::xmlerror {id args} {
+ variable wrapper
+ variable debug
+
+ if {$debug > 1} {
+ puts "wrapper::xmlerror id=$id, args='$args'"
+ }
+
+ # Resets the wrapper and XML parser to be prepared for a fresh new document.
+ #reset $id
+ #uplevel #0 $wrapper($id,errorcmd) [list $args] ????
+ uplevel #0 $wrapper($id,errorcmd) $args
+ #reset $id
+ return -code error {Fatal XML error}
+}
+
+# wrapper::createxml --
+#
+# Creates raw xml data from a hierarchical list of xml code.
+# This proc gets called recursively for each child.
+# It makes also internal entity replacements on character data.
+# Mixed elements aren't treated correctly generally.
+#
+# Arguments:
+# xmllist a list of xml code in the format described in the header.
+#
+# Results:
+# raw xml data.
+
+proc wrapper::createxml {xmllist} {
+
+ # Extract the XML data items.
+ foreach {tag attrlist isempty chdata childlist} $xmllist {break}
+ set rawxml "<$tag"
+ foreach {attr value} $attrlist {
+ append rawxml " ${attr}='${value}'"
+ }
+ if {$isempty} {
+ append rawxml "/>"
+ } else {
+ append rawxml ">"
+
+ # Call ourselves recursively for each child element.
+ # There is an arbitrary choice here where childs are put before PCDATA.
+ foreach child $childlist {
+ append rawxml [createxml $child]
+ }
+
+ # Make standard entity replacements.
+ if {[string length $chdata]} {
+ append rawxml [xmlcrypt $chdata]
+ }
+ append rawxml "</$tag>"
+ }
+ return $rawxml
+}
+
+# wrapper::createtag --
+#
+# Build an element list given the tag and the args.
+#
+# Arguments:
+# tagname: the name of this element.
+# args:
+# -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)
+# -attrlist {attr1 value1 attr2 value2 ..} Vars is a list
+# consisting of attr/value pairs, as shown.
+# -chdata $chdata ChData of tag (default: "").
+# -subtags {$subchilds $subchilds ...} is a list containing xmldata
+# of $tagname's subtags. (default: no sub-tags)
+#
+# Results:
+# a list suitable for wrapper::createxml.
+
+proc wrapper::createtag {tagname args} {
+ variable xmldefaults
+
+ # Fill in the defaults.
+ array set xmlarr $xmldefaults
+
+ # Override the defults with actual values.
+ if {[llength $args] > 0} {
+ array set xmlarr $args
+ }
+ if {!(($xmlarr(-chdata) == "") && ($xmlarr(-subtags) == ""))} {
+ set xmlarr(-isempty) 0
+ }
+
+ # Build sub elements list.
+ set sublist {}
+ foreach child $xmlarr(-subtags) {
+ lappend sublist $child
+ }
+ set xmllist [list $tagname $xmlarr(-attrlist) $xmlarr(-isempty) \
+ $xmlarr(-chdata) $sublist]
+ return $xmllist
+}
+
+# wrapper::getattr --
+#
+# This proc returns the value of 'attrname' from 'attrlist'.
+#
+# Arguments:
+# attrlist: a list of key value pairs for the attributes.
+# attrname: the name of the attribute which value we query.
+#
+# Results:
+# value of the attribute or empty.
+
+proc wrapper::getattr {attrlist attrname} {
+
+ foreach {attr val} $attrlist {
+ if {[string equal $attr $attrname]} {
+ return $val
+ }
+ }
+ return {}
+}
+
+proc wrapper::getattribute {xmllist attrname} {
+
+ foreach {attr val} [lindex $xmllist 1] {
+ if {[string equal $attr $attrname]} {
+ return $val
+ }
+ }
+ return {}
+}
+
+proc wrapper::isattr {attrlist attrname} {
+
+ foreach {attr val} $attrlist {
+ if {[string equal $attr $attrname]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+proc wrapper::isattribute {xmllist attrname} {
+
+ foreach {attr val} [lindex $xmllist 1] {
+ if {[string equal $attr $attrname]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+proc wrapper::setattr {attrlist attrname value} {
+
+ array set attrArr $attrlist
+ set attrArr($attrname) $value
+ return [array get attrArr]
+}
+
+# wrapper::gettag, getattrlist, getisempty, ,getcdata, getchildren --
+#
+# Accessor functions for 'xmllist'.
+# {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+#
+# Arguments:
+# xmllist: an xml hierarchical list.
+#
+# Results:
+# list of childrens if any.
+
+proc wrapper::gettag {xmllist} {
+ return [lindex $xmllist 0]
+}
+
+proc wrapper::getattrlist {xmllist} {
+ return [lindex $xmllist 1]
+}
+
+proc wrapper::getisempty {xmllist} {
+ return [lindex $xmllist 2]
+}
+
+proc wrapper::getcdata {xmllist} {
+ return [lindex $xmllist 3]
+}
+
+proc wrapper::getchildren {xmllist} {
+ return [lindex $xmllist 4]
+}
+
+proc wrapper::splitxml {xmllist tagVar attrVar cdataVar childVar} {
+
+ foreach {tag attr empty cdata children} $xmllist break
+ uplevel 1 [list set $tagVar $tag]
+ uplevel 1 [list set $attrVar $attr]
+ uplevel 1 [list set $cdataVar $cdata]
+ uplevel 1 [list set $childVar $children]
+}
+
+proc wrapper::getchildswithtag {xmllist tag} {
+
+ set clist {}
+ foreach celem [lindex $xmllist 4] {
+ if {[string equal [lindex $celem 0] $tag]} {
+ lappend clist $celem
+ }
+ }
+ return $clist
+}
+
+proc wrapper::getchildwithtaginnamespace {xmllist tag ns} {
+
+ set clist {}
+ foreach celem [lindex $xmllist 4] {
+ if {[string equal [lindex $celem 0] $tag]} {
+ unset -nocomplain attrArr
+ array set attrArr [lindex $celem 1]
+ if {[info exists attrArr(xmlns)] && \
+ [string equal $attrArr(xmlns) $ns]} {
+ lappend clist $celem
+ break
+ }
+ }
+ }
+ return $clist
+}
+
+proc wrapper::getfromchilds {childs tag} {
+
+ set clist {}
+ foreach celem $childs {
+ if {[string equal [lindex $celem 0] $tag]} {
+ lappend clist $celem
+ }
+ }
+ return $clist
+}
+
+proc wrapper::getnamespacefromchilds {childs tag ns} {
+
+ set clist {}
+ foreach celem $childs {
+ if {[string equal [lindex $celem 0] $tag]} {
+ unset -nocomplain attrArr
+ array set attrArr [lindex $celem 1]
+ if {[info exists attrArr(xmlns)] && \
+ [string equal $attrArr(xmlns) $ns]} {
+ lappend clist $celem
+ break
+ }
+ }
+ }
+ return $clist
+}
+
+proc wrapper::setattrlist {xmllist attrlist} {
+
+ return [lreplace $xmllist 1 1 $attrlist]
+}
+
+proc wrapper::setcdata {xmllist cdata} {
+
+ return [lreplace $xmllist 3 3 $cdata]
+}
+
+proc wrapper::setchildlist {xmllist childlist} {
+
+ return [lreplace $xmllist 4 4 $childlist]
+}
+
+# wrapper::xmlcrypt --
+#
+# Makes standard XML entity replacements.
+#
+# Arguments:
+# chdata: character data.
+#
+# Results:
+# chdata with XML standard entities replaced.
+
+proc wrapper::xmlcrypt {chdata} {
+
+ foreach from {\& < > {"} {'}} \
+ to {{\&} {\<} {\>} {\"} {\'}} {
+ regsub -all $from $chdata $to chdata
+ }
+ return $chdata
+}
+
+# wrapper::xmldecrypt --
+#
+# Replaces the XML standard entities with real characters.
+#
+# Arguments:
+# chdata: character data.
+#
+# Results:
+# chdata without any XML standard entities.
+
+proc wrapper::xmldecrypt {chdata} {
+
+ foreach from {{\&} {\<} {\>} {\"} {\'}} \
+ to {{\&} < > {"} {'}} {
+ regsub -all $from $chdata $to chdata
+ }
+ return $chdata
+}
+
+# wrapper::parse_xmllist_to_array --
+#
+# Takes a hierarchical list of xml data and parses the character data
+# into array elements. The array key of each element is constructed as:
+# rootTag_subTag_subSubTag.
+# Repetitative elements are not parsed correctly.
+# Mixed elements of chdata and tags are not allowed.
+# This is typically called without a 'key' argument.
+#
+# Arguments:
+# xmllist: a hierarchical list of xml data as defined above.
+# arrName:
+# key: (optional) the rootTag, typically only used internally.
+#
+# Results:
+# none. Array elements filled.
+
+proc wrapper::parse_xmllist_to_array {xmllist arrName {key {}}} {
+
+ upvar #0 $arrName locArr
+
+ # Return if empty element.
+ if {[lindex $xmllist 2]} {
+ return
+ }
+ if {[string length $key]} {
+ set und {_}
+ } else {
+ set und {}
+ }
+
+ set childs [lindex $xmllist 4]
+ if {[llength $childs]} {
+ foreach c $childs {
+ set newkey "${key}${und}[lindex $c 0]"
+
+ # Call ourselves recursively.
+ parse_xmllist_to_array $c $arrName $newkey
+ }
+ } else {
+
+ # This is a leaf of the tree structure.
+ set locArr($key) [lindex $xmllist 3]
+ }
+ return {}
+}
+
+#-------------------------------------------------------------------------------
+
+package provide xmppd::wrapper 1.0.0
+
+# -------------------------------------------------------------------------
+
projects / tclxmppd.git / commitdiff