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.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  41.8 KB  |  1,204 lines
  1. # SOAP.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
  2. #
  3. # Provide Tcl access to SOAP 1.1 methods.
  4. #
  5. # See http://tclsoap.sourceforge.net/ or doc/TclSOAP.html for usage details.
  6. #
  7. # -------------------------------------------------------------------------
  8. # This software is distributed in the hope that it will be useful, but
  9. # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  10. # or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
  11. # for more details.
  12. # -------------------------------------------------------------------------
  13.  
  14. package provide SOAP 1.6
  15.  
  16. # -------------------------------------------------------------------------
  17.  
  18. package require http 2.0
  19. package require SOAP::Utils
  20. package require rpcvar
  21.  
  22. if {[catch {
  23.     package require tdom
  24.     package require SOAP::dom
  25.     puts "using tDOM and SOAP::dom"
  26. }]} {
  27.     if { [catch {package require dom 2.0} domVer]} {
  28.         if { [catch {package require dom 1.6} domVer]} {
  29.             error "require dom package greater than 1.6"
  30.         }
  31.         package require SOAP::xpath
  32.     }
  33. }
  34.  
  35.  
  36. namespace eval SOAP {
  37.     variable version 1.6
  38.     variable domVersion $domVer
  39.     variable rcs_version { $Id: SOAP.tcl,v 1.36 2001/10/11 22:38:38 patthoyts Exp $ }
  40.  
  41.     namespace export create cget dump configure proxyconfig export
  42.     catch {namespace import -force Utils::*} ;# catch to allow pkg_mkIndex.
  43.     catch {namespace import -force [uplevel {namespace current}]::rpcvar::*}
  44. }
  45.  
  46. unset domVer
  47.  
  48. # -------------------------------------------------------------------------
  49.  
  50. # Description:
  51. #   Called from SOAP package methods, shift up to the callers level and
  52. #   get the fully namespace qualified name for the given proc / var
  53. # Parameters:
  54. #   name - the name of a Tcl entity, or list of command and arguments
  55. # Result:
  56. #   Fully qualified namespace path for the named entity. If the name 
  57. #   parameter is a list the the first element is namespace qualified
  58. #   and the remainder of the list is unchanged.
  59. #
  60. proc SOAP::qualifyNamespace {name} {
  61.     if {$name != {}} {
  62.         set name [lreplace $name 0 0 \
  63.                 [uplevel 2 namespace origin [lindex $name 0]]]
  64.     }
  65.     return $name
  66. }
  67.  
  68. # -------------------------------------------------------------------------
  69.  
  70. proc SOAP::methodVarName {methodName} {
  71.     set name [uplevel 2 namespace origin $methodName]
  72.     regsub -all {::+} $name {_} name
  73.     return [namespace current]::$name
  74. }
  75.  
  76. # -------------------------------------------------------------------------
  77.  
  78. # Retrieve configuration variables
  79.  
  80. proc SOAP::cget { args } {
  81.  
  82.     if { [llength $args] != 2 } {
  83.         error "wrong # args: should be \"cget methodName optionName\""
  84.     }
  85.  
  86.     set methodName [lindex $args 0]
  87.     set optionName [lindex $args 1]
  88.     set configVarName [methodVarName $methodName]
  89.  
  90.     if {[catch {set [subst $configVarName]([string trimleft $optionName "-"])} result]} {
  91.         # kenstir@synchonicity.com: Fixed typo.
  92.         error "unknown option \"$optionName\""
  93.     }
  94.     return $result
  95. }
  96.  
  97. # -------------------------------------------------------------------------
  98.  
  99. # Dump the HTTP data from the last request performed.
  100. # Options to dump the HTTP meta data the reply data or the XML of the
  101. # SOAP request that was posted to the server
  102. #
  103. proc SOAP::dump {args} {
  104.     if {[llength $args] == 1} {
  105.         set type -reply
  106.         set methodName [lindex $args 0]
  107.     } elseif { [llength $args] == 2 } {
  108.         set type [lindex $args 0]
  109.         set methodName [lindex $args 1]
  110.     } else {
  111.         error "wrong # args: should be \"dump ?option? methodName\""
  112.     }
  113.  
  114.     # Check that methodName exists and has a http variable.
  115.     if { [catch {cget $methodName http} token] } {
  116.         error "invalid method name: \"$methodName\" is not a SOAP command"
  117.     }
  118.     if { $token == {} } {
  119.         error "no information HTTP information available for SOAP method \"$methodName\""
  120.     }
  121.  
  122.     set result {}
  123.     switch -glob -- $type {
  124.         -meta   {set result [lindex [array get $token meta] 1]}
  125.         -qu*    -
  126.         -req*   {set result [lindex [array get $token -query] 1]}
  127.         -rep*   {set result [::http::data $token]}
  128.         default {
  129.             error "unrecognised option: must be one of \
  130.                     \"-meta\", \"-request\" or \"-reply\""
  131.         }
  132.     }
  133.  
  134.     return $result
  135. }
  136.  
  137. # -------------------------------------------------------------------------
  138.  
  139. # Description:
  140. #   Configure or display a SOAP method options.
  141. # Parameters:
  142. #   procName - the SOAP method Tcl procedure name
  143. #   args     - list of option name / option pairs
  144. # Result:
  145. #   Sets up a configuration array for the SOAP method.
  146.  
  147. proc SOAP::configure { procName args } {
  148.     # The list of valid options, used in the error messsage
  149.     set options { uri proxy params name transport action \
  150.                   wrapProc replyProc parseProc postProc \
  151.                   command errorCommand schemas version \
  152.                   encoding }
  153.  
  154.     if { $procName == "-transport" } {
  155.         return [eval "transport_configure $args"]
  156.     }
  157.  
  158.     # construct the name of the options array from the procName.
  159.     set procVarName "[uplevel namespace current]::$procName"
  160.     regsub -all {::+} $procVarName {_} procVarName
  161.     set procVarName [namespace current]::$procVarName
  162.  
  163.     # Check that the named method has actually been defined
  164.     if {! [array exists $procVarName]} {
  165.         error "invalid command: \"$procName\" not defined"
  166.     }
  167.  
  168.     # if no args - print out the current settings.
  169.     if { [llength $args] == 0 } {
  170.         set r {}
  171.         foreach {opt value} [array get $procVarName] {
  172.             lappend r -$opt $value
  173.         }
  174.         return $r
  175.     }
  176.  
  177.     foreach {opt value} $args {
  178.         switch -- $opt {
  179.             -uri       { set [subst $procVarName](uri) $value }
  180.             -proxy     { set [subst $procVarName](proxy) $value }
  181.             -params    { set [subst $procVarName](params) $value }
  182.             -transport { set [subst $procVarName](transport) $value }
  183.             -name      { set [subst $procVarName](name) $value }
  184.             -action    { set [subst $procVarName](action) $value }
  185.             -schemas   { set [subst $procVarName](schemas) $value }
  186.             -version   { set [subst $procVarName](version) $value }
  187.             -encoding  { set [subst $procVarName](encoding) $value }
  188.             -wrapProc  { set [subst $procVarName](wrapProc) \
  189.                     [qualifyNamespace $value] }
  190.             -replyProc { set [subst $procVarName](replyProc) \
  191.                     [qualifyNamespace $value] }
  192.             -parseProc { set [subst $procVarName](parseProc) \
  193.                     [qualifyNamespace $value] }
  194.             -postProc  { set [subst $procVarName](postProc) \
  195.                     [qualifyNamespace $value] }
  196.             -command   { set [subst $procVarName](command) \
  197.                     [qualifyNamespace $value] }
  198.             -errorCommand { set [subst $procVarName](errorCommand) \
  199.                     [qualifyNamespace $value] }
  200.             default {
  201.                 error "unknown option \"$opt\": must be one of ${options}"
  202.             }
  203.         }
  204.     }
  205.  
  206.     if { [set [subst $procVarName](name)] == {} } { 
  207.         set [subst $procVarName](name) $procName
  208.     }
  209.  
  210.     if { [set [subst $procVarName](transport)] == {} } {
  211.         set [subst $procVarName](transport) \
  212.                 [namespace current]::Transport::http::xfer
  213.     } 
  214.     
  215.     # The default version is SOAP 1.1
  216.     set soapver [set [subst $procVarName](version)]
  217.     if { $soapver == {} } {
  218.         set soapver SOAP1.1
  219.     }
  220.     # Canonicalize the SOAP version URI
  221.     switch -glob -- $soapver {
  222.         SOAP1.1 - 1.1 { set soapver "http://schemas.xmlsoap.org/soap/envelope/" }
  223.         SOAP1.2 - 1.2 { set soapver "http://www.w3.org/2001/06/soap-envelope" }
  224.     }
  225.     set [subst $procVarName](version) $soapver
  226.  
  227.     # Default SOAP encoding is SOAP 1.1
  228.     set soapenc [set [subst $procVarName](encoding)]
  229.     if { $soapenc == {} } {
  230.         set soapenc SOAP1.1
  231.     }
  232.     switch -glob -- $soapenc {
  233.         SOAP1.1 - 1.1 { set soapenc "http://schemas.xmlsoap.org/soap/encoding/" }
  234.         SOAP1.2 - 1.2 { set soapenc "http://www.w3.org/2001/06/soap-encoding" }
  235.     }
  236.     set [subst $procVarName](encoding) $soapenc
  237.  
  238.     # Select the default parser unless one is specified
  239.     if { [set [subst $procVarName](parseProc)] == {} } {
  240.         set [subst $procVarName](parseProc) \
  241.                 [namespace current]::parse_soap_response
  242.     } 
  243.  
  244.     # If no request wrapper is set, use the default SOAP wrap proc.
  245.     if { [set [subst $procVarName](wrapProc)] == {} } {
  246.         set [subst $procVarName](wrapProc) \
  247.                 [namespace current]::soap_request
  248.     }
  249.  
  250.     # Create the Tcl procedure that maps to this RPC method.
  251.     uplevel 1 "proc $procName { args } {eval [namespace current]::invoke $procVarName \$args}"
  252.  
  253.     # return the fully qualified command name created.
  254.     return [uplevel 1 "namespace which $procName"]
  255. }
  256.  
  257. # -------------------------------------------------------------------------
  258.  
  259. proc SOAP::create { args } {
  260.     if { [llength $args] < 1 } {
  261.         error "wrong # args: should be \"create procName ?options?\""
  262.     } else {
  263.         set procName [lindex $args 0]
  264.         set args [lreplace $args 0 0]
  265.     }
  266.  
  267.     set ns "[uplevel namespace current]::$procName"
  268.     regsub -all {::+} $ns {_} varName
  269.     set varName [namespace current]::$varName
  270.     array set $varName {}
  271.     array set $varName {uri       {}} ;# the XML namespace URI for this method 
  272.     array set $varName {proxy     {}} ;# URL for the location of a provider
  273.     array set $varName {params    {}} ;# name/type pairs for the parameters
  274.     array set $varName {transport {}} ;# transport procedure for this method
  275.     array set $varName {name      {}} ;# SOAP method name
  276.     array set $varName {action    {}} ;# Contents of the SOAPAction header
  277.     array set $varName {http      {}} ;# the http data variable (if used)
  278.     array set $varName {wrapProc  {}} ;# encode request into XML for sending
  279.     array set $varName {replyProc {}} ;# post process the raw XML result
  280.     array set $varName {parseProc {}} ;# parse raw XML and extract the values
  281.     array set $varName {postProc  {}} ;# post process the parsed result
  282.     array set $varName {command   {}} ;# asynchronous reply handler
  283.     array set $varName {errorCommand {}} ;# asynchronous error handler
  284.     array set $varName {headers   {}} ;# SOAP Header information of last call
  285.     array set $varName {schemas   {}} ;# List of SOAP Schemas in force
  286.     array set $varName {version   {}} ;# SOAP Version in force (URI)
  287.     array set $varName {encoding  {}} ;# SOAP Encoding (URI)
  288.  
  289.     # call configure from the callers level so it can get the namespace.
  290.     return [uplevel 1 "[namespace current]::configure $procName $args"]
  291. }
  292.  
  293. # -------------------------------------------------------------------------
  294.  
  295. proc SOAP::export {args} {
  296.     foreach item $args {
  297.         uplevel "set \[namespace current\]::__soap_exports($item)\
  298.                 \[namespace code $item\]"
  299.     }
  300.     return
  301. }
  302.  
  303. # -------------------------------------------------------------------------
  304.  
  305. # Description:
  306. #   Make a SOAP method call using the configured transport.
  307. # Parameters:
  308. #   procName  - the SOAP method configuration variable path
  309. #   args      - the parameter list for the SOAP method call
  310. # Returns:
  311. #   Returns the parsed and processed result of the method call
  312. #
  313. proc SOAP::invoke { procVarName args } {
  314.     set procName [lindex [split $procVarName {_}] end]
  315.     if {![array exists $procVarName]} {
  316.         error "invalid command: \"$procName\" not defined"
  317.     }
  318.  
  319.     # Get the URL
  320.     set url [set [subst $procVarName](proxy)]
  321.  
  322.     # Get the XML data containing our request by calling the -wrapProc 
  323.     # procedure
  324.     set req [eval "[set [subst $procVarName](wrapProc)] $procVarName $args"]
  325.  
  326.     # Send the SOAP packet (req) using the configured transport procedure
  327.     set transport [set [subst $procVarName](transport)]
  328.     set reply [$transport $procVarName $url $req]
  329.  
  330.     # Check for an async command handler. If async then return now,
  331.     # otherwise call the invoke second stage immediately.
  332.     if { [set [subst $procVarName](command)] != {} } {
  333.         return $reply
  334.     }
  335.     return [invoke2 $procVarName $reply]
  336. }
  337.  
  338. # -------------------------------------------------------------------------
  339.  
  340. # Description:
  341. #   The second stage of the method invocation deals with unwrapping the
  342. #   reply packet that has been received from the remote service.
  343. # Parameters:
  344. #   procVarName - the SOAP method configuration variable path
  345. #   reply       - the raw data returned from the remote service
  346. # Notes:
  347. #   This has been separated from `invoke' to support asynchronous
  348. #   transports. It calls the various unwrapping hooks in turn.
  349. #
  350. proc SOAP::invoke2 {procVarName reply} {
  351.     set ::lastReply $reply
  352.  
  353.     set procName [lindex [split $procVarName {_}] end]
  354.  
  355.     # Post-process the raw XML using -replyProc
  356.     set replyProc [set [subst $procVarName](replyProc)]
  357.     if { $replyProc != {} } {
  358.         set reply [$replyProc $procVarName $reply]
  359.     }
  360.  
  361.     # Call the relevant parser to extract the returned values
  362.     set parseProc [set [subst $procVarName](parseProc)]
  363.     if { $parseProc == {} } {
  364.         set parseProc parse_soap_response
  365.     }
  366.     set r [$parseProc $procVarName $reply]
  367.  
  368.     # Post process the parsed reply using -postProc
  369.     set postProc [set [subst $procVarName](postProc)]
  370.     if { $postProc != {} } {
  371.         set r [$postProc $procVarName $r]
  372.     }
  373.  
  374.     return $r
  375. }
  376.  
  377. # -------------------------------------------------------------------------
  378.  
  379. # Description:
  380. #   Handle a proxy server.
  381. # Notes:
  382. #   Needs expansion to use a list of non-proxied sites or a list of
  383. #   {regexp proxy} or something.
  384. #   The proxy variable in this namespace is set up by 
  385. #   configure -transport http.
  386. #
  387. namespace eval SOAP::Transport::http {
  388.     variable options
  389.  
  390.     proc filter {host} {
  391.         variable options
  392.         if { [string match "localhost*" $host] \
  393.                 || [string match "127.*" $host] } {
  394.             return {}
  395.         }
  396.         return [lrange [split $options(proxy) {:}] 0 1]
  397.     }
  398.  
  399.     # Provide missing code for http < 2.3
  400.     if {[info proc ::http::ncode] == {}} {
  401.         namespace eval ::http {
  402.             proc ncode {token} {
  403.                 return [lindex [split [code $token]] 1]
  404.             }
  405.         }
  406.     }
  407. }
  408.  
  409. # -------------------------------------------------------------------------
  410.  
  411. # Description:
  412. #   Perform a remote procedure call using HTTP as the transport protocol.
  413. #   This uses the Tcl http package to do the work. If the SOAP method has
  414. #   the -command option set to something then the call is made 
  415. #   asynchronously and the result data passed to the users callback
  416. #   procedure.
  417. #   If you have an HTTP proxy to deal with then you should set up the 
  418. #   SOAP::Transport::http::filter procedure and proxy variable to suit.
  419. #   This can be done using SOAP::proxyconfig.
  420. # Parameters:
  421. #   procVarName - 
  422. #   url         -
  423. #   request     -
  424. # Result:
  425. #   The request data is POSTed to the SOAP provider via HTTP using any
  426. #   configured proxy host. If the HTTP returns an error code then an error
  427. #   is raised otherwise the reply data is returned. If the method has
  428. #   been configured to be asynchronous then the async handler is called
  429. #   once the http request completes.
  430. #
  431. proc SOAP::Transport::http::xfer { procVarName url request } {
  432.     variable options
  433.  
  434.     # Get the SOAP package version
  435.     set version [set [namespace parent [namespace parent]]::version]
  436.  
  437.     # setup the HTTP POST request
  438.     ::http::config -useragent "TclSOAP/$version ($::tcl_platform(os))"
  439.  
  440.     # If a proxy was configured, use it.
  441.     if { [info exists options(proxy)] && $options(proxy) != {} } {
  442.         ::http::config -proxyfilter [namespace origin filter]
  443.     }
  444.  
  445.     # Check for an HTTP progress callback.
  446.     set local_progress {}
  447.     if { [info exists options(progress)] && $options(progress) != {} } {
  448.         set local_progress "-progress [list $options(progress)]"
  449.     }
  450.     
  451.     # There may be http headers configured. eg: for proxy servers
  452.     # eg: SOAP::configure -transport http -headers 
  453.     #    [list "Proxy-Authorization" [basic_authorization]]
  454.     set local_headers {}
  455.     if {[info exists options(headers)]} {
  456.         set local_headers $options(headers)
  457.     }
  458.  
  459.     # Add mandatory SOAPAction header (SOAP 1.1). This may be empty otherwise
  460.     # must be in quotes.
  461.     set action [set [subst $procVarName](action)]
  462.     if { $action != {} } { 
  463.         set action [string trim $action "\""]
  464.         set action "\"$action\""
  465.         lappend local_headers "SOAPAction" $action
  466.     }
  467.  
  468.     # cleanup the last http request
  469.     if { [set [subst $procVarName](http)] != {} } {
  470.         catch { eval "::http::cleanup [set [subst $procVarName](http)]" }
  471.     }
  472.  
  473.     # Check for an asynchronous handler and perform the transfer.
  474.     # If async - return immediately.
  475.     set command {}
  476.     if {[set [subst $procVarName](command)] != {}} {
  477.         set command "-command {[namespace current]::asynchronous $procVarName}"
  478.     }
  479.  
  480.     set token [eval ::http::geturl [list $url] \
  481.             -headers [list $local_headers] \
  482.             -type text/xml -query [list $request] \
  483.             $local_progress $command]
  484.     set [subst $procVarName](http) $token
  485.     if { $command != {}} { return {} }
  486.     
  487.  
  488.     # store the http structure reference for possible access later.
  489.     set [subst $procVarName](http) $token
  490.  
  491.     # Some other sort of error ...
  492.     if {[::http::status $token] != "ok"} {
  493.          error "SOAP transport error: \"[::http::code $token]\""
  494.     }
  495.  
  496.     return [::http::data $token]
  497. }
  498.  
  499. # -------------------------------------------------------------------------
  500.  
  501. # Description:
  502. #    Asynchronous http handler command.
  503. proc SOAP::Transport::http::asynchronous {procVarName token} {
  504.     if {[catch {asynchronous2 $procVarName $token} msg]} {
  505.         if {[set [subst $procVarName](errorCommand)] != {}} {
  506.             set errorCommand [set [subst $procVarName](errorCommand)]
  507.             if {[catch {eval $errorCommand [list $msg]} result]} {
  508.                 bgerror $result
  509.             }
  510.         } else {
  511.             bgerror $msg
  512.         }
  513.     }
  514.     return $msg
  515. }
  516.  
  517. proc SOAP::Transport::http::asynchronous2 {procVarName token} {
  518.     set procName [lindex [split $procVarName {_}] end]
  519.  
  520.     # Some other sort of error ...
  521.     if {[::http::status $token] != "ok"} {
  522.          error "SOAP transport error: \"[::http::code $token]\""
  523.     }
  524.  
  525.     set reply [::http::data $token]
  526.  
  527.     # Call the second part of invoke to unwrap the packet data.
  528.     set reply [SOAP::invoke2 $procVarName $reply]
  529.  
  530.     # Call the users handler.
  531.     set command [set [subst $procVarName](command)]
  532.     return [eval $command [list $reply]]
  533. }
  534.  
  535. # -------------------------------------------------------------------------
  536.  
  537. # Description:
  538. #   A dummy SOAP transport procedure to examine the SOAP requests generated.
  539. # Parameters:
  540. #   procVarName  - SOAP method name configuration variable
  541. #   url          - URL of the remote server method implementation
  542. #   soap         - the XML payload for this SOAP method call
  543. #
  544. namespace eval SOAP::Transport::print {
  545.     proc print { procVarName url soap } {
  546.         puts "$soap"
  547.     }
  548. }
  549.  
  550. namespace eval SOAP::Transport::reflect {
  551.     proc reflect {procVarName url soap} {
  552.         return $soap
  553.     }
  554. }
  555.  
  556. # -------------------------------------------------------------------------
  557.  
  558. # Description:
  559. #   Helper procedure called from configure used to setup the SOAP transport
  560. #   options. Calling `invoke' for a method will call the configured 
  561. #   transport procedure.
  562. # Parameters:
  563. #   transport - the name of the transport mechanism (smtp, http, etc)
  564. #   args      - list of options for the named transport mechanism
  565. #
  566. proc SOAP::transport_configure { transport args } {
  567.     switch -- $transport {
  568.         http {
  569.             # If no args then print out the current settings
  570.             if { $args == {} } {
  571.                 set r {}
  572.                 foreach {opt value} [array get Transport::http::options] {
  573.                     lappend r "-$opt" $value
  574.                 }
  575.                 return $r
  576.             }
  577.             
  578.             foreach {opt value} $args {
  579.                 switch -- $opt {
  580.                     -proxy   {
  581.                         set Transport::http::options(proxy) $value
  582.                     }
  583.                     -headers {
  584.                         if {[catch {
  585.                             set h $Transport::http::options(headers)}]
  586.                         } {
  587.                             set h {}
  588.                         }
  589.                         set Transport::http::options(headers) \
  590.                                 [concat $h $value]
  591.                     }
  592.                     -progress {
  593.                         set Transport::http::options(progress) $value
  594.                     }
  595.                     default {
  596.                         error [concat "invalid option \"$opt\":" \
  597.                                 "must be \"-proxy host:port\" "\
  598.                                 "or \"-headers list\""]
  599.                     }
  600.                 }
  601.             }
  602.         }
  603.         print {
  604.             return "no configuration required"
  605.         }
  606.         default {
  607.             error "SOAP transport \"$transport\" is undefined: \
  608.                     must be one of \"http\" or \"print\"."
  609.         }
  610.     }
  611. }
  612.  
  613. # -------------------------------------------------------------------------
  614.  
  615. # Description:
  616. #   Setup SOAP HTTP transport for an authenticating proxy HTTP server.
  617. #   At present the SOAP package only supports Basic authentication and this
  618. #   dialog is used to configure the proxy information.
  619. # Parameters:
  620. #   none
  621.  
  622. proc SOAP::proxyconfig {} {
  623.     package require Tk
  624.     if { [catch {package require base64}] } {
  625.         if { [catch {package require Trf}] } {
  626.             error "proxyconfig requires either tcllib or Trf packages."
  627.         } else {
  628.             set local64 "base64 -mode enc"
  629.         }
  630.     } else {
  631.         set local64 "base64::encode"
  632.     }
  633.  
  634.     toplevel .tx
  635.     wm title .tx "Proxy Configuration"
  636.     set m [message .tx.m1 -relief groove -justify left -width 6c -aspect 200 \
  637.             -text "Enter details of your proxy server (if any) and your username and password if it is needed by the proxy."]
  638.     set f1 [frame .tx.f1]
  639.     set f2 [frame .tx.f2]
  640.     button $f2.b -text "OK" -command {destroy .tx}
  641.     pack $f2.b -side right
  642.     label $f1.l1 -text "Proxy (host:port)"
  643.     label $f1.l2 -text "Username"
  644.     label $f1.l3 -text "Password"
  645.     entry $f1.e1 -textvariable SOAP::conf_proxy
  646.     entry $f1.e2 -textvariable SOAP::conf_userid
  647.     entry $f1.e3 -textvariable SOAP::conf_passwd -show {*}
  648.     grid $f1.l1 -column 0 -row 0 -sticky e
  649.     grid $f1.l2 -column 0 -row 1 -sticky e
  650.     grid $f1.l3 -column 0 -row 2 -sticky e
  651.     grid $f1.e1 -column 1 -row 0 -sticky news
  652.     grid $f1.e2 -column 1 -row 1 -sticky news
  653.     grid $f1.e3 -column 1 -row 2 -sticky news
  654.     grid columnconfigure $f1 1 -weight 1
  655.     pack $f2 -side bottom -fill x
  656.     pack $m  -side top -fill x -expand 1
  657.     pack $f1 -side top -anchor n -fill both -expand 1
  658.     tkwait window .tx
  659.     SOAP::configure -transport http -proxy $SOAP::conf_proxy
  660.     if { [info exists SOAP::conf_userid] } {
  661.         SOAP::configure -transport http \
  662.             -headers [list "Proxy-Authorization" \
  663.             "Basic [lindex [$local64 ${SOAP::conf_userid}:${SOAP::conf_passwd}] 0]" ]
  664.     }
  665.     unset SOAP::conf_passwd
  666. }
  667.  
  668. # -------------------------------------------------------------------------
  669.  
  670. # Description:
  671. #   Prepare a SOAP fault message
  672. # Parameters:
  673. #   faultcode   - the SOAP faultcode e.g: SOAP-ENV:Client
  674. #   faultstring - summary of the fault
  675. #   detail      - list of {detailName detailInfo}
  676. # Result:
  677. #   returns the XML text of the SOAP Fault packet.
  678. # 
  679. proc SOAP::fault {faultcode faultstring {detail {}}} {
  680.     set doc [dom::DOMImplementation create]
  681.     set bod [reply_envelope $doc]
  682.     set flt [dom::document createElement $bod "SOAP-ENV:Fault"]
  683.     set fcd [dom::document createElement $flt "faultcode"]
  684.     dom::document createTextNode $fcd $faultcode
  685.     set fst [dom::document createElement $flt "faultstring"]
  686.     dom::document createTextNode $fst $faultstring
  687.  
  688.     if { $detail != {} } {
  689.         set dtl0 [dom::document createElement $flt "detail"]
  690.         set dtl  [dom::document createElement $dtl0 "e:errorInfo"]
  691.         dom::element setAttribute $dtl "xmlns:e" "urn:TclSOAP-ErrorInfo"
  692.         
  693.         foreach {detailName detailInfo} $detail {
  694.             set err [dom::document createElement $dtl $detailName]
  695.             dom::document createTextNode $err $detailInfo
  696.         }
  697.     }
  698.     
  699.     # serialize the DOM document and return the XML text
  700.     regsub "<!DOCTYPE\[^>\]*>\n" [dom::DOMImplementation serialize $doc] {} r
  701.     dom::DOMImplementation destroy $doc
  702.     return $r
  703. }
  704.  
  705. # -------------------------------------------------------------------------
  706.  
  707. # Description:
  708. #   Generate the common portion of a SOAP replay packet
  709. # Parameters:
  710. #   doc   - the document element of a DOM document
  711. # Result:
  712. #   returns the body node
  713. #
  714. proc SOAP::reply_envelope { doc } {
  715.     set env [dom::document createElement $doc "SOAP-ENV:Envelope"]
  716.     dom::element setAttribute $env \
  717.             "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/"
  718.     dom::element setAttribute $env \
  719.             "xmlns:xsi"      "http://www.w3.org/1999/XMLSchema-instance"
  720.     dom::element setAttribute $env \
  721.             "xmlns:xsd"      "http://www.w3.org/1999/XMLSchema"
  722.     dom::element setAttribute $env \
  723.             "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
  724.     set bod [dom::document createElement $env "SOAP-ENV:Body"]
  725.     return $bod
  726. }
  727.  
  728. # -------------------------------------------------------------------------
  729.  
  730. # Description:
  731. #   Generate a SOAP reply packet. Uses 'rpcvar' variable type information to
  732. #   manage complex data structures and arrays.
  733. # Parameters:
  734. #   doc         empty DOM document element
  735. #   uri         URI of the SOAP method
  736. #   methodName  the SOAP method name
  737. #   result      the reply data
  738. # Result:
  739. #   returns the DOM document root
  740. #
  741. proc SOAP::reply { doc uri methodName result } {
  742.     set bod [reply_envelope $doc]
  743.     set cmd [dom::document createElement $bod "ns:$methodName"]
  744.     dom::element setAttribute $cmd "xmlns:ns" $uri
  745.     dom::element setAttribute $cmd \
  746.             "SOAP-ENV:encodingStyle" \
  747.             "http://schemas.xmlsoap.org/soap/encoding/"
  748.  
  749.     # insert the results into the DOM tree (unless it's a void result)
  750.     if {$result != {}} {
  751.         set retnode [dom::document createElement $cmd "return"]
  752.         SOAP::insert_value $retnode $result
  753.     }
  754.  
  755.     return $doc
  756. }
  757.  
  758. # -------------------------------------------------------------------------
  759.  
  760. # Description:
  761. #   Procedure to generate the XML data for a configured SOAP procedure.
  762. #   This is the default SOAP -wrapProc procedure
  763. # Parameters:
  764. #   procVarName - the path of the SOAP method configuration variable
  765. #   args        - the arguments for this SOAP method
  766. # Result:
  767. #   XML data containing the SOAP method call.
  768. #
  769. proc SOAP::soap_request {procVarName args} {
  770.  
  771.     set procName [lindex [split $procVarName {_}] end]
  772.     set params [set [subst $procVarName](params)]
  773.     set name [set [subst $procVarName](name)]
  774.     set uri [set [subst $procVarName](uri)]
  775.     set soapenv [set [subst $procVarName](version)]
  776.     set soapenc [set [subst $procVarName](encoding)]
  777.  
  778.     # Check for options (ie: -header)
  779.     array set opts {-headers {} -attributes {}}
  780.     while {[string match -* [lindex $args 0]]} {
  781.         switch -glob -- [lindex $args 0] {
  782.             -header* {
  783.                 set opts(-headers) [concat $opts(-headers) [lindex $args 1]]
  784.                 set args [lreplace $args 0 0]
  785.             }
  786.             -attr* {
  787.                 set opts(-attributes) [concat $opts(-attributes) [lindex $args 1]]
  788.                 set args [lreplace $args 0 0]
  789.             }
  790.             -- {
  791.                 set args [lreplace $args 0 0]
  792.                 break
  793.             }
  794.             default {
  795.                 # stop option processing at the first invalid option.
  796.                 break
  797.             }
  798.         }
  799.         set args [lreplace $args 0 0]
  800.     }
  801.  
  802.     # check for variable number of params and set the num required.
  803.     if {[lindex $params end] == "args"} {
  804.         set n_params [expr ( [llength $params] - 1 ) / 2]
  805.     } else {
  806.         set n_params [expr [llength $params] / 2]
  807.     }
  808.  
  809.     # check we have the correct number of parameters supplied.
  810.     if {[llength $args] < $n_params} {
  811.         set msg "wrong # args: should be \"$procName"
  812.         foreach { id type } $params {
  813.             append msg " " $id
  814.         }
  815.         append msg "\""
  816.         error $msg
  817.     }
  818.  
  819.     set doc [dom::DOMImplementation create]
  820.     set envx [dom::document createElement $doc "SOAP-ENV:Envelope"]
  821.  
  822.     dom::element setAttribute $envx "xmlns:SOAP-ENV" $soapenv
  823.     dom::element setAttribute $envx "xmlns:SOAP-ENC" $soapenc
  824.     dom::element setAttribute $envx "SOAP-ENV:encodingStyle" $soapenc
  825.  
  826.     # The set of namespaces depends upon the SOAP encoding as specified by
  827.     # the encoding option and the user specified set of relevant schemas.
  828.     foreach {nsname url} [rpcvar::default_schemas $soapenc] {
  829.         dom::element setAttribute $envx $nsname $url
  830.     }
  831.  
  832.     # Insert the Header elements (if any)
  833.     if {$opts(-headers) != {}} {
  834.         set headelt [dom::document createElement $envx "SOAP-ENV:Header"]
  835.         foreach {hname hvalue} $opts(-headers) {
  836.             set hnode [dom::document createElement $headelt $hname]
  837.             insert_value $hnode $hvalue
  838.         }
  839.     }
  840.  
  841.     # Insert the body element and atributes.
  842.     set bod [dom::document createElement $envx "SOAP-ENV:Body"]
  843.     if {$uri == ""} {
  844.         # don't use a namespace prefix if we don't have a namespace.
  845.         set cmd [dom::document createElement $bod "$name" ]
  846.     } else {
  847.         set cmd [dom::document createElement $bod "ns:$name" ]
  848.         dom::element setAttribute $cmd "xmlns:ns" $uri
  849.     }
  850.  
  851.     # Insert any method attributes
  852.     if {$opts(-attributes) != {}} {
  853.         foreach {atname atvalue} $opts(-attributes) {
  854.             dom::element setAttribute $cmd $atname $atvalue
  855.         }
  856.     }
  857.  
  858.     # insert the parameters.
  859.     set param_no 0
  860.     foreach {key type} $params {
  861.         set val [lindex $args $param_no]
  862.         set d_param [dom::document createElement $cmd $key]
  863.         insert_value $d_param [rpcvar $type $val]
  864.         incr param_no
  865.     }
  866.  
  867.     # We have to strip out the DOCTYPE element though. It would be better to
  868.     # remove the DOM node for this, but that didn't work.
  869.     set prereq [dom::DOMImplementation serialize $doc]
  870.     set req {}
  871.     dom::DOMImplementation destroy $doc              ;# clean up
  872.     regsub "<!DOCTYPE\[^>\]*>\r?\n?" $prereq {} req  ;# hack
  873.  
  874.     set req [encoding convertto utf-8 $req]          ;# make it UTF-8
  875.     return $req                                      ;# return the XML data
  876. }
  877.  
  878. # -------------------------------------------------------------------------
  879.  
  880. # Description:
  881. #   Procedure to generate the XML data for a configured XML-RPC procedure.
  882. # Parameters:
  883. #   procVarName - the name of the XML-RPC method variable
  884. #   args        - the arguments for this RPC method
  885. # Result:
  886. #   XML data containing the XML-RPC method call.
  887. #
  888. proc SOAP::xmlrpc_request {procVarName args} {
  889.  
  890.     set procName [lindex [split $procVarName {_}] end]
  891.     set params [set [subst $procVarName](params)]
  892.     set name   [set [subst $procVarName](name)]
  893.     
  894.     if { [llength $args] != [expr [llength $params] / 2]} {
  895.         set msg "wrong # args: should be \"$procName"
  896.         foreach { id type } $params {
  897.             append msg " " $id
  898.         }
  899.         append msg "\""
  900.         error $msg
  901.     }
  902.     
  903.     set doc [dom::DOMImplementation create]
  904.     set d_root [dom::document createElement $doc "methodCall"]
  905.     set d_meth [dom::document createElement $d_root "methodName"]
  906.     dom::document createTextNode $d_meth $name
  907.     
  908.     if { [llength $params] != 0 } {
  909.         set d_params [dom::document createElement $d_root "params"]
  910.     }
  911.     
  912.     set param_no 0
  913.     foreach {key type} $params {
  914.         set val [lindex $args $param_no]
  915.         set d_param [dom::document createElement $d_params "param"]
  916.         XMLRPC::insert_value $d_param [rpcvar $type $val]
  917.         incr param_no
  918.     }
  919.  
  920.     # We have to strip out the DOCTYPE element though. It would be better to
  921.     # remove the DOM element, but that didn't work.
  922.     set prereq [dom::DOMImplementation serialize $doc]
  923.     set req {}
  924.     dom::DOMImplementation destroy $doc          ;# clean up
  925.     regsub "<!DOCTYPE\[^>\]*>\n" $prereq {} req  ;# hack
  926.  
  927.     return $req                                  ;# return the XML data
  928. }
  929.  
  930. # -------------------------------------------------------------------------
  931.  
  932. # Description:
  933. #   Parse a SOAP response payload. Check for Fault response otherwise 
  934. #   extract the value data.
  935. # Parameters:
  936. #   procVarName  - the name of the SOAP method configuration variable
  937. #   xml          - the XML payload of the response
  938. # Result:
  939. #   The returned value data.
  940. # Notes:
  941. #   Needs work to cope with struct or array types.
  942. #
  943. proc SOAP::parse_soap_response { procVarName xml } {
  944.     # Sometimes Fault packets come back with HTTP code 200
  945.     #
  946.     # kenstir@synchronicity.com: Catch xml parse errors and present a
  947.     #   friendlier message.  The parse method throws awful messages like
  948.     #   "{invalid attribute list} around line 16".
  949.     if {[catch {set doc [dom::DOMImplementation parse $xml]}]} {
  950.         error "Server response is not well-formed XML.\nresponse was $xml" \
  951.                 $::errorInfo Server
  952.     }
  953.  
  954.     set faultNode [selectNode $doc "/Envelope/Body/Fault"]
  955.     if {$faultNode != {}} {
  956.         array set fault [decomposeSoap $faultNode]
  957.         dom::DOMImplementation destroy $doc
  958.         if {![info exists fault(detail)]} { set fault(detail) {}}
  959.         error [list $fault(faultcode) $fault(faultstring)] $fault(detail)
  960.     }
  961.  
  962.     # If there is a header element then make it available via SOAP::getHeader
  963.     set headerNode [selectNode $doc "/Envelope/Header"]
  964.     if {$headerNode != {} \
  965.             && [string match \
  966.                     "http://schemas.xmlsoap.org/soap/envelope/" \
  967.                     [namespaceURI $headerNode]]} {
  968.         set [subst $procVarName](headers) [decomposeSoap $headerNode]
  969.     } else {
  970.         set [subst $procVarName](headers) {}
  971.     }
  972.     
  973.     set result {}
  974.  
  975.     if {[info exists [subst $procVarName](name)]} {
  976.         set responseName "[set [subst $procVarName](name)]Response"
  977.     } else {
  978.         set responseName "*"
  979.     }
  980.     set responseNode [selectNode $doc "/Envelope/Body/$responseName"]
  981.     if {$responseNode == {}} {
  982.         set responseNode [lindex [selectNode $doc "/Envelope/Body/*"] 0]
  983.     }
  984.  
  985.     set nodes [getElements $responseNode]
  986.     foreach node $nodes {
  987.         set r [decomposeSoap $node]
  988.         if {$result == {}} { set result $r } else { lappend result $r }
  989.     }
  990.  
  991.     dom::DOMImplementation destroy $doc
  992.     return $result
  993. }
  994.  
  995. # -------------------------------------------------------------------------
  996.  
  997. # Description:
  998. #   Parse an XML-RPC response payload. Check for fault response otherwise 
  999. #   extract the value data.
  1000. # Parameters:
  1001. #   procVarName  - the name of the XML-RPC method configuration variable
  1002. #   xml          - the XML payload of the response
  1003. # Result:
  1004. #   The extracted value(s). Array types are converted into lists and struct
  1005. #   types are turned into lists of name/value pairs suitable for array set
  1006. # Notes:
  1007. #   The XML-RPC fault response doesn't allow us to add in extra values
  1008. #   to the fault struct. So where to put the servers errorInfo?
  1009. #
  1010. proc SOAP::parse_xmlrpc_response { procVarName xml } {
  1011.     set result {}
  1012.     if {[catch {set doc [dom::DOMImplementation parse $xml]}]} {
  1013.         error "Server response is not well-formed XML.\nresponse was $xml" \
  1014.                 $::errorInfo Server
  1015.     }
  1016.  
  1017.     set faultNode [selectNode $doc "/methodResponse/fault"]
  1018.     if {$faultNode != {}} {
  1019.         array set err [lindex [decomposeXMLRPC \
  1020.                 [selectNode $doc /methodResponse]] 0]
  1021.         dom::DOMImplementation destroy $doc
  1022.         error $err(faultString) {Received XML-RPC Error} $err(faultCode)
  1023.     }
  1024.     
  1025.     # Recurse over each params/param/value
  1026.     set n_params 0
  1027.     foreach valueNode [selectNode $doc \
  1028.             "/methodResponse/params/param/value"] {
  1029.         lappend result [xmlrpc_value_from_node $valueNode]
  1030.         incr n_params
  1031.     }
  1032.     dom::DOMImplementation destroy $doc
  1033.  
  1034.     # If (as is usual) there is only one param, simplify things for the user
  1035.     # ie: sort {one two three} should return a 3 element list, not a single
  1036.     # element list whose first element has 3 elements!
  1037.     if {$n_params == 1} {set result [lindex $result 0]}
  1038.     return $result
  1039. }
  1040.  
  1041. # -------------------------------------------------------------------------
  1042.  
  1043. ### NB: this procedure needs to be moved into XMLRPC namespace
  1044.  
  1045. # Description:
  1046. #   Retrieve the value under the given <value> node.
  1047. # Parameters:
  1048. #   valueNode - reference to a <value> element in the response dom tree
  1049. # Result:
  1050. #   Either a single value or a list of values. Arrays expand into a list
  1051. #   of values, structs to a list of name/value pairs.
  1052. # Notes:
  1053. #   Called recursively when processing arrays and structs.
  1054. #
  1055. proc SOAP::xmlrpc_value_from_node {valueNode} {
  1056.     set value {}
  1057.     set elts [getElements $valueNode]
  1058.  
  1059.     if {[llength $elts] != 1} {
  1060.         return [getElementValue $valueNode]
  1061.     }
  1062.     set typeElement [lindex $elts 0]
  1063.     set type [dom::node cget $typeElement -nodeName]
  1064.  
  1065.     if {$type == "array"} {
  1066.         set dataElement [lindex [getElements $typeElement] 0]
  1067.         foreach valueElement [getElements $dataElement] {
  1068.             lappend value [xmlrpc_value_from_node $valueElement]
  1069.         }
  1070.     } elseif {$type == "struct"} {
  1071.         # struct type has 1+ members which have a name and a value elt.
  1072.         foreach memberElement [getElements $typeElement] {
  1073.             set params [getElements $memberElement]
  1074.             foreach param $params {
  1075.                 set nodeName [dom::node cget $param -nodeName]
  1076.                 if { $nodeName == "name"} {
  1077.                     set pname [getElementValue $param]
  1078.                 } elseif { $nodeName == "value" } {
  1079.                     set pvalue [xmlrpc_value_from_node $param]
  1080.                 }
  1081.             }
  1082.             lappend value $pname $pvalue
  1083.         }
  1084.     } else {
  1085.         set value [getElementValue $typeElement]
  1086.     }
  1087.     return $value
  1088. }
  1089.  
  1090. # -------------------------------------------------------------------------
  1091.  
  1092. proc SOAP::insert_headers {node headers} {
  1093.     set doc [SOAP::Utils::getDocumentElement $node]
  1094.     if {[set h [selectNode $doc /Envelope/Header]] == {}} {
  1095.         set e [dom::document cget $doc -documentElement]
  1096.         set h [dom::document createElement $e "SOAP-ENV:Header"]
  1097.     }
  1098.     foreach {name value} $headers {
  1099.         if {$name != {}} {
  1100.             set elt [dom::document createElement $h $name]
  1101.             insert_value $elt $value
  1102.         }
  1103.     }
  1104. }
  1105.  
  1106. # -------------------------------------------------------------------------
  1107.  
  1108. proc SOAP::insert_value {node value} {
  1109.  
  1110.     set type     [rpctype $value]
  1111.     set subtype  [rpcsubtype $value]
  1112.     set attrs    [rpcattributes $value]
  1113.     set headers  [rpcheaders $value]
  1114.     set value    [rpcvalue $value]
  1115.     set typeinfo [typedef -info $type]
  1116.     set typexmlns [typedef -namespace $type]
  1117.  
  1118.     # Handle any header elements
  1119.     if {$headers != {}} {
  1120.         insert_headers $node $headers
  1121.     }
  1122.     
  1123.     # If the rpcvar namespace is a URI then assign it a tag and ensure we
  1124.     # have our colon only when required.
  1125.     if {$typexmlns != {} && [regexp : $typexmlns]} {
  1126.         dom::element setAttribute $node "xmlns:t" $typexmlns
  1127.         set typexmlns t
  1128.     }
  1129.     if {$typexmlns != {}} { append typexmlns : }
  1130.  
  1131.     # If there are any attributes assigned, apply them.
  1132.     if {$attrs != {}} {
  1133.         foreach {aname avalue} $attrs {
  1134.             dom::element setAttribute $node $aname $avalue
  1135.         }
  1136.     }
  1137.  
  1138.     if {[string match {*()} $type] || [string match array $type]} {
  1139.         # array type: arrays are indicated by a () suffix or the word 'array'
  1140.         set itemtype [string trimright $type ()]
  1141.         if {$itemtype == "array"} {
  1142.             set itemtype ur-type
  1143.         }
  1144.         
  1145.         # Look up the typedef info of the item type
  1146.         set itemxmlns [typedef -namespace $itemtype]
  1147.         if {$itemxmlns != {} && [regexp : $itemxmlns]} {
  1148.             dom::element setAttribute $node "xmlns:i" $itemxmlns
  1149.             set itemxmlns i
  1150.         }
  1151.         
  1152.         dom::element setAttribute $node \
  1153.                 "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
  1154.         dom::element setAttribute $node "xsi:type" "SOAP-ENC:Array"
  1155.         dom::element setAttribute $node \
  1156.                 "SOAP-ENC:arrayType" "$itemxmlns:$itemtype\[[llength $value]\]"
  1157.  
  1158.         foreach elt $value {
  1159.             set d_elt [dom::document createElement $node "item"]
  1160.             if {[string match "ur-type" $itemtype]} {
  1161.                 insert_value $d_elt $elt
  1162.             } else {
  1163.                 insert_value $d_elt [rpcvar $itemtype $elt]
  1164.             }
  1165.         }
  1166.     } elseif {[llength $typeinfo] > 1} {
  1167.         # a typedef'd struct.
  1168.         if {$typexmlns != {}} {
  1169.             dom::element setAttribute $node "xsi:type" "${typexmlns}${type}"
  1170.         }
  1171.         array set ti $typeinfo
  1172.         # Bounds checking - <simon@e-ppraisal.com>
  1173.         if {[llength $typeinfo] != [llength $value]} {
  1174.             error "wrong # args: type $type contains \"$typeinfo\""
  1175.         }
  1176.         foreach {eltname eltvalue} $value {
  1177.             set d_elt [dom::document createElement $node $eltname]
  1178.             if {![info exists ti($eltname)]} {
  1179.                 error "invalid member name: \"$eltname\" is not a member of\
  1180.                         the $type type."
  1181.             }
  1182.             insert_value $d_elt [rpcvar $ti($eltname) $eltvalue]
  1183.         }
  1184.     } elseif {$type == "struct"} {
  1185.         # an unspecified struct
  1186.         foreach {eltname eltvalue} $value {
  1187.             set d_elt [dom::document createElement $node $eltname]
  1188.             insert_value $d_elt $eltvalue
  1189.         }
  1190.     } else {
  1191.         # simple type or typedef'd enumeration
  1192.         if {$typexmlns != {}} {
  1193.             dom::element setAttribute $node "xsi:type" "${typexmlns}${type}"
  1194.         }
  1195.         dom::document createTextNode $node $value
  1196.     }
  1197. }
  1198.  
  1199. # -------------------------------------------------------------------------
  1200.  
  1201. # Local variables:
  1202. #    indent-tabs-mode: nil
  1203. # End:
  1204.