home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tclsoap1.6.1 / SOAP-CGI.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  20.0 KB  |  678 lines
  1. # SOAP-CGI.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
  2. #
  3. # A CGI framework for SOAP and XML-RPC services from TclSOAP
  4. #
  5. # -------------------------------------------------------------------------
  6. # This software is distributed in the hope that it will be useful, but
  7. # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  8. # or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
  9. # for more details.
  10. # -------------------------------------------------------------------------
  11. #
  12.  
  13. package provide SOAP::CGI 1.0
  14.  
  15. namespace eval SOAP {
  16.     namespace eval CGI {
  17.  
  18.     # -----------------------------------------------------------------
  19.     # Configuration Parameters
  20.     # -----------------------------------------------------------------
  21.     #   soapdir   - the directory searched for SOAP methods
  22.     #   xmlrpcdir - the directory searched for XML-RPC methods
  23.     #   logfile   - a file to update with usage data. 
  24.     #
  25.     #   This framework is such that the same tcl procedure can be called 
  26.     #   for both types of request. The result will be packaged correctly
  27.     #   So these variables can point to the _same_ directory.
  28.     #
  29.     # ** Note **
  30.     #   These directories will be relative to your httpd's cgi-bin
  31.     #   directory.
  32.  
  33.     variable soapdir       "soap"
  34.     variable soapmapfile   "soapmap.dat"
  35.     variable xmlrpcdir     $soapdir
  36.     variable xmlrpcmapfile "xmlrpcmap.dat"
  37.     variable logfile       "rpc.log"
  38.     
  39.     # -----------------------------------------------------------------
  40.  
  41.     variable rcsid {
  42.         $Id: SOAP-CGI.tcl,v 1.10 2001/08/28 22:53:21 patthoyts Exp $
  43.     }
  44.     variable methodName  {}
  45.     variable debugging   0
  46.     variable debuginfo   {}
  47.     variable interactive 0
  48.     
  49.     package require dom
  50.     package require SOAP
  51.     package require XMLRPC
  52.     package require SOAP::Utils
  53.     catch {namespace import -force [namespace parent]::Utils::*}
  54.  
  55.     namespace export log main
  56.     }
  57. }
  58.  
  59. # -------------------------------------------------------------------------
  60.  
  61. # Description:
  62. #   Maintain a basic call log so that we can monitor for errors and 
  63. #   popularity.
  64. # Notes:
  65. #   This file will need to be writable by the httpd user. This is usually
  66. #   'nobody' on unix systems, so the logfile will need to be world writeable.
  67. #
  68. proc SOAP::CGI::log {protocol action result} {
  69.     variable logfile
  70.     catch {
  71.     if {[info exists logfile] && $logfile != {} && \
  72.         [file writable $logfile]} {
  73.         set stamp [clock format [clock seconds] \
  74.             -format {%Y%m%dT%H%M%S} -gmt true]
  75.         set f [open $logfile "a+"]
  76.         puts $f [list $stamp $protocol $action $result \
  77.             $::env(REMOTE_ADDR) $::env(HTTP_USER_AGENT)]
  78.         close $f
  79.     }
  80.     }
  81. }
  82.  
  83. # -------------------------------------------------------------------------
  84.  
  85. # Description:
  86. #   Write a complete html page to stdout, setting the content length correctly.
  87. # Notes:
  88. #   The string length is incremented by the number of newlines as HTTP content
  89. #   assumes CR-NL line endings.
  90. #
  91. proc SOAP::CGI::write {html {type text/html} {status {}}} {
  92.     variable debuginfo
  93.  
  94.     # Do some debug info:
  95.     if {$debuginfo != {}} {
  96.     append html "\n<!-- Debugging Information-->"
  97.     foreach item $debuginfo {
  98.         append html "\n<!-- $item -->"
  99.     }
  100.     }
  101.  
  102.     # For errors, status should be "500 Reason Text"
  103.     if {$status != {}} {
  104.     puts "Status: $status"
  105.     }
  106.  
  107.     puts "SOAPServer: TclSOAP/1.6"
  108.     puts "Content-Type: $type"
  109.     set len [string length $html]
  110.     puts "X-Content-Length: $len"
  111.     incr len [regexp -all "\n" $html]
  112.     puts "Content-Length: $len"
  113.  
  114.     puts "\n$html"
  115.     catch {flush stdout}
  116. }
  117.  
  118. # -------------------------------------------------------------------------
  119.  
  120. # Description:
  121. #   Convert a SOAPAction HTTP header value into a script filename.
  122. #   This is used to identify the file to source for the implementation of
  123. #   a SOAP webservice by looking through a user defined map.
  124. #   Also used to load an equvalent map for XML-RPC based on the class name
  125. # Result:
  126. #   Returns the list for an array with filename, interp and classname elts.
  127. #
  128. proc SOAP::CGI::get_implementation_details {mapfile classname} {
  129.     if {[file exists $mapfile]} {
  130.     set f [open $mapfile r]
  131.     while {! [eof $f] } {
  132.         gets $f line
  133.         regsub "#.*" $line {} line                 ;# delete comments.
  134.         regsub -all {[[:space:]]+} $line { } line  ;# fold whitespace
  135.         set line [string trim $line]
  136.         if {$line != {}} {
  137.         set line [split $line]
  138.         catch {unset elt}
  139.         set elt(classname) [lindex $line 0]
  140.         set elt(filename)  [string trim [lindex $line 1] "\""]
  141.         set elt(interp)    [lindex $line 2]
  142.         set map($elt(classname)) [array get elt]
  143.         }
  144.     }
  145.     close $f
  146.     }
  147.     
  148.     if {[catch {set map($classname)} r]} {
  149.     error "\"$classname\" not implemented by this endpoint."
  150.     }
  151.  
  152.     return $r
  153. }
  154.  
  155. proc SOAP::CGI::soap_implementation {SOAPAction} {
  156.     variable soapmapfile
  157.     variable soapdir
  158.  
  159.     if {[catch {get_implementation_details $soapmapfile $SOAPAction} detail]} {
  160.     set xml [SOAP::fault "Client" \
  161.         "Invalid SOAPAction header: $detail" {}]
  162.     error $xml {} SOAP
  163.     }
  164.     
  165.     array set impl $detail
  166.     if {$impl(filename) != {}} {
  167.     set impl(filename) [file join $soapdir $impl(filename)]
  168.     }
  169.     return [array get impl]
  170. }
  171.  
  172. proc SOAP::CGI::xmlrpc_implementation {classname} {
  173.     variable xmlrpcmapfile
  174.     variable xmlrpcdir
  175.  
  176.     if {[catch {get_implementation_details $xmlrpcmapfile $classname} r]} {
  177.     set xml [XMLRPC::fault 500 "Invalid classname: $r" {}]
  178.     error $xml {} XMLRPC
  179.     }
  180.  
  181.     array set impl $r
  182.     if {$impl(filename) != {}} {
  183.     set impl(filename) [file join $xmlrpcdir $impl(filename)]
  184.     }
  185.     return [array get impl]
  186. }
  187.  
  188. proc SOAP::CGI::createInterp {interp path} {
  189.     safe::setLogCmd [namespace current]::itrace
  190.     set slave [safe::interpCreate $interp]
  191.     safe::interpAddToAccessPath $slave $path
  192.     # override the safe restrictions so we can load our
  193.     # packages (actually the xml package files)
  194.     proc ::safe::CheckFileName {slave file} {
  195.     if {![file exists $file]} {error "file non-existent"}
  196.     if {![file readable $file]} {error "file not readable"}
  197.     }
  198.     return $slave
  199. }
  200.  
  201. # -------------------------------------------------------------------------
  202.  
  203. # Description:
  204. #   itrace prints it's arguments to stdout if we were called interactively.
  205. #
  206. proc SOAP::CGI::itrace args {
  207.     variable interactive
  208.     if {$interactive} {
  209.     puts $args
  210.     }
  211. }
  212.  
  213. # Description:
  214. #   dtrace logs debug information for appending to the end of the SOAP/XMLRPC
  215. #   response in a comment. This is not allowed by the standards so is switched
  216. #   on by the use of the SOAPDebug header. You can enable this with:
  217. #     SOAP::configure -transport http -headers {SOAPDebug 1}
  218. #
  219. proc SOAP::CGI::dtrace args {
  220.     variable debuginfo
  221.     variable debugging
  222.     if {$debugging} {
  223.     lappend debuginfo $args
  224.     }
  225. }
  226.  
  227. # -------------------------------------------------------------------------
  228.  
  229. # Description:
  230. #   Handle UTF-8 and UTF-16 data and convert into unicode for DOM parsing
  231. #   as necessary.
  232. #
  233. proc SOAP::CGI::do_encoding {xml} {
  234.     if {[binary scan $xml ccc c0 c1 c2] == 3} {
  235.     if {$c0 == -1 && $c1 == -2} {
  236.         dtrace "encoding: UTF-16 little endian"
  237.         set xml [encoding convertfrom unicode $xml]
  238.     } elseif {$c0 == -2 && $c1 == -1} {
  239.         dtrace "encoding: UTF-16 big endian"
  240.         binary scan $xml S* xml
  241.         set xml [encoding convertfrom unicode [binary format s* $xml]]
  242.     } elseif {$c0 == -17 && $c1 == -69 && $c2 == -65} {
  243.         dtrace "encoding: UTF-8"
  244.         set xml [encoding convertfrom utf-8 $xml]
  245.     }
  246.     }
  247.     return $xml
  248. }
  249.  
  250. # -------------------------------------------------------------------------
  251.  
  252. # Description:
  253. #   Handle incoming XML-RPC requests.
  254. #   We extract the name of the method and the arguments and search for
  255. #   the implementation in $::xmlrpcdir. This is then evaluated and the result
  256. #   is wrapped up and returned or a fault packet is generated.
  257. # Parameters:
  258. #   doc - a DOM tree constructed from the input request XML data.
  259. #
  260. proc SOAP::CGI::xmlrpc_call {doc {interp {}}} {
  261.     variable methodName
  262.     if {[catch {
  263.     
  264.     set methodNode [selectNode $doc "/methodCall/methodName"]
  265.     set methodName [getElementValue $methodNode]
  266.     set methodNamespace {}
  267.  
  268.     # Get the parameters.
  269.     set paramsNode [selectNode $doc "/methodCall/params"]
  270.     set argValues {}
  271.     if {$paramsNode != {}} {
  272.         set argValues [decomposeXMLRPC $paramsNode]
  273.     }
  274.     catch {dom::DOMImplementation destroy $doc}
  275.  
  276.     # Check for a permitted methodname. This is defined by being in the
  277.     # XMLRPC::export list for the given namespace. We must do this to
  278.     # prevent clients arbitrarily calling tcl commands.
  279.     #
  280.     if {[catch {
  281.         interp eval $interp \
  282.             set ${methodNamespace}::__xmlrpc_exports($methodName)
  283.     } fqdn]} {
  284.         error "Invalid request: \
  285.             method \"${methodNamespace}::${methodName}\" not found"\
  286.     }
  287.  
  288.     # evaluate the method
  289.     set msg [interp eval $interp $fqdn $argValues]
  290.  
  291.     # generate a reply packet
  292.     set reply [XMLRPC::reply \
  293.         [dom::DOMImplementation create] \
  294.         {urn:xmlrpc-cgi} "${methodName}Response" $msg]
  295.     set xml [dom::DOMImplementation serialize $reply]
  296.     regsub "<!DOCTYPE\[^>\]+>\n" $xml {} xml
  297.     catch {dom::DOMImplementation destroy $reply}
  298.  
  299.     } msg]} {
  300.     set detail [list "errorCode" $::errorCode "stackTrace" $::errorInfo]
  301.     set xml [XMLRPC::fault 500 "$msg" $detail]
  302.     error $xml {} XMLRPC
  303.     }
  304.  
  305.     # publish the answer
  306.     return $xml
  307. }
  308.  
  309. # -------------------------------------------------------------------------
  310.  
  311. # Description:
  312. #   Handle the Head section of a SOAP request. If there is a problem we 
  313. #   shall throw an error.
  314. # Parameters:
  315. #   doc
  316. #   mandate - boolean: if true then throw an error for any mustUnderstand
  317. #
  318. proc SOAP::CGI::soap_header {doc {mandate 0}} {
  319.     dtrace "Handling SOAP Header"
  320.     set result {}
  321.     foreach elt [selectNode $doc "/Envelope/Header/*"] {
  322.     set eltName [dom::node cget $elt -nodeName]
  323.     set actor [getElementAttribute $elt actor]
  324.     dtrace "SOAP actor $eltName = $actor"
  325.  
  326.     # If it's not for me, don't handle the header.
  327.     if {$actor == "" || [string match $actor \
  328.         "http://schemas.xmlsoap.org/soap/actor/next"]} {
  329.     
  330.         # Check for Mandatory Headers.
  331.         set mustUnderstand [getElementAttribute $elt mustUnderstand]        
  332.         dtrace "SOAP mustUnderstand $eltName $mustUnderstand"
  333.  
  334.         # add to the list of suitable headers.
  335.         lappend result [getElementName $elt] [getElementValue $elt]
  336.  
  337.         
  338.         ## Until we know what to do with such headers, we will have to
  339.         ## Fault.
  340.         if {$mustUnderstand == 1 && $mandate == 1} {
  341.             error "Mandatory header $eltName not understood." \
  342.                 {} MustUnderstand
  343.         }
  344.     }
  345.     }
  346.     return $result
  347. }
  348.  
  349. # -------------------------------------------------------------------------
  350.  
  351. # Description:
  352. #   Handle incoming SOAP requests.
  353. #   We extract the name of the SOAP method and the arguments and search for
  354. #   the implementation in the specified namespace. This is then evaluated
  355. #   and the result is wrapped up and returned or a SOAP Fault is generated.
  356. # Parameters:
  357. #   doc - a DOM tree constructed from the input request XML data.
  358. #
  359. proc SOAP::CGI::soap_call {doc {interp {}}} {
  360.     variable methodName
  361.     set headers {}
  362.     if {[catch {
  363.  
  364.     # Check SOAP version by examining the namespace of the Envelope elt.
  365.     set envnode [selectNode $doc "/Envelope"]
  366.     if {$envnode != {}} {
  367.         #set envns [dom::node cget $envnode -namespaceURI]
  368.         set envns [namespaceURI $envnode]
  369.         if {$envns != "" && \
  370.             ! [string match $envns \
  371.             "http://schemas.xmlsoap.org/soap/envelope/"]} {
  372.         error "The SOAP Envelope namespace does not match the\
  373.             SOAP version 1.1 namespace." {} VersionMismatch
  374.         }
  375.     }
  376.  
  377.     # Check for Header elements
  378.     if {[set headerNode [selectNode $doc "/Envelope/Header"]] != {}} {
  379.         set headers [soap_header $doc 0]
  380.         dtrace "headers: $headers"
  381.     }
  382.  
  383.     # Get the method name from the XML request.
  384.     set methodNode [selectNode $doc "/Envelope/Body/*"]
  385.     set methodName [nodeName $methodNode]
  386.  
  387.     # Get the XML namespace for this method.
  388.     set methodNamespace [namespaceURI $methodNode]
  389.     dtrace "methodinfo: ${methodNamespace}::${methodName}"
  390.  
  391.     # Extract the parameters.
  392.     set argNodes [selectNode $doc "/Envelope/Body/*/*"]
  393.     set argValues {}
  394.     foreach node $argNodes {
  395.         lappend argValues [decomposeSoap $node]
  396.     }
  397.  
  398.     # Check for a permitted methodname. This is defined by being in the
  399.     # SOAP::export list for the given namespace. We must do this to prevent
  400.     # clients arbitrarily calling tcl commands like 'eval' or 'error'
  401.     #
  402.         if {[catch {
  403.         interp eval $interp \
  404.             set ${methodNamespace}::__soap_exports($methodName)
  405.     } fqdn]} {
  406.         dtrace "method not found: $fqdn"
  407.         error "Invalid SOAP request:\
  408.             method \"${methodNamespace}::${methodName}\" not found" \
  409.         {} "Client"
  410.     }
  411.  
  412.     # evaluate the method
  413.     set msg [interp eval $interp $fqdn $argValues]
  414.  
  415.     # check for mustUnderstand headers that were not understood.
  416.     # This will raise an error for any such header elements.
  417.     if {$headerNode != {}} {
  418.         soap_header $doc 1
  419.     }
  420.  
  421.     # generate a reply packet
  422.     set reply [SOAP::reply \
  423.         [dom::DOMImplementation create] \
  424.         $methodNamespace "${methodName}Response" $msg]
  425.     set xml [dom::DOMImplementation serialize $reply]
  426.     regsub "<!DOCTYPE\[^>\]+>\n" $xml {} xml
  427.     catch {dom::DOMImplementation destroy $reply}
  428.     catch {dom::DOMImplementation destroy $doc}
  429.     
  430.     } msg]} {
  431.     # Handle errors the SOAP way.
  432.     #
  433.     set detail [list "errorCode" $::errorCode "stackTrace" $::errorInfo]
  434.     set code [lindex $detail 1]
  435.     switch {$code} {
  436.         "VersionMismatch" {
  437.         set code "SOAP-ENV:VersionMismatch"
  438.         }
  439.         "MustUnderstand" {
  440.         set code "SOAP-ENV:MustUnderstand"
  441.         }
  442.         "Client" {
  443.         set code "SOAP-ENV:Client"
  444.         }
  445.         "Server" {
  446.         set code "SOAP-ENV:Server"
  447.         }
  448.     }
  449.     set xml [SOAP::fault $code "$msg" $detail]
  450.     error $xml {} SOAP
  451.     }
  452.  
  453.     # publish the answer
  454.     return $xml
  455. }
  456.  
  457. # -------------------------------------------------------------------------
  458.  
  459. # Description:
  460. #   Prepare the interpreter for XML-RPC method invocation. We try to identify
  461. #   a Tcl file to source for the implementation of the method by using the 
  462. #   XML-RPC class name (the bit before the dot) and looking it up in the
  463. #   xmlrpcmap file. This file also tells us if we should use a safe 
  464. #   interpreter for this method.
  465. #
  466. proc SOAP::CGI::xmlrpc_invocation {doc} {
  467.     global env
  468.     variable xmlrpcdir
  469.  
  470.     array set impl {filename {} interp {}}
  471.  
  472.     # Identify the classname part of the methodname
  473.     set methodNode [selectNode $doc "/methodCall/methodName"]
  474.     set methodName [getElementValue $methodNode]
  475.     set className {}
  476.     if {[regexp {.*\.} $methodName className]} {
  477.     set className [string trim $className .]
  478.     }
  479.     set files {}
  480.     if {$className != {}} {
  481.     array set impl [xmlrpc_implementation $className]
  482.     set files $impl(filename)
  483.     }
  484.     if {$files == {}} {
  485.     set files [glob $xmlrpcdir/*]
  486.     }
  487.     # Do we want to use a safe interpreter?
  488.     if {$impl(interp) != {}} {
  489.     createInterp $impl(interp) $xmlrpcdir
  490.     }
  491.     dtrace "Interp: '$impl(interp)' - Files required: $files"
  492.  
  493.     # Source the XML-RPC implementation files at global level.
  494.     foreach file $files {
  495.     if {[file isfile $file] && [file readable $file]} {
  496.         itrace "debug: sourcing $file"
  497.         if {[catch {
  498.         interp eval $impl(interp)\
  499.             namespace eval :: \
  500.             "source [list $file]"
  501.         } msg]} {
  502.         itrace "warning: failed to source \"$file\""
  503.         dtrace "failed to source \"$file\": $msg"
  504.         }
  505.     }
  506.     }
  507.     set result [xmlrpc_call $doc $impl(interp)]
  508.     if {$impl(interp) != {}} {
  509.     safe::interpDelete $impl(interp)
  510.     }
  511.     return $result
  512. }
  513.  
  514. # -------------------------------------------------------------------------
  515.  
  516. # Description:
  517. #   Load in the SOAP method implementation file on the basis of the
  518. #   SOAPAction header. We use this header plus a map file to decide
  519. #   what file to source, or if we should source all the files in the
  520. #   soapdir directory. The map also provides for evaluating this method in
  521. #   a safe slave interpreter for extra security if needed.
  522. #   See the cgi-bin/soapmap.dat file for more details.
  523. #
  524. proc SOAP::CGI::soap_invocation {doc} {
  525.     global env
  526.     variable soapdir
  527.  
  528.     # Obtain the SOAPAction header and strip the quotes.
  529.     set SOAPAction {}
  530.     if {[info exists env(HTTP_SOAPACTION)]} {
  531.     set SOAPAction $env(HTTP_SOAPACTION)
  532.     }
  533.     set SOAPAction [string trim $SOAPAction "\""]
  534.     itrace "SOAPAction set to \"$SOAPAction\""
  535.     dtrace "SOAPAction set to \"$SOAPAction\""
  536.     
  537.     array set impl {filename {} interp {}}
  538.     
  539.     # Use the SOAPAction HTTP header to identify the files to source or
  540.     # if it's null, source the lot.
  541.     if {$SOAPAction == {} } {
  542.     set files [glob [file join $soapdir *]] 
  543.     } else {
  544.     array set impl [soap_implementation $SOAPAction]
  545.     set files $impl(filename)
  546.     if {$files == {}} {
  547.         set files [glob [file join $soapdir *]]
  548.     }
  549.     itrace "interp: $impl(interp): files: $files"
  550.     
  551.     # Do we want to use a safe interpreter?
  552.     if {$impl(interp) != {}} {
  553.         createInterp $impl(interp) $soapdir
  554.     }
  555.     }
  556.     dtrace "Interp: '$impl(interp)' - Files required: $files"
  557.     
  558.     foreach file $files {
  559.     if {[file isfile $file] && [file readable $file]} {
  560.         itrace "debug: sourcing \"$file\""
  561.         if {[catch {
  562.         interp eval $impl(interp) \
  563.             namespace eval :: \
  564.             "source [list $file]"
  565.         } msg]} {
  566.         itrace "warning: $msg"
  567.         dtrace "Failed to source \"$file\": $msg"
  568.         }
  569.     }
  570.     }
  571.     
  572.     set result [soap_call $doc $impl(interp)]
  573.     if {$impl(interp) != {}} {
  574.     safe::interpDelete $impl(interp)
  575.     }
  576.     return $result
  577. }
  578.  
  579. # -------------------------------------------------------------------------
  580.  
  581. # Description:
  582. #    Examine the incoming data and decide which protocol handler to call.
  583. #    Everything is evaluated in a large catch. If any errors are thrown we
  584. #    will wrap them up in a suitable reply. At this stage we return
  585. #    HTML for errors.
  586. # Parameters:
  587. #    xml - for testing purposes we can source this file and provide XML
  588. #          as this parameter. Normally this will not be used.
  589. #
  590. proc SOAP::CGI::main {{xml {}} {debug 0}} {
  591.     catch {package require tcllib} ;# re-eval the pkgIndex
  592.     package require ncgi
  593.     global env
  594.     variable soapdir
  595.     variable xmlrpcdir
  596.     variable methodName
  597.     variable debugging $debug
  598.     variable debuginfo {}
  599.     variable interactive 1
  600.  
  601.     if { [catch {
  602.     
  603.     # Get the POSTed XML data and parse into a DOM tree.
  604.     if {$xml == {}} {
  605.         set xml [ncgi::query]        
  606.         set interactive 0      ;# false if this is a CGI request
  607.  
  608.         # Debugging can be set by the HTTP header "SOAPDebug: 1"
  609.         if {[info exists env(HTTP_SOAPDEBUG)]} {
  610.         set debugging 1
  611.         }
  612.     }
  613.  
  614.     set doc [dom::DOMImplementation parse [do_encoding $xml]]
  615.     
  616.     # Identify the type of request - SOAP or XML-RPC, load the
  617.     # implementation and call.
  618.     if {[selectNode $doc "/Envelope"] != {}} {
  619.         set result [soap_invocation $doc]
  620.         log "SOAP" $methodName "ok"
  621.     } elseif {[selectNode $doc "/methodCall"] != {}} {
  622.         set result [xmlrpc_invocation $doc]
  623.         log "XMLRPC" $methodName "ok"
  624.     } else {
  625.         dom::DOMImplementation destroy $doc
  626.         error "invalid protocol: the XML data is neither SOAP not XML-RPC"
  627.     }
  628.  
  629.     # Send the answer to the caller
  630.     write $result text/xml
  631.  
  632.     } msg]} {
  633.     
  634.     # if the error was thrown from either of the protocol
  635.     # handlers then the error code is set to indicate that the
  636.     # message is a properly encoded SOAP/XMLRPC Fault.
  637.     # If its a CGI problem, then be a CGI error.
  638.     switch -- $::errorCode {
  639.         SOAP   {
  640.         write $msg text/xml "500 SOAP Error"
  641.         catch {
  642.             set doc [dom::DOMImplementation parse $msg]
  643.             set r [decomposeSoap [selectNode $doc /Envelope/Body/*]]
  644.         } msg
  645.         log "SOAP" [list $methodName $msg] "error" 
  646.         }
  647.         XMLRPC {
  648.         write $msg text/xml "500 XML-RPC Error"
  649.         catch {
  650.             set doc [dom::DOMImplementation parse $msg]
  651.             set r [getElementNamedValues [selectNode $doc \
  652.                 /methodResponse/*]]
  653.         } msg
  654.         log "XMLRPC" [list $methodName $msg] "error" 
  655.         }
  656.         default {
  657.         variable rcsid
  658.  
  659.         set html "<!doctype HTML public \"-//W3O//DTD W3 HTML 2.0//EN\">\n"
  660.         append html "<html>\n<head>\n<title>CGI Error</title>\n</head>\n<body>"
  661.         append html "<h1>CGI Error</h1>\n<p>$msg</p>\n"
  662.         append html "<br />\n<pre>$::errorInfo</pre>\n"
  663.         append html "<p><font size=\"-1\">$rcsid</font></p>"
  664.         append html "</body>\n</html>"
  665.         write $html text/html "500 Internal Server Error"
  666.         
  667.         log "unknown" [string range $xml 0 60] "error"
  668.         }
  669.     }
  670.     }
  671. }
  672.  
  673. # -------------------------------------------------------------------------
  674. #
  675. # Local variables:
  676. # mode: tcl
  677. # End:
  678.