error "Mandatory header $eltName not understood." \	    		{} MustUnderstand	    }	}    }    return $result}# -------------------------------------------------------------------------# Description:#   Handle incoming SOAP requests.#   We extract the name of the SOAP method and the arguments and search for#   the implementation in the specified namespace. This is then evaluated#   and the result is wrapped up and returned or a SOAP Fault is generated.# Parameters:#   doc - a DOM tree constructed from the input request XML data.#proc ::SOAP::CGI::soap_call {doc {interp {}}} {    variable methodName    set headers {}    if {[catch {	# Check SOAP version by examining the namespace of the Envelope elt.	set envnode [selectNode $doc "/Envelope"]	if {$envnode != {}} {	    #set envns [dom::node cget $envnode -namespaceURI]	    set envns [namespaceURI $envnode]	    if {$envns != "" && \		    ! [string match $envns \		    "http://schemas.xmlsoap.org/soap/envelope/"]} {		error "The SOAP Envelope namespace does not match the\			SOAP version 1.1 namespace." {} VersionMismatch	    }	}	# Check for Header elements	if {[set headerNode [selectNode $doc "/Envelope/Header"]] != {}} {	    set headers [soap_header $doc 0]	    dtrace "headers: $headers"	}	# Get the method name from the XML request.        # Ensure we only select the first child element (Vico.Klump@risa.de)	set methodNodes [selectNode $doc "/Envelope/Body/*"]        set methodNode [lindex $methodNodes 0]	set methodName [nodeName $methodNode]	# Get the XML namespace for this method.	set methodNamespace [namespaceURI $methodNode]	dtrace "methodinfo: ${methodNamespace}::${methodName}"	# Extract the parameters.	set argNodes [selectNode $doc "/Envelope/Body/${methodName}/*"]	set argValues {}	foreach node $argNodes {	    lappend argValues [decomposeSoap $node]	}	# Check for a permitted methodname. This is defined by being in the	# SOAP::export list for the given namespace. We must do this to prevent	# clients arbitrarily calling tcl commands like 'eval' or 'error'	#        if {[catch {	    interp eval $interp \		    set ${methodNamespace}::__soap_exports($methodName)	} fqdn]} {	    dtrace "method not found: $fqdn"	    error "Invalid SOAP request:\		    method \"${methodNamespace}::${methodName}\" not found" \		{} "Client"	}	# evaluate the method	set msg [interp eval $interp $fqdn $argValues]	# check for mustUnderstand headers that were not understood.	# This will raise an error for any such header elements.	if {$headerNode != {}} {	    soap_header $doc 1	}	# generate a reply packet	set reply [SOAP::reply \		[dom::DOMImplementation create] \		$methodNamespace "${methodName}Response" $msg]	set xml [dom::DOMImplementation serialize $reply]	regsub "<!DOCTYPE\[^>\]+>\n" $xml {} xml	catch {dom::DOMImplementation destroy $reply}	catch {dom::DOMImplementation destroy $doc}	    } msg]} {	# Handle errors the SOAP way.	#	set detail [list "errorCode" $::errorCode "stackTrace" $::errorInfo]	set code [lindex $detail 1]	switch -exact -- $code {	    "VersionMismatch" {		set code "SOAP-ENV:VersionMismatch"	    }	    "MustUnderstand" {		set code "SOAP-ENV:MustUnderstand"	    }	    "Client" {		set code "SOAP-ENV:Client"	    }	    "Server" {		set code "SOAP-ENV:Server"	    }	}	set xml [SOAP::fault $code "$msg" $detail]	return -code error -errorcode SOAP $xml    }    # publish the answer    return $xml}# -------------------------------------------------------------------------# Description:#   Prepare the interpreter for XML-RPC method invocation. We try to identify#   a Tcl file to source for the implementation of the method by using the #   XML-RPC class name (the bit before the dot) and looking it up in the#   xmlrpcmap file. This file also tells us if we should use a safe #   interpreter for this method.#proc ::SOAP::CGI::xmlrpc_invocation {doc} {    global env    variable xmlrpcdir    array set impl {filename {} interp {}}    # Identify the classname part of the methodname    set methodNode [selectNode $doc "/methodCall/methodName"]    set methodName [getElementValue $methodNode]    set className {}    if {[regexp {.*\.} $methodName className]} {	set className [string trim $className .]    }    set files {}    if {$className != {}} {	array set impl [xmlrpc_implementation $className]	set files $impl(filename)    }    if {$files == {}} {	set files [glob $xmlrpcdir/*]    }    # Do we want to use a safe interpreter?    if {$impl(interp) != {}} {	createInterp $impl(interp) $xmlrpcdir    }    dtrace "Interp: '$impl(interp)' - Files required: $files"    # Source the XML-RPC implementation files at global level.    foreach file $files {	if {[file isfile $file] && [file readable $file]} {	    itrace "debug: sourcing $file"	    if {[catch {		interp eval $impl(interp)\			namespace eval :: \			"source [list $file]"	    } msg]} {		itrace "warning: failed to source \"$file\""		dtrace "failed to source \"$file\": $msg"	    }	}    }    set result [xmlrpc_call $doc $impl(interp)]    if {$impl(interp) != {}} {	safe::interpDelete $impl(interp)    }    return $result}# -------------------------------------------------------------------------# Description:#   Load in the SOAP method implementation file on the basis of the#   SOAPAction header. We use this header plus a map file to decide#   what file to source, or if we should source all the files in the#   soapdir directory. The map also provides for evaluating this method in#   a safe slave interpreter for extra security if needed.#   See the cgi-bin/soapmap.dat file for more details.#proc ::SOAP::CGI::soap_invocation {doc} {    global env    variable soapdir    # Obtain the SOAPAction header and strip the quotes.    set SOAPAction {}    if {[info exists env(HTTP_SOAPACTION)]} {	set SOAPAction $env(HTTP_SOAPACTION)    }    set SOAPAction [string trim $SOAPAction "\""]    itrace "SOAPAction set to \"$SOAPAction\""    dtrace "SOAPAction set to \"$SOAPAction\""        array set impl {filename {} interp {}}        # Use the SOAPAction HTTP header to identify the files to source or    # if it's null, source the lot.    if {$SOAPAction == {} } {	set files [glob [file join $soapdir *]]     } else {	array set impl [soap_implementation $SOAPAction]	set files $impl(filename)	if {$files == {}} {	    set files [glob [file join $soapdir *]]	}	itrace "interp: $impl(interp): files: $files"		# Do we want to use a safe interpreter?	if {$impl(interp) != {}} {	    createInterp $impl(interp) $soapdir	}    }    dtrace "Interp: '$impl(interp)' - Files required: $files"        foreach file $files {	if {[file isfile $file] && [file readable $file]} {	    itrace "debug: sourcing \"$file\""	    if {[catch {		interp eval $impl(interp) \			namespace eval :: \			"source [list $file]"	    } msg]} {		itrace "warning: $msg"		dtrace "Failed to source \"$file\": $msg"	    }	}    }        set result [soap_call $doc $impl(interp)]    if {$impl(interp) != {}} {	safe::interpDelete $impl(interp)    }    return $result}# -------------------------------------------------------------------------# Description:#    Examine the incoming data and decide which protocol handler to call.#    Everything is evaluated in a large catch. If any errors are thrown we#    will wrap them up in a suitable reply. At this stage we return#    HTML for errors.# Parameters:#    xml - for testing purposes we can source this file and provide XML#          as this parameter. Normally this will not be used.#proc ::SOAP::CGI::main {{xml {}} {debug 0}} {    catch {package require tcllib} ;# re-eval the pkgIndex    package require ncgi    global env    variable soapdir    variable xmlrpcdir    variable methodName    variable debugging $debug    variable debuginfo {}    variable interactive 1    if { [catch {		# Get the POSTed XML data and parse into a DOM tree.	if {$xml == {}} {	    set xml [ncgi::query]	    	    set interactive 0      ;# false if this is a CGI request	    # Debugging can be set by the HTTP header "SOAPDebug: 1"	    if {[info exists env(HTTP_SOAPDEBUG)]} {		set debugging 1	    }	}	set doc [dom::DOMImplementation parse [do_encoding $xml]]		# Identify the type of request - SOAP or XML-RPC, load the	# implementation and call.	if {[selectNode $doc "/Envelope"] != {}} {	    set result [soap_invocation $doc]	    log "SOAP" $methodName "ok"	} elseif {[selectNode $doc "/methodCall"] != {}} {	    set result [xmlrpc_invocation $doc]	    log "XMLRPC" $methodName "ok"	} else {	    dom::DOMImplementation destroy $doc	    error "invalid protocol: the XML data is neither SOAP not XML-RPC"	}	# Send the answer to the caller	write $result text/xml    } msg]} {		# if the error was thrown from either of the protocol	# handlers then the error code is set to indicate that the	# message is a properly encoded SOAP/XMLRPC Fault.	# If its a CGI problem, then be a CGI error.	switch -- $::errorCode {	    SOAP   {		write $msg text/xml "500 SOAP Error"		catch {		    set doc [dom::DOMImplementation parse $msg]		    set r [decomposeSoap [selectNode $doc /Envelope/Body/*]]		} msg		log "SOAP" [list $methodName $msg] "error" 	    }	    XMLRPC {		write $msg text/xml "500 XML-RPC Error"		catch {		    set doc [dom::DOMImplementation parse $msg]		    set r [getElementNamedValues [selectNode $doc \			    /methodResponse/*]]		} msg		log "XMLRPC" [list $methodName $msg] "error" 	    }	    default {		variable rcsid		set html "<!doctype HTML public \"-//W3O//DTD W3 HTML 2.0//EN\">\n"		append html "<html>\n<head>\n<title>CGI Error</title>\n</head>\n<body>"		append html "<h1>CGI Error</h1>\n<p>$msg</p>\n"		append html "<br />\n<pre>$::errorInfo</pre>\n"		append html "<p><font size=\"-1\">$rcsid</font></p>"		append html "</body>\n</html>"		write $html text/html "500 Internal Server Error"				log "unknown" [string range $xml 0 60] "error"	    }	}    }}# -------------------------------------------------------------------------## Local variables:# mode: tcl# End: