# $Id: Agent.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::agent 0.8

package require xotcl::trace
package require xotcl::comm::httpAccess
package require xotcl::actiweb::webObject
package require xotcl::store::persistence

package require XOTcl

#
# current response codes for agent requests:
#
# OK      -- content arrived (can be retrieved with sinks content method)
# ERROR   -- error on the place invocation
# FAILED  -- call itself failed, e.g. cancel
#

namespace eval ::xotcl::actiweb::agent {
    namespace import ::xotcl::*

    Class AgentMemSink \
	-superclass MemorySink \
	-parameter {{agent ""} responseCode}

    AgentMemSink instproc startCb {r}   {
	my set d "" 
	next
    }
    AgentMemSink instproc notifyCb {r} {next}
    AgentMemSink instproc incCb {r t c} {next}
    AgentMemSink instproc endCb {r} {
	if {[Agent exists responseCodes([$r set responseCode])]} {
	    my set responseCode OK
	} else {
	    my set responseCode ERROR
	}
	next
    }
    AgentMemSink instproc cancelCb {r} {
	my set responseCode FAILED
	next
    }
    AgentMemSink instproc endReq {r} {
	my instvar agent 
	if {[Object isobject $agent]} {
	    if {[$agent exists sinks($r)]} {
		$agent unset sinks($r)
	    }
	}
    }

    # sink class that calls the agent's endcmd in async calls
    # the sink is destroyed automatically after endCmd is called
    Class AgentAsyncSink -superclass AgentMemSink
    AgentAsyncSink instproc endCb {r} {
	next
	my instvar endCmd responseCode
	set result [my content]
	if {[info exists endCmd]} {
	    eval [concat $endCmd $responseCode \"$result\"]
	}
	my endReq $r
    }
    AgentAsyncSink instproc cancelCb {r} {
	my instvar endCmd responseCode
	if {[info exists endCmd]} {
	    eval [concat $endCmd $responseCode ""]
	}
	next
	my endReq $r
    }

    # sink type for sync request 
    # has to be destroyed with endReq when content is 
    # read (see createSyncRequest)
    Class AgentSyncSink -superclass AgentMemSink


    Class Agent -superclass WebObject
    Agent array set responseCodes {
	200 {OK}
    }

    Agent instproc init args {
	#my showCall
	#my exportProcs invoke
	my array set endCmds {}
	my array set sinks {}
	next
    }

    #
    # method to create async requests
    #
    # endCmd specifies the command (or object method or proc ...) that
    # is to be called, when the request has ended, empty for sync requests
    #
    # args are to be given in the form -name value, like:
    #   -contentType text/xml
    #   -method PUT 
    #   -data XXX
    #
    # returns the request object name
    #
    Agent instproc createRequest {endCmd url args} {
	#my showCall
	puts stderr "[self] [self proc]"
	my instvar place
	set s [AgentAsyncSink create [$place autoname agentmemsink] \
		   -agent [self]]
	set cmd [list Access createRequest -caching 0 -url $url \
		     -informObject $s]
	foreach {n v} $args {lappend cmd $n $v}
	$s set endCmd $endCmd
	set t ::[string trimleft [::eval $cmd $args] :]
	my set sinks($t) $s
	return $t
    }
    #
    # method to create sync reqs ... url and args identical to
    # async req
    #
    # returns the result of sync request, if "OK" 
    # otherwise: Raises an error
    #
    Agent instproc createSyncRequest {url args} {
	#my showCall
	puts stderr "[self] [self proc]"
	my instvar place
	set s [AgentSyncSink [$place autoname agentmemsink] -agent [self]]
	set cmd [list Access createRequest \
		     -httpVersion 1.0 \
		     -caching 0 -url $url -informObject $s -blocking 1]
	foreach {n v} $args {lappend cmd $n $v}
	set t ::[string trimleft [::eval $cmd] :]
	#puts stderr "After SyncRequest t=$t [$s responseCode]"
	if {[$s responseCode] eq "OK"} {
	    set content [$s content]
	    # kill the sink
	    $s endReq $t
	    return $content
	}
	$s endReq $t
	error "[self] -- Sync request failed: url=$url, responseCode=[$s responseCode]"
    }
    #
    # invoke a remote method directly along the places' dispatcher 
    #
    Agent instproc invoke {endCmd host receiver args} {
	puts stderr [self proc]----host=$host
	#my showCall
	set url http://$host/${receiver}+[url encode $args]
	my createRequest $endCmd $url
    }
    Agent instproc syncInvoke {host receiver args} {
	puts stderr [self proc]----host=$host
	#[self] showCall
	set url http://$host/${receiver}+[url encode $args]
	my createSyncRequest $url
    }

    #
    # invoke a cloning migration 
    #
    Agent instproc cloneImpl {async host startcmd {endCmd ""}} {
	#my showCall
	set ai [my agentInfo]
	set place [Place getInstance]

	# get the full name of the agent ns from the places's agent mgr
	#set ns [${place}::agentMgr::rdfNS searchPrefix agent]

	$ai set agentData(script) [${place}::scriptCreator makeScript [self]]
	$ai append agentData(script) [my makeVarScript]
	$ai set agentData(startcmd) $startcmd

	set data [$ai getXMLScript [$ai name]]
	###puts $data

	#set data [[Place getInstance]::rdfCreator createFromTriples [$ai getTriples]]
	if {$async} {
	    return [my createRequest $endCmd http://$host/[my selfName] \
			-contentType text/xml \
			-method PUT \
			-data $data]
	} else {
	    return [my createSyncRequest http://$host/[my selfName] \
			-contentType text/xml \
			-method PUT \
			-data $data]
	}
    }
    Agent instproc clone {host startCmd endCmd} {
	my cloneImpl 1 $host $startCmd $endCmd
    }
    Agent instproc syncClone {host startCmd} {
	my cloneImpl 0 $host $startCmd
    }

    #
    # invoke a migration that destroys the object in the current place 
    #
    Agent instproc migrateImpl {async host startcmd {endCmd ""}} {
	### GN ???
	puts stderr "--- async=$async"
	if {$async} {
	    set r [my clone $host $startcmd $endCmd]
	} else {
	    set r [my syncClone $host $startcmd]
	}
	puts stderr "--- [self] destroy +++ "
	my destroy  ;### FIXME: this does not work in the asynchronous case
	return $r
    }
    Agent instproc migrate {host startCmd endCmd} {
	#my migrateImpl 1 $host $startCmd $endCmd
	my migrateImpl 0 $host $startCmd $endCmd
    }
    Agent instproc syncMigrate {host startCmd} {
	my migrateImpl 0 $host $startCmd
    }
    #
    # query a place with its hostname for its name
    #
    Agent instproc getPlaceFromHostName {endCb host} {
	set r [my autoname __result]
	my createRequest "[self]::$r set" http://$host/ 
	return [set [self]::$r]
    }

    namespace export AgentMemSink AgentAsyncSink AgentSyncSink Agent
}

namespace import ::xotcl::actiweb::agent::*

# $Id: AgentManagement.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::agentManagement 0.8

package require xotcl::rdf::parser
package require xotcl::rdf::triple
package require xotcl::actiweb::agent

package require XOTcl

namespace eval ::xotcl::actiweb::agentManagement {
    namespace import ::xotcl::*

    Class AgentInfo -parameter {
	{name ""}
	{changed 1}
    }

    AgentInfo instproc init args {
	next
	#
	# array providing info on a (migrated) agent
	#
	my array set agentData {}
	RDFTripleDB [self]::db
	my trace variable agentData w [list [self] changeOccured]
	my trace variable name w [list [self] changeOccured]
    }

    AgentInfo instproc getXMLScript {name} {
	#my showCall
	set s {<?xml version="1.0"?>
	    <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
	    xmlns:xotcl="http://www.xotcl.org/agent">
	    <rdf:Description about="$name">}
	set s [subst -nobackslashes $s]
	foreach n [my array name agentData] {
	    append s "
    <agent:$n> [my set agentData($n)] </agent:$n>"
	}
	append s "  
  </rdf:Description>
</rdf:RDF>"
    }

    AgentInfo instproc changeOccured args {my set changed 1}

    AgentInfo instproc getTriples {} {
	#my showCall
	if {[my set changed]} {
	    # build up the triple-db
	    [self]::db reset
	    set place [Place getInstance]
	    set subject "http://[$place set host]:[$place set port]/[my name]"
	    foreach n [my array names agentData] {
		[self]::db add $n $subject [my set agentData($n)]
	    }
	}
	return [[self]::db getTriples]
    }

    AgentInfo instproc print {} {
	puts "AGENT-INFO:"
	puts "Name == [my set name]"
	foreach a [my array names agentData] {
	    puts "$a == [my set agentData($a)]"
	}
    }

    Class AgentVisitor -superclass NodeTreeVisitor -parameter {
	{openProperty ""}
	{agentInfo ""}
	{rdfNS {[my info parent]::rdfNS}}
    }

    AgentVisitor instproc fullName {obj n} {
	set ns [$obj resolveNS]
	return [$ns getFullName $n]
    }

    AgentVisitor instproc visit {objName} {
	#puts stderr "AgentVisitor visit -- $objName"
	set ai [my set agentInfo]
	set cl [$objName info class]
	#puts stderr "AgentVisitor visit -- $objName cl=$cl <[$ai name]>"
	if {[$ai name] eq ""} {
	    #### not fixed yet
	    puts stderr "my fixme (AgentManagement)"
	    if {$cl eq "::About" &&
		[string first "::Description" [[$objName info parent] info class]] == 0} {
		$ai name [$objName set content]
	    }
	} else {  
	    #puts stderr C=<[$objName content]>
	    #$cl showVars
	    switch -exact $cl {
		::RDFProperty {
		    set c [$objName content]
		    #$objName showVars
		    if {[$objName exists pcdata]} {
			$ai set agentData($c) [lindex [$objName getPCdataList] 0]
		    } else {
			#puts stderr "empty PCDATA"
		    }
		}
	    }
	}
    }

    AgentVisitor instproc interpretNodeTree node {
	if {[my set agentInfo] eq "" } {
	    error "Agent Visitor: no agent info provided."
	} 
	$node accept [self]
    }

    Class AgentMgr -superclass Agent \
	-parameter {
	    {acceptedData [list script startcmd senderPlace senderPort senderHost]}
	}

    AgentMgr instproc init args {
	next
	my array set agents {}
	#
	# this ns class holds the prefix/Rdf-ns pairs used by this
	# agent mgr (with default values)
	#
	XMLNamespace [self]::rdfNS
	[self]::rdfNS add agent {http://www.xotcl.org/schema/agent#}
	[self]::rdfNS add service {http://www.xotcl.org/schema/service#}
	[self]::rdfNS add xotcl {http://www.xotcl.org/schema/xotcl#}
	RDFParser [self]::rdfParser 
	AgentVisitor [self]::agentVisitor
	
	#package require xotcl::xml::printVisitor 
	#PrintVisitor [self]::pv
    }

    AgentMgr instproc register {name} {
	set ai [AgentInfo [self]::[my autoname agentInfo]]
	my set agents($name) $ai
	$ai name $name
	return $ai
    }

    AgentMgr instproc deregister {name} {
	if {[my info agents $name]} {
	    # destroy the agents info objects
	    #my showMsg "calling destroy on [my set agents($name)]"
	    [my set agents($name)] destroy
	    # unset the var
	    my unset agents($name)
	}
    }

    AgentMgr instproc info args {
	if {[lindex $args 0] eq "agents"} {
	    if {[llength $args] > 1} {
		return [my exists agents([lindex $args 1])]
	    } else {
		return [my array names agents]
	    }
	}
	next
    }

    #
    # parses the data of a migration request into a new agent
    # info object
    #
    # name must be stringleft : !!
    AgentMgr instproc parseData {name data} {
	set ai [my register $name]
	next

	[self]::rdfParser reset
	[self]::rdfParser parse $data

	#puts stderr ===========================================================
	#[self]::pv interpretAll [self]::rdfParser
	#puts stderr ===========================================================

	[self]::agentVisitor agentInfo $ai
	#foreach tn [[self]::rdfParser info children topNode*] {
	#  [self]::agentVisitor interpretNodeTree $tn
	#}

	[self]::agentVisitor interpretAll [self]::rdfParser
	
	#puts "************** Received Agent:"
	#$ai print
	
	return $ai
    }

    AgentMgr instproc immigrate {AI} {
	#set ns [[self]::rdfNS searchPrefix agent]
	#::eval [$AI set agentData(${ns}script)]

	#puts stderr "immigrate call showVars"
	#$AI showVars
	#puts stderr "immigrate showVars done"

	::eval [$AI set agentData(agent:script)]
	#puts stderr "immigrate persistentVars = '[[$AI name] persistentVars]'"
	#foreach v [[$AI name] info vars] { $n persistent $v }

	if {[$AI exists agentData(agent:startcmd)]} {
	    ::after 10 [list [$AI name] [$AI set agentData(agent:startcmd)]]
	}
	return ""
    }

    namespace export AgentInfo AgentVisitor AgentMgr
}

namespace import ::xotcl::actiweb::agentManagement::*

 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstraße 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

# $Id: HtmlPlace.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::htmlPlace 0.8

package require xotcl::trace
package require xotcl::actiweb::httpPlace
package require xotcl::store::persistence
package require xotcl::actiweb::agent
package require xotcl::actiweb::pageTemplate

package require XOTcl

namespace eval ::xotcl::actiweb::htmlPlace {
    namespace import ::xotcl::*

    Class HtmlPlace -superclass Place -parameter {allowExit}

    HtmlPlace instproc init args {
	next
	#
	# just define a minimal object that can react 
	# with HTML decoration, if the called object
	# doesn't exist
	PageTemplateHtml create [self]::start.html

	my startingObj [self]::start.html
	if {[my exists allowExit]} {
	    set exitObj [WebObject create [self]::[my set allowExit]]
	    [Place getInstance] exportObjs $exitObj
	    $exitObj proc default {} {after 500 ::exit; return "Server terminates"}
	}
    }
    HtmlPlace instproc default {} {
	set place [string trimleft [self] :]
	set msg "<HTML><TITLE>Place $place</TITLE>
	<BODY><H2>Place $place</H2> Try one of the following links:<UL>"
	foreach o [my exportedObjs] {
	    set o [string trimleft $o :]
	    append msg "<LI><A HREF='[url encodeItem $o]'>$o</A></LI>"
	}
	append msg "</UL></BODY>\n"
    }

    namespace export HtmlPlace
}

namespace import ::xotcl::actiweb::htmlPlace::*

# $Id: HttpPlace.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::httpPlace 0.8

package require xotcl::trace
package require xotcl::actiweb::invoker
package require xotcl::actiweb::webObject
package require xotcl::comm::httpd
package require xotcl::scriptCreation::scriptCreator
package require xotcl::store::persistence
package require xotcl::pattern::singleton
package require xotcl::registry::registry
package require xotcl::actiweb::agentManagement
package require xotcl::rdf::tripleRecreator

package require XOTcl

namespace eval ::xotcl::actiweb::httpPlace {
    namespace import ::xotcl::*


    Singleton Place -superclass Invoker -parameter {
	{exportedObjs ""} 
	{startingObj ""}
	{startCommand ""}
	{root $::env(HOME)/public_html}
	{port 8086}
	{redirect [list]}
	{logdir $::xotcl::logdir} 
	{host localhost}
	{allowImmigrationHosts ""}
	persistenceFile persistenceDir bccFile bccDir dbPackage
	{startHTTPServer 1}
    }

    #    Giving a bccFile (and possibly bccDir) as optional parameter means 
    #    that an identical copy database will be created in that 
    #    location (e.g. for creating a backup on a second hard drive.

    Place instproc exportObjs args {
	foreach obj $args {
	    my lappend exportedObjs [string trimleft $obj :]
	    puts stderr "*** exporting $obj, self=[self], objs=[my set exportedObjs]"
	}
    } 
    Place instproc isExportedObj obj {
	expr {[lsearch [my exportedObjs] [string trimleft $obj :]] != -1}
    }
    Place instproc default {} {
	[self]
    }
    Place instproc init args {
	if {[my set startHTTPServer]} {
	    Httpd [self]::httpd \
		-port [my port] \
		-root [my root] \
		-redirect [my redirect] \
		-logdir [my logdir] \
		-httpdWrk Place::HttpdWrk
	}
	#
	# PersistenceMgr object for web entities
	#
	##### so ist das nicht toll ... init args sollten anders konfigurierbar sein
	PersistenceMgr [self]::agentPersistenceMgr -dbPackage multi

	if {[my exists dbPackage]} {
	    set dbp [my set dbPackage]
	} else {
	    set dbp ""
	}


	if {![my exists persistenceDir]} {
	    my persistenceDir [string trimleft [self] :]
	}
	if {![my exists persistenceFile]} {
	    my persistenceFile persistentObjs-[my port]
	}

	[self]::agentPersistenceMgr store add $dbp \
	    -dirName [my persistenceDir] \
	    -fileName [my persistenceFile]

	if {[my exists bccDir] || [my exists bccFile]} {
	    if {![my exists bccDir]} {
		my bccDir [my set persistenceDir]
	    }
	    if {![my exists bccFile]} {
		my bccFile [my persistenceFile]
	    }
	    [self]::agentPersistenceMgr store add $dbp \
		-dirName [my bccDir] \
		-fileName [my bccFile]
	}

	AgentMgr create [self]::agentMgr 
	RDFCreator create [self]::rdfCreator

	#
	# minimal obj for default behavior of the place -> calls go
	# to web entities default (customize through a redirecting proc
	# as in HtmlPlace or changing startingObj)
	#
	WebObject create [self]::start
	my startingObj [self]::start
	Registry [self]::registry
	ErrorMgr [self]::error

	ScriptCreator [self]::scriptCreator -dependencyChecking 0

	my exportObjs [self]::start [self]::agentMgr [self]::registry
	next
    }

    Place instproc startEventLoop args {
	if {[llength $args] > 0} {
	    set startCommand [lindex $args 0]
	    ::eval $startCommand
	}

	vwait forever  ;# if we are in xotclsh call the event loop...
    }

    ###
    ### Mixin-Classes for Http/Wrk that restricts the usable HTTP methods
    ###
    Class RestrictHTTPMethods -parameter {
	{allowedHTTPMethods "GET PUT HEAD POST CGI"}
    }
    RestrictHTTPMethods instproc init args {
	next
	my lappend workerMixins RestrictHTTPMethods::Wrk
    }
    Class RestrictHTTPMethods::Wrk
    RestrictHTTPMethods::Wrk instproc respond {} {
	my instvar method 
	[my info parent] instvar allowedHTTPMethods
	if {[lsearch $allowedHTTPMethods $method] != -1} {
	    return [next]
	} else {
	    my log Error "Restricted Method $method called"
	    my replyCode 405
	    my replyErrorMsg
	}
    }

    Class Place::HttpdWrk -superclass Httpd::Wrk 

    Place::HttpdWrk instproc init args {
	my set place [Place getInstance] 
	next
	#puts "New Http-Worker: [self class]->[self] on [my set place]" 
    } 

    Place::HttpdWrk instproc parseParams {o m a call} {
	upvar [self callinglevel] $o obj $m method $a args 
	### 
	set decodedCall [url decodeItem $call]
	#my showMsg decodedCall=$decodedCall
	if {[regexp {^([^ ]*) ?([^ ]*) ?(.*)$} $decodedCall _ \
		 obj method args]} {
	    #foreach a [my set formData] {lappend args [$a set content]}
	    #puts stderr "Parsed -- Obj: $obj, Method: $method, Args: $args" 
	    return 1
	} else {
	    puts stderr "could not parse <$decodedCall>"
	    return 0
	}
    }
    Place::HttpdWrk instproc respond-HEAD {} {
	my respond-GET;  ### sendMsg inhibits content for method HEAD
    }
    Place::HttpdWrk instproc respond-GET {} {
	my instvar fileName resourceName place
	if {$resourceName eq ""} {
	    my sendMsg [$place default] text/html  ;# kind of index.html
	} elseif {[my parseParams obj method arguments $resourceName]} {
	    if {![my isobject $obj] && [file readable $fileName]} {
		next      ;# let Httpd handle this
	    } else {
		set response [$place invokeCall obj status $method $arguments]
		#puts stderr "RESPONSE: $response"
		#
		# let the object's sending strategy mixin choose 
		# the appropriate sending mode
		#
		# $obj showClass
		if {[info exists status] && $status >= 300} {
		    my replyCode $status
		    my replyErrorMsg $response
		} else {
		    #my lappend replyHeaderFields Cache-Control maxage=0
		    my lappend replyHeaderFields Pragma no-cache
		    $obj send [self] $response
		}
	    }
	} else {
	    my set version 1.0
	    my replyCode 400
	    my replyErrorMsg [my callError "Could not parse: " $resourceName]
	}
    }
    Place::HttpdWrk instproc respond-POST {} {
	my instvar resourceName place
	my respond-GET
    }


    Place::HttpdWrk instproc respond-PUT {} {
	my instvar resourceName place data
	#my showCall
	
	if {$resourceName ne ""} {
	    if {[my parseParams obj m a $resourceName]} {
		set obj [string trimleft $obj :]
		set AMgr ${place}::agentMgr

		if {[info commands $obj] eq "" &&
		    ![$AMgr info agents $obj]} {
		    #puts stderr "Receiving to put --------------------------------$obj  $data"
		    set AI [$AMgr parseData $obj $data]
		    #puts stderr "parray --${AI}::agentData------------------------"
		    #parray ${AI}::agentData
		    #puts stderr "parray --${AI}::agentData----------------DONE--------"
		    #$AI showVars
		    #puts stderr "----[$AI exists agentData(agent:script)]----"
		    if {[$AI exists agentData(agent:script)]} {
			set immigrateResult [$AMgr immigrate $AI]
			#puts stderr "immigrateResult=<$immigrateResult>"
			my replyCode 200  
			my sendMsg $immigrateResult text/plain
		    } else {
			my set version 1.0
			my replyCode 400
			my replyErrorMsg "Migration failed"
		    }
		} else {
		    my set version 1.0
		    my replyCode 400
		    my replyErrorMsg "Migration: object name already in use."
		}
	    } else {
		my set version 1.0
		my replyCode 400 
		my replyErrorMsg "Migration call must provide object name"
	    }
	} else {
	    # return the own place name -> any client can call the place via
	    # placename::start !
	    my sendMsg $place text/plain
	}
    }

    namespace export RestrictHTTPMethods Place
    namespace eval RestrictHTTPMethods {
	namespace export Wrk
    }
    namespace eval Place {
	namespace export HttpdWrk
    }
}

namespace import ::xotcl::actiweb::httpPlace::*
namespace eval RestrictHTTPMethods {
    namespace import ::xotcl::actiweb::httpPlace::RestrictHTTPMethods::*
}
namespace eval Place {
    namespace import ::xotcl::actiweb::httpPlace::Place::*
}

# $Id: Invoker.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::invoker 0.8

package require XOTcl

namespace eval ::xotcl::actiweb::invoker {
    namespace import ::xotcl::*

    Class AbstractInvoker
    AbstractInvoker abstract instproc invokeCall {o method arguments}
    AbstractInvoker abstract instproc eval {obj method arguments}
    #
    # error types are: tclError, invocationError
    #
    AbstractInvoker abstract instproc callError {type msg obj arguments} 

    Class Invoker -superclass AbstractInvoker -parameter {{place [self]}}

    Invoker instproc handleException {response} {
	if {[my isExceptionObject $response]} {
	    set exceptionObj $response
	    switch [$exceptionObj info class] {
		::RedirectException {
		    set obj [$exceptionObj obj]
		    set method [$exceptionObj method]
		    set arguments [$exceptionObj arguments]
		    set response [my eval $obj $method $arguments]
		}
		::ErrorException {
		    set response [$exceptionObj set errorText]
		}
	    }
	    $exceptionObj destroy
	}
	return $response
    }

    Invoker instproc invokeCall {o s method arguments} {
	upvar [self callinglevel] $o obj $s status
	my instvar place
	set response ""
	if {[$place isExportedObj $obj]} {
	    # if method is not given -> call default on the object
	    if {$method eq ""} {
		set method default
	    }
	    if {[$obj isExportedProc $method]} {
		#puts stderr "ExportedProcs of $obj: [$obj exportedProcs]"
		#puts stderr "Call: $obj -- $method -- $arguments"
		set response [my eval $obj $method $arguments]
	    } else {
		#puts stderr "ExportedProcs of $obj: [$obj exportedProcs]"
		set response [my callError invocationError [$place startingObj] \
				  "Method not found or not exported" \
				  "$obj $method $arguments"]
		set status 405
	    }
	} else {
	    set called $obj
	    set obj [$place startingObj]
	    set response [my callError invocationError $obj \
			      "Object '$called' unknown" ""]
	    set status 404
	}
	
	return [my handleException $response]
    }

    #
    # tests whether "name" is an exception object or not
    #
    Invoker instproc isExceptionObject name {
	if {[Object isobject $name] && [$name istype Exception]} {
	    return 1
	}
	return 0
    }

    #
    # central eval  -- all remote call
    # are invoked through this method
    #
    Invoker instproc eval {obj method arguments} {
	puts stderr "[clock format [clock seconds] \
	-format %Y/%m/%d@%H:%M:%S] \
	Eval Call: $obj $method $arguments"
	if {[catch {
	    set r [::eval $obj $method $arguments]
	} ei]} {
	    set r [my callError tclError $obj $ei "$obj $method $::errorInfo"]
	}
	return $r
    }

    Invoker instproc callError {type obj msg arguments} {
	[my set place]::error $type $obj $msg $arguments
    }

    Class ErrorMgr
    ErrorMgr instproc isHtml o {
	if {[my isobject $o]} {
	    if {[$o exists contentType]} {
		if {[$o set contentType] eq "text/html"} {
		    return 1
		}
	    }
	}
	return 0
    }

    ErrorMgr instproc invocationError {obj msg arguments} {
	my showCall
	set ee [ErrorException [self]::[my autoname ee]]
	$ee instvar errorText
	if {[my isHtml $obj]} {
	    set errorText "<p> invocation error: $msg"
	    if {[llength $arguments] > 0} {
		append errorText ":\n<p> object: '[lindex $arguments 0]' \n"
	    } else {
		append errorText \n
	    }
	    if {[llength $arguments] > 1} {
		append errorText "<p> call: '[lrange $arguments 1 end]' \n"
	    }
	} else {
	    set errorText "invocation error: $msg $arguments"
	}
	return $ee
    }

    ErrorMgr instproc tclError {obj msg arguments} {
	set ee [ErrorException [self]::[my autoname ee]]
	if {[my isHtml $obj]} {
	    $ee errorText "<p>tcl error: '$msg' \n<code><p><pre>$arguments</pre></code>"
	} else {
	    $ee errorText "tcl error: '$msg'\n$::errorInfo"
	}
	return $ee
    }

    #
    # exceptions in invocation behavior
    #
    Class Exception
    #
    # Execpetion that tells the invoker to redirect the call to
    # parameters
    #
    Class RedirectException -superclass Exception -parameter {
	{obj ""}
	{method ""}
	{arguments ""}
    }

    Class ErrorException -superclass Exception -parameter {
	{errorText ""}
    }

    namespace export AbstractInvoker \
	Invoker ErrorMgr Exception \
	RedirectException ErrorException
}

namespace import ::xotcl::actiweb::invoker::*

# $Id: PlaceAccessControl.xotcl,v 1.7 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::placeAccessControl 0.8

package require xotcl::comm::httpd
package require xotcl::actiweb::httpPlace

package require XOTcl

#
# Simple Object Pwd Protection with BasicAccessControl
#
#Usage example:
#ConferenceOrgPlace confPlace -port $placeport -root [pwd] \
    #  -mixin PlaceAccessControl
#
#confPlace protect conference.html [confData set password]
#
#confPlace setPasswd conference.html xxx

namespace eval ::xotcl::actiweb::placeAccessControl {
    namespace import ::xotcl::*

    Class ObjectAccessControl -superclass BasicAccessControl

    ObjectAccessControl instproc protectedResource {fn method varAuthMethod varRealm} {
	# check whether access to $fn via $method is protected
	upvar [self callinglevel] $varAuthMethod authMethod $varRealm realm
	my instvar root
	# we check only the current directory, not the parent directories
	set call [url decodeItem $fn]
	regsub "^$root" $call "" call
	set call [string trimleft $call /]
	set call [string trimleft $call :]
	regexp {^([^ ]*)} $call _ call
	set call "$root/$call"

	foreach i [list $call $call:$method] {
	    #puts stderr "check <$i>"
	    if {[my exists protected($i)]} {
		set realm [my set protected($i)]
		set authMethod Basic
		return 1
	    }
	}
	return 0
    }

    Class PlaceAccessControl
    PlaceAccessControl instproc init args {
	next
	[self]::httpd mixin add ObjectAccessControl
	[self]::httpd initWorkerMixins
    }

    PlaceAccessControl instproc protect {objName id pwd} {
	set objName [string trimleft $objName :]
	[self]::httpd protectDir $objName $objName {}
	if {$pwd ne ""} {
	    my setPassword $objName $id $pwd
	} 
    }

    PlaceAccessControl instproc credentialsNotOk {credentials authMethod realm} {
	#my instvar passwd
	#parray passwd
	next
    }

    PlaceAccessControl instproc setPassword {realm id pwd} {
	set httpd [self]::httpd 
	if {[$httpd exists passwd($realm:$id)]} {
	    $httpd unset passwd($realm:$id)
	    $httpd set passwd($realm:$id) $pwd
	} else {
	    $httpd addRealmEntry $realm "$id $pwd"
	}
	#$httpd set passwd($realm:admin) nimda
    }
    PlaceAccessControl instproc removeID {realm id} {
	set httpd [self]::httpd
	if {[$httpd exists passwd($realm:$id)]} {
	    $httpd unset passwd($realm:$id)
	}
    }

    namespace export ObjectAccessControl PlaceAccessControl
}

namespace import ::xotcl::actiweb::placeAccessControl::*

# $Id: SecureHtmlPlace.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::secureHtmlPlace 0.8

package require xotcl::actiweb::secureHttpPlace
package require xotcl::actiweb::htmlPlace

package require XOTcl

namespace eval ::xotcl::actiweb::secureHtmlPlace {
    namespace import ::xotcl::*

    Class SecureHtmlPlace -superclass {SecurePlace HtmlPlace}

    namespace export SecureHtmlPlace
}

namespace import ::xotcl::actiweb::secureHtmlPlace::*

# $Id: SecureHttpPlace.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::secureHttpPlace 0.8

package require xotcl::actiweb::httpPlace

package require XOTcl

namespace eval ::xotcl::actiweb::secureHttpPlace {
    namespace import ::xotcl::*

    Class SecurePlace -superclass Place -parameter {
	{port 443}
	{requestCert 0}
	{requireValidCert 0}
	{certfile server.pem}
	{keyfile server.key} 
	{cafile cacert.pem}
	{infoCb {}}
    }

    SecurePlace instproc startHttpd {} {
	my instvar port root  requestCert requireValidCert \
	    certfile cafile infoCb keyfile
	Httpsd h1 -port $port \
	    -root $root \
	    -httpdWrk SecurePlace::HttpsdWrk \
	    -infoCb $infoCb \
	    -requestCert $requestCert \
	    -requireValidCert $requireValidCert \
	    -certfile $certfile -cafile $cafile \
	    -keyfile $keyfile
    }

    SecurePlace instproc init args {
	my set startHTTPServer 0
	next
	[self] startHttpd
    }

    Class SecurePlace::HttpsdWrk -superclass {Httpsd::Wrk Place::HttpdWrk} 

    namespace export SecurePlace
    namespace eval SecurePlace {
	namespace export HttpsdWrk
    }
}

namespace import ::xotcl::actiweb::secureHttpPlace::*
namespace eval SecurePlace {
    namespace import ::xotcl::actiweb::secureHttpPlace::SecurePlace::*
}

# $Id: SendStrategy.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::sendStrategy 0.8

package require XOTcl

#
# some simple sending strategy classes -- to be used as mixins
# for web objects
# 

namespace eval ::xotcl::actiweb::sendStrategy {
  namespace import ::xotcl::*

  Class SendStrategy
  SendStrategy abstract instproc send {httpWrk string}

  #
  # send the response given from the place as plain text
  #
  Class Send=PlainString -superclass SendStrategy
  Send=PlainString instproc send {httpWrk string} {
    $httpWrk sendMsg $string text/plain
  }

  #
  # send the response given from the place with content 
  # type of the obj, if it exists
  #
  Class Send=TypedString -superclass SendStrategy
  Send=TypedString instproc send {httpWrk string} {
    $httpWrk sendMsg $string [my set contentType]
  }
  
  #
  # send file specified in obj's instvar filename
  #
  Class Send=File -superclass SendStrategy
  Send=File instproc send {httpWrk {response ""}} {
    if {[my exists contentType]} {
      $httpWrk sendFile [my set filename] [my set contentType]
    } else {
      $httpWrk sendFile [my set filename] ""
    }
  }

  namespace export \
      SendStrategy Send=PlainString Send=TypedString Send=File
}

namespace import ::xotcl::actiweb::sendStrategy::*

# $Id: UserMgt.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::userMgt 0.8

package require XOTcl

namespace eval ::xotcl::actiweb::userMgt {
    namespace import ::xotcl::*

    Class UserMgt 
    Class UserMgt::User -parameter {name password}

    UserMgt instproc addUser {name password} {
	[self class]::User [self]::$name -name $name -password $password
    }

    UserMgt set exportedInstprocs [list \
				       addUser \
				       listUsers \
				       deleteUser \
				       userMgtOptions\
				      ]

    UserMgt instproc init args {
	next
	my exportedProcs [concat [my exportedProcs] [[self class] set exportedInstprocs]]
    }

    UserMgt instproc listUsers {} {
	#showCall
	set users ""
	foreach u [my info children] {
	    lappend users [namespace tail $u]
	}
	return $users
    }

    UserMgt instproc deleteUser {name} {
	if {[[self class]::User info instances [self]::$name] != ""} {
	    [self]::$name destroy
	}
    }
    UserMgt instproc userMgtOptions {} {
	return [[self class] set exportedInstprocs]
    }

    Class UserMgtHtml -superclass HtmlRep

    UserMgtHtml instproc addUser args {
	set place [HtmlPlace getInstance]
	if {$args eq ""} {
	    set action [url encodeItem "[my htmlCall] [my repObj] [self proc]"]
	    set c {
		<form method=get action=$action>
		<p> Name: 
		<input name="name" type=text size=30>
		<p> Password:
		<input name="password" type=password typesize=30>
		<p><p>
		<input type=submit value="Submit">
		<input type=reset value="Reset">
	    }
	    set c [subst -nobackslashes -nocommands $c]
	    
	    return [my simplePage $place "New User" $c]
	} else {
	    if {[llength $args] > 1} {
		set name [lindex $args 0]
		set password [lindex $args 1]
		set user [[my repObj] [self proc] $name $password]		
		set c "\n$name entered $place successfully\n"
		return [my simplePage "New User" "New User" $c]
	    } else {
		#
		# error !!!
	    }
	    return [my [self proc]]
	}
    }

    UserMgtHtml instproc listUsers {} {
	set c ""
	foreach u [[my repObj] [self proc]] {
	    append c "<p> $u \n"
	}
	return [my simplePage "User List" "User List" $c]  
    }

    UserMgtHtml instproc userMgtOptions {} {
	set c ""
	foreach u [[my repObj] [self proc]] {
	    append c "<p> <a href=[my selfAction $u]> $u </a>\n"
	}
	return [my simplePage "User Management Options" "User Management Options" $c]  
    }

    namespace export UserMgt UserMgtHtml
}

namespace import ::xotcl::actiweb::userMgt::*

# $Id: WebAgent.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::webAgent 0.8

package require xotcl::actiweb::agent
package require xotcl::actiweb::invoker
package require xotcl::mixinStrategy

package require XOTcl

namespace eval ::xotcl::actiweb::webAgent {
    namespace import ::xotcl::*

    #
    # Web Agent are special agents that allow us to define another
    # object in the paramter webfacade as a facade for the web agent
    # itself and the sub-system shielded by the web agent with an interface
    # for agents
    #
    Class WebAgent -superclass Agent

    WebAgent instproc init args {
	next
    }

    #
    # let the web agents facade handle the call -> interprete args
    # as "method args"
    # return result of the invoker
    #
    #WebAgent instproc invokeFacade {args} {
    #  set a ""
    #  set m ""
    #  set l [llength $args]
    #  set o [my webfacade]
    #  if {$l > 0} {
    #    set m [lindex $args 0]
    #  }
    #  if {$l > 1} {
    #    set a [lrange $args 1 end]
    #  } 
    #    
    #  #puts stderr "Web Agent [self]->invoke:  OBJ: $o PROC: $m ARGS: $a"
    #
    #  #
    #  # tell the invoker to redirect the call to the webfacade object
    #  #
    #  set re [RedirectException [self]::[my autoname re] \
    #	    -obj $o -method $m -arguments $a]
    #
    #  return $re
    #}

    #WebAgent instproc default args {
    #  return [next]
    #}

    namespace export WebAgent
}

namespace import ::xotcl::actiweb::webAgent::*

# $Id: WebDocument.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $

package provide xotcl::actiweb::webDocument 0.8

package require xotcl::actiweb::webObject
package require xotcl::comm::httpAccess
package require xotcl::mixinStrategy
package require xotcl::actiweb::sendStrategy

package require XOTcl

namespace eval ::xotcl::actiweb::webDocument {
    namespace import ::xotcl::*

    Class WebDocument -superclass WebObject \
	-parameter {
	    {content ""}
	    filename
	}


    WebDocument instproc init args {
	my exportProcs content contentType
	next
	my mixinStrategy ::Send=TypedString
    }

    WebDocument instproc attachFile filename {
	my filename $filename
	my set oldSendStrategy [my mixinStrategy ::Send=File]
	my contentType [Mime guessContentType $filename]
    }

    WebDocument instproc detachFile {} {
	my mixinStrategy [my set oldSendStrategy]
	my unset contentType
	my unset filename
    }

    WebDocument instproc default args {
	if {[my exists content]} {
	    return [my content]
	}
	return ""
    }
    #WebDocument instproc contentLength {} {
    #  my showCall
    #  return [expr {[string length [my content]] + 1}]
    #}


    Class TextDocument -superclass WebDocument
    TextDocument instproc init args {
	next
	my contentType text/plain
    }


    Class HtmlDocument -superclass TextDocument
    HtmlDocument instproc init args {
	next
	my contentType text/html
    }

    Class FileDocument -superclass WebDocument

    #
    # class factory creates classes on the fly if they do not exist
    # already, otherwise return exisiting class
    #
    # auch flyweigth
    Class DocumentClassFactory
    DocumentClassFactory abstract instproc getClass contentType

    Class FileDocumentClassFactory -superclass DocumentClassFactory
    FileDocumentClassFactory instproc getClass contentType {
	if {[FileDocument info classchildren $contentType] eq ""} {
	    Class ::FileDocument::${contentType} -superclass FileDocument
	}
	return ::FileDocument::${contentType}
    }

    Class DocumentFactory
    DocumentFactory abstract instproc create {name args}  

    Class FileDocumentFactory -superclass DocumentFactory
    FileDocumentFactory instproc create {name class filename} {
	$class $name
	#$name contentType [$class set contentType]
	$name attachFile $filename
	return $name
    }

    Class FileObjectifier 

    FileObjectifier instproc init args {
	next
	FileDocumentClassFactory [self]::clFactory
	FileDocumentFactory [self]::objFactory
    }

    #
    # filename must be given with full path ->
    # create objects with filename's tail (prefix can be used to
    # give object name a preceding dir)
    #
    FileObjectifier instproc objectifyFile {place filename {prefix ""}} {
	set obj ""
	if {[file isfile $filename]} {
	    set type [Mime guessContentType $filename]
	    #if {$type ne "unknown/unknown"} {
	    set fn [string trimleft $prefix/[file tail $filename] /]
	    set class [[self]::clFactory getClass $type]
	    set obj [[self]::objFactory create $fn $class $filename]
	    $place exportObjs $obj
	    #puts stderr "...objectified:  $obj of class $class"
	    #}
	}
	return $obj
    }

    #
    # objectify a whole directory tree
    #
    FileObjectifier instproc objectifyTree {place dir {prefix ""}} {
	if {[file isdirectory $dir]} {
	    foreach f [glob  -nocomplain $dir/*] {
		if {[file isfile $f]} {
		    my objectifyFile $place $f $prefix
		} elseif {[file isdirectory $f]} {
		    my objectifyTree $place $f $prefix/[file tail $f]
		}
	    }
	}
    }


    Class GraphicDirectoryObjectifier -superclass FileObjectifier \
	-parameter {{thumbnaildir [::xotcl::tmpdir]}}
    GraphicDirectoryObjectifier instproc objectifyTree {place dir {prefix ""}} {
	if {[file isdirectory $dir]} {
	    set indexpage ""
	    set title ""
	    set date ""
	    foreach f [lsort [glob -nocomplain $dir/* $dir/{.date,.title}]] {
		set exportedfn [string trimleft $prefix/[file tail $f] /]
		if {[file isfile $f]} {
		    set type [Mime guessContentType $f]
		    if {[string match "image/*" $type]} {
			set class [[self]::clFactory getClass $type]
			$class $exportedfn -init -attachFile $f
			$place exportObjs $exportedfn
			#puts stderr "...objectified:  FN=$exportedfn cl=$class d=$dir o=$exportedfn"
			######
			set expThumbnaildir [file dirname $exportedfn]/.thumbnail
			set thumbnaildir    [file dirname $f]/.thumbnail
			if {![file isdirectory $thumbnaildir]} {
			    file mkdir $thumbnaildir
			}
			set thumbnail $thumbnaildir/[file tail $f]
			set expThumbnail $expThumbnaildir/[file tail $f]
			if {![file exists $thumbnail]} {
			    catch {exec djpeg -pnm $f | \
				       pnmscale -xscale .2 -yscale .2 | ppmquant 256 | \
				       ppmtogif > $thumbnail}
			}
			$class $expThumbnail -init -attachFile $thumbnail
			$place exportObjs $expThumbnail
			####
			append indexpage "<A href='/$exportedfn'>" \
			    "<IMG SRC='/$expThumbnail'>$exportedfn</A><br>\n"
		    } elseif {[string match *.title $exportedfn]} {
			set title [my fileContent $f]
		    } elseif {[string match *.date $exportedfn]} {
			set date <H4>[my fileContent $f]</H4>
		    }
		} elseif {[file isdirectory $f]} {
		    if {[file exists $f/.title]} {
			set desc ": [my fileContent $f/.title]"
		    } else {
			set desc ""
		    }
		    append indexpage "<A href='/$exportedfn/gindex.html'>" \
			"$exportedfn</A>$desc<br>\n"
		    my objectifyTree $place $f $exportedfn
		}
		set gindex [string trimleft $prefix/gindex.html /]
		HtmlDocument $gindex -content \
		    "<HTML><TITLE>$title</TITLE><H1>$title</H1>\
		<BODY>$date$indexpage</BODY></HTML>"
		#puts stderr "mixins of HtmlDocument=<[$gindex info mixins]>"
		$gindex mixinStrategy ::Send=TypedString
		#$gindex showVars
		receiver exportObjs $gindex
	    }
	}
    }
    GraphicDirectoryObjectifier instproc fileContent {f} {
	set FILE [open $f r]
	set content [read $FILE]
	close $FILE
	return $content
    }



    Class HtmlProxy -superclass HtmlDocument  -parameter realSubject
    HtmlProxy instproc init args {
	next
	[Place getInstance] exportObjs [self]
    }
    HtmlProxy instproc unknown {m args} {
	my instvar realSubject
	::eval $realSubject $m $args
	return [my default]
    }

    namespace export \
	WebDocument TextDocument HtmlDocument FileDocument \
	DocumentClassFactory FileDocumentClassFactory \
	DocumentFactory FileDocumentFactory \
	FileObjectifier GraphicDirectoryObjectifier \
	HtmlProxy
}

namespace import ::xotcl::actiweb::webDocument::*

# $Id: WebObject.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::webObject 0.8

package require xotcl::actiweb::sendStrategy
package require xotcl::mixinStrategy
package require xotcl::store::persistence

package require XOTcl

namespace eval ::xotcl::actiweb::webObject {
    namespace import ::xotcl::*

    #
    # base interface for all web-entitites
    #
    Class WebObject -parameter {
	{exportedProcs {echo default}}
	agentInfo
	{contentType ""}
	{place ""}
    }

    #
    # default send strategy == send the response from the place
    #
    WebObject instproc init args {
	#my showCall
	my mixinStrategy ::Send=PlainString
	my registerPlace
	my mixinStrategy ::Persistent=Eager
	my persistenceMgr [my place]::agentPersistenceMgr
	next
    }

    WebObject instproc registerPlace {} {
	my set place [Place getInstance]
	my set agentInfo [[my place]::agentMgr register [my selfName]]
    }

    WebObject instproc deregisterPlace {} {
	[my place]::agentMgr deregister [my selfName]
    }

    #
    # seek for the HTTP worker object that has invoked
    # the current call
    #
    WebObject instproc getWorker {} {
	for {set level 1} {1} {incr level} {
	    if {[catch {set worker [uplevel $level self]}]} {
		return ""
	    } elseif {[$worker istype Place::HttpdWrk]} {
		return $worker
	    }
	}
    }
    WebObject instproc getFormData {} {
	[my getWorker] formData
    }

    #
    # code a call for an action on self;
    # action is "proc args"
    #
    WebObject instproc selfAction {action} {
	return [url encodeItem "[string trimleft [self] :] $action"]
    }
    WebObject instproc action {o action} {
	return [url encodeItem "[string trimleft $o :] $action"]
    }
    WebObject instproc echo {} {
	return [self]
    }

    WebObject instproc error args {
	return "Error on [self]: Invocation '$args' failed."
    }

    WebObject instproc default {} {
	return "No default behaviour on [self]."
    }

    WebObject instproc exportProcs args {
	my instvar exportedProcs
	foreach a $args {
	    if {[lsearch $exportedProcs $a] == -1} {
		lappend exportedProcs $a
	    }
	}
    }

    WebObject instproc isExportedProc p {
	expr {[lsearch [my set exportedProcs] $p] != -1}
    }

    WebObject instproc selfName {} {
	return [string trimleft [self] :]
    }

    WebObject instproc objName {obj} {
	return [string trimleft $obj :]
    }

    WebObject instproc buildAdress {} {
	my instvar place
	set a http://[$place host]
	if {[set p [$place port]]} {
	    append a :$p
	}
    }

    WebObject instproc destroy args {
	my deregisterPlace
	next
    }

    #
    # simple class, to be inherited before WebObject, if
    # every remote method should reach the object
    #
    Class ExportAll
    ExportAll instproc isExportedProc p {
	return 1
    }

    namespace export WebObject ExportAll
}

namespace import ::xotcl::actiweb::webObject::*

-----BEGIN CERTIFICATE-----
MIIDKjCCApOgAwIBAgIBADANBgkqhkiG9w0BAQQFADCBwDELMAkGA1UEBhMCQVQx
DzANBgNVBAgTBlZpZW5uYTEPMA0GA1UEBxMGVmllbm5hMR0wGwYDVQQKExRNeSBU
ZXN0IE9yZ2FuaXphdGlvbjETMBEGA1UECxMKTXkgRGVtbyBDQTErMCkGA1UEAxMi
TXkgRGVtbyBDQSBhdCBNeSBUZXN0IE9yZ2FuaXphdGlvbjEuMCwGCSqGSIb3DQEJ
ARYfa2xhdXMua29sb3dyYXRuaWtAd3Utd2llbi5hYy5hdDAeFw0wMzA5MDUxMTEw
MDFaFw0xMzA5MDIxMTEwMDFaMIHAMQswCQYDVQQGEwJBVDEPMA0GA1UECBMGVmll
bm5hMQ8wDQYDVQQHEwZWaWVubmExHTAbBgNVBAoTFE15IFRlc3QgT3JnYW5pemF0
aW9uMRMwEQYDVQQLEwpNeSBEZW1vIENBMSswKQYDVQQDEyJNeSBEZW1vIENBIGF0
IE15IFRlc3QgT3JnYW5pemF0aW9uMS4wLAYJKoZIhvcNAQkBFh9rbGF1cy5rb2xv
d3JhdG5pa0B3dS13aWVuLmFjLmF0MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB
gQDIKhCgkG/rSDc8NjDGtJBKW1+fQsoPoBSnMeWOjRQ0YiYomHLZo2XHxsfHsDHj
xXE69GkY9SuwYX/UiF7C0H5LhVew5GTACZsZTbqUWR3D0+R4RQTNJRhQzHq4HE0o
cWjKRiQWWMqNE6S/M4Eri4SJyoaXzhkXjkboYTf/+Dks1wIDAQABozIwMDAPBgNV
HRMBAf8EBTADAQH/MB0GA1UdDgQWBBT5lsU8wZ72pP5lB5ezzqxi5mk4KTANBgkq
hkiG9w0BAQQFAAOBgQA8pZPqoSDBduMtKzNP5A6TerIc7Whm/mwBmiMq0sRHFPWe
sCHJkBxF+ryJT6WDsm1RuCdueHgoppnJ6epdqxmtOAcNcn+OQDU5lzSATBu60B5m
bH4zRsxwn4L9ts+Q1IbjWXc0P1G+2oQSNfvduS7esrs1RM64h6gUJErzxU5cfg==
-----END CERTIFICATE-----

package provide xotcl::actiweb::pageTemplate 0.8

package require xotcl::actiweb::webObject
package require xotcl::actiweb::invoker
package require xotcl::mixinStrategy

package require XOTcl

namespace eval ::xotcl::actiweb::pageTemplate {
    namespace import ::xotcl::*

    Class PageTemplate -superclass WebObject
    PageTemplate instproc init args {
	next
	my mixinStrategy ::Send=TypedString
    }

    PageTemplate abstract instproc listExportedProcs args
    PageTemplate abstract instproc simplePage args

    Class PageTemplateHtml -superclass PageTemplate

    PageTemplateHtml instproc init args {
	my contentType text/html
	next
    }

    PageTemplateHtml instproc listExportedProcs args {
	#
	# place must be a Html place!
	#
	set place [HtmlPlace getInstance]
	set c "
  The following options are avaiable on $n:
  "

	foreach i [my exportedProcs] {
	    set href [my selfAction "[self] $i"]
	    set app {
		<p> <a href= "$href">$i</a>
	    }
	    append c [subst -nobackslashes $app]
	}
	return [my simplePage $place [self] $c]
    }

    PageTemplateHtml instproc simplePage {title heading content {closing ""}}  {
      set place [Place getInstance]
	set c {<html>
<head>
<title>$title</title>
</head>
<body>
<h1>$heading</h1>
<hr>
<p> 
    
$content
	    
<p> $closing

<p><hr><p>
</body>
</html>
}
	return [subst -nobackslashes -nocommands $c] 
    }

    #
    # builds a simple Form -- args are tupels of the form
    # {text, name, type, default, size}
    #
    #
    PageTemplateHtml instproc simpleForm {action args} {
	set action [my selfAction $action]
	set c {
	    <form method="get" action="$action">
	    <TABLE>
	}
	foreach {text name type def size} $args {
	    append c "
      <TR>
        <TD>$text: </TD>
        <TD><input name=\"$name\" type=\"$type\" size=\"$size\" value=\"$def\"></TD>
      </TR>
    "
	}
	append c {
	    <TR>
	    <td><input type=submit value="Submit"></td>
	    <td><input type=reset value="Reset"></td>
	    </TR>
	    </TABLE>

	    </FORM>
	}
	return [subst -nobackslashes -nocommands $c]
    }

    namespace export PageTemplate PageTemplateHtml
}

namespace import ::xotcl::actiweb::pageTemplate::*

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::actiweb::agent 0.8 [list source [file join $dir Agent.xotcl]]
package ifneeded xotcl::actiweb::agentManagement 0.8 [list source [file join $dir AgentManagement.xotcl]]
package ifneeded xotcl::actiweb::htmlPlace 0.8 [list source [file join $dir HtmlPlace.xotcl]]
package ifneeded xotcl::actiweb::httpPlace 0.8 [list source [file join $dir HttpPlace.xotcl]]
package ifneeded xotcl::actiweb::invoker 0.8 [list source [file join $dir Invoker.xotcl]]
package ifneeded xotcl::actiweb::pageTemplate 0.8 [list source [file join $dir pageTemplate.xotcl]]
package ifneeded xotcl::actiweb::placeAccessControl 0.8 [list source [file join $dir PlaceAccessControl.xotcl]]
package ifneeded xotcl::actiweb::secureHtmlPlace 0.8 [list source [file join $dir SecureHtmlPlace.xotcl]]
package ifneeded xotcl::actiweb::secureHttpPlace 0.8 [list source [file join $dir SecureHttpPlace.xotcl]]
package ifneeded xotcl::actiweb::sendStrategy 0.8 [list source [file join $dir SendStrategy.xotcl]]
package ifneeded xotcl::actiweb::userMgt 0.8 [list source [file join $dir UserMgt.xotcl]]
package ifneeded xotcl::actiweb::webAgent 0.8 [list source [file join $dir WebAgent.xotcl]]
package ifneeded xotcl::actiweb::webDocument 0.8 [list source [file join $dir WebDocument.xotcl]]
package ifneeded xotcl::actiweb::webObject 0.8 [list source [file join $dir WebObject.xotcl]]

# -*- tcl -*- $Id: Access.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $

set httpAccessVersion 0.91
package provide xotcl::comm::httpAccess $httpAccessVersion

package require -exact xotcl::comm::pcache 0.9
package require -exact xotcl::comm::mime 0.9
package require -exact xotcl::comm::connection 1.0
package require -exact xotcl::trace 0.91

package require XOTcl

namespace eval ::xotcl::comm::httpAccess {
    namespace import ::xotcl::*

    variable os
    variable VERSION

    if {[catch {set os [exec uname -sr]}]} {
	if {[catch {set os [exec uname -a]}]} { set os unknownOS }
    }
    if {![info exists VERSION]} { set VERSION 1.0 }


    # assert is used only for invariants in the source
    proc assert {f r} {
	set got [eval $f]
	if {$got != $r} {
	    puts stderr "assertion failed: \[$f\] == $r (got $got)"
	}
    }


    # resolve and checkUrl implement URL handling (primarily completion)
    proc checkUrl {url} {
	#puts stderr "checkUrl: <$url>"
	if {![regexp {^([^:]+:/)/([^/]+)(/.*)?$} $url _ scheme network path]} {
	    regexp {^([^:]+:)(/.*)?$} $url _ scheme path
	}
	if {![info exists path]} {
	    # no access scheme provided, try some heuristics...
	    if {[regexp {^[./]} $url]} {
		# expand leading "." to pwd
		if {[regexp {^\.(.*)$} $url _ url]} { set url [pwd]$url }
		return file:$url
	    } else {
		set url http://$url
		regsub {///$} $url // url
		return $url
	    }
	}
	if {$path eq ""} {set path /}
	return [expr {[info exists network] ?
		      "$scheme/$network$path" : "$scheme$path"}]
    }

    # resolving a relative url with respect to a base url (based on rfc 1808)
    proc resolve {rel base {childTagName ""}} {
	if {$base eq ""}    { return [checkUrl $rel] }
	if {$rel eq ""}     { return $base }
	if {[regexp {^[^:]+:/} $rel _]} { return [checkUrl $rel] }
	if {![regexp {^([^:]+:/)/([^/]+)(/.*)$} $base _ baseScheme baseNetwork basePath]} {
	    regexp {^([^:]+:)(/.*)$} $base _ baseScheme basePath
	} elseif {[regexp {^[^:/]+:} $rel]} {
	    return $rel
	}
	regexp {^(.*)\#.*$} $basePath _ basePath
	regexp {^(.*)[?].*$} $basePath _ basePath
	if {[regexp {^//([^/]+)/(.*)$} $rel _ relNetwork relPath]} {
	    return $baseScheme/$relNetwork/$relPath
	}
	if {[info exists baseNetwork]} {
	    append baseScheme /$baseNetwork
	}
	#puts stderr rel=<$rel>
	if {![string match "/*" $rel]} {
	    #puts stderr rel<$rel>base<$basePath>
	    if {[string match \#* $rel]} {
		set r $basePath$rel
	    } elseif {![regsub {/([^/]*)$} $basePath /$rel r]} {
		set r /$rel
	    }
	    while {[regsub -all {/\./} $r / r]} {}
	    regsub {/\.$} $r / r
	    while {[regsub -all {/[^/.]+/\.\./} $r / r]} {}
	    # remove leading /../ (netscapes navigator does this)
	    while {[regsub {^/\.\./} $r / r]} {}
	    set rel $r
	    #puts stderr finalrel<$r>
	}
	#if {$childTagName ne ""} 
	if {1} {
	    upvar 1 $childTagName childTag 
	    catch {unset childTag}
	    if {[regexp {^(.+)\#(.+)$} $rel _ rel childTag]} {
		#puts stderr childTag=$childTag,url=$baseScheme$rel.
	    }
	}
	return $baseScheme$rel
    }

    assert {resolve "" http://mohegan/} http://mohegan/
    assert {resolve http://mohegan/ ""} http://mohegan/
    assert {resolve http://mohegan ""} http://mohegan/
    assert {resolve http://mohegan/ http://nestroy} http://mohegan/
    assert {resolve test.html http://127.0.0.1/} http://127.0.0.1/test.html
    assert {resolve test http://nestroy/} http://nestroy/test
    assert {resolve test file:/u/neumann/old} file:/u/neumann/test
    assert {resolve /test http://nestroy/} http://nestroy/test
    assert {resolve //mohegan/index.html http://nestroy/} http://mohegan/index.html
    assert {resolve //mohegan/index.html http://nestroy/} http://mohegan/index.html
    assert {resolve index.html http://nestroy/dir/} http://nestroy/dir/index.html
    assert {resolve ./index.html http://nestroy/dir/} http://nestroy/dir/index.html
    assert {resolve ././index.html http://nestroy/dir/} http://nestroy/dir/index.html
    assert {resolve ../index.html http://nestroy/dir/} http://nestroy/index.html
    assert {resolve ../../index.html http://nestroy/dir/} http://nestroy/index.html
    assert {resolve ../../../test file:/u/neumann/old} file:/test
    assert {resolve newdir/  http://nestroy/dir/} http://nestroy/dir/newdir/
    assert {resolve /newdir/  http://nestroy/dir/} http://nestroy/newdir/
    assert {resolve file:/u/neumann/ice.html ""} file:/u/neumann/ice.html
    assert {resolve \#label http://nestroy/h.html} http://nestroy/h.html
    assert {resolve mailto:user@host http://nestroy/h.html} mailto:user@host
    assert {resolve ../../../../mis2001/folien/081101.ppt  http://wwwi.wu-wien.ac.at/Studium/Abschnitt_2/LVA_ws01/IT/index.html} http://wwwi.wu-wien.ac.at/mis2001/folien/081101.ppt


    ##############################################################
    # Every object of class Access informs the (possibly empty) list of 
    # informObjects during its lifecycle with the following messages
    #   
    #   startCb:   when the request for the object is created
    #              and was classified and initialized
    #
    #   notifyCb:  when the type of the incming data is dertermined
    #              (typically after parsing the http header)
    #
    #   incCb:     when new data is available
    #
    #   endCb:     when the request is finished sucessfully and the object
    #              is going to be destroyed
    #
    #   cancelCb:  when the request is finished nonsucessfully and the object
    #              is going to be destroyed
    #
    # All these messages receive the name of the Access object
    # as first parameter, incCb has two more arguments (totalsize 
    # and currentsize) 

    # caching:
    # 0 no caching
    # 1 volatile cache (does not check cache, keeps spool file for back button)
    # 2 persistent cache

    Class Access -parameter {
	{method GET} {blocking 0} {httpVersion 1.1} {headers {}} 
	url query data contentType path caching sinkClass parentUrl
    }
    Access instproc informObject x {
	foreach i $x { my lappend informObjects $i }
    }
    Access instproc method x {
			      my set method [string toupper $x]
			  }
    Access instproc unknown {m args} {
	error "Method '$m' with args '$args' is unknown for [self class]"
    }

    Access proc checkRunning {} {
	foreach u [my array names running] {
	    puts stderr "... running: $u"
	}
	puts stderr "... -----------"
    }
    Access proc createRequest args {
	#my showCall
	set informobject {}
	set allowJoin 1
	set nargs {}
	foreach {a v} $args {
	    switch -exact -- $a {
		-url           {set url $v;          lappend nargs $a $v}
		-informObject  {set informobject $v; lappend nargs $a $v}
		-parentRequest {set parentRequest $v}
		-allowJoin     {set allowJoin $v}
		default        {lappend nargs $a $v}
	    }
	}
	#if {[my array exists running]} {parray [self]::running}
	if {[my exists running($url)] && $allowJoin} {
	    my showMsg "we can join running($url)=[my set running($url)]"
	    # we can join the request.
	    # requests are joined by adding the informobjects to
	    # the existing request
	    set token [my set running($url)]
	    # delegation to a different request works only so easy
	    # when loading to a file...
	    $token informObject $informobject
	    return $token
	} else {
	    set token [my autoname ::req]
	    if {[info exists parentRequest]} {
		set token ${parentRequest}$token
	    } 
	    #my showMsg "TOKEN = $token $url"
	    return [eval my create $token $nargs]
	}
    }
    Access instproc running {} {
	#my showCall
	[self class] set running([my url]) [self]
    }
    Access instproc stop {} {
	#showCall
	my instvar url
	if {[[self class] exists running($url)]} {
	    #puts stderr "my unset [[self class] set running($url)]
	    [self class] unset running($url)
	    #if {[my array exists running]} { parray [self class]::running }
	} else {
	    #puts stderr "not running($url)"
	    #if {[my array exists running]} { parray [self class]::running }
	}
    }
    #Access instproc destroy args {
    #  my showCall
    #  next
    #}
    Access instproc init args {
	#my showCall
	my instvar method url
	if {![my exists informObjects]} {
	    my set informObjects {}
	}
	next
	if {![my exists caching]} { 
	    if {$method eq "GET"} {
		set defaultCaching 2
	    } else {
		set defaultCaching 1
	    }
	    my caching $defaultCaching
	}
	#my showVars

	set url [string trim $url]
	my initialize
	if {[my classify $url]} {
	    #my showVars
	    # now inform all interested objects that we have the object
	    my doCallbacks startCb
	    #my showVars blocking
	    # trigger the transfer... (might be blocking or not)
	    my $method
	    if {![my exists finished]} {
		# the request is not finished
		if {[my blocking]} {
		    #my showMsg "waiting"
		    my vwait finished
		    #my showMsg "waiting DONE"
		}
	    }
	}
    }
    Access instproc getContent {} {
	[my set sink] content
    }

    #########################################
    Access instproc timeout t {
	my set timeout [::after $t [self] timeoutOccured]
    }
    Access instproc timeoutOccured {} {
	#my showCall
	my unset timeout
	my abort "timeout exceeded"
    }
    Access instproc timeoutFinish {} {
	if {[my exists timeout]} {
	    after cancel [my set timeout]
	    my unset timeout
	}
    }
    #########################################

    Access instproc initialize {} {
	#my showCall
	my set state           0
	my set meta            {}
	my set currentsize     0
	my set totalsize       0
    }
    Access instproc classify {url} {
	my instvar host path port method
	#my showVars caching
	if {[my caching] > 1 && [persistentCache isValidated $url]} {
	    #puts stderr "*** cacheable && validated"
	    #showVars
	    #persistentCache dump
	    set access CacheAccess
	} elseif {[regexp -nocase {^http://([^/:]+)(:([0-9]+))?(/.*)?$} $url \
		       _ host y givenPort path]} {
	    if {$givenPort ne ""} {set port $givenPort } {set port 80}
	    switch -exact $method {
		PROPFIND -
		PROPPATCH -
		COPY -
		MKCOL -
		MOVE -
		LOCK -
		UNLOCK {
		    package require xotcl::comm::dav
		    set access Dav
		}
		default {set access Http}
	    }
	} elseif {[regexp -nocase {^https://([^/:]+)(:([0-9]+))?(/.*)$} $url \
		       _ host y givenPort path]} {
	    if {$givenPort ne ""} {set port $givenPort } {set port 443}
	    set access Https
	} elseif {[regexp -nocase {^file:(.*)$} $url _ path]} {
	    set access File
	} elseif {[regexp -nocase {^ftp://([^/]+)/(.*)$} $url _ host path]} {
	    package require -exact xotcl::comm::ftp 0.9
	    set access Ftp
	} elseif {[regexp -nocase {^imap://([^/]+)/(.*)$} $url _ host path]} {
	    package require xotcl::comm::imap
	    set access Imap
	} elseif {[regexp -nocase {^cmd:/(.*)$} $url _ path]} {
	    set access xotcl::Cmd    
	} elseif {[regexp -nocase {^ldap://([^/:]+)?(:([0-9]+))?(/.*)$} \
		       $url _ host y givenPort path]} {
	    if {$givenPort ne ""} { set port $givenPort }
	    my showMsg "*** ldap://<$host>:<$port>/<$path>"
	    package require xotcl::comm::ldap
	    set access Ldap  
	} else {
	    #my set state 0
	    my abort "Unsupported URL: '$url'"
	    return 0
	}
	my class $access
	#my showMsg "class of request = $access"
	return 1
    }
    Access instproc revisit {} {
	my class ReAccess
	my initialize
	my [my set method]
    }
    ### dummy stubs for 'close' and 'GET' for error cases
    Access instproc close {} {
    }
    Access instproc GET {} {
	if {[my exists errormsg]} { ;# the error was already reportet
	    my finish
	} else {
	    my abort "unknown error"
	}
    }

    Access instproc headerDone {} {
	my instvar caching sink
	if {[my exists ignoreBody]} return
	if {[my exists sinkClass] && $caching>0 } {
	    error "can´t set both sinkclass and caching"
	}
	switch $caching {
	    2 {
		set sink [CacheFileSink create [self]::cfs]
		#my showMsg "[self class] result goes to cache"
		$sink notifyCb [self]
	    }
	    1 {
		set sink [CacheFileSink create [self]::cfs -persistent 0]
		#my showMsg "result goes to volatile cache"
		$sink notifyCb [self]
	    }
	    0 {
		if {[my exists sinkClass]} {
		    set sink [[my sinkClass] create [self]::s]
		}
	    }
	}
	my doCallbacks notifyCb
    }
    Access instproc mkSpoolFile {{name ""}} {
	if {![my exists fileName]} {
	    my set fileName [persistentCache newEntry [my url] [self] [my caching] $name]
	}
    }
    Access instproc block {} {
	my set block
    }
    Access instproc kill {} {
	my showCall
	my set state -1; #interrupted
	my finish
    }
    Access instproc abort {msg} {
	#my showCall
	#my showVars
	my instvar state errormsg
	if {[catch {::printError "[self] ($state): $msg"} err]} {
	    puts stderr "\n$err\nERROR [self] ($state): $msg\n"
	}
	#my set error [list $msg $::errorInfo $::errorCode]
	my caching 0
	if {[my exists ignoreBody]} {
	    my unset ignoreBody
	}
	set state -2 ;# error
	set errormsg $msg
	my finish
    }
    Access instproc finish {} {
	#my showCall
	my timeoutFinish
	my close
	#my showVars state ignoreBody
	# state is "interrupted" or "error"
	if {[my set state] < 0} {
	    set action cancelCb
	    set success 0
	} else {
	    set action endCb
	    #set state ok
	    set success 1
	}
	if {[my exists ignoreBody]} {
	    my stop
	    #my set finished $success
	    set cmd [my set ignoreBody]
	    my unset ignoreBody
	    #my showMsg "executing... <$cmd>"
	    eval my $cmd
	} else {
	    if {[my exists sink]} {
		[my set sink] $action [self]
	    }
	    #catch {after cancel $after} ;# ????
	    my doCallbacks $action
	    my stop
	    my set finished $success
	}
    }
    Access instproc eof {} {
	#my showCall
	#my showMsg "c [my set currentsize]== t [[self set totalsize]]"
	#my set state eof
	my finish
    }
    Access instproc doCallbacks {cb} {
	#my showCall
	if {[my exists ignoreBody]} {
	    my showMsg "ignoring callback"
	} else {
	    foreach obj [my set informObjects] {
		#my showMsg "*** $obj $cb [self]"
		#puts stderr "------------ calling: $obj $cb [self]"
		if {[catch {$obj $cb [self]} errormsg]} {
		    puts stderr "--------------$cb:errormsg=$errormsg, \
		     errorInfo=$::errorInfo, \
		     errorCode=$::errorCode."
		}
		#puts stderr "------------ calling DONE: $obj $cb [self]"
	    }
	}
    }
    Access instproc shutdown {} {
	#my showMsg "state=[my set state] > 3"
	if {[my set state] > 3} {
	    my set mustDestroy 1
	} else {
	    #my showVars
	    #my showStack
	    #my showMsg "DESTROY !!!"
	    if {[my set state] > -2} {
		my destroy
	    }
	}
    }


    Class FileAccess -superclass Access
    FileAccess instproc initialize args {
	my caching 0
	next
    }
    FileAccess instproc close {} {
    }
    FileAccess instproc block {} {
	my showTimeStart
	set S [open [my set fileName] r]
	fconfigure $S -translation binary
	set block [::read $S]
	::close $S
	my showTimeEnd
	return $block
    }
    FileAccess instproc GET {} {
	my instvar path response totalsize currentsize \
	    fileName informObjects
	set fileName $path
	set totalsize [file size $path]
	set response "file 200 OK"
	my headerDone
	my set state 4
	set currentsize $totalsize
	#my showVars informObjects 
	foreach obj $informObjects {
	    $obj incCb [self] $totalsize $currentsize
	}
	my eof
    }


    Class File -superclass FileAccess
    File instproc GET {} {
	my instvar path
	#puts stderr path=$path,exists=[file exists $path]
	if {![file exists $path]} {
	    my abort "No such file '$path'"
	    return
	}
	if {![my exists contentType]} {
	    my contentType [Mime guessContentType $path]
	}
	my set sink [FileSink create [self]::fas -fileName $path]
	#puts stderr ****sink=$sink,[$sink info class]
	#puts stderr "*** before next ([self class])"
	next
	#puts stderr "*** after next ([self class])"
    }

    Class CacheAccess -superclass File
    CacheAccess instproc GET {} {
	my instvar url
	my path         [persistentCache cacheFileName $url]
	my contentType  [persistentCache contentType $url]
	my set meta     [persistentCache meta $url]
	next
    }

    Class ReAccess -superclass File
    ReAccess instproc GET {} {
	my instvar fileName sink
	my set block       ""
	my set currentsize 0
	my caching     0
	if {![info exists fileName]} {
	    set fileName [$sink set fileName]
	}
	my set path $fileName
	next
    }



    Class Cmd -superclass Access
    Cmd instproc init args {
	if {![my exists caching]} {
	    my caching 0
	}
	next
    }
    Cmd instproc GET {} {
	my instvar path block totalsize currentsize \
	    response informObjects state
	if {[catch {set block [eval $path]} error]} {
	    my contentType text/plain
	    set block $error
	} else {
	    my contentType text/html
	}
	set totalsize [string length $block]
	set response "cmd 200 OK"
	my headerDone
	my set state 4
	set currentsize $totalsize
	foreach obj $informObjects {
	    $obj incCb [self] $totalsize $currentsize
	    #$obj endCb [self]
	}
	#set state eof
	my finish
    }
    Cmd instproc block args {
	my instvar block
	return $block
    }


    #Class NetAccess -superclass Access -parameter {host port}
    Class NetAccess -superclass Access
    NetAccess instproc initialize args {
	if {![my exists blocksize]} {my set blocksize 512}
	my set readMethod read
	next
    }
    NetAccess instproc read {} {
	#my instvar S blocksize block
	#set block [::read $S $blocksize]
	my instvar S block blocksize
	set block [::read $S $blocksize]
    }
    NetAccess instproc gzread {} {
	my instvar S Z blocksize block
	puts -nonewline $Z [::read $S $blocksize]
	set block [::read $Z]
	#puts stderr len=[string length $block],block=<$block>
    }
    NetAccess instproc gzopen {} {
	my instvar Z S readMethod
	requireModules {zipchan libzipchan.so}
	fconfigure $S -translation binary
	set Z [zipchan]
	set readMethod gzread
    }
    NetAccess instproc close {} {
	#my showMsg "**** close persistent=[my exists persistent]"
	if {![my exists persistent]} {
	    foreach stream {S Z} {
		if {[my exists $stream]} {
		    ::close [my set $stream]
		    my unset $stream
		}
	    }
	}
	my stop
    }
    NetAccess instproc hold {} {
	my instvar S
	$S hold
    }
    NetAccess instproc resume {} {
	my instvar S
	$S resume
    }
    NetAccess instproc readData {} {
	#my showCall
	if {[catch {
	    #puts stderr "??????????????readMethod=[my set readMethod]"
	    my [my set readMethod]
	    my pushBlock
	} err]} {
	    puts stderr ERR=$err
	    my set block ""
	    my abort $err
	}
    }
    NetAccess instproc pushBlock {} {
	#my showCall
	my instvar block
	if {[set n [string length $block]]} {
	    my instvar currentsize totalsize informObjects sink
	    #my showVars n currentsize totalsize
	    incr currentsize $n
	    if {$currentsize > $totalsize} {
		set totalsize $currentsize
	    }
	    #my showMsg "total=$totalsize current=$currentsize"
	    if {[my exists ignoreBody]} {
		#puts stderr "ignoring: <$block>"
	    } else {
		if {[info exists sink]} {
		    $sink incCb [self] $totalsize $currentsize
		}
		foreach obj $informObjects {
		    #my showMsg "call incbCb $totalsize $currentsize $obj [$obj info class]"
		    $obj incCb [self] $totalsize $currentsize
		    #my showMsg "done incbCb $totalsize $currentsize"
		}
	    }
	} else {
	    #my showVars n
	    return [my eof]
	}
    }

    Class Http -superclass NetAccess  ;###  -parameter {query {httpVersion 1.0}}
    Http set proxyfilter  httpProxyRequired
    Http set proxyhost    {}
    Http set proxyport    {}
    Http set accept       */*
    if {[info exists argv0]} {
	Http set useragent    "[file tail $argv0] httpAccess/$httpAccessVersion xotcl/$::xotcl::version ($os)"
    }
    Http proc proxyfilter {host phostv pportv} {
	my instvar proxyfilter proxyhost proxyport
	upvar \#1 $phostv phost $pportv pport
	switch -- $proxyfilter {
	    httpProxyRequired {
		if {[string length $proxyhost]} {
		    if {![string length $proxyport]} { set proxyport 8080 }
		    set phost $proxyhost
		    set pport $proxyport
		}
	    }
	}
    }

    Http instproc initialize args {
	if {![my exists port]}        {my set port 80}
	if {![my exists httpVersion]} {my set httpVersion 1.1}
	next
	#my showMsg "result queried from net"
    }
    Http instproc GET {} {
	#my showCall
	if {[my exists query]} {
	    my instvar query caching
	    my append url ?$query
	    my append path ?$query
	    if {$caching == 2} {set caching 1}
	    my showVars caching $query
	}
	my open
    }
    Http instproc HEAD {} {
	my open
    }
    Http instproc POST {} {
	# we have query and data only for a uniform interface for
	# forms that cann pass the attribute value pairs always via
	# query.
	if {[my exists query]} {
	    my data [my query]
	}
	my open
    }
    Http instproc PUT {} {  
	my open
    }
    # Http1.1
    Http instproc OPTIONS {} {
	my showCall
	my open  
    }
    # Http1.1
    Http instproc TRACE {} {
	my showCall
    }
    # Http1.1
    Http instproc DELETE {} {
	#my showCall
	my open  
    }
    Http instproc openConnection {host port reuse} {
	return [Connection make [self] $host $port $reuse _]
    }
    Http instproc open {} {
	#my showCall
	my instvar url S state host port path
	if {$state > 0} {
	    puts stderr "... [self]:$proc ignoring request in state $state"
	    return
	}
	Http proxyfilter $host phost pport
	if {[info exists phost] && [string length $phost]} {
	    set usePort $pport
	    set useHost $phost
	    set path $url
	} else {
	    set usePort $port
	    set useHost $host
	}

	set S [my openConnection $useHost $usePort [expr {[my httpVersion]>1.0}]]
	if {[$S exists error]} {
	    my abort [$S set error]
	    return
	}
	set state 2
	my running
	$S event writable [self] ask
    }

    Http instproc ask {} {
	my instvar url S state host port path \
	    method headers data caching

	$S event writable [self] {}

	if {[pwdManager checkAvailableCredentials $url credentials]} {
	    eval lappend headers $credentials
	    #my showMsg "*** new headers = <$headers>"
	}
	if {$caching==2 && [persistentCache ifModifiedHeader $url ifModified]} {
	    eval lappend headers $ifModified
	    #puts stderr "new headers = <$headers>"
	}
	# Send data in cr-lf format, but accept any line terminators
	$S translation {auto crlf}

	#my showMsg "'$method $path HTTP/[my httpVersion]' headers {$headers}"
	$S puts "$method $path HTTP/[my httpVersion]"
	if {[$S  exists error]} {
	    my abort "Connection refused by host '$host' port '$port'\n\
    	[$S set error]"
	    return
	}

	$S puts "Accept: [Http set accept]"
	$S puts "Host: $host"
	$S puts "User-Agent: [Http set useragent]"
	foreach {tag value} $headers {
	    regsub -all \[\n\r\] $value {} value
	    set tag [string trim $tag]
	    if {[string length $tag]} {
		#my showMsg "+++ <$tag: $value>"
		$S puts "$tag: $value"
	    }
	}
	if {[my exists data]} {
	    $S puts "Content-Length: [string length $data]"
	    $S puts "Content-Type: [my contentType]"
	    $S puts ""
	    $S translation {auto binary}
	    $S puts-nonewline $data
	} else {
	    $S puts ""
	}
	$S flush
	if {[$S  exists error]} {
	    my instvar host port
	    my abort "Connection refused by host '$host' port '$port'\n\
		[$S set error]"
	} else {
	    set state 3
	    $S event readable [self] headerStart
	}
    }

    Http instproc headerStart {} {
	#my showCall
	my instvar S response
	set n [$S gets response]
	#my showVars n response
	if {[$S  exists error]} {
	    my instvar host port
	    my abort "Error on connection to host '$host' port '$port'\n\
		[$S set error]"
	    return
	}
	#my showMsg "n=$n, eof=[$S eof]"
	if {$n == -1 && ![$S eof]} {
	    #my showMsg "******************************input pending, no full line"
	    return
	}
	my instvar responseCode responseHttpVersion
	if {[regexp {^HTTP/([0-9.]+) +([0-9]+) *} $response _ \
		 responseHttpVersion responseCode]} {
	    #my showMsg "response valid: '$response'"
	    $S event readable [self] header
	} else {
	    my instvar host port
	    my abort "Unexpected response from $host:$port\n    $n: '$response'"
	}
    }
    Http instproc header {} {
	my instvar S meta totalsize
	if {[$S gets line]} {
	    #my showMsg "line=$line"
	    if {[regexp -nocase {^content-type:(.+)$} $line _ type]} {
		my contentType [string trim $type]
	    } elseif {[regexp -nocase {^content-length:(.+)$} $line _ length]} {
		set totalsize [string trim $length]
	    }
	    if {[regexp -nocase {^([^:]+): *(.+)$} $line _ key value]} {
		lappend meta [string tolower $key] $value
	    }
	} else {
	    my headerDone
	}
    }
    Http array set expectsBody \
	{GET 1 HEAD 0 POST 1 PUT 0 DELETE 1 OPTIONS 0 TRACE 1}
    Http instproc headerDone {} {
	#my showVars meta
	my instvar S meta method responseCode responseHttpVersion
	[self class] instvar expectsBody
	set expectBody $expectsBody($method)

	array set v [my set meta]
	if {([info exists v(connection)] && $v(connection) eq "close") || \
		$responseHttpVersion < 1.1} {
	    $S makePersistent 0
	} else {
	    $S makePersistent 1
	}
	
	switch $responseCode {
	    200 {}
	    204 {
		#set state empty
		my finish
		set block ""
		set expectBody 0
		return
	    }
	    301 -
	    302 {
		# the request is redirected to another server
		my set ignoreBody [list redirect $v(location)]
		
		# RFC2068 Note: When automatically redirecting a POST request after
		# receiving a 302 status code, some existing HTTP/1.0 user agents
		# will erroneously change it into a GET request.
		#my method GET 
		
		my showMsg "redirect '[my url]' --> '$v(location)'"
	    }
	    304 { ;#  Not Modified, use cached version
		my set ignoreBody cacheAccess
		set expectBody 1
		#my showMsg "result comes from cache"
	    }
	    401 {
		my set ignoreBody \
		    [list resubmitAuthenticated $v(www-authenticate)]
		#my showMsg "resubmitAuthenticated $v(www-authenticate)"
		if {[my exists resubmitAuthenticated]} {
		    if {[my set resubmitAuthenticated] > 5} {
			my abort "Too many wrong passwords given"
		    } else {
			my incr resubmitAuthenticated
		    }
		} else {
		    my set resubmitAuthenticated 1
		}
		set expectBody 1
	    }
	    404 {
		my instvar url
		#my showVars
		my set ignoreBody [list abort "File Not Found on Server '$url'"]
		set expectBody 1
	    }
	    default {
		#my showVars responseCode
	    }
	}
	next
	if {![my exists S]} {;# this request was already canceled
	    return
	}
	if {[info exists v(transfer-encoding)]} {
	    if {$v(transfer-encoding) == "chunked"} {
		$S translation {auto binary}
		my set state 4
		$S event readable [self] readChunkedLength
	    } else {
		my abort "Unexpected Transfer encoding '$v(transfer-encoding)'"
	    }
	} else {
	    # yahoo does not send a content length for a get request
	    #if {$totalsize == 0 && ($responseCode > 300 || !$expectsBody($method) )} 
	    #my showVars method totalsize expectsBody($method) expectBody
	    # the following is used currently for Actiweb-Agents:
	    # the reponse of a PUTS contains a BODY!
	    if {!$expectBody && 
		[::info exists v(content-length)] &&
		$v(content-length) > 0} {
		set expectBody 1
		#my showMsg "setting expectBody 1"
	    }

	    if {!$expectBody} {
		#$S event readable [self] ""
		#set state eof
		my finish
		set block ""
	    } else {
		### To avoid CRLF problmes we set the translation for 
		### the body entity  to binary
		$S translation binary
		my set state 4
		$S event readable [self] readData
	    }
	}
    }

    Http instproc cacheAccess {} {
	# there is an actual version of the document in the cache
	#showCall
	persistentCache validated [my url]
	#my close
	my class CacheAccess
	#my showMsg "result comes from cache [persistentCache cacheFileName $url]"
	my caching 0 ;# should be really: toCache 0
	my GET
    }

    Http instproc redirect location {
	# the request is redirected to another server
	if {$location ne [my url] } {
	    #my showVars
	    my url $location
	    my initialize
	    my classify $location
	    my [my set method]
	}
    }
    Http instproc resubmitAuthenticated headerField {
	#my showCall
	# the server requires authentification
	my instvar path method
	if {[pwdManager checkRequestedAuthentification $method $path $headerField \
		 type realm]} {
	    my instvar url caching method headers
	    array set v $headers
	    #my showVars
	    catch {unset v(Authorization)}
	    set headers [array get v]
	    pwdManager removePasswd $realm
	    my close
	    if {[pwdManager requireCredentials $realm $url]} {
		my initialize
		if {$caching == 2} {set caching 1}
		my $method
	    }
	} else {
	    my abort "unknown authentication method '$headerField'"
	}
    }
    Http instproc readChunkedLength {} {
	#my showCall
	my instvar S chunkLength totalsize
	set length [$S gets lengthString]
	if {$length > 0} {
	    set chunkLength [expr 0x$lengthString]
	    #my showVars lengthString chunkLength
	    if {$chunkLength == 0} {
		$S event readable [self] readChunkedTrailer
	    } else {
		incr totalsize $chunkLength
		$S translation {binary}
		$S event readable [self] readChunkedData
	    }
	}
    }
    Http instproc readChunkedTrailer {} {
	#my showCall
	my instvar S state block
	set size [$S gets line]
	if {$size != 0} {
	    showObj [self]
	    my abort "expected trailer size 0, got size $size"
	} else {
	    #set state eof
	    my finish
	    set block ""
	    #showObj [self]
	}
    }
    Http instproc readChunkedData {} {
	#my showCall
	my instvar S block totalsize currentsize chunkLength
	set block [$S readSize $chunkLength]
	set received [string length $block]
	#my showVars block
	#my showVars currentsize totalsize chunkLength received
	if {$chunkLength == $received} {
	    $S translation {auto binary}
	    $S event readable [self] readChunkedLength
	} else {
	    incr chunkLength -$received
	}
	my pushBlock
    }

    Http instproc readData {} {
	#my showCall
	my instvar S block totalsize currentsize
	set block [$S read]
	#puts stderr "????? bl=[string length $block]"
	if {[$S exists error]} {
	    set block ""
	    my abort [$S set error]
	    return
	}
	my pushBlock
	#my showMsg "c [my set currentsize]== t [[self set totalsize]]"
	if {$currentsize == $totalsize && 
	    [my exists S] && [$S exists persistent]} {
	    #my showMsg "PERSITENT, end of entity reached"
	    #my set state eof
	    my finish
	    set block ""
	    #showObj [self]
	}
	if {[my exists mustDestroy]} {
	    #my showMsg "mustDestroy was set"
	    my destroy
	}
    }
    Http instproc close {} {
	#my showCall
	if {[my exists S]} {
	    [my set S] close
	    #unset S
	}
	#next
    }
    Http instproc freeConnection {} {
	#showCall
	my instvar S
	#::puts stderr "[self] freeing $S !!!!!!!!!!!!!!!!!!!!!!!"
	unset S
    }


    #Access instproc makeZombie {} {
    #  my showMsg "procs= [my info procs], i [Object info instcommands]"
    #  my class Zombie
    #}
    #Class Zombie
    #Zombie instproc unknown {m args} {
    #  my showMsg "+++ zombie method '$m' called"
    #}


    Class Https -superclass Http
    Https instproc initialize args {
	#my showCall
	package require tls 
	if {![my exists port]} { my set port 443}
	next
	### temporary solution, FIXME: 
	### zur zeit muss man den secure-webserver.xotcl und 
	### secure-webclient.xotcl jedenfalls aus dem xotcl/apps/xocomm-apps
	### verzeichnis starten, da haben wir mal die cfg files in unserem
	### baum....
	source .ssl/ssl-configuration.xotcl
	###
    }
    Https instproc openConnection {host port reuse} {
	set S [Connection make [self] $host $port $reuse reused]
	if {$reused} {
	    #my showMsg "reusing $S"
	} else {
	    my showMsg "make the socket ([$S socket]) secure ..."    
	    set cmd [list $S importSSL]
	    foreach attr {cafile cadir certfile cipher command keyfile \
			      model request require ssl2 ssl3 tls1} {
		if {[sslClientConfig exists $attr]} {
		    lappend cmd -$attr [sslClientConfig set $attr]
		}
	    }
	    my showMsg "the assembled command is... ´$cmd´"    
	    eval $cmd
	    puts stderr "CHANNELS= [file channels]"
	}
	return $S
    }



    #######################################################################
    Object pwdManager
    pwdManager proc requirePasswd {realm username password} {
	# used by ftp and imap
	my instvar user area
	upvar [self callinglevel] $password passwd
	if {[my exists pwd($realm)]} {
	    #my showMsg "*** reusing password for $realm"
	    set passwd [my set pwd($realm)]
	    return 1
	} else {
	    userPwd user $username
	    if {[userPwd show $realm user($realm) passwd]} {
		set area($realm/$username) $realm
		return 1
	    }
	}
	return 0
    }
    pwdManager proc storePasswd {realm username password} {
	# used by ftp and imap
	my instvar pwd user
	set pwd($realm) $password
	set user($realm) $username
    }
    pwdManager proc removePasswd {realm} {
	if {[my exists pwd($realm)]} {
	    my unset pwd($realm) 
	    my unset user($realm) 
	}
    }
    pwdManager proc requireCredentials {realm url} {
	regexp {^(.*/)[^/]*$} $url _ path
	if {[my exists pwd($realm)]} {
	    #my showMsg "*** register url=$url for ther realm=$realm"
	    my set area($path) $realm
	    return 1
	} else {
	    my instvar pwd user
	    if {[info exists ::env(USER)]} {
		set USER $::env(USER)
	    } elseif {[info exists ::env(USERNAME)]} {
		set USER $::env(USERNAME)
	    } else {
		set USER unknown
	    }

	    userPwd user $USER
	    if {[userPwd show $realm user($realm) pwd($realm)]} {
		#my showMsg "*** setting password for realm '$realm' url=$path"
		my set area($path) $realm
		return 1
	    }
	}
	return 0
    }
    pwdManager proc encodeCredentials {authMethod realm} {
	#my showCall
	switch $authMethod {
	    basic  {set credential [my encodeCredentialsBasic $realm]}
	    digest {set credential [my encodeCredentialsDigest $realm]}
	}
	return $credential
    }
    pwdManager proc encodeCredentialsBasic {realm} {
	my instvar pwd user
	return [list Authorization \
		    "Basic [base64 encode $user($realm):$pwd($realm)]"]
    }
    pwdManager proc encodeCredentialsDigest {realm} {
	#my showCall
	package require tcu;        #FIXME: noch nicht in distribution
	my instvar digestResponseData
	my mkDigestResponseData $realm
	set digestResponse {}
	foreach {t v} [array get digestResponseData] {
	    append digestResponse " $t = \"$v\","
	}
	return [list Authorization "Digest [string trimright $digestResponse ,]"] 
    }
    pwdManager proc mkDigestResponseData {realm} {
	#my showCall
	my instvar pwd user digestResponseData requestUri
	# RFC 2617
	#   credentials      = "Digest" digest-response
	#   digest-response  = 1#( username | realm | nonce | digest-uri
	#                                | response | [ algorithm ] | [cnonce] |
	#                                [opaque] | [message-qop] |
	#                                    [nonce-count]  | [auth-param] )
	#   username         = "username" "=" username-value
	#   username-value   = quoted-string
	#   digest-uri       = "uri" "=" digest-uri-value
	#   digest-uri-value = request-uri   ; As specified by HTTP/1.1
	#   message-qop      = "qop" "=" qop-value
	#   cnonce           = "cnonce" "=" cnonce-value
	#   cnonce-value     = nonce-value
	#   nonce-count      = "nc" "=" nc-value
	#   nc-value         = 8LHEX
	#   response         = "response" "=" request-digest
	#   request-digest = <"> 32LHEX <">
	#   LHEX             =  "0" | "1"| ...| "e" | "f"  
	set digestResponseData(username) $user($realm)
	set digestResponseData(uri) $requestUri
	set digestResponseData(cnonce) "TEST"
	set digestResponseData(nc) 00000001
	set digestResponseData(response) [my mkRequestDigest]
	#parray digestResponseData
    }
    pwdManager proc mkRequestDigest {} {
	# returns a string of 32 hex digits, which proves that the user
	# knows a password
	
	#A1 = unq(username-value) ":" unq(realm-value) ":" passwd
	my instvar digestResponseData pwd requestMethod requestUri
	append A1 $digestResponseData(username)\
	    : $digestResponseData(realm) : $pwd($digestResponseData(realm))
	if {![my exists digestResponseData(qop)] || 
	    $digestResponseData(qop) eq "auth"} {
	    append A2 $requestMethod : $requestUri
	} elseif {$digestResponseData(qop) eq "auth-int"} {
	    #A2 = Method ":" digest-uri-value ":" H(entity-body)
	    append A2 $requestMethod : $requestUri: ""
	}
	if {[my exists digestResponseData(qop)]} {
	    append reqDigest $digestResponseData(nonce) : \
		$digestResponseData(nc) : \
		$digestResponseData(cnonce): \
		$digestResponseData(qop)
	    set reqDigest [md5 [md5 $A1]:$reqDigest:[md5 $A2]]
	} else {    
	    set reqDigest [md5 [md5 $A1]:$digestResponseData(nonce):[md5 $A2]]
	}  
	return $reqDigest 
    }

    pwdManager proc checkAvailableCredentials {url returnCredentials} {
	# we start a fresh request and check, whether we have sent for this url
	# (directory) already some credentials in an earlier reqhest.
	my instvar authMethod
	regexp {^(.*/)[^/]*$} $url _ path
	if {[my exists area($path)]} {
	    set realm [my set area($path)]
	    upvar [self callinglevel] $returnCredentials credentials
	    #my showMsg "*** adding credentials for realm=$realm and $path"
	    set credentials [my encodeCredentials $authMethod $realm]
	    return 1
	}
	return 0
    }
    pwdManager proc checkRequestedAuthentification {reqMethod path headerField 
						    typeVar realmVar} {
	# check for which realm with which authentification method the
	# server wants an authentification
	#my showCall
	upvar [self callinglevel] $typeVar type $realmVar realm
	my instvar authMethod digestResponseData requestUri requestMethod
	set requestUri $path
	set requestMethod $reqMethod
	if {[regexp {^Basic realm="(.*)"$} $headerField _ realm]} {
	    set type basic;#    FD: musste da lassen wg. call by reference
	    set authMethod $type
	    return 1
	} elseif {[regsub {^Digest } $headerField _ headerField]} {
	    set type digest ;# FD: musste da lassen wg. call by reference
	    set authMethod $type
	    foreach pair [split $headerField ,] {      
		if {[regexp {^(.*) *= *(".*")$} $pair _ n v]} {
		    set digestResponseData([string trim $n]) [string trim [string trim $v] \"]
		}
	    }
	    set realm $digestResponseData(realm)
	    return 1
	}
	return 0
    }

    #######################################################################
    # test classes
    Class Sink
    Sink instproc startCb         {r}   {
	my set contentLength 0
	next
    }
    Sink instproc notifyCb      {r}     {
	next
    }
    Sink instproc incCb         {r t c} {
	my set contentLength $t
	next
    }
    Sink instproc endCb         {r}     {
	next
	#showCall
    }
    Sink instproc cancelCb      {r}     {
	next
	#showCall
    }
    Sink instproc content       {}      {
	next
	#showCall
    }
    Sink instproc contentLength {}      {
	my set contentLength
	#showCall
    }


    Class TimeSink -superclass Sink
    TimeSink instproc startCb         {r}   {
	my set startTime [clock clicks]
	next
    }
    TimeSink instproc notifyCb      {r}     {
	my set notifyTime [clock clicks]
	next
    }
    TimeSink instproc endCb         {r}     {
	my set endTime [clock clicks]
	next
	my reportTimes
    }
    TimeSink instproc cancelCb      {r}     {
	my set endTime [clock clicks]
	next
    }
    TimeSink instproc reportTimes {}     {
	my instvar startTime endTime notifyTime
	set bytes [my contentLength]
	set grossSecs		[expr {($endTime-$startTime)/1000000.0}]
	set grossKbps		[expr {($bytes/1000.0)/$grossSecs}]
	set netSecs		[expr {($endTime-$notifyTime)/1000000.0}]
	set netKbps [expr {($bytes/1000.0)/$netSecs}]
	#if {[catch {set netKbps [expr {($bytes/1000.0)/$netSecs}]}]} {
	#  set netKbps 0
	#}
	set headSecs		[expr {$grossSecs-$netSecs}]
	foreach v {grossSecs grossKbps netSecs netKbps headSecs} {
	    set $v [format %.2f [set $v]]
	}
	my showMsg "got $bytes bytes in $grossSecs ($headSecs+$netSecs) seconds,\
	$grossKbps ($netKbps) KB/S"
    }


    Class ParallelSink -superclass Sink -parameter {
	{httpVersion 1.1}
	{sinkClass TimeSink}
	{maxsimultaneous 20}
    }
    ParallelSink instproc init args {
	next
	my set running 1
	my set numrequests 0
	my set sumbytes 0
	my set blocked {}
    }
    ParallelSink instproc startCb r {
	#my showCall
	my incr running
	my incr numrequests
	#puts stderr "... running++ [my set running]"
    }
    ParallelSink instproc endCb r {
	#my showCall
	my incr sumbytes [$r set currentsize]
	my done $r
    }
    ParallelSink instproc cancelCb r {
	#my showCall
	my done $r
    }
    ParallelSink instproc done r {
	#my showCall
	my instvar blocked
	$r shutdown
	my incr running -1
	#puts stderr "... running-- [my set running] [llength [Http info instances]]"
	#puts stderr [Http info instances]
	#foreach i [Http info instances] {puts stderr "\t$i: [$i set method] [$i set url]"}
	#puts stderr RUNNING=[my set running]
	if {[llength $blocked] > 0} {
	    set newreq [lindex $blocked 0]
	    set blocked [lrange $blocked 1 end]
	    my scheduleRequest [lindex $newreq 0] [lindex $newreq 1] [lindex $newreq 2]
	} elseif {[my set running] < 1} {
	    my set done 1
	}
    }


    ParallelSink instproc scheduleRequest {method url {parentUrl ""}} {
	my instvar requests blocked running maxsimultaneous
	if {$running > $maxsimultaneous} {
	    lappend blocked [list $method $url $parentUrl]
	} else {
	    set cmd [list Access createRequest -url $url \
			 -sinkClass [my sinkClass] \
			 -informObject [self] \
			 -method $method \
			 -timeout 25000 \
			 -caching 0 -allowJoin 0 -httpVersion [my httpVersion]]
	    if {$parentUrl ne ""} {
		lappend cmd -parentUrl $parentUrl
	    }
	    set r [eval $cmd]
	}
    }

    ParallelSink instproc requests {urls} {
	my showTimeStart
	foreach url $urls { my scheduleRequest GET $url }
	my wait
	my showTimeEnd
    }

    ParallelSink instproc wait {} {
	my instvar running
	if {$running > 0} {
	    set savedValue $running
	    #my showMsg ".......... waiting for initially $running requests"
	    if {[catch {my vwait done} err]} {
		my showMsg "vwait returned: $err "
	    }
	    #my showMsg "$savedValue requests FINISHED "
	}
    }

    Class MemorySink -superclass Sink
    MemorySink instproc incCb         {r t c} {
	my append d [$r block]
	next
    }
    MemorySink instproc content       {}      {
	return [my set d]
    }
    MemorySink instproc contentLength {}      {
	if {[my exists d]} {
	    return [string length [my set d]]
	} else {
	    return 0
	}
    }

    Class FileSink  -superclass Sink -parameter fileName
    ### write methods
    #FileSink instproc startCb         {r}   {
    #  next
    #}
    FileSink instproc notifyCb      {r}     {
	#my showVars
	next
	my instvar file fileName
	if {[info exists fileName]} {
	    set file [::open $fileName w]
	    fconfigure $file -translation binary
	} else {
	    # we have no filename; we assume the sink must be a dummy sink
	    # that deletgates its work to some other FileSink
	    my class ShadowFileSink
	    my notifyCb $r
	}
    }
    FileSink instproc incCb {r t c} {
	next
	if {[my exists file]} {
	    if {$r == "req0"} {
		puts stderr "*******************************************************"
		puts stderr [$r block]
		puts stderr "*******************************************************"
	    }
	    puts -nonewline [my set file] [$r block]
	}
    }
    FileSink instproc endCb  {r} {
	#my showCall
	next
	my close
    }
    FileSink instproc cancelCb  {r} {
	next
	my close
    }
    FileSink instproc close {} {
	if {[my exists file]} {
	    ::close [my set file]
	    my unset file
	}
    }
    ### read methods
    FileSink instproc content {} {
	next
	my instvar file fileName
	set file [::open $fileName r]
	fconfigure $file -translation binary
	set d [read [my set file]]
	my close
	return $d
    }
    FileSink instproc contentLength {}      {
	next
	if {[my exists fileName]} {
	    return [file size [my set fileName]]
	} else {
	    return 0
	}
    }


    Class ShadowFileSink -superclass Sink
    ShadowFileSink instproc notifyCb      {r} {
	next
	my set token $r
    }
    ShadowFileSink instproc content       {} {
	my instvar token
	next
	return [[$token set sink] content]
    }
    ShadowFileSink instproc contentLength {} {
	my instvar token
	next
	return [[$token set sink] contentLength]
    }


    Class CacheFileSink -superclass FileSink -parameter {{persistent 1}}
    CacheFileSink instproc notifyCb req {
	#my showCall
	if {![my exists fileName]} {
	    my instvar persistent
	    set url [$req set url]
	    my set fileName [persistentCache newEntry $url $req $persistent ""]
	}
	# it is important to execute next after setting the fileName...
	next
    }
    CacheFileSink instproc endCb req {
	#my showCall
	my instvar persistent
	next
	if {$persistent} {
	    persistentCache entryDone [$req set url]
	}
    }
    CacheFileSink instproc cancelCb req {
	next
	if {[my exists fileName]} {
	    file delete [my set fileName]
	    my unset fileName
	}
    }
    CacheFileSink instproc destroy {} {
	#my showCall
	if {[my exists fileName] && ![my set persistent]} {
	    #my showMsg "file delete $fileName"
	    file delete [my set fileName]
	    my unset fileName
	}
	next
    }


    #===========================================================

    Class SimpleRequest -parameter {
	{caching 0} 
	{useFileSink 0} 
	{blocking 1} 
	{timing 0} 
	url fileName 
	timeout httpVersion method headers data query contentType informObject
    }
    SimpleRequest instproc fileName x {
	my set fileName $x
	my set useFileSink 1
    }
    SimpleRequest instproc init args {
	my instvar useFileSink fileName sink caching token  
	#my showMsg "Starting Request"
	next
	if {[info exists fileName]} {
	    set sink [FileSink create [self]::sink -fileName $fileName]
	} elseif {$useFileSink || $caching > 0} {
	    set sink [FileSink create [self]::sink]
	} else {
	    set sink [MemorySink create [self]::sink]
	}
	#my showMsg "class of sink = [$sink info class]"
	if {[my set timing]} {
	    $sink mixin TimeSink
	}
	set cmd [list Access createRequest \
		     -url [my url] \
		     -informObject $sink \
		     -blocking [my blocking] \
		     -caching $caching]
	foreach optionalParameter {
	    timeout httpVersion method headers data query  
	    contentType informObject
	} {
	    if {[my exists $optionalParameter]} {
		lappend cmd -$optionalParameter [my set $optionalParameter]
	    }
	}
	#my showMsg "cmd=$cmd"
	set token [eval $cmd]
	#if {[my success]} {
	#  $sink reportTimes
	#  #puts stderr <[$sink content]>
	#}
    }
    SimpleRequest instproc success {} {
	if {[my exists token]} {
	    return [expr {[[my set token] set finished] == 1}]
	} 
	return 0
    }
    SimpleRequest instproc destroy {} {
	if {[my exists token]} {
	    [my set token] destroy
	}
	next
    }
    SimpleRequest instproc getContent {} {
	[my set sink] content
    }
    SimpleRequest instproc getContentLength {} {
	[my set sink] contentLength
    }
    #SimpleRequest instproc destroy args { next }

    #######################################################################

    namespace export \
	Access FileAccess File CacheAccess ReAccess \
	Cmd NetAccess Http Https Sink TimeSink \
	ParallelSink MemorySink FileSink \
	ShadowFileSink CacheFileSink SimpleRequest
}

namespace import ::xotcl::comm::httpAccess::*

 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstraße 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

# -*- tcl -*- $Id: Connection.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::comm::connection 1.0

package require XOTcl

namespace eval ::xotcl::comm::connection {
    namespace import ::xotcl::*

    Class Connection -parameter {host port req socket handle}

    Connection proc make {r host port reuse reusedVar} {
	#my showCall
	my instvar openConnections
	upvar [self callinglevel] $reusedVar reused
	if {$reuse} {
	    set handle $host:$port-[$r set blocking]
	    #if {[array exists openConnections]} {parray openConnections}
	    if {![info exists openConnections($handle)]} {
		# there is no persistent connection, we create a new one
		set reused 0
		set openConnections($handle) \
		    [Connection new -host $host -port $port -req $r -handle $handle]
		#my showMsg "$openConnections($handle) CONNECTION add for $handle added"
	    } else {
		# there is a persistent connection
		set reused 1
		set c $openConnections($handle)
		$c instvar req
		#::puts stderr "$c CONNECTION reuse for $handle ($c) new req=$r"
		if {[info exists req]} {
		    # the persistent connection is active with some request $req
		    #::puts stderr "$c CONNECTION req $req already active"
		} else {
		    # the persistent connection is currently not active
		    $c set req $r
		}
	    }
	    return $openConnections($handle)
	} else {
	    set reused 0
	    return [Connection new -host $host -port $port -req $r]
	}
    }
    Connection proc removeHandle handle {
	#my showVars
	#puts stderr "***************** unsetting $handle ***************"
	if {[my exists openConnections($handle)]} {
	    my unset openConnections($handle)
	}
    }
    Connection instproc init args {  ;# the constructor creates the socket
	my set blocked {}
	next
	if {[my exists socket]} {
	    my set keepOpen 1
	} else {
	    my set keepOpen 0
	    if {[catch {my socket [socket -async [my host] [my port]]} msg]} {
		my set error $msg
		return
	    }
	}
	::fconfigure [my socket] -blocking false -buffersize 16384
    }
    #Connection instproc STATUS {ctx} {
    #  my instvar socket
    #  ::puts stderr "*** $ctx: $socket blocking=[::fconfigure $socket -blocking]"
    #}
    Connection instproc destroy {} { ;# the destructor closes the socket
	#my showCall
	if {[my exists handle]} {
	    #my showVars handle
	    # the connection was created via make
	    [self class] removeHandle [my handle]
	    #::puts stderr "my CONNECTION close and destroy [my handle]"
	} else {
	    #::puts stderr "my CONNECTION close and destroy"
	}
	# in cases of errors we might not have a socket yet
	if {[my exists socket]} {
	    close [my socket]
	}
	next
    }
    Connection instproc translation {translation} {
	#showCall
	::fconfigure [my socket] -translation $translation
    }    
    Connection instproc importSSL args {
	#my showCall
	package require tls
	eval tls::import [my socket] $args
    }
    Connection instproc fconfigure args {
	#my showCall
	eval ::fconfigure [my socket] $args
    }    
    Connection instproc event {type r method} {
	#my showCall
	my instvar req blocked
	# is the request in the argument list the currently active request?
	if {[info exists req] && $r == $req} {
	    # a request can overwrite its active request
	    if {$method eq ""} {
		::fileevent [my socket] $type ""
		#my showMsg "CONNECTION clear for [my socket]"
	    } else {
		#my showMsg "CONNECTION register for [my socket]"
		::fileevent [my socket] $type [list $r $method]
	    }
	} else {
	    #my showMsg "event BLOCKING current request=$req, new=$r $method"
	    #my showMsg "event BLOCKING rd=[::fileevent [my socket] readable]"
	    #my showMsg "event BLOCKING wr=[::fileevent [my socket] writable]"
	    #my showMsg "event BLOCKING bl=$blocked"
	    ::lappend blocked $r $type $method
	}
    }
    Connection instproc hold {} {
	my set continueCmd [list ::fileevent [my socket] readable \
				[::fileevent [my socket] readable]]
	::fileevent $socket readable {}
	#my showVars continueCmd
    }
    Connection instproc resume {} {
	#my showCall
	if {[my exists continueCmd]} {
	    eval [my set continueCmd]
	    my unset continueCmd
	}
    }

    Connection instproc puts {string} {
	#my showCall
	if {[catch {::puts [my socket] $string} msg]} {
	    ::puts stderr message=$msg
	}
    }
    Connection instproc puts-nonewline {string} {
	#my showCall
	if {[catch {::puts -nonewline [my socket] $string} msg]} {
	    ::puts stderr message=$msg
	}
    }
    Connection instproc gets {var} {
	#my showCall
	upvar [self callinglevel] $var result
	if {[catch {set n [::gets [my socket] result]} msg]} {
	    my set error $msg 
	    #my showMsg "CONNECTION error"
	    return 0
	}
	#my showMsg "n=$n, result=<$result>"
	return $n
    }
    Connection instproc read {} {
	#my showCall
	my instvar socket
	if {[catch {set result [::read $socket [::fconfigure $socket -buffersize]]} msg]} {
	    my set error $msg 
	    return ""
	}
	#my showMsg Done
	return $result
    }
    Connection instproc readSize {length} {
	if {[catch {set result [::read [my socket] $length]} msg]} {
	    my set error $msg 
	    return 0
	}
	return $result
    }
    Connection instproc flush {} {
	#my showCall
	if {[catch {::flush [my socket]} msg]} {
	    my set error $msg 
	}
    }
    Connection instproc eof {} {
	#my showCall
	if {[my exists error]} {
	    return 1
	} else {
	    return [::eof [my socket]]
	}
    }
    Connection instproc close {} {
	#my showCall
	my instvar req socket blocked
	if {![info exists socket]} return ;# error during connection open
	::fileevent $socket readable ""
	::fileevent $socket writable ""
	$req freeConnection
	if {[my exists persistent]} {
	    my flush
	    #::puts stderr "[self] PERSISTENT CONNECTION wanna close"
	    if {$blocked eq ""} {
		::fileevent $socket readable [list [self] destroy]
		unset req
	    } else {
		#my showVars blocked
		set req [lindex $blocked 0]
		set type [lindex $blocked 1]
		set method [lindex $blocked 2]
		set blocked [lrange $blocked 3 end]
		#my showMsg "in persistent connection unblock $type [list $req $method]"
		::fileevent $socket $type [list $req $method]
	    }
	} else {
	    #my showMsg "in nonpersistent connection blocked=$blocked"
	    if {$blocked ne ""} {
		set req [lindex $blocked 0]
		set type [lindex $blocked 1]
		set method [lindex $blocked 2]
		set nblocked [lrange $blocked 3 end]
		close $socket
		unset socket
		if {[my exists handle]} {
		    [self class] removeHandle [my handle]
		}
		if {[my exists error]} {
		    #my showMsg "UNSETTING ERROR -----------"
		    my unset error
		}
		my init
		set blocked $nblocked
		::fileevent $socket $type [list $req $method]
		#my showMsg "REANIMATE $socket $type [list $req $method]"
		#my showVars
	    } else {
		#my showMsg "Nothing blocked: readable=[::fileevent $socket readable]"

		my destroy
	    }
	}
    }
    Connection instproc makePersistent {p} {
	if {$p} {
	    my set persistent 1
	} else {
	    if {[my exists persistent]} {
		my unset persistent
		#my showMsg "no longer persistent"
	    }
	}
    }

    namespace export Connection
}

namespace import ::xotcl::comm::connection::*

if {[info command bgerror] eq ""} {
    proc bgerror {msg} { puts stderr "******* bgerror $msg $::errorInfo*****"}
}

# $Id: Dav.xotcl,v 1.4 2006/02/18 22:17:33 neumann Exp $

package provide xotcl::comm::dav 0.9

package require XOTcl

namespace eval ::xotcl::comm::dav {
  package require xotcl::comm::httpAccess
  namespace import ::xotcl::*

  Class Dav -superclass Http
  Dav instproc initialize args {
    my instvar contentType 
    #showCall
    set contentType text/xml
    next
  }

  Dav instproc PROPFIND {} {
    #showCall
    # extra dav headers
    # Depth: ("0" | "1" | "infinity") [infinity is the default]
    
    # body is a propfind XML-Element
    # <!ELEMENT propfind (allprop | propname | prop) >
    #     <!ELEMENT allprop EMPTY >
    #     <!ELEMENT propname EMPTY >
    #     <!ELEMENT prop ANY>

    # this should be set by the clients
    #<?xml version="1.0" encoding="utf-8" ?>
    #             <D:propfind xmlns:D='DAV:'>
    #                  <D:allprop/>
    #             </D:propfind>
    my open
  }
  Dav instproc PROPPATCH {} {
    #showCall
    # body is a propertyupdate XML-Element
    # <!ELEMENT propertyupdate (remove | set)+ >
    #     <!ELEMENT remove (prop) >
    #     <!ELEMENT set (prop) >
    
    #   set xmlReqBody($method) "<?xml version=\"1.0\" encoding=\"utf-8\" ?>
    #             <D:propertyupdate xmlns:D=\"DAV:\">
    #                 <D:remove>
    #                    <D:prop> 
    #                        <D:displayname/>
    #                    </D:prop>                    
    #                  </D:remove>
    #             </D:propertyupdate>"
    my open
  }
  Dav instproc MKCOL {} {
    #showCall
    # invoked without a request body (may contain a message body?)
    my open
  }
  Dav instproc GET {} {
    #showCall
    # invoked without a request body and without extra header
    # back to HTTP class
    next
  }
  Dav instproc HEAD {} {
    #showCall
    # invoked without a request bodyand without extra header
    # back to HTTP class
    next
  }
  Dav instproc POST {} {
    #showCall
    # the same as in  RFC2068
    # back to HTTP class
    next
  }
  Dav instproc DELETE {} {
    #showCall
    # extra dav headers
    # Depth: ("0" | "1" | "infinity")

    # invoked without a request body
    my open
  }
  Dav instproc PUT {} {
    #showCall
    # PUT for Non-Collection Resources --> RFC2068
    # PUT for Collections --> MKCOL
    # next
  }
  Dav instproc COPY {} {
    #showCall
    # extra dav headers
    # If: [see 9.4 WebDAV]
    # Destination: <absolutURI> [see RFC2396 for the definition of absolutURI]
    # Depth: ("0" | "1" | "infinity")
    # Overwrite: ("T" | "F")
    

    # body is a propertybehavior XML-Element
    # <!ELEMENT propertybehavior (omit | keepalive) >
    #     <!ELEMENT omit EMPTY >
    #     <!ELEMENT keepalive (#PCDATA | href+) >
    #         <!ELEMENT href (#PCDATA) >
    my open
  }
  Dav instproc MOVE {} {
    #showCall
    # extra dav headers
    # If: [see 9.4 WebDAV]
    # Destination: <absolutURI> [see RFC2396 for the definition of absolutURI]
    # Depth: "infinity" [see 8.9.2]
    # Overwrite: ("T" | "F")

    # body is a propertybehavior XML-Element
    # see COPY
    my open
  }
  Dav instproc LOCK {} {
    #showCall
    # extra dav headers
    # If: [see 9.4 WebDAV]
    # Destination: <absolutURI> [see RFC2396 for the definition of absolutURI]
    # Depth: ("0" | "1" | "infinity")
    # Timeout: [see 9.8 WebDAV]
    # Authorization: (defined in HTTP1.1 in 14.8)

    # body is a lockinfo XML-Element
    # <!ELEMENT lockinfo (lockscope, locktype, owner?) >
    #    <!ELEMENT lockscope (exclusive | shared) >
    #        <!ELEMENT exclusive EMPTY >
    #        <!ELEMENT shared EMPTY >
    #    <!ELEMENT locktype (write) >
    #        <!ELEMENT write EMPTY >
    #    <!ELEMENT owner ANY>
    my open
  }

  # The Lock-Token request header is used with the UNLOCK method to
  # identify the lock to be removed.
  Dav instproc UNLOCK {} {
    my instvar headers 
    #showCall
    # extra dav headers
    # Lock-Token: <Coded-URL> [see 8.11 in WebDAV]

    # invoked without a request body
    my open
  }

  #---------------------
  # Utility            #
  #---------------------

  #?
  Object xmlReqBodyManager 
  xmlReqBodyManager proc requireXmlReqBody {request} {
  }

  #? 
  Object davHeaderManager 
  davHeaderManager proc requireDavHeader {request} {
  }



  #LOCK /DAV/welcome.html HTTP/1.1  
  #Host: wawog
  #Connection: close

  namespace export Dav \
      xmlReqBodyManager davHeaderManager 
}

namespace import ::xotcl::comm::dav::*

# $Id: Ftp.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::comm::ftp 0.9
package require xotcl::comm::httpAccess

package require XOTcl

namespace eval ::xotcl::comm::ftp {
    namespace import ::xotcl::*

    Class Ftp -superclass NetAccess -parameter {user passwd}
    Ftp instproc initialize args {
	#my showCall
	my instvar port caching user passwd loginMsg resp blocksize
	set port 21
	set blocksize 1024
	set caching 0
	set user ftp
	set passwd cineast@
	set loginMsg {}
	set resp(connect)       {220 provideUser}
	set resp(provideUser)   {331 providePasswd}
	set resp(providePasswd) {230 loginFinished}
	set resp(loginFinished) {227 pasv}
	set resp(pasv)          {200 type}
	set resp(type-list)     {150 list}
	set resp(type-retr)     {150 retr 550 retry-retrieve}
	set resp(transfer)      {226 transferDone}
	next
    }
    Ftp instproc err {state reply} {
	my abort "Error in $state: $reply"
    }
    Ftp instproc queryServer {query state} {
	my instvar S
	puts $S $query
	flush $S
	fileevent $S readable [::list [self] response $state]
    }
    Ftp instproc response {state} {
	#my showCall
	my instvar S code msg
	set reply [gets $S]
	#my showVars reply
	if {[regexp {^([0-9]+)[-](.*)$} $reply _ code msg]} {
	    fileevent $S readable [::list [self] responseMulti $state]
	} else {
	    regexp {^([0-9]+) (.*)$} $reply _ code msg 
	    my responseEnd $state
	}
    }
    Ftp instproc responseMulti {state} {
	# multi line response
	my instvar S code msg 
	set m [gets $S]
	if {[regexp "^$code " $m]} { 
	    my responseEnd $state
	} else {
	    # try to strip code and dash
	    regexp "^$code-(.*)\$" $m _ m
	    append msg \n$m
	}
    }
    Ftp instproc responseEnd {state} {
	my instvar S code msg resp
	fileevent $S readable {}
	#puts stderr "code=$code, msg=<$msg>"
	foreach {c newState} $resp($state) {
	    if {$c == $code} { return [my $newState] }
	}
	my err $state "expected=$resp($state), got $code $msg"
    }
    Ftp instproc GET {} {
	my instvar S  host port url
	regexp {^(.*):([0-9]+)$} $host _ host port
	my running
	# rb running my $url ;# ???
	# proxy ?
	set S [socket -async $host $port]
	fconfigure $S -blocking false -translation {auto crlf}
	fileevent $S readable [::list [self] response connect]
    }
    Ftp instproc provideUser {} {
	my instvar user msg loginMsg
	set loginMsg $msg
	my queryServer "USER $user" provideUser
    }
    Ftp instproc providePasswd {} {
	my instvar passwd
	#  if {[pwdManager requirePasswd "Ftp $user\@$host" $user password]} {
	#    my queryServer "PASS $password" providePasswd
	#  }
	my queryServer "PASS $passwd" providePasswd
    }
    Ftp instproc loginFinished {} {  
	my instvar msg loginMsg
	append  loginMsg \n$msg
	my queryServer "PASV" loginFinished
    }
    Ftp instproc pasv {} {
	my instvar S D msg
	set d {([0-9]+)}
	if {[regexp "\[(]$d,$d,$d,$d,$d,$d" $msg _ 1 2 3 4 p1 p2]} {
	    if {[catch {set D [socket -async $1.$2.$3.$4 [expr {$p1*256 + $p2}]]} err
		]} {
		return [my err $proc $err] 
	    }
	    fconfigure $D -blocking no -translation binary
	} else {
	    return [my err $proc $msg] 
	}
	my queryServer "TYPE I" pasv
    }
    Ftp instproc type {} {
	my instvar path
	if {$path=={}} {
	    my queryServer "LIST" type-list
	} elseif {[regexp /$ $path]} { 
	    my queryServer "LIST $path" type-list
	} else {
	    my queryServer "RETR $path" type-retr
	}
    }
    Ftp instproc retry-retrieve {} {
	my instvar path url
	append url /
	my queryServer "LIST $path/" type-list
    }
    Ftp instproc list {} {
	my instvar S D contentType
	set contentType text/dirlist
	my headerDone
	fileevent $S readable [::list [self] response transfer]
	fileevent $D readable [::list [self] readData]
    }
    Ftp instproc read {} {
	# the method read is called by the more general method readData
	my instvar D block blocksize
	if {[::eof $D]} {
	    set block ""
	    close $D
	    unset D
	} else {
	    #puts stderr blocksize=$blocksize
	    set block [::read $D $blocksize]
	    #puts stderr read:[string length $block]bytes
	}
    }
    Ftp instproc transferDone {} {
	my instvar D S
	if {[info exists D]} {
	    fileevent $S readable {}
	    set block ""
	    close $D
	    unset D
	} 
	my finish
    }
    Ftp instproc retr {} {
	my instvar S D msg totalsize contentType path
	regexp {[(]([0-9]+)[ ]+[Bb]ytes} $msg _ totalsize
	set contentType [Mime guessContentType $path]
	my headerDone
	if {[info exists S]} {
	    # file dialog was not canceled
	    fileevent $S readable [::list [self] response transfer]
	    fileevent $D readable [::list [self] readData]
	    fconfigure $D -translation binary
	}
    }

    namespace export Ftp
}

namespace import ::xotcl::comm::ftp::*

# -*- tcl -*- $Id: Httpd.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $
#
# The XOTcl class Httpd implements an HTTP/1.0 and HTTP/1.1 server with  
# basic functionality.
#
#  Gustaf Neumann (neumann@wu-wien.ac.at)

set VERSION 1.1
package provide xotcl::comm::httpd $VERSION

package require XOTcl

#package require xotcl::comm::httpAccess

package require -exact xotcl::comm::connection 1.0
package require -exact xotcl::trace 0.91
package require -exact xotcl::comm::mime 0.9

namespace eval ::xotcl::comm::httpd {
  namespace import ::xotcl::*

  Class Httpd -parameter {
    {port 80} 
    ipaddr 
    {root ./} 
    {logdir $::xotcl::logdir} 
    {httpdWrk Httpd::Wrk}
    {redirects [list]}
    {workerTimeout 10000}
  }
  Httpd proc Date seconds {clock format $seconds -format {%a, %d %b %Y %T %Z}}
  Httpd instproc checkRoot {} {
    my instvar root
    set root [string trimright $root /]
    if {![file isdir $root]} {
      puts stderr "Warning: create root directory '$root'"
      file mkdir $root
    } 
    # make directory absolute
    set currentdir [pwd]
    cd $root
    set root [pwd]
    #puts stderr "[self] root=$root"
    cd $currentdir
  }

  proc ! string {
    set f [open [::xotcl::tmpdir]log w+]; 
    puts $f "[clock format [clock seconds]] $string"
    close $f}

  Httpd instproc init args {
    my instvar port logdir logfile redirects
    if {![my exists workerMixins]} {
      my set workerMixins {}
      #puts stderr "resetting workermixins of [self]"
    }
    next
    set proto [string trim [namespace tail [my info class]] :d]
    puts stderr "Starting XOTcl [string toupper $proto] server $::VERSION\
	[string tolower $proto]://[info hostname]:$port/"

    # Start a server by listening on the port
    if {[my exists ipaddr]} {set ip "-myaddr [my set ipaddr]"} {set ip ""}
    my set listen [eval [list socket -server [list [self] accept]] $ip $port]
    #my set listen [socket -server [list [self] accept] $port]

    my checkRoot
    if {![file isdir $logdir]} {file mkdir $logdir}
    set logfile [open $logdir/serverlog-$port a+]
    my array set requiresBody \
	{GET 0 HEAD 0 POST 1 PUT 1 DELETE 0 OPTIONS 0 TRACE 0}
  }
  Httpd instproc destroy {} {			# destructor
    catch {close [my set listen]}
    catch {close [my set logfile]}
    next
  }
  Httpd instproc accept {socket ipaddr port} {	# Accept a new connection and set up a handler
    #puts stderr "using workermixins of [self] {[my set workerMixins]}"

    [my set httpdWrk] new -childof [self] -socket $socket -ipaddr $ipaddr \
	-port $port -mixin [my set workerMixins]
  }
  Httpd instproc redirect list {
    foreach {pattern hostport} $list {
      my lappend redirects $pattern $hostport
    }
  }


  Class Httpd::Wrk -parameter {socket port ipaddr}
  Httpd::Wrk array set codes {
    200 {Data follows}          201 {Created}         204 {No Content}
    302 {Moved Temporarily}     304 {Not Modified}
    400 {Bad Request}           401 {Unauthorized}    402 {Payment Required}
    403 {Forbidden}             404 {Not Found}       405 {Method Not Allowed}
    406 {Not Acceptable}        408 {Request Timeout} 411 {Length Required}
    500 {Internal Server Error} 503 {Service Unavailable}  504 {Service Temporarily Unavailable}
  }
  Httpd::Wrk instproc formData {} {my set formData}
  Httpd::Wrk instproc init args {		# Constructor 
    my instvar socket port ipaddr
    my set formData [list]
    my set replyHeaderFields [list]
    next
    my makeConnection $socket
    my log Connect "$ipaddr $port"
    my connection translation {auto crlf}
    my connection event readable [self] firstLine
  }
  Httpd::Wrk instproc makeConnection {socket} {
    Connection create [self]::connection -socket $socket -req [self]
  }
  Httpd::Wrk instproc close {} {		# logical close of a single request
    #my showCall
    my instvar version timeout meta
    set eof [my connection eof]
    if {$version > 1.0 && !$eof} {
      #my showMsg "!EOF in http/$version"
      my connection flush
      set timeout [after [[my info parent] workerTimeout] [self] destroy]
      ### reset parameters, worker will be potentially reused
      if {[array exists meta]} {
	unset meta
	array set meta {}
      }
      unset version
      if {[my exists user]} {
	my unset user
	my unset realm
      }
      foreach c [my set formData] { $c destroy }
      my set replyHeaderFields [list]
      my set formData {}
      #my showVars
      my connection translation {auto crlf}
      my connection event readable [self] firstLine
    } elseif {$eof} {
      #my showMsg "Destroy in http/$version"
      # the client side has closed the connection
      my destroy
    } else {
      #my showMsg "!EOF in http/$version ???"
      # we close the conneciton actively (e.g. forced by an error)
      my connection flush
      #puts stderr "DESTROY----this line should never show up"
      my destroy
    }
  }
  Httpd::Wrk instproc destroy {} {
    #my showCall
    if {[my isobject [self]::connection]} {
      my connection close
    }
    next
  }
  Httpd::Wrk instproc freeConnection {} {
  }
  Httpd::Wrk instproc firstLine {} {	# Read the first line of the request
    #my showCall
    my instvar method resourceName hasFormData query fileName \
	version timeout 
    if {[info exists timeout]} {
      after cancel $timeout
      unset timeout
    }
    my lappend replyHeaderFields Date [Httpd Date [clock seconds]]
    set n [my connection gets firstLine]
    if {$n > 0} {
      #::puts stderr "[self] firstline=<$firstLine>"
      # parse request line, ignore HTTP version for now
      if {[regexp {^(POST|GET|PUT|HEAD|OPTIONS) ([^?]+)(\??)([^ ]*) *HTTP/(.*)$} \
	       $firstLine _ method resourceName hasFormData query version]} {
	set resourceName [string trimright [string trimleft $resourceName ./] " "]
	# construct filename
	[my info parent] instvar root
	set fileName $root/[url decodeName $resourceName]
	#puts stderr ---[encoding convertfrom utf-8 $fileName]----
	set fileName [encoding convertfrom utf-8 $fileName]
	#
	my decode-formData $query
	my log Query $firstLine
	if {[my exists forceVersion1.0]} {
	  set version 1.0
	}
	my connection makePersistent [expr {$version > 1.0}]
	my connection event readable [self] header
      } else {
	set version 1.0
	set resourceName ???
	set method ???
	my log Error "bad first line:$firstLine"
	my replyCode 400
	my replyErrorMsg
      }
    } elseif {![my connection eof]} {
      #my showMsg "+++ not completed EOF=[my connection eof]"
    } else {
      set version 1.0
      #my showMsg "+++ n=negative ($n) EOF=[my connection eof] version set to 1.0"
      my close
    }
  }
  Httpd::Wrk instproc header {} {			# Read the header
    #my showCall
    my instvar method data
    if {[my connection gets line] > 0} {
      #puts stderr line=$line
      if {[regexp -nocase {^([^:]+): *(.+)$} $line _ key value]} {
	my set meta([string tolower $key]) $value
      }
    } else {
      #puts stderr line-EMPTY
      if {[my exists meta(content-length)] && [my set meta(content-length)]>0} {
	#puts stderr "we have content-length [my set meta(content-length)]"
	set data ""
	my connection translation binary
	my connection event readable [self] receive-body
      } elseif {[my exists meta(content-type)] &&
		[regexp -nocase {multipart/form-data; *boundary=} \
		     [my set meta(content-type)]]} {
	#puts stderr "formdata"
	set data ""
	my connection event readable [self] receive-body
      } else {
	#puts stderr "no-content-length, triggering respond"
	my connection event readable [self] ""
	[my info parent] instvar requiresBody
	if {$requiresBody($method)} {
	  my replyCode 411
	  my replyErrorMsg
	} else {
	  my check-redirect
	}
      }
    }
  }
  Httpd::Wrk instproc receive-body {} {	;# ... now we have to read the body
    #my showCall
    my instvar method data meta
    set d [my connection read]
    if {$d ne ""} {
      append data $d
      #my showMsg "datal=[string length $data], cl=$meta(content-length)"
      if {[string length $data] >= $meta(content-length)} {
	my connection event readable [self] ""
	if {$method eq "POST"} { my decode-POST-query  }
	my check-redirect
      }
    } else {   ;# 0 byte, must be eof...
      my showMsg "received 0 bytes"
      my connection event readable [self] ""
      if {[string length $data] < $meta(content-length)} {
	my replyCode 404
	my replyErrorMsg
      } else {
	my check-redirect
      }
    }
  }
  Httpd::Wrk instproc unmodified mtime {
    my instvar meta
    if {[info exists meta(if-modified-since)]} {
      set ms $meta(if-modified-since)
      regexp {^([^;]+);(.*)$} $ms _ ms options
      if {[catch {set mss [clock scan $ms]}]} {
	regsub -all -- {-} $ms " " ms
	if {[catch {set mss [clock scan $ms]}]} {
	  set ms [lreplace $ms end end]
	  set mss [clock scan $ms]
	}
      }
      return [expr {$mtime <= $mss}]
    }
    return 0
  }
  Httpd::Wrk instproc check-redirect {} {	
    [my info parent] instvar redirects
    my instvar resourceName hasFormData query
    set resource $resourceName$hasFormData$query
    foreach {pattern hostport} $redirects {
      #puts stderr "match <$pattern> <$resource> [regexp $pattern $resource]"
      if {[regexp $pattern $resource]} {
	#puts stderr "do redirect to $hostport/$resource"
	my replyCode 302 location $hostport/$resource
	my replyErrorMsg
	return
      }
    }
    my respond
  }
  Httpd::Wrk instproc respond {} {			# Respond to the query
    # the request was read completely...   This method is wellsuited for mixins!
    my respond-[my set method]
  }

  Httpd::Wrk instproc respond-GET {} {
    #my showCall
    my instvar fileName
    my sendFile $fileName
  }
  Httpd::Wrk instproc respond-HEAD {} {			# Respond to the query
    my instvar fileName
    if {[file readable $fileName]} {
      my replyCode 200 \
	  Last-Modified [Httpd Date [file mtime $fileName]] \
	  Content-Type [Mime guessContentType $fileName] \
	  Content-Length [file size $fileName]
      my connection puts ""
      #my log Done "$fileName [Mime guessContentType $fileName]"
      my close
    } else {
      my replyCode 404
      my replyErrorMsg
    }
  }
  Httpd::Wrk instproc respond-OPTIONS {} {			# Respond to the query
    my replyCode 200 \
	Allow "OPTIONS, GET, HEAD, POST" \
	Public "OPTIONS, GET, HEAD, POST"
    my connection puts ""
    my close
  }
  Httpd::Wrk instproc respond-PUT {} {
    my instvar data method fileName
    my replyCode [expr {[file writable $fileName] ? 200 : 201}]
    my connection puts ""
    set out [open $fileName w]
    fconfigure $out -translation binary
    puts -nonewline $out $data
    my log Done "$fileName [Mime guessContentType $fileName]"
    close $out
    my close
  }
  Httpd::Wrk instproc respond-CGI {} {
    my instvar fileName
    if {[file executable $fileName]} {
      my replyCode 200
      my connection puts [exec $fileName]      ;# no parameter handling yet
      my close
    } else {
      my replyCode 403
      my replyErrorMsg
    }
  }
  Httpd::Wrk instproc new-formData {} {
    set arg [Object create [self]::[my autoname formData]]
    my lappend formData $arg
    return $arg
  }
  Httpd::Wrk instproc decode-formData {query} {
    #my showCall
    foreach pair [split [string trimleft $query \n] &] {
      set arg [my new-formData]
      if {[regexp {^(.+)=(.*)$} $pair _ name content]} {
	$arg set name [url decodeItem $name]
	$arg set content [url decodeItem $content]
      } else {
	$arg set content [url decodeItem $pair]
      }
    }
  }
  Httpd::Wrk instproc decode-POST-query {} {
    if {[my exists meta(content-type)]} {
      set ct [my set meta(content-type)]
      if {[regexp -nocase {application/x-www-form-urlencoded} $ct]} {
	#my showMsg "ordinary FORM"
	my decode-formData [my set data]
	return
      } elseif {[regexp -nocase {multipart/form-data; *boundary=(.*)$} $ct \
		     _ boundary]} {
	#my showMsg "multipart FORM"
	set parts [my set data]
	set bl [expr {[string length $boundary]+2}]
	while {[set endIDX [string first --$boundary $parts]] > -1} {
	  set part [string range $parts $bl [expr {$endIDX-1}]]
	  if {[set endHD [string first \r\n\r\n $part]] > -1} {
	    set arg [my new-formData]
	    if {[catch {Mime multipart-decode-header \
			    [string range $part 0 [expr {$endHD-1}]] \
			    $arg} msg]} {
	      my replyCode 406
	      my replyErrorMsg $msg
	      return 0
	    }
	    $arg set content [string range $part \
				  [expr {$endHD + 4}] \
				  [expr {[string length $part] -3}]]
	    #$arg showVars
	  }
	  set parts [string range $parts [expr {$endIDX+2}] end]
	}
      }
    }
  }
  Httpd::Wrk instproc respond-POST {} {
    my replyCode 405
    my replyErrorMsg
    #my respond-CGI
  }

  Httpd::Wrk instproc replyErrorMsg {{msg ""} args} {
    my instvar replyCode
    [self class] instvar codes
    foreach {tag value} $args {my connection puts "$tag: $value"}
    my sendText "\n<HTML><title>Status Code: $replyCode</title>\n\
      <BODY>$msg<p>\n\
      Status Code $replyCode: <b>$codes($replyCode)</b><br>\n\
      Resource Name: [my set resourceName]</BODY></HTML>\n"
    my close  ;# close must be last call
  }
  Httpd::Wrk instproc replyCode {code args} {
    #my showCall
    my instvar version
    [self class] instvar codes
    my set replyCode $code
    my connection puts "HTTP/$version $code $codes($code)"
    foreach {tag value} [my set replyHeaderFields] {my connection puts "$tag: $value"}
    foreach {tag value} $args {my connection puts "$tag: $value"}
    if {$code >= 400} {
      my log Error "$code $codes($code)\tmeta: [my array get meta]"
    }  else {
      my log Done "$code $codes($code)"
    }
  }
  Httpd::Wrk instproc sendText {response {type text/html}} {
    #my showCall
    my connection puts "Content-Type: $type"
    # bei einer leeren Responses blockieren Klienten und melden Fehler
    if {$response eq ""} { set response " " }
    my connection puts "Content-Length: [string length $response]\n"
    if {[my set method] ne "HEAD"} {
      my connection fconfigure -translation {auto binary}
      my connection puts-nonewline $response
    } else {
      my showMsg HEAD!
    }
  }
  Httpd::Wrk instproc sendMsg {response {type text/html}} {
    # my showCall
    my replyCode 200
    my sendText $response $type 
    my close
  }
  Httpd::Wrk instproc sendDir {dirName} {
    [my info parent] instvar root
    set title "Directory listing"
    set reply "<HTML><TITLE>$title</TITLE><BODY><H1>$title</H1>\n<TABLE>\n"
    set oldpwd [pwd]
    cd $root
    set dirs ""; set files ""
    foreach f [lsort -dictionary [glob -nocomplain ./$dirName/*]] {
      set full [file join $root $f]
      set pname [string trimleft $f ./]
      if {[file isdir $full]} {
	append pname /
      }
      if {![catch {set size [file size $full]}]} {
	# it is not a broken link
	set entry ""
	append entry <tr> \
	    <td> "<A href='/$pname'>$pname</a>"    </td> \
	    "<td align='right'>" $size </td> \
	    "<td align='right'>" [clock format [file mtime $full]] </td> \
	    </tr>\n
	if {[string match */ $pname]} {append dirs $entry} else {append files $entry}
      }
    }
    append reply $dirs $files "</TABLE></HTML>\n"
    cd $oldpwd
    my sendMsg $reply
    return
  }

  Httpd::Wrk instproc sendFile {fn {type ""}} {
    #my showCall
    if {[file isdirectory $fn]} {
      set full [file join $fn index.html]
      if {[file readable $full]} {
	set fn $full
      } else {
	my sendDir [my set resourceName]
	return
      }
    }
    #puts stderr "readable '$fn' [file readable $fn]"
    if {[file readable $fn]} {
      set mtime [file mtime $fn]
      if {[my unmodified $mtime]} { 
	my replyCode 304
	my replyErrorMsg
	return 
      }
      if {$type eq ""} {set type [Mime guessContentType $fn]}
      my replyCode 200 \
	  Last-Modified [Httpd Date $mtime] \
	  Content-Type $type \
	  Content-Length [file size $fn]
      my connection puts ""
      my connection fconfigure -translation binary ;#-buffersize 65536
      set localFile [open $fn]
      fconfigure $localFile -translation binary -buffersize 65536
      fcopy $localFile [my connection set socket] \
	  -command [list [self] fcopy-end $localFile]
    } else {
      my replyCode 404
      my replyErrorMsg
    }
  }
  Httpd::Wrk instproc fcopy-end {localFile args} {	# End of fcopy
    close $localFile
    my connection fconfigure -blocking false ;# fconfigure changes blocking in 8.3.2!
    my close
  }
  Httpd::Wrk instproc log {reason arg} {			# trivial logging
    my instvar port ipaddr
    if {[my exists user]} {
      set user [my set user]/[my set realm]
    } {set user -}
    [my info parent] instvar logfile
    puts $logfile "[clock format [clock seconds]] $user $ipaddr:$port\t$reason\t$arg"
    flush $logfile
  }


  #########################################################################
  Class Httpsd -superclass Httpd -parameter {
    {port 443}
    {httpdWrk Httpsd::Wrk}
    {requestCert 0}
    {requireValidCert 0}
    {certfile filename.crt}
    {keyfile filename.key}
    {cafile cacert.pem}
    {infoCb {}}
  }
  Httpsd instproc init args {
    package require tls
    proc tls::password {} {
      puts stderr "getting passwd"
      return pemp
    }
    next
  }

  Class Httpsd::Wrk -superclass Httpd::Wrk
  Httpsd::Wrk instproc firstLine {} {
    my set forceVersion1.0 1
    my lappend replyHeaderFields Connection close
    next
  }
  Httpsd::Wrk instproc makeConnection {socket} {
    Connection create [self]::connection -socket $socket -req [self]
    [my info parent] instvar \
	keyfile certfile cafile infoCb requestCert requireValidCert
    # SSL-enable a regular Tcl channel - it need not be a socket, but
    # must provide bi-directional flow. Also setting session parameters
    # for SSL handshake. www.sensus.org/tcl/tls.htm
    
    # -request bool --> Request a certificate from peer during SSL
    # handshake. (default: true)
    
    # -require bool --> Require a valid certificate from peer during SSL
    # handshake. If this is set to true then -request must also be set
    # to true. (default: false)
    
    # -server bool --> Handshake as server if true, else handshake as
    # client.(default: false)
    my connection importSSL -server 1 \
	-certfile  $certfile \
	-keyfile  $keyfile \
	-cafile    $cafile \
	-request   $requestCert \
	-require   $requireValidCert \
	-command   $infoCb
  }
  #########################################################################



  ###
  ### Mixin-Classes for respond patterns
  ### mixes into Http and Httpd::Wrk 
  ###
  Class Httpd::Responder
  Httpd::Responder instproc init args {
    next
    my lappend workerMixins Httpd::Responder::Wrk
    my set respondpatterns {}
    # Example how to register new methods: regexp is matched with the triple
    # (HTTP-METHOD URL HASFORMDATA) where HASFORMDATA is empty when no
    # parameters are given. The parsed components of the url etc. are
    # available as instvars
    my actions {^GET cgi[-]bin [?]} respond-CGI
  }
  Httpd::Responder instproc actions {regexp method} {
    my lappend respondpatterns $regexp $method
  }
  Class Httpd::Responder::Wrk
  Httpd::Responder::Wrk instproc respond {} {
    my instvar fileName method resourceName hasFormData
    [my info parent] instvar respondpatterns
    ### auch das ist ein kandidat fuer eine chain of responsibility
    foreach {pattern action} $respondpatterns {
      if {[regexp $pattern "$method $resourceName $hasFormData"]} {
	my $action
	return
      }
    }
    next
  }

  ###
  ### Mixin-Classes for Access Control
  ### mixes into Http and Httpd::Wrk
  ###
  Class Httpd::AccessControl
  Httpd::AccessControl abstract instproc protectedResource {fn method varAuthMethod varRealm}
  Httpd::AccessControl abstract instproc credentialsNotOk {wrk credentials authMethod realm}
  Httpd::AccessControl abstract instproc addRealmFile {realm authFile}
  Httpd::AccessControl abstract instproc addRealmEntry {realm passwds}
  Httpd::AccessControl abstract instproc protectDir {realm path methods}

  Class Httpd::AccessControl::Wrk
  Httpd::AccessControl::Wrk instproc respond {} {
    my instvar fileName method digestChallengeData
    set controller [my info parent]
    if {[$controller protectedResource $fileName $method authMethod realm]} {
      #my showMsg "*** Protected resource: $fileName $method"
      if {![my exists meta(authorization)] ||
	  [$controller credentialsNotOk [self] \
	       [my set meta(authorization)] $authMethod $realm]} {
	my unauthorizedAccess $realm
	return
      }
    }
    next
  }

  ###########################################################################
  ## Basic Access Control
  ###########################################################################
  Class Httpd::BasicAccessControl -superclass Httpd::AccessControl

  Httpd::BasicAccessControl instproc initWorkerMixins {} {
    my lappend workerMixins [self class]::Wrk
  }

  Httpd::BasicAccessControl instproc init args {
    next
    my initWorkerMixins
  }

  Httpd::BasicAccessControl instproc protectedResource {fn method varAuthMethod varRealm} {
    #my showCall
    # check whether access to $fn via $method is protected
    upvar [self callinglevel] $varAuthMethod authMethod $varRealm realm
    # we check only the current directory, not the parent directories
    if {[string match */ $fn]} {
      set path $fn
    } else {
      set path [file dirname $fn]/
    } 
    foreach i [list $path $path:$method] {
      if {[my exists protected($i)]} {
	set realm [my set protected($i)]
	set authMethod Basic
	return 1
      }
    }
    return 0
  }

  Httpd::BasicAccessControl instproc credentialsNotOk {wrk credentials authMethod realm} {
    # check whether $credentials are sufficient for $realm
    regexp {^(.*):(.*)$} [base64 decode [lindex $credentials 1]] _ user pwd
    #puts stderr "passwd($realm:$user)=[my exists passwd($realm:$user)]"
    $wrk set user $user
    $wrk set realm $realm
    if {[my exists passwd($realm:$user)]} {
      return [expr {[my set passwd($realm:$user)] != $pwd}]
    }
    return 1
  }

  Httpd::BasicAccessControl instproc addRealmEntry {realm passwds} {
    if {[llength $passwds] == 1} {
      my addRealmFile [lindex $passwds 0]
    } else {
      foreach {name pwd} $passwds {
	#puts stderr "realm='$realm' adding user: $name pw: $pwd"
	my set passwd($realm:$name) $pwd
      }
    }
  }
  Httpd::BasicAccessControl instproc addRealmFile {realm authFile} {
    set FILE [open $authFile r]
    while {![eof $FILE]} {
      foreach {name pwd} [split [gets $FILE] :] {
	my addRealmEntry $realm [list $name $pwd]
      }
    }
    close $FILE
  }

  Httpd::BasicAccessControl instproc protectDir {realm path methods} {
    my instvar root
    my checkRoot
    set resource $root/$path      ;# resources are currently directories
    if {$methods == {}} {
      my set protected($resource) $realm       ;#for every method
    } else {
      foreach m $methods {
	my set protected($resource:$m) $realm  ;#for selected methods
      }
    }
  }
  Class Httpd::BasicAccessControl::Wrk -superclass Httpd::AccessControl::Wrk
  Httpd::BasicAccessControl::Wrk instproc unauthorizedAccess {realm} {
    my set digestChallengeData(realm) $realm
    my replyCode 401 www-authenticate "Basic realm=\"$realm\""
    my replyErrorMsg "Unauthorized request for realm '$realm'" 
  }



  ###########################################################################
  ## Digest Access Control
  ###########################################################################
  Class Httpd::DigestAccessControl -superclass Httpd::BasicAccessControl
  Httpd::DigestAccessControl instproc init args {
    package require tcu
    next
    my lappend workerMixins [self class]::Wrk
  }
  Httpd::DigestAccessControl instproc credentialsNotOk {wrk credentials authMethod realm} {
    # check whether $credentials are sufficient for $realm
    my showMsg "Digest Authentication ..."
    # HELP FD: hier muss ich noch überprüfen, ob die digest-header
    # (credentials) ok sind. Hier habe ich probleme auf die sachen,
    # die der worker gesendet (bspw. nonce) hat zu kommen. Ich
    # weiß, man kann mit [my info children] daran kommen. Aber,
    # was ist, wenn man mehrere Worker hat?

    ## Fredj, das sollte kein Problem sein: das credentialsNotOk wird
    ## vom aktuellen worker (respond) aufgerufen. man kann dem *NotOk
    ## den worker mitgeben, oder die beiden Methoden etwas umorganisieren.
    return
  }
  Class Httpd::DigestAccessControl::Wrk -superclass Httpd::BasicAccessControl::Wrk
  Httpd::DigestAccessControl::Wrk instproc unauthorizedAccess {realm} {
    my set digestChallengeData(realm) $realm
    my replyCode 401 www-authenticate "Digest [my digestChallenge]"
    my replyErrorMsg "Unauthorized request for realm '$realm'"
  }
  Httpd::DigestAccessControl::Wrk instproc digestChallenge {} {
    my showCall
    my instvar digestChallengeData
    my mkDigestChallengeData
    set digestResponse {}
    foreach {t v} [array get digestChallengeData] {
      append digestResponse "$t = \"$v\", "
    }
    regsub {, $} $digestResponse {} digestResponse
    return $digestResponse
  }
  Httpd::DigestAccessControl::Wrk instproc mkDigestChallengeData {} {
    my showCall
    my instvar digestChallengeData

    # RFC 2617
    #   challenge         =  "Digest" digest-challenge
    #   digest-challenge  = 1#( realm | [ domain ] | nonce |
    #                       [ opaque ] |[ stale ] | [ algorithm ] |
    #                       [ qop-options ] | [auth-param] )
    #   domain            = "domain" "=" <"> URI ( 1*SP URI ) <">
    #   URI               = absoluteURI | abs_path
    #   nonce             = "nonce" "=" nonce-value
    #   nonce-value       = quoted-string
    #   opaque            = "opaque" "=" quoted-string
    #   stale             = "stale" "=" ( "true" | "false" )
    #   algorithm         = "algorithm" "=" ( "MD5" | "MD5-sess" | token )
    #   qop-options       = "qop" "=" <"> 1#qop-value <">
    #   qop-value         = "auth" | "auth-int" | token

    # FD: hier würde man die nötigen parametern (nonce,domain,opaque,
    # etc.) berechnen und in dem asso. Array speichern.
    # FD: minimale Anforderung
    set digestChallengeData(nonce)  [my genNonce]
    set digestChallengeData(opaque) [base64 encode [self]:my-self-spcified-string]
    set digestChallengeData(algorithm) "MD5" ;#default
    set digestChallengeData(qop) "auth"
    set digestChallengeData(domain) [array names [my info parent]::protected]
  }

  Httpd::DigestAccessControl::Wrk instproc genNonce {} {
    my showCall
    my instvar digestChallengeData
    set timeStamp [clock seconds]
    set nonce [base64 encode [md5 $timeStamp:[self]]]
    return $nonce
  }


  #
  # example usage:

  #Httpd h1 -port 8081 -root [glob ~/wafe]
  #Httpd h2 -port 9086 -root $root \
      -mixin {Httpd::Responder Httdp::BasicAccessControl} \
      -addRealmEntry test {test test} -protectDir test "" {} \
      -redirect {^(mailman|pipermail|cgi-bin) http://alice.wu-wien.ac.at:80}


  namespace export Httpd Httpsd 
  namespace eval Httpd               {
    namespace export Wrk \
	AccessControl BasicAccessControl DigestAccessControl \
	Responder
  }
  namespace eval Httpsd              {
    namespace export Wrk
  }
  #namespace eval Responder           {namespace export Wrk}
  #namespace eval AccessControl       {namespace export Wrk}
  #namespace eval BasicAccessControl  {namespace export Wrk}
  #namespace eval DigestAccessControl {namespace export Wrk}
}

namespace import ::xotcl::comm::httpd::*
namespace eval Httpd               {namespace import ::xotcl::comm::httpd::Httpd::*}
namespace eval Httpsd              {namespace import ::xotcl::comm::httpd::Httpsd::*}
#namespace eval Responder           {namespace import ::xotcl::comm::httpd::Responder::*}
#namespace eval AccessControl       {namespace import ::xotcl::comm::httpd::AccessControl::*}
#namespace eval BasicAccessControl  {namespace import ::xotcl::comm::httpd::BasicAccessControl::*}
#namespace eval DigestAccessControl {namespace import ::xotcl::comm::httpd::DigestAccessControl::*}

# $Id: Imap.xotcl,v 1.4 2006/02/18 22:17:33 neumann Exp $

package provide xotcl::comm::imap 0.9

package require XOTcl

namespace eval ::xotcl::comm::imap {
  package require xotcl::comm::httpAccess
  namespace import ::xotcl::*

  Class Imap -superclass NetAccess -parameter {user}
  Imap instproc initialize args {
    my instvar port caching tokenCounter resp token
    set port 143
    set caching 1
    set resp(connect)       {"[*] OK" login}
    set resp(login)         {"A[0-9]+ OK" loginFinished  "A[0-9]+ NO" login}
    set resp(loginFinished) {"[*] [0-9]+" inboxSize "[*] OK" inboxSelected}
    set resp(mailSelected)  {"[*] [0-9]+ FETCH" fetchBody 
      "A[0-9]+ OK " ignoreLine
      "[*] " ignoreLine}
    set resp(heads)         {"[*] [0-9]+ FETCH" fetchHeaders 
      "A[0-9]+ OK " ignoreLine
      "[*] " ignoreLine}
    set tokenCounter 0
    next
    set token NONE
  }
  Imap instproc err {state reply} {
    my abort "Error in $state: $reply"
  }
  Imap instproc token {} {
    my instvar tokenCounter
    return [format {A%.4d} [incr tokenCounter]]
  }
  Imap instproc imapString {input} {
    regsub -all {(["\])} $input {\\\1} output ;#"
		   return \"$output\"
		 }
		  Imap instproc queryServer {query state} {
		    #my showCall
		    my instvar S token
		    set token [my token]
		    puts $S "$token $query"
		    #puts stderr "$token $query"
		    flush $S
		    fileevent $S readable [list [self] response $state]
		  }
		  Imap instproc response {state} {
		    my instvar S resp msg token
		    set msg [gets $S]
		    #my showVars msg token
		    foreach {c newState} $resp($state) {
		      if {![regexp {^[*]} $msg] && ![regexp ^$token $msg]} {
			my showMsg "$state: token=$token IGNORING $msg"
			return
		      }
		      if {[regexp ^$c $msg]} {
			#my showMsg "$state NEWSTATE $newState"
			return [my $newState] 
		      }
		    }
		    my err $state "expected=$resp($state), got $msg"
		  }
		  Imap instproc GET {} {
		    my instvar state S path host port user inbox mailNr
		    # number at end of path is the message number in the mailbox
		    if {[regexp {^([^/]+)/([^/]+)/([0-9]+)$} $path _ user inbox mailNr]} {
		    } elseif {[regexp {^([^/]+)/([^/]+)/?$} $path _ user inbox]} {
		    } else {
		      my abort "invalid imap path $path"
		    }
		    regexp {^(.*):([0-9]+)$} $host _ host port
		    # proxy ?
		    if {[catch {set S [socket -async $host $port]} err]} {
		      my abort "Could not open connection to host '$host:$port'\n    $err"
		    } else {
		      fconfigure $S -blocking false 
		      fileevent $S readable [list [self] response connect]
		    }
		  }
		  Imap instproc login {} {
		    my instvar user host password
		    if {[pwdManager requirePasswd "Imap $user\@$host" $user password]} {
		      my queryServer "login $user [my imapString $password]" login
		    } else {
		      what now?
		    }
		  }
		  Imap instproc loginFinished {} {
		    my instvar user host password inbox
		    pwdManager storePasswd "Imap $user\@$host" $user $password
		    my queryServer "select $inbox" loginFinished
		  }
		  Imap instproc inboxSize {} {
		    my instvar msg nrMails
		    regexp {^[*] ([0-9]+) EXISTS} $msg _ nrMails
		  }
		  Imap instproc inboxSelected {} {
		    my instvar msg contentType nrMails mailNr
		    if {[info exists mailNr]} {
		      set contentType text/plain
		      my body-state
		      my queryServer "fetch $mailNr rfc822" mailSelected
		    } else {
		      my instvar header inbox block host user block
		      set contentType text/html
		      my body-state
		      set what "Mailbox $inbox of $user@$host"
		      set block "<HTML><HEAD><TITLE>$what</TITLE></HEAD>\n"
		      append block "<BODY><H1>$what</H1>\n" \
			  "The following <i>$nrMails</i> messages are in this mailbox:" \
			  "<p>\n<UL>\n"
		      my pushBlock
		      catch {unset header}
		      set mailNr $nrMails
		      my queryServer "fetch $nrMails body\[header\]" heads
		    }
		  }
		  Imap instproc ignoreLine {} {;}
		  Imap instproc fetchBody {} {
		    my instvar S
		    fileevent $S readable [list [self] bodyContent]
		  }
		  Imap instproc bodyContent {} {
		    my instvar S block msg
		    set msg [gets $S]
		    if {$msg == ")"} {
		      my set state 4
		      my finish
		    } else {
		      set block $msg\n
		      my pushBlock
		    }
		  }
		  Imap instproc fetchHeaders {} {
		    my instvar S
		    fileevent $S readable [list [self] headContent]
		  }
		  Imap instproc headContent {} {
		    my instvar S token header nrMails mailNr block host user inbox
		    set msg [gets $S]
		    if {[regexp -nocase {^([^:]+): *(.+)$} $msg _ key value]} {
		      set key [string tolower $key]
		      set header($mailNr,$key) $value
		    } elseif {$msg == ")"} {
		      # mail header finished
		      set block "<LI> Message $mailNr from $header($mailNr,date)<br>\ 
	<A HREF=\"imap://$host/$user/$inbox/$mailNr\">"
		      if {[catch {set from $header($mailNr,from)}]} {
			if {[catch {set from $header($mailNr,sender)}]} {	set from UNKNOWN }
		      }
		      if {[regexp {[(](.*)[)]} $from _ x]} { 
		      } elseif {[regexp {[<](.*)[>]} $from _ x]} { 
		      } else  { set x $from }
		      append block $x ": "
		      if {[info exists header($mailNr,subject)]} { append block $header($mailNr,subject) }
		      append block </A><P>
		      my pushBlock
		      if {$mailNr > 1} {
			incr mailNr -1
			my queryServer "fetch $mailNr body\[header\]" heads
		      } else {
			set block "</UL></BODY></HTML>\n"
			my pushBlock
			my set state 4
			my finish
		      }
		    }
		  }

		  namespace export Imap
		}

      namespace import ::xotcl::comm::imap::*

package provide xotcl::comm::ldap 0.9

package require xotcl::wafecompat ; # Get 'requireModules'.

package require XOTcl

namespace eval ::xotcl::comm::ldap {
    namespace import ::xotcl::*

    requireModules { ldapOpen ldaplibGen.so }

    Class Ldap -superclass NetAccess -parameter {host port dn attributes scope filter}
    Ldap instproc initialize args {
	my instvar port mapToC useCache
	my set port 389
	my set useCache 0
	set mapToC(one) onelevel
	set mapToC(sub) subtree
	set mapToC(base) base
	next
    }
    Ldap proc urlDecode string {
	set toParse $string
	set parsed ""
	while {1} {
	    if {[regexp {^([^%]*)%(..)(.*)$} $toParse _ front hex toParse]} {
		append parsed $front [binary format c 0x$hex]
	    } else {
		append parsed $toParse
		break
	    }
	}
	return $parsed
    }
    Ldap instproc getUrlcomponents {} { 
	showCall
	my instvar path dn attributes scope filter url
	set path [Ldap urlDecode $path]
	puts stderr "___ path=<$path>"
	if {[regexp -nocase {^/([^?]*)(\?([^?]*)(\?([^?]*)(\?([^?]*))?)?)?$} \
		 $path _ dn a attributes s scope f filter]} {
	    if {$scope eq ""} { set scope "base" }
	    if {$filter eq ""} { set filter "(objectClass=*)" }
	} else {
	    set errmsg    "*** Ldap Url trail=<$path> does not  match!\n"      
	    append errmsg "___ RFC 1959 says:\n"
	    append errmsg "    ldap://<host>:<port>/<dn>\[?<attributes>\[?<scope>?<filter>\]\]\n"    
	    append errmsg "___ Cineast and Netscape uses:\n"
	    append errmsg "    ldap://<host>:<port>/<dn>\[?<attributes>\[?<scope>\[?<filter>\]\]\]"
	    my abort "Unsupported URL: '$url' \n $errmsg"
	}    
    }
    Ldap instproc GET {} {
	my instvar  contentType totalsize state currentsize informObjects block
	showCall
	set contentType text/html
	my getUrlcomponents
	if {"start" ne $state } {
	    puts stderr "... [self]:$proc ignoring request in state $state"
	    return
	}
	my open
	my search
	my body-state
	set totalsize [string length $block]
	set currentsize $totalsize
	foreach obj $informObjects {
	    $obj incCb [self] $totalsize $currentsize
	}
	my eof
    }
    Ldap instproc open {} {
	showCall
	my instvar port host  ldapHandle
	set ldapHandle [ldapOpen $host $port]
    }
    Ldap instproc bind {} {
	my instvar ldapHandle
	showCall
    }
    Ldap instproc search {} {
	showVars
	my instvar url ldapHandle searchHandle dn attributes scope filter results mapToC path
	set searchHandle [ldapSearch $ldapHandle $dn \
			      $mapToC($scope) $filter [split $attributes ,] false results]
	set nentries [ldapCountEntries $ldapHandle $searchHandle]
	puts stderr "*** nentries = $nentries"
	if {!$nentries} {set results ""}
	my response 
    }
    Ldap instproc getAttrs {dn} {
    }
    Ldap instproc makeUrl {dn} {
	showCall
	my instvar port host scope filter attributes
	set tmpUrl ldap://$host:$port/$dn?$attributes?$scope?$filter
	return "<a href=\"$tmpUrl\">$dn</a>"  
    }
    Ldap instproc  response {} { 
	showCall
	my  instvar block results attrsVals ldapHandle searchHandle
	set block "
<HTML>
 <HEAD><TITLE>LDAP searching result!!</TITLE></HEAD>
 <BODY bgcolor=FFFFFF>
   <H1>Result</H1>\n  <ul>\n"
	foreach {resDN}  $results {
	    append block "   <li>  [my makeUrl $resDN] <p>\n    <ul>\n"   
	    ldapAttributes $ldapHandle $searchHandle $resDN attrsVals
	    foreach {a v} [array get attrsVals] {      
		append block "     <li> <FONT COLOR=\"\#cc0000\" face=\"Arial,Helvetica\" size=4><b> $a </b></FONT> = $v <p>\n"    
	    }
	    append block "    </ul>\n" 
	}
	append block "  </ul>\n </BODY>\n</HTML>"
    }

    # destructor: Close Connection to LDAP-Server and unbind 
    Ldap instproc destroy {} {
	showCall
	my  instvar ldapHandle
	if {[catch {ldapUnbind $ldapHandle} error]} {
	    return $error
	}
	my freeSearchHandle
    }
    Ldap instproc close {} {
	showCall
	my destroy
	next
    }
    Ldap instproc freeSearchHandle {} { 
	showCall
	my instvar searchHandle 
	if {[info exists searchHandle]} {
	    ldapFreeSearch $searchHandle  
	}
    }

    namespace export Ldap
}

namespace import ::xotcl::comm::ldap::*

# $Id: Mime.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::comm::mime 0.9

package require XOTcl

namespace eval ::xotcl::comm::mime {
  namespace import ::xotcl::*

  #######################################################################
  Class MimeTypeLoader
  MimeTypeLoader instproc loadMimeTypes {file} {
    if {![file exists $file]} return

    puts stderr "Loading Mime types from $file"
    set f [open $file r]
    set content [read $f]
    close $f
    regsub -all "\\\\ *\n" $content " " content
    foreach line [split $content \n] {
      set line [string trim $line]
      if {[regexp ^\# $line]} continue
      if {$line eq ""} continue
      regsub -all "  +" $line " " line
      #puts stderr <$line>
      while {$line ne ""} {
	if {[regexp {^ *([^ ]+)=\"([^\"]+)\" *(.*)$} $line _ key value line]} {
	  set v([string tolower $key]) $value
	} elseif {[regexp {^ *([^ ]+)=([^ ]+) *(.*)$} $line _ key value line]} {
	  set v([string tolower $key]) $value
	} else {
	  set tokens [split $line]
	  if {![regexp / [lindex $line 0]]} {
	    puts stderr "Mime: cannot parse line '$line' in $file"
	  } else {
	    set v(exts) [join [lrange $tokens 1 end] ,]
	    set v(type) [lindex $tokens 0]
	  }
	  break
	}
      }
      if {[info exists v(exts)] && [info exists v(type)]} {
	set v(exts) [string tolower $v(exts)]
	set v(type) [string tolower $v(type)]
	foreach ext [split $v(exts) ,] {
	  set ext [string trimleft $ext .]
	  #puts stderr "ext '$ext', contentType = '$v(type)'"
	  my set extTable($ext) $v(type)
	}
	unset v(exts) v(type)
      } else {
	puts stderr "invalid mime entry in $file"
      }
    } 
  }
  MimeTypeLoader instproc guessContentType {name} {
    my loadMimeTypes ~/.mime.types
    my mixin {}
    return [next]
  }

  Class MIME
  MIME instproc guessContentType {name} {
    my instvar extTable nameTable
    if {[regexp {\.([a-zA-Z0-9]+)$} $name _ ext]} {
      catch {set contentType $extTable([string tolower $ext])}
    }
    if {![info exists contentType]} {
      foreach namePattern [array names nameTable] {
	if {[regexp $namePattern $name]} {
	  set contentType text/plain
	  break
	}
      }
    }
    if {![info exists contentType]} {
      set contentType unknown/unknown
    }
    return $contentType
  }
  MIME instproc multipart-decode-header {header obj} {
    $obj instvar name filename contentType
    foreach line [split $header \r] {
      set line [string trim $line \n]
      #puts stderr line=$line
      if {[regexp -nocase {^Content-Disposition: *([^;]+);(.*)$} $line _ \
	       dispo detail]} {
	if {$dispo ne "form-data"} {
	  error "Unknown Content Disposition '$line'"
	}
	if {![regexp -nocase { name *= *"([^\"]+)"} $line _ name]} {
	  error "can't parse form-data name '$line'"
	}
	regexp -nocase {filename *= *"([^\"]+)"} $line _ filename
      } elseif {[regexp -nocase {^Content-Type: *([^; ]+)} $line _ contentType]} {
      } else {
	my showMsg "ignoring '$line'"
      }
    }
  }

  MIME create Mime -mixin MimeTypeLoader
  Mime array set nameTable {
    README text/plain
  }
  Mime array set extTable {
    gif  image/gif
    xpm  image/x-xpixmap
    xbm  image/x-xbitmap
    jpg  image/jpeg
    png  image/x-png
    html text/html
    htm  text/html
    xml  text/xml
    css  text/css
    ps   application/postscript
    pdf  application/pdf
    doc  application/msword
    xls  application/msexel
  }


  ##################################################################
  Class FormData
  FormData instproc encode list {;#RFC 1867
    my showCall
  }
  FormData formData
  ##################################################################
  Class Base64
  Base64 instproc init args {
    my instvar base64 base64_en
    # Emit base64 encoding for a string
    set i 0
    foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
		      a b c d e f g h i j k l m n o p q r s t u v w x y z \
		      0 1 2 3 4 5 6 7 8 9 + /} {
      set base64($char) $i
      set base64_en($i) $char
      incr i
    }
    next
  }
  Base64 instproc encode string {
    my instvar base64_en
    set result {}
    set length 0
    foreach {a b c} [split $string {}] {
      scan $a %c x
      if {$c ne ""} {
	scan $b %c y
	scan $c %c z
	append result \
	    $base64_en([expr {($x>>2) & 0x3F}]) \
	    $base64_en([expr {(($x<<4) & 0x30) | (($y>>4) & 0xF)}]) \
	    $base64_en([expr {(($y<<2) & 0x3C) | (($z>>6) & 0x3)}]) \
	    $base64_en([expr {$z & 0x3F}])
      } elseif {$b ne ""} {
	scan $b %c y
	append result \
	    $base64_en([expr {($x>>2) & 0x3F}]) \
	    $base64_en([expr {(($x<<4) & 0x30) | (($y>>4) & 0xF)}]) \
	    $base64_en([expr {($y<<2) & 0x3C}]) \
	    =
      } else {
	append result \
	    $base64_en([expr {($x>>2) & 0x3F}]) \
	    $base64_en([expr {($x<<4) & 0x30}]) \
	    ==
      }
      if {[incr length 4] >= 72} {
	append result \n
	set length 0
      }
    }
    return $result
  }
  Base64 instproc decode string {
    my instvar base64
    set output {}
    set group 0
    set j 18
    foreach char [split $string {}] {
      if {$char != "="} {
	set group [expr {$group | ($base64($char) << $j)}]
	if {[incr j -6] < 0} {
	  scan [format %06x $group] %2x%2x%2x a b c
	  append output [format %c%c%c $a $b $c]
	  set group 0
	  set j 18
	}
      } else {
	scan [format %04x $group] %2x%2x a b
	if {$j==6} {
	  append output [format %c $a]
	} else {
	  append output [format %c%c $a $b]
	}
	break
      }
    }
    return $output
  }
  Base64 base64
  ##################################################################
  Class Url
  Url instproc encode list {
    set result ""
    set sep ""
    foreach i $list {
      append result $sep [my encodeItem $i]
      if {$sep != "="} {
	set sep =
      } else {
	set sep &
      }
    }
    return $result
  }
  Url instproc encodeItem string {
    my instvar httpFormMap
    set alphanumeric    a-zA-Z0-9.
    if {![info exists httpFormMap]} {
      for {set i 1} {$i <= 256} {incr i} {
	set c [format %c $i]
	if {![string match \[$alphanumeric\] $c]} {
	  set httpFormMap($c) %[format %.2x $i]
	}
      }
      # these are handled specially
      array set httpFormMap { " " +   \n %0d%0a }
    }
    regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string
    regsub -all \n $string {\\n} string
    regsub -all \t $string {\\t} string
    regsub -all {[][{})\\]\)} $string {\\&} string
  return [subst $string]
}
Url instproc hexToChar hex {
  ::scan $hex %x h
  #my showMsg "::scan $hex %x h -> $h"
  format %c $h
}
Url instproc decodeItem string {
  #my showCall
  set result ""  
  regsub -all {\+} $string " " string
  regsub -all {%0d%0a} $string "\n" string
  regsub -all {%([a-fA-F0-9][a-fA-F0-9])} $string {[my hexToChar \1]} string
  return [subst -novariables -nobackslashes $string]
}
Url instproc decodeName string {
  #my showCall
  set result ""  
  regsub -all {%0d%0a} $string "\n" string
  regsub -all {%([a-fA-F0-9][a-fA-F0-9])} $string {[my hexToChar \1]} string
  return [subst -novariables -nobackslashes $string]
}
Url instproc decode string {
  #my showCall
  set result ""
  foreach i [split $string &=] {
    lappend result [decodeItem $i]
  }
  #my showVars result
  return $result
}
Url url

namespace export Mime url base64
}

namespace import ::xotcl::comm::mime::*
#puts stderr "importing ::xotcl::comm::mime::* to [namespace current]"

# -*- Tcl -*- $Id: PCache.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $
# Persistent Cache object, using gdbm

# Configuration:
# The persistent cache is kept in a directory which is determined by
# the following three rules.
#
# 1) the global variable "CACHE_DIR", which has to be set,
#    before this file is loaded
# 2) If "CACHE_DIR" is not set, the global variable "homedir"
#    is checked, which is assumed to be the home directory
#    of the Cineast browser
# 3) As a last resource the tmp directory is used as the cache directory
#
# Additionally, the cache directory can be specified after loading of this
# file (before the first open) through the instance variable "dir"
# in the object persistentCache.

package provide xotcl::comm::pcache 0.9
#package require xotcl::package

package require XOTcl

namespace eval ::xotcl::comm::pcache {
    namespace import ::xotcl::*

    variable CACHE_DIR
    variable homeDir

    if {![info exists CACHE_DIR]} {
	if {![info exists homeDir]} {
	    set homeDir [::xotcl::tmpdir]
	}
	set CACHE_DIR $homeDir/cache2
    }

    Object persistentCache
    persistentCache set dir $CACHE_DIR
    persistentCache proc flush { {cmd {}} } {
	my instvar DBID
	if {[info exists DBID]} { $DBID close }
	if {{} ne $cmd } {
	    if {[catch {eval $cmd} err]} {puts stderr err=$err}
	}
	my open  ;# UZ: wenn hier das self weggenommen wird, crashed das lintFilter
	#open  ;# UZ: wenn hier das self weggenommen wird, crashed das lintFilter

    }
    # the open method for the first invocation
    persistentCache proc open {} {
	my instvar dir DBID 
	package require xotcl::store
	set DBID [Storage someNewChildStore]
	if {![file isdirectory $dir]} {
	    # if the cache directory does not exist, create it..
	    file mkdir $dir
	}
	# the open method for later invocations, doing the real work
	my proc open {} {
	    my instvar dir DBID
	    $DBID open $dir/index
	}
	# invoke the method
	open
    }
    persistentCache proc clear {} {
	my instvar cacheFileName contentType meta entry validated dir
	my flush [list eval file delete -force  $dir/index \
		      [glob -nocomplain $dir/\[0-9\]*::*]]
	foreach var {cacheFileName contentType meta entry validated} {
	    catch {unset $var}
	}
    }
    persistentCache proc clearEntry {url} {
	my instvar DBID cacheFileName contentType meta entry validated
	my inCache $url
	if {[info exists cacheFileName($url)]} {
	    my flush [list eval file delete -force $cacheFileName($url)]
	    foreach var {cacheFileName contentType meta entry validated} {
		my showMsg "unset ${var}($url)"
		catch {unset ${var}($url)}
	    }
	    catch {$DBID unset $url}
	}
    }
    persistentCache proc lazyFlush {} {
	my instvar flushPending
	if {[info exists flushPending]} { after cancel $flushPending }
	set flushPending [after 100 [self] flush]
    }
    persistentCache proc newEntry {url access doCache name} {
	my instvar cacheFileName contentType meta dir
	if {$name ne ""} {
	    #$access set caching 0
	    return $name
	} elseif {$doCache} {
	    set cacheFileName($url) $dir/[pid]-$access
	    set contentType($url)   [$access set contentType]
	    set meta($url)          [$access set meta]
	    return $cacheFileName($url)
	} else {
	    # we use the Memory cache only for non-persistent cache entries
	    # which are deleted when the program terminates
	    set fileName $dir/v[pid]-$access
	    MemoryCache + $url $fileName
	    return $fileName
	}
    }
    persistentCache proc entryDone {url} {
	my instvar entry cacheFileName contentType DBID meta
	if {![info exists DBID]} { open }
	$DBID set $url [list \
			    cacheFileName $cacheFileName($url) \
			    contentType   $contentType($url)   \
			    meta          $meta($url)          ]
	my lazyFlush
	#my showMsg "size=[file size $cacheFileName($url)]"
	set entry($url) 1
	my set validated($url) 1
    }
    persistentCache proc inCache {url} {
	my instvar entry
	if {[info exists entry($url)]} {
	    set result 1
	} else {
	    my instvar cacheFileName contentType meta DBID
	    if {![info exists DBID]} { open }
	    set result [$DBID set $url]
	    my lazyFlush
	    if {$result ne ""} {
		set entry($url) 1
		array set r $result
		set cacheFileName($url) $r(cacheFileName)
		set contentType($url)   $r(contentType)
		set meta($url)          $r(meta)
		set result 1
	    } else {
		set result 0
	    }
	}
	return $result
    }
    persistentCache proc validated {url} {
	my set validated($url) 1
    }
    persistentCache proc invalidate {url} {
	if {[my exists validated($url)]} {
	    my unset validated($url)
	}
    }
    persistentCache proc isValidated {url} {
	if {[my exists validated($url)]} {
	    return 1
	}
	return 0
    }
    persistentCache proc ifModifiedHeader {url ifModVar} {
	set result 0
	if {[my inCache $url]} {
	    #puts stderr inCache:$url
	    upvar [self callinglevel] $ifModVar ifModifiedHeader
	    my instvar meta
	    array set m $meta($url)
	    if {[info exists m(last-modified)]} {
		set ifModifiedHeader [list If-Modified-Since $m(last-modified)]
		set result 1
	    }
	} else {
	    #puts stderr "url=$url is not in cache"
	}
	return $result
    }
    persistentCache proc dump {} {
	my instvar DBID
	puts stderr DUMP:
	foreach k [$DBID names] {
	    puts stderr $k
	    puts stderr "    [$DBID set $k]"
	}
    }
    persistentCache proc cacheFileName {url} {
	my instvar cacheFileName
	return $cacheFileName($url)
    }
    persistentCache proc contentType {url} {
	my instvar contentType
	return $contentType($url)
    }
    persistentCache proc meta {url} {
	my instvar meta
	return $meta($url)
    }
    persistentCache proc destroy {} {
	#my showCall
	next
    }
    #persistentCache flush



    ########################################################### Cache
    Object MemoryCache
    MemoryCache proc query {url entry} {
	my instvar cache
	if {[info exists cache($url)]} {
	    upvar [self callinglevel] $entry e
	    #puts stderr "-->[self] [self proc] finds: $url"
	    set e $cache($url)
	    return 1
	}
	return 0
    }
    MemoryCache proc + {url entry} {
	#puts stderr "-->[self class]:[self] [self proc] $url"
	my set cache($url) $entry
    }
    MemoryCache proc - {url} {
	#puts stderr "-->[self class]:[self] [self proc] $url"
	catch {my unset cache($url)}
    }
    MemoryCache proc destroy {} {
	my instvar cache
	foreach url [array names cache] {
	    set f $cache($url)
	    if {[regexp ^/ $f]} {
		#my showMsg "trying to remove $f [file exists $f]"
		file delete -force $f
	    }
	}
	next
    }


    Object instproc allInstances {} {
	# Diese Methode ermittelt rekursiv alle direkten und indirekten
	# Instanzen einer Klasse
	::set inst [my info instances]
	foreach s [my info subclass] {
	    foreach i [$s allInstances] { ::lappend inst $i }
	}
	return $inst
    }

    # onExit is automatically called when wafe terminates
    proc onExit {} {
	#puts stderr "allinstances of Access: [Access allInstances]"
	#foreach i [Access allInstances] {
	#  if {[info command $i] eq ""} continue
	#  $i destroy
	#}
	#MemoryCache clear
	persistentCache flush
	#Trace statReport
    }

    namespace export persistentCache MemoryCache
}

namespace import ::xotcl::comm::pcache::*

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::comm::connection 1.0 [list source [file join $dir Connection.xotcl]]
package ifneeded xotcl::comm::dav 0.9 [list source [file join $dir Dav.xotcl]]
package ifneeded xotcl::comm::ftp 0.9 [list source [file join $dir Ftp.xotcl]]
package ifneeded xotcl::comm::httpAccess 0.91 [list source [file join $dir Access.xotcl]]
package ifneeded xotcl::comm::httpd 1.1 [list source [file join $dir Httpd.xotcl]]
package ifneeded xotcl::comm::imap 0.9 [list source [file join $dir Imap.xotcl]]
package ifneeded xotcl::comm::ldap 0.9 [list source [file join $dir Ldap.xotcl]]
package ifneeded xotcl::comm::mime 0.9 [list source [file join $dir Mime.xotcl]]
package ifneeded xotcl::comm::pcache 0.9 [list source [file join $dir PCache.xotcl]]

 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstraße 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

#$Id: Script.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::script 0.9
package require XOTcl

namespace eval ::xotcl::script {
    namespace import ::xotcl::*

    @ @File {description {
	A small package to instantiate an object, that 
	represents a script.
    }
    }
    @ Class Script {
	description {
	    An object of type Script becomes automatically the command
	    line arguments evaluated as "-" method calls during creation, e.g.
	    <@pre>
	    Script s -set r 5
	    </@pre>
	    and a call with cmd-line "-set v 6" of the script, results in an
	    object s with two vars set: r to 5, and v to 6.
	}
    }



    Class Script
    Script proc create args {
	eval lappend args $::argv
	eval next $args
    }
    Script instproc unknown args {
	puts stderr "$::argv0: Unknown option ´-$args´ provided"
    }

    namespace export Script
}

namespace import ::xotcl::script::*

#
# this is a maintenance program for XOTcl that allows us to change the 
# version information across the whole distribution automatically.
# 
# this program assumes that pwd is in xotcl-full-X.X* directory or subdir
#
set XOTCL_MAJOR_VERSION 1
set XOTCL_MINOR_VERSION 6
set XOTCL_RELEASE_LEVEL .6

# example settings: 
# 1.0
#set XOTCL_MAJOR_VERSION 1
#set XOTCL_MINOR_VERSION 0
#set XOTCL_RELEASE_LEVEL .3
#
# 0.9.3
#set XOTCL_MAJOR_VERSION 0
#set XOTCL_MINOR_VERSION 9
#set XOTCL_RELEASE_LEVEL .3

#set XOTCL_MAJOR_VERSION 0
#set XOTCL_MINOR_VERSION 9
#set XOTCL_RELEASE_LEVEL .3
#set XOTCL_RELEASE_LEVEL .4
#set XOTCL_RELEASE_LEVEL .5


set XOTCL_VERSION $XOTCL_MAJOR_VERSION.$XOTCL_MINOR_VERSION
set FULL_VERSION $XOTCL_VERSION$XOTCL_RELEASE_LEVEL

if {![regexp {((^.*/xotcl-)([0-9.]*))/?} [pwd] _ topdirname topdirprefix oldversion]} {
  error "this program assumes that pwd is in xotcl-X.X* directory"
}

puts "Prior version is: $oldversion"
puts "New version is:   $FULL_VERSION"
puts "Working in:       $topdirname"

cd $topdirname

puts "... make clean first"
if {[file exists Makefile]} {
  exec make clean
}

foreach file [exec find . -name configure.in] {
  puts "... updating $file"
  set F [open $file]; set c [read $F]; close $F
  set newFile ""
  foreach line [split $c \n] {
    set newLine $line
    if {[regexp {^XOTCL_MAJOR_VERSION=[0-9]} $line]} {
      set line "XOTCL_MAJOR_VERSION=$XOTCL_MAJOR_VERSION"
    } elseif {[regexp {^XOTCL_MINOR_VERSION=[0-9]} $line]} {
      set line "XOTCL_MINOR_VERSION=$XOTCL_MINOR_VERSION"
    } elseif {[regexp {^XOTCL_RELEASE_LEVEL=} $line]} {
      set line "XOTCL_RELEASE_LEVEL=$XOTCL_RELEASE_LEVEL"
    } elseif {[regexp {^define\(XOTclVersion, .*$} $line]} {
      set line "define(XOTclVersion, $XOTCL_MAJOR_VERSION.$XOTCL_MINOR_VERSION$XOTCL_RELEASE_LEVEL)"
    }
    append newFile $line\n
  }
  set F [open $file w]; puts $F $newFile; close $F
}

set newtopdirname $topdirprefix$FULL_VERSION
if {$oldversion != $FULL_VERSION} {
  puts "topdir:               $topdirname->$newtopdirname"
  file rename -force $topdirname $newtopdirname
} 
cd $newtopdirname

foreach file [exec find . -name configure.in] {
  set dir [file dirname $file]
  set oldpwd [pwd]
  cd $dir
  exec autoconf
  cd $oldpwd
}

# determine last configure command
cd $newtopdirname
if {[catch {set configurecmd [exec fgrep {$ ./configure} config.log]}]} {
  set configurecmd "./configure"
} else {
  regsub {^ +\$ } $configurecmd "" configurecmd
}
#puts $configurecmd

cd $newtopdirname/
puts "Configuring in [pwd]"
eval exec $configurecmd

puts "ok ... version is now $FULL_VERSION"

## $Header: /home/neumann/cvs/xotcl/xotcl/library/lib/htmllib.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

#
# htmllib.xotcl
#
# Author: Antti Salonen, as@fishpool.fi
#
# Copyright:
#
# This software is copyrighted by Fishpool Creations Oy Ltd.  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.
# 

package provide xotcl::htmllib 0.1
package require XOTcl

namespace eval ::xotcl::htmllib {
    namespace import ::xotcl::*

    @ @File {
	description {
	    This package provides the class HtmlBuilder, which can be used to 
	    generate HTML documents, or a part of a document.
	}
	authors {
	    Antti Salonen, as@fishpool.fi
	}
	date {
	    $Date: 2006/09/27 08:12:40 $
	}
    }
    
    #
    # the compressed parameter means that minimal HTML page are created
    # i.e. that space indentation is turned off
    #
    Class HtmlBuilder -parameter {
	{compressed 0}
    }

    ## The constructor.
    ##
    ## The HtmlBuilder object has two instance variables. The document Tcl list
    ## contains the document as a list of strings. The document is stored as a list
    ## rather than a single string to allow further indentation of the whole
    ## document when necessary.
    ##   The indentLevel variable is the level of indentation, which is generally
    ## increased for the contents of any HTML element that may contain block-level
    ## elements. Typical examples would be <ul>, <li>, <td> and so forth.

    HtmlBuilder instproc init {} {
	my instvar document indentLevel
	set document [list] 
	set indentLevel 0
	return
    }


    HtmlBuilder instproc clear {} {
	my instvar document indentLevel

	set document [list]
	set indentLevel 0
	return
    }


    HtmlBuilder instproc getDocument {} {
	my instvar document
	return $document
    }


    HtmlBuilder instproc toString {} {
	my instvar document compressed
	set rvalue ""
	foreach line $document {
	    if {$compressed == "0"} {
		append rvalue "$line\n"
	    } else {
		## only new line for closing tags at the beginnig 
		## of a document element
		if {[string equal -length 2 "</" $line]} {
		    append rvalue "$line\n"
		} else {
		    append rvalue "$line "
		}
	    }
	}
	return $rvalue
    }


    ## parseArguments - Parses the arguments in argList as described in the two
    ## additional Tcl lists. In addition to the arguments listed in the two 
    ## additional lists, the procedure also accepts arguments common to all
    ## HTML elements.
    ## Arguments:
    ##   argList - List of arguments to be parsed
    ##   argParamList - List of arguments that take a parameter
    ##   argNoParamList - List of arguments that don't take a parameter
    ## Returns:
    ##   A string with arguments to an HTML element.

    HtmlBuilder proc parseArguments {argList argParamList argNoParamList} {
	set rvalue ""
	set argParamList [concat $argParamList [list "ID" "CLASS" "STYLE" "TITLE" "LANG" "DIR"]]
	set param 0
	foreach arg $argList {
	    if {$param} {
		append rvalue "=\"$arg\""
		set param 0
	    } else {
		set arg2 [string toupper [string trimleft $arg "-"]]
		if {[lsearch -exact $argParamList $arg2] != -1} {
		    append rvalue " $arg2"
		    set param 1
		} elseif {[lsearch -exact $argNoParamList $arg2] != -1} {
		    append rvalue " $arg2"
		} else {
		    error "HTML syntax error: Invalid argument $arg2 to element"
		}
	    }
	}
	if {$param} {
	    error "HTML syntax error: Missing parameter to argument $arg2"
	}
	return $rvalue
    }


    ##############################################################################
    ## Low-level modification methods:
    ##
    ## The efficiency of these is of utmost importance if efficiency is an issue
    ## in the first place.
    ##
    ## addString
    ## addStringIncr
    ## addStringDecr
    ## addWhiteSpace
    ## addDocument
    ## mergeDocument


    ## Add a new arbitrary string to the document. This method is used by other
    ## modification methods, as well as the user directly to add content other than
    ## HTML elements. The string str is appended to the document with proper
    ## indentation.

    HtmlBuilder instproc addString {str} {
	my instvar document indentLevel compressed
	
	if {$compressed == "0"} {
	    for {set n 0} {$n < $indentLevel} {incr n} {
		append newLine "  "
	    }
	}
	append newLine $str
	lappend document $newLine
	
	return
    }

    ## Add a string to the document and increase the indentation level.

    HtmlBuilder instproc addStringIncr {str} {
	my instvar indentLevel
	my addString $str
	incr indentLevel
	return
    }


    ## Decrease the indentation level and add a string to the document.

    HtmlBuilder instproc addStringDecr {str} {
	my instvar indentLevel
	incr indentLevel -1
	my addString $str
	return
    }

    #
    # add the string and replace all line breaks in the
    # string with addLineBreak calls so that given plain text 
    # appears similar in HTML output

    HtmlBuilder instproc addStringWithLineBreaks {str} {
	while {[set idx [string first "\n" $str]] != -1} {
	    my addString [string range $str 0 [expr {$idx - 1}]]
	    my addLineBreak
	    set str [string range $str [expr {$idx + 1}] end]
	}
	my addString $str
    }
    
    ## Add a single line of white space to the HTML document.
    
    HtmlBuilder instproc addWhiteSpace {} {
	my addString ""
	return
    }

    ## Add the content of the document given as parameter.

    HtmlBuilder instproc addDocument {document} {
	set documentList [$document getDocument]
	
	foreach line $documentList {
	    my addString $line
	}
	return
    }

    ## Merge the content of the document given as a parameter. The difference
    ## to addDocument is that the document merged is destroyed.

    HtmlBuilder instproc mergeDocument {document} {
	set documentList [$document getDocument]
	
	foreach line $documentList {
	    my addString $line
	}
	$document destroy
	return
    }




    ##############################################################################
    ## HTML generation methods:                                                
    ##              
    ## The methods for generating various HTML structures are either a pair of 
    ## start and end methods, such as startParagraph and endParagraph, or a single
    ## method such as addListItem. Even if the the closing tag for <p>, for
    ## example, is not required by the HTML specification, using the closing method
    ## is necessary to have the document properly indented.


    # Add a string to the document within <strong>...</strong>

    HtmlBuilder instproc addStringStrong {str} {
	my addString "<STRONG>$str</STRONG>"
	return
    }

    # Add a string to the document within <em>...</em>

    HtmlBuilder instproc addStringEmphasized {str} {
	my addString "<EM>$str</EM>"
	return
    }

    # Add a comment to the document <!-- ... -->

    HtmlBuilder instproc addComment {str} {
	my addString "<!-- $str -->"
	return
    }

    HtmlBuilder instproc addLineBreak {} {
	my addString "<BR>"
	return
    }

    ## startDocument - Start an HTML document. Currently all documents are HTML 4.0
    ## Transitional. HTML, BODY, HEAD and TITLE elements are added/started here.
    ## Optional arguments:
    ##   -title documentTitle (empty if not given)
    ##   -stylesheet externalStyleSheet
    ##   -bgcolor backgroundColour (deprecated in HTML 4.0)

    HtmlBuilder instproc startDocument {args} {
	set title ""
	foreach {name value} $args {
	    switch -- $name {
		-title {
		    set title $value
		}
		-stylesheet {
		    set stylesheet $value
		}
		-bgcolor {
		    set bgcolor $value
		}
	    }
	}
	my addString {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/frameset.dtd">}
	my addWhiteSpace
	my addString {<HTML>}
	my addStringIncr {<HEAD>}
	my addString "<TITLE>$title</TITLE>"
	if {[info exists stylesheet]} {
	    my addString "<LINK REL=\"StyleSheet\" HREF=\"$stylesheet\" TYPE=\"text/css\">"
	}
	my addStringDecr {</HEAD>}
	my addWhiteSpace
	if {[info exists bgcolor]} {
	    my addStringIncr "<BODY BGCOLOR=\"$bgcolor\">"
	} else {
	    my addStringIncr {<BODY>}
	}
	return
    }

    ## endDocument - end an HTML document

    HtmlBuilder instproc endDocument {} {
	my addStringDecr {</BODY>}
	my addString {</HTML>}
	return
    }

    ## startParagraph - start a P element
    ## Optional arguments:
    ##   Common HTML arguments

    HtmlBuilder instproc startParagraph {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addStringIncr "<P$attributes>"
	return
    }

    ## endParagraph - end a P element

    HtmlBuilder instproc endParagraph {} {
	my addStringDecr {</P>}
	return
    }

    ## startAnchor - start an A element
    ## Optional arguments:
    ##   -href URI
    ##   -name cdata
    ##   -target frameTarget
    ##   Common HTML arguments

    HtmlBuilder instproc startAnchor {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "HREF" "NAME" "TARGET"] [list]]
	my addStringIncr "<A$attributes>"
	return
    }

    ## endAnchor - end an A element

    HtmlBuilder instproc endAnchor {args} {
	my addStringDecr {</A>}
	return
    }

    ## addAnchor - add an A element, using content as the visible link.
    ## Optional arguments:
    ##   -href URI
    ##   -name cdata
    ##   -target frameTarget
    ##   Common HTML arguments

    HtmlBuilder instproc addAnchor {content args} {
	eval my startAnchor $args
	my addString $content
	my endAnchor
	return
    }

    ## startUnorderedList - start a UL element
    ## Optional arguments:
    ##   Commmon HTML arguments

    HtmlBuilder instproc startUnorderedList {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addStringIncr "<UL$attributes>"
	return
    }

    ## endUnorderedList - end a UL element

    HtmlBuilder instproc endUnorderedList {} {
	my addStringDecr {</UL>}
	return
    }

    ## startListItem - start an LI element
    ## Optional arguments:
    ##   Common HTML arguments

    HtmlBuilder instproc startListItem {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addStringIncr "<LI$attributes>"
	return
    }

    ## endListItem - end an LI element

    HtmlBuilder instproc endListItem {} {
	my addStringDecr {</LI>}
	return
    }

    ## add a simple list item
    HtmlBuilder instproc addListItem {content} {
	my startListItem
	my addString $content
	my endListItem
    }

    ## startTable - start a TABLE element. Note that if the -border argument isn't
    ## used, by default the table are created with borders (<TABLE BORDER>).

    ## Optional arguments:
    ##   -border pixels
    ##   -cellpadding length
    ##   -cellspacing length
    ##   -summary text
    ##   -width length
    ##   -bgcolor  color spec
    ##   Common HTML arguments

    HtmlBuilder instproc startTable {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "BORDER" "CELLPADDING" "CELLSPACING" "SUMMARY" \
				 "WIDTH" "BGCOLOR"] [list]]
	if {[lsearch $args "-border"] == -1} {
	    append attributes " BORDER"
	}
	my addStringIncr "<TABLE$attributes>"
	return
    }

    ## endTable - end a TABLE element

    HtmlBuilder instproc endTable {} {
	my addStringDecr {</TABLE>}
	return
    }

    ## startTableRow - start a TR element
    ## Optional arguments:
    ##   Common HTML arguments
    HtmlBuilder instproc startTableRow {args} {
	set attributes [HtmlBuilder parseArguments $args [list "VALIGN"] [list]]
	my addStringIncr "<TR$attributes>"
	return
    }

    ## endTableRow - end a TR element

    HtmlBuilder instproc endTableRow {} {
	my addStringDecr {</TR>}
	return
    }

    ## startTableCell - start a TD element
    ## Optional arguments:
    ##   -colspan number
    ##   -rowspan number
    ##   -align left|center|right|justify|char
    ##   -valign top|middle|bottom|baseline
    ##   -bgcolor
    ##   -width
    ##   Common HTML arguments

    HtmlBuilder instproc startTableCell {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "COLSPAN" "ROWSPAN" "ALIGN" "VALIGN" \
				 "BGCOLOR" "WIDTH"] [list]]
	my addStringIncr "<TD$attributes>"
	return
    }

    ## endTableCell - end a TD element

    HtmlBuilder instproc endTableCell {} {
	my addStringDecr {</TD>}
	return
    }

    #
    # add a simple table cell which just contains a string
    #
    HtmlBuilder instproc addTableCell {{string ""} args} {
	eval my startTableCell $args
	my addString $string
	my endTableCell
    }

    ## startTableHeaderCell - start a TH element
    ## Optional arguments:
    ##   -colspan number
    ##   -rowspan number
    ##   -align left|center|right|justify|char
    ##   -valign top|middle|bottom|baseline
    ##   Common HTML arguments

    HtmlBuilder instproc startTableHeaderCell {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "COLSPAN" "ROWSPAN" "ALIGN" "VALIGN"] [list]]
	my addStringIncr "<TH$attributes>"
	return
    }

    ## endTableHeaderCell - end a TH element

    HtmlBuilder instproc endTableHeaderCell {} {
	my addStringDecr {</TH>}
	return
    }

    ## startForm - start a FORM element
    ## Required arguments:
    ##   -action URI
    ## Optional arguments:
    ##   -method get|post
    ##   Common HTML arguments

    HtmlBuilder instproc startForm {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "ACTION" "METHOD" "ENCTYPE"] [list]]
	my addStringIncr "<FORM$attributes>"
	return
    }

    ## endForm - end a FORM element

    HtmlBuilder instproc endForm {} {
	my addStringDecr {</FORM>}
	return
    }

    ## addInput - add in INPUT element
    ## Required arguments:
    ##   -type <input type>
    ##   -name <control name>
    ## Optional arguments:
    ##   -value <initial value>
    ##   -size <width of input, in pixels of characters>
    ##   -maxlength <max number of characters for text input>
    ##   -checked
    ##   Common HTML arguments
    
    HtmlBuilder instproc addInput {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "TYPE" "NAME" "VALUE" "SIZE" "MAXLENGTH"] \
			    [list "CHECKED"]]
	my addString "<INPUT$attributes>"
	return
    }

    ## addTextArea - start a TEXTAREA element
    ## First parameter: value - Default value of the text area
    ## Required arguments:
    ##   -rows <number of rows>
    ##   -cols <number of columns>
    ## Optional arguments:
    ##   -name <control name>
    ##   Common HTML Arguments

    HtmlBuilder instproc addTextArea {value args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "ROWS" "COLS" "NAME"] [list]]
	my addString "<TEXTAREA$attributes>$value</TEXTAREA>"
	return
    }

    ## startOptionSelector - start a SELECT element
    ## Optional arguments:
    ##   -name <control name>
    ##   -size <number of visible items>
    ##   -multiple
    ##   Common HTML arguments

    HtmlBuilder instproc startOptionSelector {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "NAME" "SIZE"] [list "MULTIPLE"]]
	my addStringIncr "<SELECT$attributes>"
	return
    }    

    ## endOptionSelector - end a SELECT element

    HtmlBuilder instproc endOptionSelector {} {
	my addStringDecr "</SELECT>"
	return
    }

    ## startOption - start an OPTION element
    ## Optional arguments:
    ##   -value <value of option>
    ##   -selected
    ##   Common HTML arguments

    HtmlBuilder instproc startOption {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "VALUE"] [list "SELECTED"]]
	my addStringIncr "<OPTION$attributes>"
	return
    }

    ## endOption - end an OPTION element

    HtmlBuilder instproc endOption {} {
	my addStringDecr "</OPTION>"
	return
    }

    ## addImage - add an IMG element
    ## Required arguments:
    ##   -src <url>
    ##   -alt <alternate text>
    ##   -align <alignment> (deprecated in HTML 4.0)
    ## Optional arguments:
    ##   Common HTML arguments

    HtmlBuilder instproc addImage {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "SRC" "ALT" "ALIGN"] [list]]
	my addString "<IMG$attributes>"
	return
    }

    ## startBlock - start a DIV element (a generic block-level container)
    ## Optional arguments:
    ##   Common HTML attributes

    HtmlBuilder instproc startBlock {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addStringIncr "<DIV$attributes>"
	return
    }

    ## endBlock - end a DIV element

    HtmlBuilder instproc endBlock {} {
	my addStringDecr "</DIV>"
	return
    }

    ## addHorizontalRule - add an HR element
    ## Optional arguments:
    ##   Common HTML arguments

    HtmlBuilder instproc addHorizontalRule {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addString "<HR$attributes>"
	return
    }

    namespace export HtmlBuilder
}

namespace import ::xotcl::htmllib::*

# $Id: make.xotcl,v 1.4 2006/09/27 08:12:40 neumann Exp $ 
### inEachDir changes now to each directory
### install clears tgarget directory before installing
### Object file added (for better -n processing)
#lappend auto_path ..

package require XOTcl 1
namespace import -force ::xotcl::*

###
Object make
#
# shared lib add files for pkgIndex.tcl
#
make proc mkIndex {name} {
  #puts stderr "+++ mkIndex in [pwd]"
  set fls {}
  foreach f [glob -nocomplain *tcl] {
    if {![file isdirectory $f]} {
      set F [open $f]; set c [read $F]; close $F
      if {[string match "*package provide*" $c]} { lappend fls $f }
    }
  }

  set so [glob -nocomplain *[info sharedlibextension]]
  # loading libxotcl into xotclsh crashes on some systems
  foreach lib [list libxotcl$::xotcl::version[info sharedlibextension] \
		   xotcl$::xotcl::version.dll] {
    set p [lsearch -exact $so $lib]
    if {$p != -1} {
      set so [lreplace $so $p $p]
      #puts stderr "new so=<$so>"
    }
  }
  #puts stderr "[pwd]: call so=<$so>"
  set fls [concat $fls $so]
  
  if {$fls ne ""} {
    if {[file exists pkgIndex.tcl]} {
      file delete -force pkgIndex.tcl
    }
    #puts stderr "callinglevel <[self callinglevel]> $fls"
    #puts stderr "[pwd]:\n\tcall eval pkg_mkIndex -direct . $fls"
    if {[catch {eval pkg_mkIndex -direct . $fls} errs]} {
      puts stderr "!!! $errs"
    }
    #puts stderr "[pwd] done"
  }

  foreach addFile [glob -nocomplain *.add] {
    if {[file exists $addFile]} {
      puts stderr "Appending $addFile to pkgIndex.tcl in [pwd]"
      set OUT [file open pkgIndex.tcl a]
      set IN [file open $addFile]
      puts -nonewline $OUT [read $IN]
      close $IN; close $OUT
    }
  }
  #puts stderr "+++ mkIndex name=$name, pwd=[pwd] DONE"
}
make proc inEachDir {path cmd} {
  #puts stderr "[pwd] inEachDir $path  [file isdirectory $path]"
  if { [file isdirectory $path] 
       && ![string match *CVS $path]
       && ![string match *SCCS $path]
       && ![string match *Attic $path]
       && ![string match *dbm* $path]
    } {
    set olddir [pwd]
    cd $path
    eval make $cmd $path
    set files [glob -nocomplain *]
    cd $olddir
    foreach p $files { my inEachDir $path/$p $cmd }
    #puts stderr "+++ change back to $olddir"
  }
}
make proc in {path cmd} {
  if {[file isdirectory $path] && ![string match *CVS $path]} {
    set olddir [pwd]
    cd $path
    eval make $cmd $path
    cd $olddir
  }
}
### tcl file-command
rename file tcl_file
Object file -requireNamespace

rename open file::open
proc open {f {mode r}} { file open $f $mode }
#file proc open {f {mode r}} { ::open $f $mode }


file array set destructive {
  atime 0       attributes 0  copy 1       delete 1      dirname 0
  executable 0  exists 0      extension 0  isdirectory 0 isfile 0
  join 0        lstat 0       mkdir 1      mtime 0       nativename 0
  owned 0       pathtype 0    readable 0   readlink 0    rename 1
  rootname 0    size 0        split 0      stat 0        tail 0
  type 0        volumes 0     writable 0
}
foreach subcmd [file array names destructive] {
  file proc $subcmd args {
    #puts stderr " [pwd] call: '::tcl_file [self proc] $args'"
    eval ::tcl_file [self proc] $args
  }
}
### minus n option
Class make::-n
foreach f [file info commands] {
  if {$f eq "unknown" || $f eq "next" || $f eq "self"} continue
  if {![file exists destructive($f)] || [file set destructive($f)]} {
    #puts stderr destruct=$f
    make::-n instproc $f args {
	puts "--- [pwd]:\t[self proc] $args"
    }
  } else {
    #puts stderr nondestruct=$f
    make::-n instproc $f args {
      set r [next]
      #puts "??? [self proc] $args -> {$r}"
      return $r
    }
  }
}

### command line parameters
if {![info exists argv] || $argv eq ""} {set argv -all}
if {$argv eq "-n"} {set argv "-n -all"}

Class Script
Script proc create args {
  eval lappend args $::argv
  eval next $args
}
Script instproc unknown args {
  puts stderr "$::argv0: Unknown option ´-$args´ provided"
}

Script instproc n {} {file mixin make::-n}
Script instproc all {} {
  make inEachDir . mkIndex
}
Script instproc dir {dirName} {
  cd $dirName
}
Script instproc target {path} {
  make set target $path
}
Script create main

#puts stderr "+++ make.xotcl finished."
#if {[set ::tcl_platform(platform)] eq "windows"} {
#  exit
#}

#$Id: makeDoc.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $
package require XOTcl 1.6
namespace import ::xotcl::*
@ @File {
  description {
    Documentation tool for the XOTcl distribution.<br>
    Usage: 'makeDoc docdir filename ?filename ...?'<br>
    Called by Makefile.
  }
}
lappend auto_path [file dirname [info script]]

#package require xotcl::package
#package verbose 1
package require -exact xotcl::xodoc 0.84
set fileList ""

puts "XOTcl Documentation Tool"
puts "------------------------"
if {$argc > 1} {
  set DOCDIR [lindex $argv 0]
  puts "Documenting to directory $DOCDIR:"
  if {![file isdirectory $DOCDIR]} {
    file mkdir $DOCDIR
  }
  set files [lrange $argv 1 end]
  foreach file $files {
      puts "...$file"
      if {[catch {XODoc documentFileAsHTML $file $DOCDIR} fb]} {
	  puts stderr "\terror processing $file:\n[string replace $::errorInfo 400 end ...]"
      } else {
	  lappend fileList $file $fb
      }
  }
} else {
  error "usage: xodoc docdir filename ?filename ...?"
}

set filesHtml ""
set filesDir ""
## write index page
foreach {f fb} $fileList {
  set dir .
  regexp {^(.*)/[^/]*$} $f _ dir
  if {$fb ne "langRef-xotcl"} {
    set tail ", "
    if {$dir != $filesDir} {
      append filesHtml "<li> <b>Directory '$dir': </b><br>"
      set filesDir $dir
      set tail ""
    }
    append filesHtml "$tail<a HREF=\"./${fb}.html\">[file tail $f]</a>"
  }
}

#  <html>
#  <head>
#  <title>XOTcl - Documentation</title>
#  </head>
#  <body bgcolor=FFFFFF>
#  <h1><IMG ALIGN=MIDDLE SRC = "./logo-100.jpg">Lanuage Reference - Index</h1>

set content {

The <EM>Extended Object Tcl (XOTcl)</EM> Documentation contains the
following parts: 

<h2> XOTcl Language Documentation </h2>
  <UL>
  <LI>XOTcl Tutorial (<a href="tutorial.html">HTML</a>, 
		      <a href="tutorial.pdf">PDF</a>)
  <LI>Language Reference (<a href="langRef-xotcl.html">HTML</a>,
		      <a href="langRef-xotcl.pdf">PDF</a>)
  <LI>If you have question, problems etc. you might check the
      <a href="http://alice.wu-wien.ac.at/mailman/listinfo/xotcl">XOTcl 
         mailing list</a> (<a href="http://alice.wu-wien.ac.at:8000/xotcl-mailing-list/">archive 1</a>,
      <a href="http://alice.wu-wien.ac.at/pipermail/xotcl/">archive 2</a>)
      or you might check the XOTcl section of the  
         <a href="http://wiki.tcl.tk/XOTcl">Tcl wiki</a>.
   </UL>

<h2>Package and Script Documentation</h2>
<center>
  This section of the documentation is under work...
</center>

  <ul>
    $filesHtml
  </ul>
  <p>

<h2>Tcl Online Information </h2>
  <ul>
   <li>Online information for <a href="http://www.tcl.tk/man/">
      Tcl manual pages</a>
  </ul>
 
}


set content [subst -nobackslashes -nocommands $content]
set f [open $DOCDIR/index.html w]
puts $f $content
close $f

puts "Documentation finished"

package provide xotcl::metadataAnalyzer 0.84 
package require XOTcl

namespace eval ::xotcl::metadataAnalyzer {
    namespace import ::xotcl::*

    @ @File {
	description {
	    XOTcl file analyzer for @ metadata. E.g.\ used for 
	    doumentation with xoDoc (but in the static variant 
				     StaticMetadataAnalyzer which uses the dynamic 
				     variant in this file).
	    <@p>
	    Sample sample usage:
	    <@pre>
	    package require xotcl::metadataAnalyzer

	    # instantiate metadata analyzer object
	    MetadataAnalyzer @::m
	    # make this object be known to @ and turn @ metadata processing on
	    @ analyzerObj @::m
	    @ onOff 1

	    # read in some metadata tags (in sample file) & execute the file
	    source lib/testx.xotcl

	    # turn @ metadata processing off again
	    @ onOff 0

	    # print out all collected metadata
	    puts [@::m print]
	    </@pre>
	}
    }

    @ Class MetadataToken {
	description {
	    Each collected metadata element is stored in a token object.
	    MetadataToken is superclass of token object classes. Each metadata token
	    has two interesting parameters: 
	    <@p>
	    "properties" contains list of all described metadata properties. E.g. can
	    be printed with
	    <@pre>
	    foreach p [my set properties] { 
		if {[my exists $p]} {
		    append c "    $p=[my set $p]\n"
		}
	    }
	    </@pre>
	    "name" contains the method, object, ... name of the metadata element.
	    <@p>
	    All metadata token are aggregated by @. Therefore, 
	    <@pre>
	    foreach mdt [@ info children] { 
		if {[$mdt istype MetadataToken]} {$mdt print}
	    }
	    </@pre>
	    prints all token.

	}
    }
    Class MetadataToken -parameter {
	{name ""}
	{properties ""}
    }

    @ MetadataToken proc sortTokenList {l "token list"} {
	description {Sort a token list with names. Since names are autonames, 
	    this means order of appearance in the program.}
    }
    MetadataToken proc sortTokenList l {
	foreach t $l {
	    set names([$t set name]) $t
	}
	set sortedNames [lsort [array names names]]
	set sortedList ""
	foreach n $sortedNames {
	    lappend sortedList $names($n)
	}
	return $sortedList
    }

    MetadataToken instproc evaluateMetadata md {
	my instvar properties
	foreach {p v} $md {
	    # only append property, if its not already there
	    # otherwise just overwrite the value
	    if {[lsearch $properties $p] == -1} {
		my lappend properties $p
	    }
	    my set $p $v
	}
    }

    @ MetadataToken instproc printProperties {} {
	description {Print metadata properties to stdout.}
    }
    MetadataToken instproc printProperties {} {
	set c ""
	foreach p [my set properties] { 
	    if {[my exists $p]} {
		append c "   [my capitalize $p]=[my set $p]\n"
	    }
	}
	return $c
    }

    MetadataToken instproc capitalize string {
	if {$::tcl_version >= 8.3} {
	    string toupper $string 0 0
	} else {
	    return "[string toupper [string range $string 0 0]][string range $string 1 end]"
	}
    }

    @ MetadataToken abstract instproc print {} {
	description {
	    Abstract method for printing a token to stdout.
	}
    }
    MetadataToken abstract instproc print {}

    @ Class FileToken -superclass MetadataToken {
	description {
	    Token for @File Metadata.
	}
    }
    Class FileToken -superclass MetadataToken
    FileToken instproc print {} {
	set c "FILE=[my set name]\n"
	append c [my printProperties]
	return $c
    }

    @ Class ConstraintToken -superclass MetadataToken {
	description {
	    Token for @Constraint Metadata.
	}
    }
    Class ConstraintToken -superclass MetadataToken
    ConstraintToken instproc print {} {
	set c "CONSTRAINT=[my set name]\n"
	append c [my printProperties]
	return $c
    }

    @ Class PackageToken -superclass MetadataToken {
	description {
	    Token for Package metadata. Contains additional parameters:
	    "version" of the package and "type"= either "require" or "provide".

	}
    }
    Class PackageToken -superclass MetadataToken -parameter {
	{version ""}
	{type ""}
    }

    @ Class ObjToken -superclass MetadataToken {
	description {
	    Token for Object metadata. Contains additional parameters:
	    "procList" = list of all proc token and "cl"= class name.
	}
    }
    Class ObjToken -superclass MetadataToken -parameter {
	{procList ""}
	cl
    }

    ObjToken instproc printProcs {} {
	set c "  PROCS:\n"
	set pl [MetadataToken sortTokenList [my procList]]
	if {[my istype ClassToken]} {
	    set pl [concat [MetadataToken sortTokenList [my instprocList]] $pl]
	}
	foreach p $pl {
	    append c "    [$p set name]\n"
	}
	return $c
    }

    ObjToken instproc print {} {
	set c "OBJECT=[my set name]\n"
	if {[my exists cl]} {append c "  CLASS=[my set cl]\n"}
	if {[my exists heritage]} {append c "  HERITAGE=[my set heritage]\n"}
	append c [my printProperties]

	set pl [MetadataToken sortTokenList [my procList]]
	if {[my istype ClassToken]} {
	    set pl [concat [MetadataToken sortTokenList [my instprocList]] $pl]
	}
	foreach p $pl {
	    append c [$p print]
	}

	return $c
    }

    @ Class ClassToken -superclass ObjToken {
	description {
	    Token for Class metadata. Contains additional parameters:
	    "instprocList" = list of all instproc token.
	}
    }
    Class ClassToken -superclass ObjToken -parameter {
	{instprocList ""}
    }
    ClassToken instproc print {} {
	regsub "^OBJECT=" [next] "CLASS=" r
	return $r
    }

    @ Class MetaClassToken -superclass ClassToken {
	description {
	    Token for Meta-Class metadata.
	}
    }
    Class MetaClassToken -superclass ClassToken
    MetaClassToken instproc print {} {
	regsub "^CLASS=" [next] "META-CLASS=" r
	return $r
    }

    @ Class MethodToken -superclass MetadataToken {
	description {
	    Token for Method metadata. Contains additional parameters:
	    "arguments" of the method, "returnValue"  of the method, 
	    "obj" name, "abstract" = 0 or 1 (whether its an abstract method or not).
	}
    }
    Class MethodToken -superclass MetadataToken -parameter {
	arguments
	returnValue
	obj
	{abstract 0}
    }

    # Prints out method information
    MethodToken instproc print {} {
	set c "  METHOD=[my set name], ARGUMENTS= "

	if {[my exists arguments]} {
	    foreach {arg argDescription} [my set arguments] {
		# ignore argDescription and default values
		if {[llength $arg] > 1} {set arg [lindex $arg 0]}
		append c $arg " "
	    }
	}
	append c "\n [my printProperties]"
	return $c
    }

    @ Class ProcToken -superclass MethodToken {
	description {
	    Token for Proc metadata
	}
    }
    Class ProcToken -superclass MethodToken
    ProcToken instproc print {} {
	regsub "^  METHOD=" [next] "  PROC=" r
	return $r
    }

    @ Class InstprocToken -superclass MethodToken {
	description {
	    Token for Instproc metadata.
	}
    }
    Class InstprocToken -superclass MethodToken
    InstprocToken instproc print {} {
	regsub "^  METHOD=" [next] "  INSTPROC=" r
	return $r
    }

    @ Class MetadataAnalyzer { 
	description "Handler class for building a metadata runtime structure"
    }

    Class MetadataAnalyzer -parameter {
	{objList ""}
	{packageList ""}
	{knownMetaclasses "Class"}
	{ns ""}
	fileToken
	{constraintList ""}
    }

    MetadataAnalyzer instproc init args {
	next
    }

    MetadataAnalyzer instproc handleMethod {obj type name {argList ""} {doc ""}} {
	#puts stderr "+++Method $type $name $argList $doc"
	set procClass ProcToken
	set objCl ObjToken
	if {$type eq "instproc"} {
	    set procCl InstprocToken
	    set objCl ClassToken
	}
	set t [$procClass create [my autoname ::xotcl::@::t]]
	
	set n [$t set name [string trimleft $name :]]
	$t set obj $obj

	set objFound 0
	foreach o [my set objList] {
	    if {[$o set name] == $obj} {
		set objFound 1
		if {$type eq "instproc" && ![$o istype ClassToken]} {
		    $o class ClassToken
		}
		break
	    }
	}
	if {$objFound == 0} {
	    set o [$objCl create [my autoname ::xotcl::@::t]]
	    $o set name $obj
	    my lappend objList $o
	}
	$o lappend ${type}List $t

	$t set arguments $argList 

	$t evaluateMetadata $doc
	return $t
    }

    MetadataAnalyzer instproc handleObj {class name args} {
	my instvar knownMetaclasses objList extensions
	set objCl ObjToken
	if {[lsearch $class $knownMetaclasses] != -1} {
	    set objCl ClassToken
	}
	# if an instproc/proc has created an entry for this obj/class
	# -> use it and overwrite it with new info
	if {[set idx [lsearch $name $objList]] != -1} {
	    set t [lindex $objList $idx]
	    $t class $objCl
	} else {
	    set t [$objCl create [my autoname ::xotcl::@::t]]
	    my lappend objList $t
	}

	$t set name $name

	set la [llength $args]

	# evaluate -superclass argument
	if {($la == 3 || $la == 2) && [lindex $args 0] eq "-superclass"} {
	    set heritage [$t set heritage [lindex $args 1]]
	    foreach h $heritage {
		if {[lsearch $h $knownMetaclasses] != -1} {
		    # A new metaclass was defined
		    lappend knownMetaclasses $name
		    $t class MetaClassToken
		}
	    }
	}

	# evaluate documentation
	set doc ""
	if {$la == 1} {
	    set doc [lindex $args 0]
	} elseif {$la == 3} {
	    set doc [lindex $args 2]
	}
	$t evaluateMetadata $doc
	$t set cl $class

	#puts stderr "+++Obj $name $args"
    }

    MetadataAnalyzer instproc handleFile doc {
	if {[my exists fileToken]} {
	    [my set fileToken] evaluateMetadata $doc
	}
    }

    MetadataAnalyzer instproc handleConstraint {constraint name args} {
	set t [ConstraintToken create [my autoname ::xotcl::@::t]]
	my lappend constraintList $t
	$t set name $name
	set doc [lindex $args 0]
	$t evaluateMetadata $doc
    }

    MetadataAnalyzer instproc handlePackage args {
	#puts "$args"
	if {[llength $args] > 2} {
	    set type [lindex $args 1]
	    if {$type eq "provide" || $type eq "require"} {
		set t [PackageToken create [my autoname ::xotcl::@::t]]
		my lappend packageList $t
		$t set name [lindex $args 2]
		$t set type $type
		if {[llength $args] > 3} {
		    $t set version [lindex $args 3]
		}
	    }
	}
    }

    @ MetadataAnalyzer instproc print {} {
	description "Print all collected token information to stdout. 
   This method is also an exmaple how the tokens can be used."
    }
    MetadataAnalyzer instproc print {} {
	my instvar extensions packageList
	set c ""
	if {[llength $packageList] > 0} {
	    append c "PACKAGES:"
	    foreach t $packageList {
		if {[$t type] eq "provide"} {
		    append c "  Package provided: [$t name] [$t version]\n"
		} elseif {[$t type] eq "require"} {
		    append c "  Package required: [$t name] [$t version]\n"
		}
	    }
	}

	if {[my exists fileToken]} {
	    append c [[my set fileToken] print]
	}

	if {[my exists constraintToken]} {
	    append c [[my set constraintToken] print]
	}

	if {[info exists extensions]} {
	    # Add list of extensions.
	    foreach extension $extensions {
		append c "\nExtensions: [$extension name], " \
		    "Description: [$extension description]"
	    }
	}

	set objList [MetadataToken sortTokenList [my objList]]

	if {[llength $objList]>0} {
	    foreach obj $objList {append c [$obj print]}
	}
	return $c
    }

    @ Class AnalyzerCmd {
	description {Class that overload the unknown mechanism of @ to provide metadata analysis.}
    }
    Class AnalyzerCmd -parameter {
	{analyzerObj ""}
	{onOff 0}
    } 
    AnalyzerCmd instproc unknown args {
	my instvar analyzerObj onOff

	if {!$onOff} {return [next]}

	if {[llength $args] > 1} {
	    set abstract 0
	    if {[lindex $args 1] eq "abstract"} {
		if {[llength $args] > 2} {
		    set p [lindex $args 2]
		    if {$p eq "proc" || $p eq "instproc"} {
			set args [lreplace $args 1 1]
			set abstract 1
		    }
		}
	    }
	    switch [lindex $args 1] {
		proc - instproc {
		    set r [eval $analyzerObj handleMethod $args]
		    if {$abstract} {$r abstract 1}
		    return $r
		}
		default {
		    switch [lindex $args 0] {
			@File {
			    return [$analyzerObj handleFile [lindex $args 1]]
			}
			@Constraint {
			    return [eval $analyzerObj handleConstraint $args]
			}
			default {
			    return [eval $analyzerObj handleObj $args]
			}
		    }
		}
	    }
	}
	puts stderr "Unknown @ metadata: '$args'"
    }
    @ AnalyzerCmd @ {
	description {Recreate @ with metadata analyis funtionality.}
    }
    AnalyzerCmd @

    namespace export \
	MetadataToken FileToken ConstraintToken PackageToken ObjToken \
	ClassToken MetaClassToken MethodToken ProcToken InstprocToken \
	MetadataAnalyzer AnalyzerCmd
}

namespace import ::xotcl::metadataAnalyzer::*