From: Pat Thoyts Date: Thu, 3 Aug 2006 23:52:17 +0000 (+0000) Subject: Imported code into Google SVN repository. Incuded DIO from Apache Rivet to X-Git-Url: http://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=2a49945050ae2d307a29b98f71aa30868eca4c4a;p=tclxmppd.git Imported code into Google SVN repository. Incuded DIO from Apache Rivet to simplify testing (Apache license for this stuff). --- 2a49945050ae2d307a29b98f71aa30868eca4c4a diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..fe29753 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,97 @@ +2006-08-04 Pat Thoyts + + * sm.tcl: Authentication via DIO to database. + * dio/*: Brought in modified DIO from Apache Rivet. + +2006-04-16 Pat Thoyts + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * ijbridge.conf.sample: NEW sample config file for ijbridge. + * ijbridge.tcl: Various nick presence cleanups. + +2004-11-28 Pat Thoyts + + * 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 + + * ijbridge.tcl: Bridge script now links IRC and S2S successfully. + +2004-11-25 Pat Thoyts + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * s2s.tcl: Still not complete. Reconfigured big time. + +2004-11-18 Pat Thoyts + + * s2s.tcl: NEW file: Jabber server to server daemon. diff --git a/cmdloop.tcl b/cmdloop.tcl new file mode 100644 index 0000000..e8d7b6c --- /dev/null +++ b/cmdloop.tcl @@ -0,0 +1,102 @@ +# cmdloop.tcl - Copyright (C) 2005 Pat Thoyts +# +# $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: diff --git a/core.tcl b/core.tcl new file mode 100644 index 0000000..199c714 --- /dev/null +++ b/core.tcl @@ -0,0 +1,280 @@ +# core.tcl - Copyright (C) 2006 Pat Thoyts +# +# 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: + diff --git a/demos/chime.conf.sample b/demos/chime.conf.sample new file mode 100644 index 0000000..d92eba3 --- /dev/null +++ b/demos/chime.conf.sample @@ -0,0 +1,20 @@ +# 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 diff --git a/demos/chime.tcl b/demos/chime.tcl new file mode 100644 index 0000000..364e39d --- /dev/null +++ b/demos/chime.tcl @@ -0,0 +1,348 @@ +#!/usr/bin/env tclsh +# chime.tcl - Copyright (C) 2005 Pat Thoyts +# +# 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 +} diff --git a/dio/dio.tcl b/dio/dio.tcl new file mode 100644 index 0000000..2f426c0 --- /dev/null +++ b/dio/dio.tcl @@ -0,0 +1,829 @@ +# 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 diff --git a/dio/dio_Mysql.tcl b/dio/dio_Mysql.tcl new file mode 100644 index 0000000..87318cd --- /dev/null +++ b/dio/dio_Mysql.tcl @@ -0,0 +1,188 @@ +# 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 + +} diff --git a/dio/dio_Oracle.tcl b/dio/dio_Oracle.tcl new file mode 100644 index 0000000..3737a16 --- /dev/null +++ b/dio/dio_Oracle.tcl @@ -0,0 +1,240 @@ +# 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:
" + if {[catch {$cmd $_cur $req} error]} { +#puts "ORA:error:$error:
" + 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 + +} diff --git a/dio/dio_Postgresql.tcl b/dio/dio_Postgresql.tcl new file mode 100644 index 0000000..af6a6a9 --- /dev/null +++ b/dio/dio_Postgresql.tcl @@ -0,0 +1,169 @@ +# 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 + +} diff --git a/dio/dio_Sqlite.tcl b/dio/dio_Sqlite.tcl new file mode 100644 index 0000000..a8ed6bb --- /dev/null +++ b/dio/dio_Sqlite.tcl @@ -0,0 +1,331 @@ +# 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 +} diff --git a/dio/diodisplay.tcl b/dio/diodisplay.tcl new file mode 100644 index 0000000..b5e3ee6 --- /dev/null +++ b/dio/diodisplay.tcl @@ -0,0 +1,1305 @@ +# 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 "An error has occurred processing your request" + puts "
"
+	puts "$error"
+	puts ""
+	puts "$::errorInfo"
+	puts "
" + } + + # + # 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 "" + } + + # put out the table header + puts {} + puts "" + puts {" + puts "" + puts "
} + + # 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 "
" + + if {$cleanup} { destroy } + } + + method showview {} { + puts {} + set row 0 + foreach field $fields { + $field showview [lindex {"" "Alt"} $row] + set row [expr 1 - $row] + } + puts "
" + } + + # + # 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 {} + } + + method showform_epilog {} { + set save [button_image_src DIOFormSaveButton] + set cancel [button_image_src DIOFormCancelButton] + + puts "
" + + puts "" + puts "" + puts "" + puts "" + puts "" + puts "
" + if {![lempty $save]} { + $form image save -src $save -class DIOFormSaveButton + } else { + $form submit save.x -value "Save" -class DIOFormSaveButton + } + puts "" + if {![lempty $cancel]} { + $form image cancel -src $cancel -class DIOFormSaveButton + } else { + $form submit cancel.x -value "Cancel" -class DIOFormCancelButton + } + puts "
" + + $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 {$n" + lappend navbar $html + } + } + + if {"$end" == "Bottom"} { + puts "
" + } + set class [get_css_class TABLE DIONavButtons ${pref}NavButtons] + puts "" + puts "" + puts "" + 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 "" + $f end + } + puts "" + puts "
" + if {"$end" == "Top"} { + puts "$count rows, go to page" + } else { + puts "Go to page" + } + foreach link $navbar { + puts "$link " + } + puts "" + puts "Jump directly to" + $f text page -size 4 -value $response(page) + $f submit submit -value "Go" + puts "
" + if {"$end" == "Top"} { + puts "
" + } + } + + + method rowheader {{total 0}} { + set fieldList $fields + if {![lempty $rowfields]} { set fieldList $rowfields } + + set rowcount 0 + + puts

+ + if {$topnav} { page_buttons Top $total } + + puts {} + puts "" + 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 {$text" + } + set class [get_css_class TH DIORowHeader DIORowHeader-$field] + puts "" + } + + if {![lempty $rowfunctions] && "$rowfunctions" != "-"} { + puts {} + } + puts "" + } + + 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 "" + 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 "" + } + + if {![lempty $rowfunctions] && "$rowfunctions" != "-"} { + set f [::form #auto] + puts "" + $f end + } + + puts "" + } + + method rowfooter {{total 0}} { + puts "
$htmlFunctions
$text" + $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 "
" + + 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 "" + + 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 "" + $f end + } + } + + puts "" + + if {![lempty $numresults]} { + puts "" + } + + $form end + puts "
" + $f submit submit -value "Show All" -class DIORowFunctionButton + puts "" + $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 "
Results per page: " + $form select num -values $numresults -class DIOMainNumResults + puts "
" + } + + 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 "

" + puts {} + puts "" + puts {" + puts "" + puts "" + puts {" + puts {" + puts "" + puts "
} + puts "Are you sure you want to delete this record from the database?" + puts "
} + 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 "} + 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 "
" + puts "
" + } + + 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 "" + + set class [get_css_class TD DIOViewHeader DIOViewHeader-$name] + puts "$text:" + + set class [get_css_class TD DIOViewField DIOViewField-$name] + puts "$value" + + puts "" + } + + # + # 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 "" + + set class [get_css_class TD DIOFormHeader DIOFormHeader-$name] + puts "$text:" + + set class [get_css_class TD DIOFormField DIOFormField-$name] + puts "" + 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 "" + puts "" + } + + # 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 "" + + set class [get_css_class TD DIOFormHeader DIOFormHeader-$name] + puts "$text:" + + set class [get_css_class TD DIOFormField DIOFormField-$name] + puts "" + 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 "" + puts "" + } + + # + # showview -- emit a view for a boolean + # + method showview {{alt ""}} { + set class [get_css_class TR DIOViewRow$alt DIOViewRow$alt-$name] + puts "" + + set class [get_css_class TD DIOViewHeader DIOViewHeader-$name] + puts "$text:" + + set class [get_css_class TD DIOViewField DIOViewField-$name] + puts "" + if {[boolean_value]} { + puts $true + } else { + puts $false + } + puts "" + + puts "" + } + + # + # 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 + + diff --git a/dio/pkgIndex.tcl b/dio/pkgIndex.tcl new file mode 100644 index 0000000..cbbb3b6 --- /dev/null +++ b/dio/pkgIndex.tcl @@ -0,0 +1,6 @@ +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]] diff --git a/jcp.tcl b/jcp.tcl new file mode 100644 index 0000000..332161d --- /dev/null +++ b/jcp.tcl @@ -0,0 +1,250 @@ +# jcp.tcl - Copyright (C) 2006 Pat Thoyts +# +# 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) "" + 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 "" + append xml "" + 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 "$reply" + 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) "" + 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: diff --git a/license.terms b/license.terms new file mode 100644 index 0000000..7e65585 --- /dev/null +++ b/license.terms @@ -0,0 +1,38 @@ +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. diff --git a/pkgIndex.tcl b/pkgIndex.tcl new file mode 100644 index 0000000..a1db4be --- /dev/null +++ b/pkgIndex.tcl @@ -0,0 +1,12 @@ +# pkgIndex.tcl - Copyright (C) 2004 Pat Thoyts +# +# 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]] diff --git a/s2c.tcl b/s2c.tcl new file mode 100644 index 0000000..16dc116 --- /dev/null +++ b/s2c.tcl @@ -0,0 +1,594 @@ +# s2c.tcl - Copyright (C) 2006 Pat Thoyts +# +# 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 "" + append xml "" + 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 "" + append xml "<$type xmlns='[xmlns streams]'/>" + if {$text ne ""} { + append xml "[xmlquote $text]" + } + append xml "" + 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 "" + append xml "<$error xmlns='[xmlns stanzas]'/>" + if {$text ne ""} { + append xml "[xmlquote $text]" + } + append xml "" + 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 "" + 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 "" + append xml "" + + # RFC3920 4.6: Stream Features + if {$attr(version) >= 1.0} { + append xml "" + # Check for previous SASL negotiation + if {$channel(state) eq "authorized"} { + # RFC3920 7: Resource binding + append xml "" + + # 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 "" + } + # RFC3920 6.1: Use of SASL + append xml "" + append xml "DIGEST-MD5" + append xml "PLAIN" + append xml "" + } + append xml "" + } + 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 "" + 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 "" + wrapper::reset $channel(parser) +} + +proc ::xmppd::s2c::SASLFailure {Channel msg} { + set xml "" + if {$msg ne ""} { + append xml "[xmlquote $msg]" + } + append xml "" + 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 "" + WriteTo $Channel $xml + Close $Channel + } else { + set xml "" + 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 "[base64::encode -maxlen 0 [SASL::response $channel(sasl)]]" + 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 "[base64::encode -maxlen 0 [SASL::response $channel(sasl)]]" + 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 "" + 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 "$jid" + 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: + diff --git a/s2s.tcl b/s2s.tcl new file mode 100644 index 0000000..da7e84e --- /dev/null +++ b/s2s.tcl @@ -0,0 +1,755 @@ +# s2s.tcl - Copyright (C) 2004 Pat Thoyts +# +# 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 "" + append xml "" + 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 "<$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 "" + 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 "$session(key)" + 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 "" + append xml "" + + # RFC3920 4.6: Stream Features + if {$attr(version) >= 1.0} { + append xml "" + # FIX ME: provide tls support then add the feature here + append xml "" + } + 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 "" + 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 "$session(key)" + 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 "" + 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 "" + + 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 + +# ------------------------------------------------------------------------- diff --git a/sm.tcl b/sm.tcl new file mode 100644 index 0000000..ef898fb --- /dev/null +++ b/sm.tcl @@ -0,0 +1,232 @@ +# sm.tcl - Copyright (C) 2004 Pat Thoyts +# +# 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 + +# ------------------------------------------------------------------------- diff --git a/tests/ctalk.tcl b/tests/ctalk.tcl new file mode 100644 index 0000000..1b9e3d1 --- /dev/null +++ b/tests/ctalk.tcl @@ -0,0 +1,250 @@ +# ctalk.tcl - Copyright (C) 2006 Pat Thoyts +# +# 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 diff --git a/tests/jabberd.db b/tests/jabberd.db new file mode 100644 index 0000000..f330756 Binary files /dev/null and b/tests/jabberd.db differ diff --git a/tests/jabberd.pem b/tests/jabberd.pem new file mode 100644 index 0000000..5830d9e --- /dev/null +++ b/tests/jabberd.pem @@ -0,0 +1,34 @@ +-----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----- diff --git a/tests/jabberd.tcl b/tests/jabberd.tcl new file mode 100644 index 0000000..3f8055e --- /dev/null +++ b/tests/jabberd.tcl @@ -0,0 +1,170 @@ +# jabbberd.tcl - Copyright (C) 2006 Pat Thoyts +# +# 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 "" + 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: diff --git a/wrapper.tcl b/wrapper.tcl new file mode 100644 index 0000000..ed7add3 --- /dev/null +++ b/wrapper.tcl @@ -0,0 +1,836 @@ +################################################################################ +# +# 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, , and level 2 + # is the command tag, such as . 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 + 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 (). + # 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 "" + } + 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 + +# ------------------------------------------------------------------------- +