Artifact Content
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.

Artifact d072926db77b9f6cec450ffa9e4baed61047930924e5a7d04192ae33ac2a96c4:


     1  ###############################################################################
     2  ##                                                                           ##
     3  ##  Copyright (c) 2016-2017, Harald Oehlmann                                 ##
     4  ##  Copyright (c) 2006-2013, Gerald W. Lester                                ##
     5  ##  Copyright (c) 2008, Georgios Petasis                                     ##
     6  ##  Copyright (c) 2006, Visiprise Software, Inc                              ##
     7  ##  Copyright (c) 2006, Arnulf Wiedemann                                     ##
     8  ##  Copyright (c) 2006, Colin McCormack                                      ##
     9  ##  Copyright (c) 2006, Rolf Ade                                             ##
    10  ##  Copyright (c) 2001-2006, Pat Thoyts                                      ##
    11  ##  All rights reserved.                                                     ##
    12  ##                                                                           ##
    13  ##  Redistribution and use in source and binary forms, with or without       ##
    14  ##  modification, are permitted provided that the following conditions       ##
    15  ##  are met:                                                                 ##
    16  ##                                                                           ##
    17  ##    * Redistributions of source code must retain the above copyright       ##
    18  ##      notice, this list of conditions and the following disclaimer.        ##
    19  ##    * Redistributions in binary form must reproduce the above              ##
    20  ##      copyright notice, this list of conditions and the following          ##
    21  ##      disclaimer in the documentation and/or other materials provided      ##
    22  ##      with the distribution.                                               ##
    23  ##    * Neither the name of the Visiprise Software, Inc nor the names        ##
    24  ##      of its contributors may be used to endorse or promote products       ##
    25  ##      derived from this software without specific prior written            ##
    26  ##      permission.                                                          ##
    27  ##                                                                           ##
    28  ##  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS      ##
    29  ##  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT        ##
    30  ##  LIMITED  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS       ##
    31  ##  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE           ##
    32  ##  COPYRIGHT OWNER OR  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,     ##
    33  ##  INCIDENTAL, SPECIAL,  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,    ##
    34  ##  BUT NOT LIMITED TO,  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;        ##
    35  ##  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER         ##
    36  ##  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT       ##
    37  ##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
    38  ##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
    39  ##  POSSIBILITY OF SUCH DAMAGE.                                              ##
    40  ##                                                                           ##
    41  ###############################################################################
    42  
    43  package require Tcl 8.4
    44  package require WS::Utils 2.4 ; # dict, lassign
    45  package require tdom 0.8
    46  package require http 2
    47  package require log
    48  package require uri
    49  
    50  package provide WS::Client 2.5.1
    51  
    52  namespace eval ::WS::Client {
    53      # register https only if not yet registered
    54      if {[catch { http::unregister https } lPortCmd]} {
    55          # not registered -> register on my own
    56          if {[catch {
    57              package require tls
    58              http::register https 443 [list ::tls::socket -ssl2 no -ssl3 no -tls1 yes]
    59          } err]} {
    60              log::log warning "No https support: $err"
    61          }
    62      } else {
    63          # Ok, was registered - reregister
    64          http::register https {*}$lPortCmd
    65      }
    66      unset -nocomplain err lPortCmd
    67  
    68      ##
    69      ## serviceArr is indexed by service name and contains a dictionary that
    70      ## defines the service.  The dictionary has the following structure:
    71      ##   targetNamespace - the target namespace
    72      ##   operList - list of operations
    73      ##   objList  - list of operations
    74      ##   headers  - list of http headers
    75      ##   types    - dictionary of types
    76      ##   service  - dictionary containing general information about the service, formatted:
    77      ##      name     -- the name of the service
    78      ##      location -- the url
    79      ##      style    -- style of call (e.g. rpc/encoded, document/literal)
    80      ##
    81      ## For style of rpc/encoded, document/literal
    82      ##   operations - dictionary with information about the operations.  The key
    83      ##               is the operations name and each with the following structure:
    84      ##      soapRequestHeader -- list of SOAP Request Headers
    85      ##      soapReplyHeader   -- list of SOAP Reply Headers
    86      ##      action            -- SOAP Action Header
    87      ##      inputs            -- list of fields with type info
    88      ##      outputs           -- return type
    89      ##      style             -- style of call (e.g. rpc/encoded, document/literal)
    90      ##
    91      ## For style of rest
    92      ##   object - dictionary with informat about objects.  The key is the object
    93      ##            name each with the following strucutre:
    94      ##     operations -- dictionary with information about the operations.  The key
    95      ##                   is the operations name and each with the following structure:
    96      ##       inputs            --- list of fields with type info
    97      ##       outputs           --- return type
    98      ##
    99      ## Note -- all type information is formated suitable to be passed
   100      ##         to ::WS::Utils::ServiceTypeDef
   101      ##
   102      array set ::WS::Client::serviceArr {}
   103      set ::WS::Client::currentBaseUrl {}
   104      array set ::WS::Client::options {
   105          skipLevelWhenActionPresent 0
   106          skipLevelOnReply 0
   107          skipHeaderLevel 0
   108          suppressTargetNS 0
   109          allowOperOverloading 1
   110          contentType {text/xml;charset=utf-8}
   111          UseNS {}
   112          parseInAttr {}
   113          genOutAttr {}
   114          valueAttrCompatiblityMode 1
   115          suppressNS {}
   116          useTypeNs {}
   117          nsOnChangeOnly {}
   118          noTargetNs 0
   119          errorOnRedefine 0
   120          inlineElementNS 1
   121      }
   122      ##
   123      ## List of options which are copied to the service array
   124      ##
   125      set ::WS::Client::serviceLocalOptionsList {
   126          skipLevelWhenActionPresent
   127          skipLevelOnReply
   128          skipHeaderLevel
   129          suppressTargetNS
   130          allowOperOverloading
   131          contentType
   132          UseNS
   133          parseInAttr
   134          genOutAttr
   135          valueAttrCompatiblityMode
   136          suppressNS
   137          useTypeNs
   138          nsOnChangeOnly
   139          noTargetNs
   140      }
   141  
   142      set ::WS::Client::utilsOptionsList {
   143          UseNS
   144          parseInAttr
   145          genOutAttr
   146          valueAttrCompatiblityMode
   147          suppressNS
   148          useTypeNs
   149          nsOnChangeOnly
   150      }
   151  }
   152  
   153  
   154  ###########################################################################
   155  #
   156  # Public Procedure Header - as this procedure is modified, please be sure
   157  #                           that you update this header block. Thanks.
   158  #
   159  #>>BEGIN PUBLIC<<
   160  #
   161  # Procedure Name : ::WS::Client::SetOption
   162  #
   163  # Description : Set or get file global or default option.
   164  #               Global option control the service creation process.
   165  #               Default options are takren as defaults to new created services.
   166  #
   167  # Arguments :
   168  #       -globalonly
   169  #               - Return list of global options/values
   170  #       -defaultonly
   171  #               - Return list of default options/values
   172  #       --
   173  #       option  - Option to be set/retrieved
   174  #                 Return all option/values if omitted
   175  #       args    - Value to set the option to
   176  #                 Return the value if not given
   177  #
   178  # Returns : The value of the option
   179  #
   180  # Side-Effects :        None
   181  #
   182  # Exception Conditions :        None
   183  #
   184  # Pre-requisite Conditions :    None
   185  #
   186  # Original Author : Gerald W. Lester
   187  #
   188  #>>END PUBLIC<<
   189  #
   190  # Maintenance History - as this file is modified, please be sure that you
   191  #                       update this segment of the file header block by
   192  #                       adding a complete entry at the bottom of the list.
   193  #
   194  # Version     Date     Programmer   Comments / Changes / Reasons
   195  # -------  ----------  ----------   -------------------------------------------
   196  #       1  04/272009   G.Lester     Initial version
   197  #   2.4.5  2017-12-04  H.Oehlmann   Return all current options if no argument
   198  #                                   given. Options -globalonly or -defaultonly
   199  #                                   limit this to options which are (not)
   200  #                                   copied to the service.
   201  #                                   
   202  ###########################################################################
   203  proc ::WS::Client::SetOption {args} {
   204      variable options
   205      variable serviceLocalOptionsList
   206      if {0 == [llength $args]} {
   207          return [array get options]
   208      }
   209      set args [lassign $args option]
   210      
   211      switch -exact -- $option {
   212          -globalonly {
   213              ##
   214              ## Return list of global options
   215              ##
   216              # A list convertible to a dict is build for performance reasons:
   217              # - lappend does not test existence for each element
   218              # - if a list is needed, dict build burden is avoided
   219              set res {}
   220              foreach option [array names options] {
   221                  if {$option ni $serviceLocalOptionsList} {
   222                      lappend res $option $options($option)
   223                  }
   224              }
   225              return $res
   226          }
   227          -defaultonly {
   228              ##
   229              ## Return list of default options
   230              ##
   231              set res {}
   232              foreach option [array names options] {
   233                  if {$option in $serviceLocalOptionsList} {
   234                      lappend res $option $options($option)
   235                  }
   236              }
   237              return $res
   238          }
   239          -- {
   240              ##
   241              ## End of options
   242              ##
   243              set args [lassign $args option]
   244          }
   245      }
   246      ##
   247      ## Check if given option exists
   248      ##
   249      if {![info exists options($option)]} {
   250          return  -code error \
   251                  -errorcode [list WS CLIENT UNKOPT $option] \
   252                  "Unknown option: '$option'"
   253      }
   254      ##
   255      ## Check if value is given
   256      ##
   257      switch -exact -- [llength $args] {
   258          0 {
   259              return $options($option)
   260          }
   261          1 {
   262              set value [lindex $args 0]
   263              set options($option) $value
   264              return $value
   265          }
   266          default {
   267              return  -code error \
   268                      -errorcode [list WS CLIENT INVALDCNT $args] \
   269                      "To many parameters: '$args'"
   270          }
   271      }
   272  }
   273  
   274  ###########################################################################
   275  #
   276  # Public Procedure Header - as this procedure is modified, please be sure
   277  #                           that you update this header block. Thanks.
   278  #
   279  #>>BEGIN PUBLIC<<
   280  #
   281  # Procedure Name : ::WS::Client::CreateService
   282  #
   283  # Description : Define a service
   284  #
   285  # Arguments :
   286  #       serviceName - Service name to add namespace to
   287  #       type        - The type of service, currently only REST is supported
   288  #       url         - URL of namespace file to import
   289  #       args        - Optional arguments:
   290  #                       -header httpHeaderList
   291  #
   292  # Returns :     The local alias (tns)
   293  #
   294  # Side-Effects :        None
   295  #
   296  # Exception Conditions :        None
   297  #
   298  # Pre-requisite Conditions :    None
   299  #
   300  # Original Author : Gerald W. Lester
   301  #
   302  #>>END PUBLIC<<
   303  #
   304  # Maintenance History - as this file is modified, please be sure that you
   305  #                       update this segment of the file header block by
   306  #                       adding a complete entry at the bottom of the list.
   307  #
   308  # Version     Date     Programmer   Comments / Changes / Reasons
   309  # -------  ----------  ----------   -------------------------------------------
   310  #       1  04/14/2009  G.Lester     Initial version
   311  # 2.4.5    2017-12-04  H.Oehlmann   Use distinct list of option items, which are
   312  #                                   copied to the service array. Not all options
   313  #                                   are used in the service array.
   314  #
   315  ###########################################################################
   316  proc ::WS::Client::CreateService {serviceName type url target args} {
   317      variable serviceArr
   318      variable options
   319      variable serviceLocalOptionsList
   320  
   321      if {$options(errorOnRedefine) && [info exists serviceArr($serviceName)]} {
   322          return -code error "Service '$serviceName' already exists"
   323      } elseif {[info exists serviceArr($serviceName)]} {
   324          unset serviceArr($serviceName)
   325      }
   326  
   327      dict set serviceArr($serviceName) types {}
   328      dict set serviceArr($serviceName) operList {}
   329      dict set serviceArr($serviceName) objList {}
   330      dict set serviceArr($serviceName) headers {}
   331      dict set serviceArr($serviceName) targetNamespace tns1 $target
   332      dict set serviceArr($serviceName) name $serviceName
   333      dict set serviceArr($serviceName) location $url
   334      dict set serviceArr($serviceName) style $type
   335      dict set serviceArr($serviceName) imports {}
   336      dict set serviceArr($serviceName) inTransform {}
   337      dict set serviceArr($serviceName) outTransform {}
   338      foreach item $serviceLocalOptionsList {
   339          dict set serviceArr($serviceName) $item $options($item)
   340      }
   341      foreach {name value} $args {
   342          set name [string trimleft $name {-}]
   343          dict set serviceArr($serviceName) $name $value
   344      }
   345  
   346      ::log::logsubst debug {Setting Target Namespace tns1 as $target}
   347      if {[dict exists $serviceArr($serviceName) xns]} {
   348          foreach xnsItem [dict get $serviceArr($serviceName) xns] {
   349              lassign $xnsItem tns xns
   350              ::log::logsubst debug {Setting targetNamespace $tns for $xns}
   351              dict set serviceArr($serviceName) targetNamespace $tns $xns
   352          }
   353      }
   354  }
   355  
   356  ###########################################################################
   357  #
   358  # Public Procedure Header - as this procedure is modified, please be sure
   359  #                           that you update this header block. Thanks.
   360  #
   361  #>>BEGIN PUBLIC<<
   362  #
   363  # Procedure Name : ::WS::Client::Config
   364  #
   365  # Description : Configure a service information
   366  #
   367  # Arguments :
   368  #       serviceName - Service name to add namespace to.
   369  #                     Return a list of items/values of default options if not
   370  #                     given.
   371  #       item        - The item to configure. Return a list of all items/values
   372  #                     if not given.
   373  #       value       - Optional, the new value. Return the value, if not given.
   374  #
   375  # Returns :     The value of the option or a list of item/value pairs.
   376  #
   377  # Side-Effects :        None
   378  #
   379  # Exception Conditions :        None
   380  #
   381  # Pre-requisite Conditions :    None
   382  #
   383  # Original Author : Gerald W. Lester
   384  #
   385  #>>END PUBLIC<<
   386  #
   387  # Maintenance History - as this file is modified, please be sure that you
   388  #                       update this segment of the file header block by
   389  #                       adding a complete entry at the bottom of the list.
   390  #
   391  # Version     Date     Programmer   Comments / Changes / Reasons
   392  # -------  ----------  ----------   -------------------------------------------
   393  #       1  04/14/2009  G.Lester     Initial version
   394  #   2.4.5  2017-12-04  H.Oehlmann   Allow to set an option to the empty string.
   395  #                                   Return all option/values, if called without
   396  #                                   item. Return default items/values if no
   397  #                                   service given.
   398  #
   399  ###########################################################################
   400  proc ::WS::Client::Config {args} {
   401      variable serviceArr
   402      variable options
   403      variable serviceLocalOptionsList
   404  
   405      set validOptionList $serviceLocalOptionsList
   406      lappend validOptionList location targetNamespace
   407      
   408      if {0 == [llength $args]} {
   409          # A list convertible to a dict is build for performance reasons:
   410          # - lappend does not test existence for each element
   411          # - if a list is needed, dict build burden is avoided
   412          set res {}
   413          foreach item $validOptionList {
   414              lappend res $item
   415              if {[info exists options($item)]} {
   416                  lappend res $options($item)
   417              } else {
   418                  lappend res {}
   419              }
   420          }
   421          return $res
   422      }    
   423      set args [lassign $args serviceName]
   424      if {0 == [llength $args]} {
   425          set res {}
   426          foreach item $validOptionList {
   427              lappend res $item [dict get $serviceArr($serviceName) $item]
   428          }
   429          return $res
   430      }
   431      
   432      set args [lassign $args item]
   433      if { $item ni $validOptionList } {
   434          return -code error "Uknown option '$item' -- must be one of: [join $validOptionList {, }]"
   435      }
   436  
   437      switch -exact -- [llength $args] {
   438          0 {
   439              return [dict get $serviceArr($serviceName) $item]
   440          }
   441          1 {
   442              set value [lindex $args 0]
   443              dict set serviceArr($serviceName) $item  $value
   444              return $value
   445          }
   446          default {
   447              ::log::log debug "To many arguments arguments {$args}"
   448              return \
   449                  -code error \
   450                  -errorcode [list WS CLIENT INVARGCNT $args] \
   451                  "To many arguments '$args'"
   452          }
   453      }
   454  }
   455  
   456  ###########################################################################
   457  #
   458  # Public Procedure Header - as this procedure is modified, please be sure
   459  #                           that you update this header block. Thanks.
   460  #
   461  #>>BEGIN PUBLIC<<
   462  #
   463  # Procedure Name : ::WS::Client::SetServiceTransforms
   464  #
   465  # Description : Define a service's transforms
   466  #               Transform signature is:
   467  #                   cmd serviceName operationName transformType xml {url {}} {argList {}}
   468  #               where transformType is REQUEST or REPLY
   469  #               and url and argList will only be present for transformType == REQUEST
   470  #
   471  # Arguments :
   472  #       serviceName  - Service name to add namespace to
   473  #       inTransform  - Input transform, defaults to {}
   474  #       outTransform - Output transform, defaults to {}
   475  #
   476  # Returns :     None
   477  #
   478  # Side-Effects :        None
   479  #
   480  # Exception Conditions :        None
   481  #
   482  # Pre-requisite Conditions :    None
   483  #
   484  # Original Author : Gerald W. Lester
   485  #
   486  #>>END PUBLIC<<
   487  #
   488  # Maintenance History - as this file is modified, please be sure that you
   489  #                       update this segment of the file header block by
   490  #                       adding a complete entry at the bottom of the list.
   491  #
   492  # Version     Date     Programmer   Comments / Changes / Reasons
   493  # -------  ----------  ----------   -------------------------------------------
   494  #       1  04/14/2009  G.Lester     Initial version
   495  #
   496  #
   497  ###########################################################################
   498  proc ::WS::Client::SetServiceTransforms {serviceName {inTransform {}} {outTransform {}}} {
   499      variable serviceArr
   500  
   501      dict set serviceArr($serviceName) inTransform $inTransform
   502      dict set serviceArr($serviceName) outTransform $outTransform
   503  
   504      return;
   505  }
   506  
   507  ###########################################################################
   508  #
   509  # Public Procedure Header - as this procedure is modified, please be sure
   510  #                           that you update this header block. Thanks.
   511  #
   512  #>>BEGIN PUBLIC<<
   513  #
   514  # Procedure Name : ::WS::Client::GetServiceTransforms
   515  #
   516  # Description : Define a service's transforms
   517  #
   518  # Arguments :
   519  #       serviceName  - Service name to add namespace to
   520  #
   521  # Returns :     List of two elements: inTransform outTransform
   522  #
   523  # Side-Effects :        None
   524  #
   525  # Exception Conditions :        None
   526  #
   527  # Pre-requisite Conditions :    None
   528  #
   529  # Original Author : Gerald W. Lester
   530  #
   531  #>>END PUBLIC<<
   532  #
   533  # Maintenance History - as this file is modified, please be sure that you
   534  #                       update this segment of the file header block by
   535  #                       adding a complete entry at the bottom of the list.
   536  #
   537  # Version     Date     Programmer   Comments / Changes / Reasons
   538  # -------  ----------  ----------   -------------------------------------------
   539  #       1  04/14/2009  G.Lester     Initial version
   540  #
   541  #
   542  ###########################################################################
   543  proc ::WS::Client::GetServiceTransforms {serviceName} {
   544      variable serviceArr
   545  
   546      set inTransform [dict get serviceArr($serviceName) inTransform]
   547      set outTransform [dict get serviceArr($serviceName) outTransform]
   548  
   549      return [list $inTransform $outTransform]
   550  }
   551  
   552  ###########################################################################
   553  #
   554  # Public Procedure Header - as this procedure is modified, please be sure
   555  #                           that you update this header block. Thanks.
   556  #
   557  #>>BEGIN PUBLIC<<
   558  #
   559  # Procedure Name : ::WS::Client::DefineRestMethod
   560  #
   561  # Description : Define a method
   562  #
   563  # Arguments :
   564  #       serviceName   - Service name to add namespace to
   565  #       objectName    - Name of the object
   566  #       operationName - The name of the method to add
   567  #       inputArgs     - List of input argument definitions where each argument
   568  #                       definition is of the format: name typeInfo
   569  #       returnType    - The type, if any returned by the procedure.  Format is:
   570  #                       xmlTag typeInfo
   571  #
   572  #  where, typeInfo is of the format {type typeName comment commentString}
   573  #
   574  # Returns :     The current service definition
   575  #
   576  # Side-Effects :        None
   577  #
   578  # Exception Conditions :        None
   579  #
   580  # Pre-requisite Conditions :    None
   581  #
   582  # Original Author : Gerald W. Lester
   583  #
   584  #>>END PUBLIC<<
   585  #
   586  # Maintenance History - as this file is modified, please be sure that you
   587  #                       update this segment of the file header block by
   588  #                       adding a complete entry at the bottom of the list.
   589  #
   590  # Version     Date     Programmer   Comments / Changes / Reasons
   591  # -------  ----------  ----------   -------------------------------------------
   592  #       1  04/14/2009  G.Lester     Initial version
   593  #
   594  #
   595  ###########################################################################
   596  proc ::WS::Client::DefineRestMethod {serviceName objectName operationName inputArgs returnType {location {}}} {
   597      variable serviceArr
   598  
   599      if {[lsearch -exact  [dict get $serviceArr($serviceName) objList] $objectName] == -1} {
   600          dict lappend serviceArr($serviceName) objList $objectName
   601      }
   602      if {![llength $location]} {
   603          set location [dict get $serviceArr($serviceName) location]
   604      }
   605  
   606      if {$inputArgs ne {}} {
   607          set inType $objectName.$operationName.Request
   608          ::WS::Utils::ServiceTypeDef Client $serviceName $inType $inputArgs
   609      } else {
   610          set inType {}
   611      }
   612      if {$returnType ne {}} {
   613          set outType $objectName.$operationName.Results
   614          ::WS::Utils::ServiceTypeDef Client $serviceName $outType $returnType
   615      } else {
   616          set outType {}
   617      }
   618  
   619      dict set serviceArr($serviceName) object $objectName location $location
   620      dict set serviceArr($serviceName) object $objectName operation $operationName inputs $inType
   621      dict set serviceArr($serviceName) object $objectName operation $operationName outputs $outType
   622  
   623  }
   624  
   625  ###########################################################################
   626  #
   627  # Public Procedure Header - as this procedure is modified, please be sure
   628  #                           that you update this header block. Thanks.
   629  #
   630  #>>BEGIN PUBLIC<<
   631  #
   632  # Procedure Name : ::WS::Client::ImportNamespace
   633  #
   634  # Description : Import and additional namespace into the service
   635  #
   636  # Arguments :
   637  #       serviceName - Service name to add namespace to
   638  #       url         - URL of namespace file to import
   639  #
   640  # Returns :     The local alias (tns)
   641  #
   642  # Side-Effects :        None
   643  #
   644  # Exception Conditions :        None
   645  #
   646  # Pre-requisite Conditions :    None
   647  #
   648  # Original Author : Gerald W. Lester
   649  #
   650  #>>END PUBLIC<<
   651  #
   652  # Maintenance History - as this file is modified, please be sure that you
   653  #                       update this segment of the file header block by
   654  #                       adding a complete entry at the bottom of the list.
   655  #
   656  # Version     Date     Programmer   Comments / Changes / Reasons
   657  # -------  ----------  ----------   -------------------------------------------
   658  #       1  01/30/2009  G.Lester     Initial version
   659  # 2.4.1    2017-08-31  H.Oehlmann   Use utility function
   660  #                                   ::WS::Utils::geturl_fetchbody for http call
   661  #                                   which also follows redirects.
   662  #
   663  #
   664  ###########################################################################
   665  proc ::WS::Client::ImportNamespace {serviceName url} {
   666      variable serviceArr
   667  
   668      switch -exact -- [dict get [::uri::split $url] scheme] {
   669          file {
   670              upvar #0 [::uri::geturl $url] token
   671              set xml $token(data)
   672              unset token
   673          }
   674          http -
   675          https {
   676              set xml [::WS::Utils::geturl_fetchbody $url]
   677          }
   678          default {
   679              return \
   680                  -code error \
   681                  -errorcode [list WS CLIENT UNKURLTYP $url] \
   682                  "Unknown URL type '$url'"
   683          }
   684      }
   685      set tnsCount [expr {[llength [dict get $serviceArr($serviceName) targetNamespace]]/2}]
   686      set serviceInfo $serviceArr($serviceName)
   687      dict lappend serviceInfo imports $url
   688      ::WS::Utils::ProcessImportXml Client $url $xml $serviceName serviceInfo tnsCount
   689      set serviceArr($serviceName) $serviceInfo
   690      set result {}
   691      foreach {result target} [dict get $serviceArr($serviceName) targetNamespace] {
   692          if {$target eq $url} {
   693              break
   694          }
   695      }
   696      return $result
   697  }
   698  
   699  ###########################################################################
   700  #
   701  # Public Procedure Header - as this procedure is modified, please be sure
   702  #                           that you update this header block. Thanks.
   703  #
   704  #>>BEGIN PUBLIC<<
   705  #
   706  # Procedure Name : ::WS::Client::GetOperationList
   707  #
   708  # Description : Import and additional namespace into the service
   709  #
   710  # Arguments :
   711  #       serviceName - Service name to add namespace to
   712  #
   713  # Returns :     A list of operations names.
   714  #
   715  # Side-Effects :        None
   716  #
   717  # Exception Conditions :        None
   718  #
   719  # Pre-requisite Conditions :    None
   720  #
   721  # Original Author : Gerald W. Lester
   722  #
   723  #>>END PUBLIC<<
   724  #
   725  # Maintenance History - as this file is modified, please be sure that you
   726  #                       update this segment of the file header block by
   727  #                       adding a complete entry at the bottom of the list.
   728  #
   729  # Version     Date     Programmer   Comments / Changes / Reasons
   730  # -------  ----------  ----------   -------------------------------------------
   731  #       1  01/30/2009  G.Lester     Initial version
   732  #
   733  #
   734  ###########################################################################
   735  proc ::WS::Client::GetOperationList {serviceName {object {}}} {
   736      variable serviceArr
   737  
   738      if {$object eq {}} {
   739          return [dict get $serviceArr($serviceName) operList]
   740      } else {
   741          return [list $object [dict get $serviceArr($serviceName) operation $object inputs] [dict get $serviceArr($serviceName) operation $object outputs]]
   742      }
   743  
   744  }
   745  
   746  ###########################################################################
   747  #
   748  # Public Procedure Header - as this procedure is modified, please be sure
   749  #                           that you update this header block. Thanks.
   750  #
   751  #>>BEGIN PUBLIC<<
   752  #
   753  # Procedure Name : ::WS::Client::AddInputHeader
   754  #
   755  # Description : Import and additional namespace into the service
   756  #
   757  # Arguments :
   758  #       serviceName - Service name to of the operation
   759  #       operation   - name of operation to add an input header to
   760  #       headerType  - the type name to add as a header
   761  #       attrList    - list of name value pairs of attributes and their
   762  #                     values to add to the XML
   763  #
   764  # Returns :     Nothing
   765  #
   766  # Side-Effects :        None
   767  #
   768  # Exception Conditions :        None
   769  #
   770  # Pre-requisite Conditions :    None
   771  #
   772  # Original Author : Gerald W. Lester
   773  #
   774  #>>END PUBLIC<<
   775  #
   776  # Maintenance History - as this file is modified, please be sure that you
   777  #                       update this segment of the file header block by
   778  #                       adding a complete entry at the bottom of the list.
   779  #
   780  # Version     Date     Programmer   Comments / Changes / Reasons
   781  # -------  ----------  ----------   -------------------------------------------
   782  #       1  01/30/2009  G.Lester     Initial version
   783  #
   784  #
   785  ###########################################################################
   786  proc ::WS::Client::AddInputHeader {serviceName operationName headerType {attrList {}}} {
   787      variable serviceArr
   788  
   789      set serviceInfo $serviceArr($serviceName)
   790      set soapRequestHeader [dict get $serviceInfo operation $operationName soapRequestHeader]
   791      lappend soapRequestHeader [list $headerType $attrList]
   792      dict set serviceInfo operation $operationName soapRequestHeader $soapRequestHeader
   793      set serviceArr($serviceName) $serviceInfo
   794      return ;
   795  
   796  }
   797  
   798  ###########################################################################
   799  #
   800  # Public Procedure Header - as this procedure is modified, please be sure
   801  #                           that you update this header block. Thanks.
   802  #
   803  #>>BEGIN PUBLIC<<
   804  #
   805  # Procedure Name : ::WS::Client::AddOutputHeader
   806  #
   807  # Description : Import any additional namespace into the service
   808  #
   809  # Arguments :
   810  #       serviceName - Service name to of the oepration
   811  #       operation   - name of operation to add an output header to
   812  #       headerType  - the type name to add as a header
   813  #       attrList    - list of name value pairs of attributes and their
   814  #                     values to add to the XML
   815  #
   816  # Returns :     Nothing
   817  #
   818  # Side-Effects :        None
   819  #
   820  # Exception Conditions :        None
   821  #
   822  # Pre-requisite Conditions :    None
   823  #
   824  # Original Author : Gerald W. Lester
   825  #
   826  #>>END PUBLIC<<
   827  #
   828  # Maintenance History - as this file is modified, please be sure that you
   829  #                       update this segment of the file header block by
   830  #                       adding a complete entry at the bottom of the list.
   831  #
   832  # Version     Date     Programmer   Comments / Changes / Reasons
   833  # -------  ----------  ----------   -------------------------------------------
   834  #       1  01/30/2009  G.Lester     Initial version
   835  #
   836  #
   837  ###########################################################################
   838  proc ::WS::Client::AddOutputHeader {serviceName operation headerType} {
   839      variable serviceArr
   840  
   841      set serviceInfo $serviceArr($serviceName)
   842      set soapReplyHeader [dict get $serviceInfo operation $operation soapReplyHeader]
   843      lappend soapReplyHeader $headerType
   844      dict set serviceInfo operation $operation soapReplyHeader $soapReplyHeader
   845      set serviceArr($serviceName) $serviceInfo
   846      return
   847  
   848  }
   849  
   850  
   851  ###########################################################################
   852  #
   853  # Public Procedure Header - as this procedure is modified, please be sure
   854  #                           that you update this header block. Thanks.
   855  #
   856  #>>BEGIN PUBLIC<<
   857  #
   858  # Procedure Name : ::WS::Client::GetParsedWsdl
   859  #
   860  # Description : Get a service definition
   861  #
   862  # Arguments :
   863  #       serviceName - Name of the service.
   864  #
   865  # Returns :     The parsed service information
   866  #
   867  # Side-Effects :        None
   868  #
   869  # Exception Conditions :        UNKSERVICE
   870  #
   871  # Pre-requisite Conditions :    None
   872  #
   873  # Original Author : Gerald W. Lester
   874  #
   875  #>>END PUBLIC<<
   876  #
   877  # Maintenance History - as this file is modified, please be sure that you
   878  #                       update this segment of the file header block by
   879  #                       adding a complete entry at the bottom of the list.
   880  #
   881  # Version     Date     Programmer   Comments / Changes / Reasons
   882  # -------  ----------  ----------   -------------------------------------------
   883  #       1  07/06/2006  G.Lester     Initial version
   884  #
   885  #
   886  ###########################################################################
   887  proc ::WS::Client::GetParsedWsdl {serviceName} {
   888      variable serviceArr
   889  
   890      if {![info exists serviceArr($serviceName)]} {
   891          return \
   892              -code error "Unknown service '$serviceName'" \
   893              -errorcode [list UNKSERVICE $serviceName]
   894      }
   895  
   896      return $serviceArr($serviceName)
   897  }
   898  
   899  ###########################################################################
   900  #
   901  # Public Procedure Header - as this procedure is modified, please be sure
   902  #                           that you update this header block. Thanks.
   903  #
   904  #>>BEGIN PUBLIC<<
   905  #
   906  # Procedure Name : ::WS::Client::LoadParsedWsdl
   907  #
   908  # Description : Load a saved service definition in
   909  #
   910  # Arguments :
   911  #       serviceInfo - parsed service definition, as returned from
   912  #                     ::WS::Client::ParseWsdl or ::WS::Client::GetAndParseWsdl
   913  #       headers     - Extra headers to add to the HTTP request. This
   914  #                       is a key value list argument. It must be a list with
   915  #                       an even number of elements that alternate between
   916  #                       keys and values. The keys become header field names.
   917  #                       Newlines are stripped from the values so the header
   918  #                       cannot be corrupted.
   919  #                       This is an optional argument and defaults to {}.
   920  #       serviceAlias - Alias (unique) name for service.
   921  #                       This is an optional argument and defaults to the name of the
   922  #                       service in serviceInfo.
   923  #
   924  # Returns :     The name of the service loaded
   925  #
   926  # Side-Effects :        None
   927  #
   928  # Exception Conditions :        None
   929  #
   930  # Pre-requisite Conditions :    None
   931  #
   932  # Original Author : Gerald W. Lester
   933  #
   934  #>>END PUBLIC<<
   935  #
   936  # Maintenance History - as this file is modified, please be sure that you
   937  #                       update this segment of the file header block by
   938  #                       adding a complete entry at the bottom of the list.
   939  #
   940  # Version     Date     Programmer   Comments / Changes / Reasons
   941  # -------  ----------  ----------   -------------------------------------------
   942  #       1  07/06/2006  G.Lester     Initial version
   943  #
   944  #
   945  ###########################################################################
   946  proc ::WS::Client::LoadParsedWsdl {serviceInfo {headers {}} {serviceAlias {}}} {
   947      variable serviceArr
   948      variable options
   949  
   950      if {[string length $serviceAlias]} {
   951          set serviceName $serviceAlias
   952      } else {
   953          set serviceName [dict get $serviceInfo name]
   954      }
   955      if {$options(errorOnRedefine) && [info exists serviceArr($serviceName)]} {
   956          return -code error "Service '$serviceName' already exists"
   957      } elseif {[info exists serviceArr($serviceName)]} {
   958          unset serviceArr($serviceName)
   959      }
   960  
   961      if {[llength $headers]} {
   962          dict set serviceInfo headers $headers
   963      }
   964      set serviceArr($serviceName) $serviceInfo
   965  
   966      if {[dict exists $serviceInfo types]} {
   967          foreach {typeName partList} [dict get $serviceInfo types] {
   968              set definition [dict get $partList definition]
   969              set xns [dict get $partList xns]
   970              set isAbstarct [dict get $partList abstract]
   971              if {[lindex [split $typeName {:}] 1] eq {}} {
   972                  ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition tns1 $isAbstarct
   973              } else {
   974                  #set typeName [lindex [split $typeName {:}] 1]
   975                  ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition $xns $isAbstarct
   976              }
   977          }
   978      }
   979  
   980      if {[dict exists $serviceInfo simpletypes]} {
   981          foreach partList [dict get $serviceInfo simpletypes] {
   982              lassign $partList typeName definition
   983              if {[lindex [split $typeName {:}] 1] eq {}} {
   984                  ::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $definition tns1
   985              } else {
   986                  set xns [lindex [split $typeName {:}] 0]
   987                  #set typeName [lindex [split $typeName {:}] 1]
   988                  ::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $definition $xns
   989              }
   990          }
   991      }
   992  
   993      return $serviceName
   994  }
   995  
   996  ###########################################################################
   997  #
   998  # Public Procedure Header - as this procedure is modified, please be sure
   999  #                           that you update this header block. Thanks.
  1000  #
  1001  #>>BEGIN PUBLIC<<
  1002  #
  1003  # Procedure Name : ::WS::Client::GetAndParseWsdl
  1004  #
  1005  # Description :
  1006  #
  1007  # Arguments :
  1008  #       url           - The url of the WSDL
  1009  #       headers       - Extra headers to add to the HTTP request. This
  1010  #                       is a key value list argument. It must be a list with
  1011  #                       an even number of elements that alternate between
  1012  #                       keys and values. The keys become header field names.
  1013  #                       Newlines are stripped from the values so the header
  1014  #                       cannot be corrupted.
  1015  #                       This is an optional argument and defaults to {}.
  1016  #       serviceAlias  - Alias (unique) name for service.
  1017  #                       This is an optional argument and defaults to the name 
  1018  #                       of the service in serviceInfo.
  1019  #       serviceNumber - Number of service within the WSDL to assign the
  1020  #                       serviceAlias to. Only usable with a serviceAlias.
  1021  #                       First service (default) is addressed by value "1".
  1022  #
  1023  # Returns : The parsed service definition
  1024  #
  1025  # Side-Effects : None
  1026  #
  1027  # Exception Conditions : None
  1028  #
  1029  # Pre-requisite Conditions : None
  1030  #
  1031  # Original Author : Gerald W. Lester
  1032  #
  1033  #>>END PUBLIC<<
  1034  #
  1035  # Maintenance History - as this file is modified, please be sure that you
  1036  #                       update this segment of the file header block by
  1037  #                       adding a complete entry at the bottom of the list.
  1038  #
  1039  # Version     Date     Programmer   Comments / Changes / Reasons
  1040  # -------  ----------  ----------   -------------------------------------------
  1041  #       1  07/06/2006  G.Lester     Initial version
  1042  #   2.4.1  2017-08-31  H.Oehlmann   Use utility function
  1043  #                                   ::WS::Utils::geturl_fetchbody for http call
  1044  #   2.4.6  2017-12-07  H.Oehlmann   Added argument "serviceNumber".
  1045  #
  1046  ###########################################################################
  1047  proc ::WS::Client::GetAndParseWsdl {url {headers {}} {serviceAlias {}} {serviceNumber 1}} {
  1048      variable currentBaseUrl
  1049  
  1050      set currentBaseUrl $url
  1051      switch -exact -- [dict get [::uri::split $url] scheme] {
  1052          file {
  1053              upvar #0 [::uri::geturl $url] token
  1054              set wsdlInfo [ParseWsdl $token(data) -headers $headers -serviceAlias $serviceAlias -serviceNumber $serviceNumber]
  1055              unset token
  1056          }
  1057          http -
  1058          https {
  1059              if {[llength $headers]} {
  1060                  set body [::WS::Utils::geturl_fetchbody $url -headers $headers]
  1061              } else {
  1062                  set body [::WS::Utils::geturl_fetchbody $url]
  1063              }
  1064              set wsdlInfo [ParseWsdl $body -headers $headers -serviceAlias $serviceAlias -serviceNumber $serviceNumber]
  1065          }
  1066          default {
  1067              return \
  1068                  -code error \
  1069                  -errorcode [list WS CLIENT UNKURLTYP $url] \
  1070                  "Unknown URL type '$url'"
  1071          }
  1072      }
  1073      set currentBaseUrl {}
  1074  
  1075      return $wsdlInfo
  1076  }
  1077  
  1078  ###########################################################################
  1079  #
  1080  # Public Procedure Header - as this procedure is modified, please be sure
  1081  #                           that you update this header block. Thanks.
  1082  #
  1083  #>>BEGIN PUBLIC<<
  1084  #
  1085  # Procedure Name : ::WS::Client::ParseWsdl
  1086  #
  1087  # Description : Parse a WSDL and create the service. Create stubs if specified.
  1088  #
  1089  # Arguments :
  1090  #       wsdlXML - XML of the WSDL
  1091  #
  1092  # Optional Arguments:
  1093  #       -createStubs 0|1 - create stub routines for the service
  1094  #       -headers         - Extra headers to add to the HTTP request. This
  1095  #                          is a key value list argument. It must be a list with
  1096  #                          an even number of elements that alternate between
  1097  #                          keys and values. The keys become header field names.
  1098  #                          Newlines are stripped from the values so the header
  1099  #                          cannot be corrupted.
  1100  #                          This is an optional argument and defaults to {}.
  1101  #       -serviceAlias    - Alias (unique) name for service.
  1102  #                          This is an optional argument and defaults to the
  1103  #                          name of the service in serviceInfo.
  1104  #       -serviceNumber   - Number of service within the WSDL to assign the
  1105  #                          serviceAlias to. Only usable with a serviceAlias.
  1106  #                          First service (default) is addressed by value "1".
  1107  #
  1108  # NOTE -- Arguments are position independent.
  1109  #
  1110  # Returns : The parsed service definition
  1111  #
  1112  # Side-Effects : None
  1113  #
  1114  # Exception Conditions :None
  1115  #
  1116  # Pre-requisite Conditions : None
  1117  #
  1118  # Original Author : Gerald W. Lester
  1119  #
  1120  #>>END PUBLIC<<
  1121  #
  1122  # Maintenance History - as this file is modified, please be sure that you
  1123  #                       update this segment of the file header block by
  1124  #                       adding a complete entry at the bottom of the list.
  1125  #
  1126  # Version     Date     Programmer   Comments / Changes / Reasons
  1127  # -------  ----------  ----------   -------------------------------------------
  1128  #       1  07/06/2006  G.Lester     Initial version
  1129  # 2.4.4    2017-11-03  H.Oehlmann  Included ticket [dcce437d7a] with
  1130  #                                   solution by Wolfgang Winkler:
  1131  #                                   Search namespace prfix also in element
  1132  #                                   nodes and not only in definition node
  1133  #                                   of wsdl file.
  1134  # 2.4.4    2017-11-06  H.Oehlmann   Added check (for nested namespace prefix
  1135  #                                   case), that a namespace prefix is not
  1136  #                                   reused for another URI.
  1137  # 2.4.5    2017-11-24  H.Oehlmann   Added option "inlineElementNS" to activate
  1138  #                                   namespace definition search in element nodes
  1139  # 2.4.6    2017-12-07  H.Oehlmann   Added argument "-serviceNumber".
  1140  #
  1141  ###########################################################################
  1142  proc ::WS::Client::ParseWsdl {wsdlXML args} {
  1143      variable currentBaseUrl
  1144      variable serviceArr
  1145      variable options
  1146  
  1147      # Build the argument array with the following defaults
  1148      array set argument {
  1149          -createStubs    0
  1150          -headers        {}
  1151          -serviceAlias   {}
  1152          -serviceNumber  1
  1153      }
  1154      array set argument $args
  1155  
  1156      set first [string first {<} $wsdlXML]
  1157      if {$first > 0} {
  1158          set wsdlXML [string range $wsdlXML $first end]
  1159      }
  1160      ::log::logsubst debug {Parsing WSDL: $wsdlXML}
  1161  
  1162      # save parsed document node to tmpdoc
  1163      dom parse $wsdlXML tmpdoc
  1164      # save transformed document handle in variable wsdlDoc
  1165      $tmpdoc xslt $::WS::Utils::xsltSchemaDom wsdlDoc
  1166      $tmpdoc delete
  1167      # save top node in variable wsdlNode
  1168      $wsdlDoc documentElement wsdlNode
  1169      set nsCount 1
  1170      set targetNs [$wsdlNode getAttribute targetNamespace]
  1171      set ::WS::Utils::targetNs $targetNs
  1172      ##
  1173      ## Build the namespace prefix dict
  1174      ##
  1175      # nsDict contains two tables:
  1176      # 1) Lookup URI, get internal prefix
  1177      #   url <URI> <tns>
  1178      # 2) Lookup wsdl namespace prefix, get internal namespace prefix
  1179      #   tns <ns> <tns>
  1180      # <URI>: unique ID, mostly URL
  1181      # <ns>: namespace prefix used in wsdl
  1182      # <tns> internal namespace prefix which allows to use predefined prefixes
  1183      #   not to clash with the wsdl prefix in <ns>
  1184      #   Predefined:
  1185      #   - tns1 : targetNamespace
  1186      #   - w: http://schemas.xmlsoap.org/wsdl/
  1187      #   - d: http://schemas.xmlsoap.org/wsdl/soap/
  1188      #   - xs: http://www.w3.org/2001/XMLSchema
  1189      #
  1190      # The top node
  1191      # <wsdl:definitions
  1192      #   targetNamespace="http://www.webserviceX.NET/">
  1193      #   xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/ ...>
  1194      # contains the target namespace and all namespace definitions
  1195      dict set nsDict url $targetNs tns$nsCount
  1196  
  1197      $wsdlDoc selectNodesNamespaces {
  1198          w http://schemas.xmlsoap.org/wsdl/
  1199          d http://schemas.xmlsoap.org/wsdl/soap/
  1200          xs http://www.w3.org/2001/XMLSchema
  1201      }
  1202  
  1203      ##
  1204      ## build list of namespace definition nodes
  1205      ##
  1206      ## the top node is always used
  1207      set NSDefinitionNodeList [list $wsdlNode]
  1208      
  1209      ##
  1210      ## get namespace definitions in element nodes
  1211      ##
  1212      ## Element nodes may declare namespaces inline like:
  1213      ## <xs:element xmlns:q1="myURI" type="q1:MessageQ1"/>
  1214      ## ticket [dcce437d7a]
  1215      
  1216      # This is only done, if option inlineElementNS is set in the default
  1217      # options. Service dependent options may not be used at this stage,
  1218      # as serviceArr is not created jet (Client::Config will fail) and the
  1219      # service name is not known jet.
  1220      if {$options(inlineElementNS)} {
  1221          lappend NSDefinitionNodeList {*}[$wsdlDoc selectNodes {//xs:element}]
  1222      }
  1223      foreach elemNode $NSDefinitionNodeList {
  1224          # Get list of xmlns attributes
  1225          # This list looks for the example like: {{q1 q1 {}} ... }
  1226          set xmlnsAttributes [$elemNode attributes xmlns:*] 
  1227          # Loop over found namespaces
  1228          foreach itemList $xmlnsAttributes {
  1229              set ns [lindex $itemList 0]
  1230              set url [$elemNode getAttribute xmlns:$ns]
  1231  
  1232              if {[dict exists $nsDict url $url]} {
  1233                  set tns [dict get $nsDict url $url]
  1234              } else {
  1235                  ##
  1236                  ## Check for hardcoded namespaces
  1237                  ##
  1238                  switch -exact -- $url {
  1239                      http://schemas.xmlsoap.org/wsdl/ {
  1240                          set tns w
  1241                      }
  1242                      http://schemas.xmlsoap.org/wsdl/soap/ {
  1243                          set tns d
  1244                      }
  1245                      http://www.w3.org/2001/XMLSchema {
  1246                          set tns xs
  1247                      }
  1248                      default {
  1249                          set tns tns[incr nsCount]
  1250                      }
  1251                  }
  1252                  dict set nsDict url $url $tns
  1253              }
  1254              ##
  1255              ## Check if same namespace prefix was already assigned to a
  1256              ## different URL
  1257              ##
  1258              # This may happen, if the element namespace prefix overwrites
  1259              # a global one, like
  1260              # <wsdl:definitions xmlns:q1="URI1" ...>
  1261              #   <xs:element xmlns:q1="URI2" type="q1:MessageQ1"/>
  1262              if { [dict exists $nsDict tns $ns] && $tns ne [dict get $nsDict tns $ns] } {
  1263                  ::log::logsubst debug {Namespace prefix '$ns' with different URI '$url': $nsDict}
  1264                  return \
  1265                      -code error \
  1266                      -errorcode [list WS CLIENT AMBIGNSPREFIX] \
  1267                      "element namespace prefix '$ns' used again for different URI '$url'.\
  1268                      Sorry, this is a current implementation limitation of TCLWS."
  1269              }
  1270              dict set nsDict tns $ns $tns
  1271          }
  1272      }
  1273  
  1274      if {[info exists currentBaseUrl]} {
  1275          set url $currentBaseUrl
  1276      } else {
  1277          set url $targetNs
  1278      }
  1279  
  1280      array unset ::WS::Utils::includeArr
  1281      ::WS::Utils::ProcessIncludes $wsdlNode $url
  1282  
  1283      set serviceInfo {}
  1284  
  1285      foreach serviceInfo [buildServiceInfo $wsdlNode $nsDict $serviceInfo $argument(-serviceAlias) $argument(-serviceNumber)] {
  1286          set serviceName [dict get $serviceInfo name]
  1287  
  1288          if {[llength $argument(-headers)]} {
  1289              dict set serviceInfo headers $argument(-headers)
  1290          }
  1291          dict set serviceInfo types [::WS::Utils::GetServiceTypeDef Client $serviceName]
  1292          dict set serviceInfo simpletypes [::WS::Utils::GetServiceSimpleTypeDef Client $serviceName]
  1293  
  1294          set serviceArr($serviceName) $serviceInfo
  1295  
  1296          if {$argument(-createStubs)} {
  1297              catch {namespace delete $serviceName}
  1298              namespace eval $serviceName {}
  1299              CreateStubs $serviceName
  1300          }
  1301      }
  1302  
  1303      $wsdlDoc delete
  1304      unset -nocomplain ::WS::Utils::targetNs
  1305  
  1306      return $serviceInfo
  1307  
  1308  }
  1309  
  1310  ###########################################################################
  1311  #
  1312  # Public Procedure Header - as this procedure is modified, please be sure
  1313  #                           that you update this header block. Thanks.
  1314  #
  1315  #>>BEGIN PUBLIC<<
  1316  #
  1317  # Procedure Name : ::WS::Client::CreateStubs
  1318  #
  1319  # Description : Create stubs routines to make calls to Webservice Operations.
  1320  #               All routines will be create in a namespace that is the same
  1321  #               as the service name.  The procedure name will be the same
  1322  #               as the operation name.
  1323  #
  1324  #               NOTE -- Webservice arguments are position independent, thus
  1325  #                       the proc arguments will be defined in alphabetical order.
  1326  #
  1327  # Arguments :
  1328  #       serviceName     - The service to create stubs for
  1329  #
  1330  # Returns : A string describing the created procedures.
  1331  #
  1332  # Side-Effects : Existing namespace is deleted.
  1333  #
  1334  # Exception Conditions : None
  1335  #
  1336  # Pre-requisite Conditions : Service must have been defined.
  1337  #
  1338  # Original Author : Gerald W. Lester
  1339  #
  1340  #>>END PUBLIC<<
  1341  #
  1342  # Maintenance History - as this file is modified, please be sure that you
  1343  #                       update this segment of the file header block by
  1344  #                       adding a complete entry at the bottom of the list.
  1345  #
  1346  # Version     Date     Programmer   Comments / Changes / Reasons
  1347  # -------  ----------  ----------   -------------------------------------------
  1348  #       1  07/06/2006  G.Lester     Initial version
  1349  #
  1350  #
  1351  ###########################################################################
  1352  proc ::WS::Client::CreateStubs {serviceName} {
  1353      variable serviceArr
  1354  
  1355      namespace eval [format {::%s::} $serviceName] {}
  1356  
  1357      if {![info exists serviceArr($serviceName)]} {
  1358          return \
  1359              -code error \
  1360              -errorcode [list WS CLIENT UNKSRV $serviceName] \
  1361              "Unknown service '$serviceName'"
  1362      }
  1363  
  1364      set serviceInfo $serviceArr($serviceName)
  1365  
  1366      set procList {}
  1367  
  1368      foreach operationName [dict get $serviceInfo operList] {
  1369          if {[dict get $serviceInfo operation $operationName cloned]} {
  1370              continue
  1371          }
  1372          set procName [format {::%s::%s} $serviceName $operationName]
  1373          set argList {}
  1374          foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] {
  1375              set  inputHeaderType [lindex $inputHeaderTypeItem 0]
  1376              if {$inputHeaderType eq {}} {
  1377                  continue
  1378              }
  1379              set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType]
  1380              set headerFields [dict keys [dict get $headerTypeInfo definition]]
  1381              if {$headerFields ne {}} {
  1382                  lappend argList [lsort -dictionary $headerFields]
  1383              }
  1384          }
  1385          set inputMsgType [dict get $serviceInfo operation $operationName inputs]
  1386          ## Petasis, 14 July 2008: If an input message has no elements, just do
  1387          ## not add any arguments...
  1388          set inputMsgTypeDefinition [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType]
  1389          if {[dict exists $inputMsgTypeDefinition definition]} {
  1390            set inputFields [dict keys [dict get $inputMsgTypeDefinition definition]]
  1391           } else {
  1392            ::log::logsubst debug {no definition found for inputMsgType $inputMsgType}
  1393            set inputFields {}
  1394          }
  1395          if {$inputFields ne {}} {
  1396              lappend argList [lsort -dictionary $inputFields]
  1397          }
  1398          set argList [join $argList]
  1399  
  1400          set body {
  1401              set procName [lindex [info level 0] 0]
  1402              set serviceName [string trim [namespace qualifiers $procName] {:}]
  1403              set operationName [string trim [namespace tail $procName] {:}]
  1404              set argList {}
  1405              foreach var [namespace eval ::${serviceName}:: [list info args $operationName]] {
  1406                  lappend argList $var [set $var]
  1407              }
  1408              ::log::logsubst debug {::WS::Client::DoCall $serviceName $operationName $argList}
  1409              ::WS::Client::DoCall $serviceName $operationName $argList
  1410          }
  1411          proc $procName $argList $body
  1412          append procList "\n\t[list $procName $argList]"
  1413      }
  1414      return "$procList\n"
  1415  }
  1416  
  1417  ###########################################################################
  1418  #
  1419  # Public Procedure Header - as this procedure is modified, please be sure
  1420  #                           that you update this header block. Thanks.
  1421  #
  1422  #>>BEGIN PUBLIC<<
  1423  #
  1424  # Procedure Name : ::WS::Client::DoRawCall
  1425  #
  1426  # Description : Call an operation of a web service
  1427  #
  1428  # Arguments :
  1429  #       serviceName     - The name of the Webservice
  1430  #       operationName   - The name of the Operation to call
  1431  #       argList         - The arguments to the operation as a dictionary object.
  1432  #                         This is for both the Soap Header and Body messages.
  1433  #       headers         - Extra headers to add to the HTTP request. This
  1434  #                         is a key value list argument. It must be a list with
  1435  #                         an even number of elements that alternate between
  1436  #                         keys and values. The keys become header field names.
  1437  #                         Newlines are stripped from the values so the header
  1438  #                         cannot be corrupted.
  1439  #                         This is an optional argument and defaults to {}.
  1440  #
  1441  # Returns :
  1442  #       The XML of the operation.
  1443  #
  1444  # Side-Effects :        None
  1445  #
  1446  # Exception Conditions :
  1447  #       WS CLIENT HTTPERROR      - if an HTTP error occurred
  1448  #
  1449  # Pre-requisite Conditions :    Service must have been defined.
  1450  #
  1451  # Original Author : Gerald W. Lester
  1452  #
  1453  #>>END PUBLIC<<
  1454  #
  1455  # Maintenance History - as this file is modified, please be sure that you
  1456  #                       update this segment of the file header block by
  1457  #                       adding a complete entry at the bottom of the list.
  1458  #
  1459  # Version     Date     Programmer   Comments / Changes / Reasons
  1460  # -------  ----------  ----------   -------------------------------------------
  1461  #       1  07/06/2006  G.Lester     Initial version
  1462  # 2.4.1    2017-08-31  H.Oehlmann   Use utility function
  1463  #                                   ::WS::Utils::geturl_fetchbody for http call
  1464  #                                   which also follows redirects.
  1465  #
  1466  #
  1467  ###########################################################################
  1468  proc ::WS::Client::DoRawCall {serviceName operationName argList {headers {}}} {
  1469      variable serviceArr
  1470  
  1471      ::log::logsubst debug {Entering [info level 0]}
  1472      if {![info exists serviceArr($serviceName)]} {
  1473          return \
  1474              -code error \
  1475              -errorcode [list WS CLIENT UNKSRV $serviceName] \
  1476              "Unknown service '$serviceName'"
  1477      }
  1478      set serviceInfo $serviceArr($serviceName)
  1479      if {![dict exists $serviceInfo operation $operationName]} {
  1480          return \
  1481              -code error \
  1482              -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \
  1483              "Unknown operation '$operationName' for service '$serviceName'"
  1484      }
  1485      
  1486      ##
  1487      ## build query
  1488      ##
  1489      
  1490      set url [dict get $serviceInfo location]
  1491      SaveAndSetOptions $serviceName
  1492      if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} {
  1493          RestoreSavedOptions $serviceName
  1494          return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err
  1495      } else {
  1496          RestoreSavedOptions $serviceName
  1497      }
  1498      if {[dict exists $serviceInfo headers]} {
  1499          set headers [concat $headers [dict get $serviceInfo headers]]
  1500      }
  1501      if {[dict exists $serviceInfo operation $operationName action]} {
  1502          lappend headers  SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]]
  1503      }
  1504      
  1505      ##
  1506      ## do http call
  1507      ##
  1508      
  1509      if {[llength $headers]} {
  1510          set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
  1511      } else {
  1512          set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType]]
  1513      }
  1514  
  1515      ::log::logsubst debug {Leaving ::WS::Client::DoRawCall with {$body}}
  1516      return $body
  1517  
  1518  }
  1519  
  1520  ###########################################################################
  1521  #
  1522  # Public Procedure Header - as this procedure is modified, please be sure
  1523  #                           that you update this header block. Thanks.
  1524  #
  1525  #>>BEGIN PUBLIC<<
  1526  #
  1527  # Procedure Name : ::WS::Client::DoCall
  1528  #
  1529  # Description : Call an operation of a web service
  1530  #
  1531  # Arguments :
  1532  #       serviceName     - The name of the Webservice
  1533  #       operationName   - The name of the Operation to call
  1534  #       argList         - The arguments to the operation as a dictionary object
  1535  #                         This is for both the Soap Header and Body messages.
  1536  #       headers         - Extra headers to add to the HTTP request. This
  1537  #                         is a key value list argument. It must be a list with
  1538  #                         an even number of elements that alternate between
  1539  #                         keys and values. The keys become header field names.
  1540  #                         Newlines are stripped from the values so the header
  1541  #                         cannot be corrupted.
  1542  #                         This is an optional argument and defaults to {}.
  1543  #
  1544  # Returns :
  1545  #       The return value of the operation as a dictionary object.
  1546  #
  1547  # Side-Effects :        None
  1548  #
  1549  # Exception Conditions :
  1550  #       WS CLIENT HTTPERROR      - if an HTTP error occurred
  1551  #       others                  - as raised by called Operation
  1552  #
  1553  # Pre-requisite Conditions :    Service must have been defined.
  1554  #
  1555  # Original Author : Gerald W. Lester
  1556  #
  1557  #>>END PUBLIC<<
  1558  #
  1559  # Maintenance History - as this file is modified, please be sure that you
  1560  #                       update this segment of the file header block by
  1561  #                       adding a complete entry at the bottom of the list.
  1562  #
  1563  # Version     Date     Programmer   Comments / Changes / Reasons
  1564  # -------  ----------  ----------   -------------------------------------------
  1565  #       1  07/06/2006  G.Lester     Initial version
  1566  # 2.4.1    2017-08-30  H.Oehlmann   Use ::WS::Utils::geturl_fetchbody to do
  1567  #                                   http call. This automates a lot and follows
  1568  #                                   redirects.
  1569  #
  1570  #
  1571  ###########################################################################
  1572  proc ::WS::Client::DoCall {serviceName operationName argList {headers {}}} {
  1573      variable serviceArr
  1574  
  1575      ::log::logsubst debug {Entering [info level 0]}
  1576      if {![info exists serviceArr($serviceName)]} {
  1577          return \
  1578              -code error \
  1579              -errorcode [list WS CLIENT UNKSRV $serviceName] \
  1580              "Unknown service '$serviceName'"
  1581      }
  1582      set serviceInfo $serviceArr($serviceName)
  1583      if {![dict exists $serviceInfo operation $operationName]} {
  1584          return \
  1585              -code error \
  1586              -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \
  1587              "Unknown operation '$operationName' for service '$serviceName'"
  1588      } elseif {[dict get $serviceInfo operation $operationName cloned]} {
  1589          return \
  1590              -code error \
  1591              -errorcode [list WS CLIENT MUSTCALLCLONE [list $serviceName $operationName]] \
  1592              "Operation '$operationName' for service '$serviceName' is overloaded, you must call one of its clones."
  1593      }
  1594  
  1595      set url [dict get $serviceInfo location]
  1596      SaveAndSetOptions $serviceName
  1597      if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} {
  1598          RestoreSavedOptions $serviceName
  1599          return -code error -errorcode $::errorCode -errorinfo $::errorInfo "buildCallquery error -- $err"
  1600      } else {
  1601          RestoreSavedOptions $serviceName
  1602      }
  1603      if {[dict exists $serviceInfo headers]} {
  1604          set headers [concat $headers [dict get $serviceInfo headers]]
  1605      }
  1606      if {[dict exists $serviceInfo operation $operationName action]} {
  1607          lappend headers  SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]]
  1608      }
  1609      ##
  1610      ## Do the http request
  1611      ##
  1612      # This will directly return with correct error
  1613      # side effect: sets the variable httpCode
  1614      if {[llength $headers]} {
  1615          set body [::WS::Utils::geturl_fetchbody -codeok {200 500} -codevar httpCode $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
  1616      } else {
  1617          set body [::WS::Utils::geturl_fetchbody -codeok {200 500} -codevar httpCode $url -query $query -type [dict get $serviceInfo contentType] ]
  1618      }
  1619      # numerical http code was saved in variable httpCode
  1620  
  1621      ##
  1622      ## Process body
  1623      ##
  1624      set outTransform [dict get $serviceInfo outTransform]
  1625      if {$httpCode == 500} {
  1626          ## Code 500 treatment
  1627          if {$outTransform ne {}} {
  1628              SaveAndSetOptions $serviceName
  1629              catch {set body [$outTransform $serviceName $operationName REPLY $body]}
  1630              RestoreSavedOptions $serviceName
  1631          }
  1632          set hadError [catch {parseResults $serviceName $operationName $body} results]
  1633          if {$hadError} {
  1634              lassign $::errorCode mainError subError
  1635              if {$mainError eq {WSCLIENT} && $subError eq {NOSOAP}} {
  1636                  ::log::logsubst debug {\tHTTP error $body}
  1637                  set results $body
  1638                  set errorCode [list WSCLIENT HTTPERROR $body]
  1639                  set errorInfo {}
  1640              } else {
  1641                  ::log::logsubst debug {Reply was $body}
  1642                  set errorCode $::errorCode
  1643                  set errorInfo $::errorInfo
  1644              }
  1645          }
  1646      } else {
  1647          if {$outTransform ne {}} {
  1648              SaveAndSetOptions $serviceName
  1649              catch {set body [$outTransform $serviceName $operationName REPLY $body]}
  1650              RestoreSavedOptions $serviceName
  1651          }
  1652          SaveAndSetOptions $serviceName
  1653          set hadError [catch {parseResults $serviceName $operationName $body} results]
  1654          RestoreSavedOptions $serviceName
  1655          if {$hadError} {
  1656              ::log::logsubst debug {Reply was $body}
  1657              set errorCode $::errorCode
  1658              set errorInfo $::errorInfo
  1659          }
  1660      }
  1661      if {$hadError} {
  1662          ::log::log debug "Leaving (error) ::WS::Client::DoCall"
  1663          return \
  1664              -code error \
  1665              -errorcode $errorCode \
  1666              -errorinfo $errorInfo \
  1667              $results
  1668      } else {
  1669          ::log::logsubst debug {Leaving ::WS::Client::DoCall with {$results}}
  1670          return $results
  1671      }
  1672  
  1673  }
  1674  
  1675  ###########################################################################
  1676  #
  1677  # Public Procedure Header - as this procedure is modified, please be sure
  1678  #                           that you update this header block. Thanks.
  1679  #
  1680  #>>BEGIN PUBLIC<<
  1681  #
  1682  # Procedure Name : ::WS::Client::FormatHTTPError
  1683  #
  1684  # Description : Format error after a http::geturl failure.
  1685  # A failure consists wether in the HTTP return code unequal to 200
  1686  # or in the status equal "error". Status "timeout" is untreated, as this
  1687  # http feature is not used in the package.
  1688  #
  1689  # Arguments :
  1690  #       tolken          - tolken of the http::geturl request
  1691  #
  1692  # Returns :
  1693  #       Error message
  1694  #
  1695  # Side-Effects :        None
  1696  #
  1697  # Pre-requisite Conditions :    HTTP failure must be present
  1698  #
  1699  # Original Author : Harald Oehlmann
  1700  #
  1701  #>>END PUBLIC<<
  1702  #
  1703  # Maintenance History - as this file is modified, please be sure that you
  1704  #                       update this segment of the file header block by
  1705  #                       adding a complete entry at the bottom of the list.
  1706  #
  1707  # Version     Date     Programmer   Comments / Changes / Reasons
  1708  # -------  ----------  ----------   -------------------------------------------
  1709  #       1  06/02/2015  H.Oehlmann   Initial version
  1710  #
  1711  #
  1712  ###########################################################################
  1713  proc ::WS::Client::FormatHTTPError {token} {
  1714      if {[::http::status $token] eq {ok}} {
  1715          if {[::http::size $token] == 0} {
  1716              return "HTTP failure socket closed"
  1717          }
  1718          return "HTTP failure code [::http::ncode $token]"
  1719      } else {
  1720          return "HTTP error: [::http::error $token]"
  1721      }
  1722  }
  1723  
  1724  ###########################################################################
  1725  #
  1726  # Public Procedure Header - as this procedure is modified, please be sure
  1727  #                           that you update this header block. Thanks.
  1728  #
  1729  #>>BEGIN PUBLIC<<
  1730  #
  1731  # Procedure Name : ::WS::Client::DoAsyncCall
  1732  #
  1733  # Description : Call an operation of a web service asynchronously
  1734  #
  1735  # Arguments :
  1736  #       serviceName     - The name of the Webservice
  1737  #       operationName   - The name of the Operation to call
  1738  #       argList         - The arguments to the operation as a dictionary object
  1739  #                         This is for both the Soap Header and Body messages.
  1740  #       succesCmd       - A command prefix to be called if the operations
  1741  #                         does not raise an error.  The results, as a dictionary
  1742  #                         object are concatenated to the prefix.
  1743  #       errorCmd        - A command prefix to be called if the operations
  1744  #                         raises an error.  The error code and stack trace
  1745  #                         are concatenated to the prefix.
  1746  #       headers         - Extra headers to add to the HTTP request. This
  1747  #                         is a key value list argument. It must be a list with
  1748  #                         an even number of elements that alternate between
  1749  #                         keys and values. The keys become header field names.
  1750  #                         Newlines are stripped from the values so the header
  1751  #                         cannot be corrupted.
  1752  #                         This is an optional argument and defaults to {}.
  1753  #
  1754  # Returns :
  1755  #       None.
  1756  #
  1757  # Side-Effects :        None
  1758  #
  1759  # Exception Conditions :
  1760  #       WS CLIENT HTTPERROR      - if an HTTP error occurred
  1761  #       others                  - as raised by called Operation
  1762  #
  1763  # Pre-requisite Conditions :    Service must have been defined.
  1764  #
  1765  # Original Author : Gerald W. Lester
  1766  #
  1767  #>>END PUBLIC<<
  1768  #
  1769  # Maintenance History - as this file is modified, please be sure that you
  1770  #                       update this segment of the file header block by
  1771  #                       adding a complete entry at the bottom of the list.
  1772  #
  1773  # Version     Date     Programmer   Comments / Changes / Reasons
  1774  # -------  ----------  ----------   -------------------------------------------
  1775  #       1  07/06/2006  G.Lester     Initial version
  1776  #
  1777  #
  1778  ###########################################################################
  1779  proc ::WS::Client::DoAsyncCall {serviceName operationName argList succesCmd errorCmd {headers {}}} {
  1780      variable serviceArr
  1781  
  1782      ::log::logsubst debug {Entering [info level 0]}
  1783      if {![info exists serviceArr($serviceName)]} {
  1784          return \
  1785              -code error \
  1786              -errorcode [list WS CLIENT UNKSRV $serviceName] \
  1787              "Unknown service '$serviceName'"
  1788      }
  1789      set serviceInfo $serviceArr($serviceName)
  1790      if {![dict exists $serviceInfo operation $operationName]} {
  1791          return \
  1792              -code error \
  1793              -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \
  1794              "Unknown operation '$operationName' for service '$serviceName'"
  1795      }
  1796      if {[dict exists $serviceInfo headers]} {
  1797          set headers [concat $headers [dict get $serviceInfo headers]]
  1798      }
  1799      set url [dict get $serviceInfo location]
  1800      SaveAndSetOptions $serviceName
  1801      if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} {
  1802          RestoreSavedOptions $serviceName
  1803          return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err
  1804      } else {
  1805          RestoreSavedOptions $serviceName
  1806      }
  1807      if {[llength $headers]} {
  1808          ::log::logsubst info {::http::geturl $url \
  1809                  -query $query \
  1810                  -type [dict get $serviceInfo contentType] \
  1811                  -headers $headers \
  1812                  -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]}
  1813          ::http::geturl $url \
  1814              -query $query \
  1815              -type [dict get $serviceInfo contentType] \
  1816              -headers $headers \
  1817              -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]
  1818      } else {
  1819          ::log::logsubst info {::http::geturl $url \
  1820                  -query $query \
  1821                  -type [dict get $serviceInfo contentType] \
  1822                  -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]}
  1823          ::http::geturl $url \
  1824              -query $query \
  1825              -type [dict get $serviceInfo contentType] \
  1826              -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]
  1827      }
  1828      ::log::logsubst debug {Leaving ::WS::Client::DoAsyncCall}
  1829      return;
  1830  }
  1831  
  1832  ###########################################################################
  1833  #
  1834  # Public Procedure Header - as this procedure is modified, please be sure
  1835  #                           that you update this header block. Thanks.
  1836  #
  1837  #>>BEGIN PUBLIC<<
  1838  #
  1839  # Procedure Name : ::WS::Client::List
  1840  #
  1841  # Description : List a Webservice's Operations.
  1842  #
  1843  #               NOTE -- Webservice arguments are position independent, thus
  1844  #                       the proc arguments will be defined in alphabetical order.
  1845  #
  1846  # Arguments :
  1847  #       serviceName     - The service to create stubs for
  1848  #
  1849  # Returns : A string describing the operations.
  1850  #
  1851  # Side-Effects : Existing namespace is deleted.
  1852  #
  1853  # Exception Conditions : None
  1854  #
  1855  # Pre-requisite Conditions : Service must have been defined.
  1856  #
  1857  # Original Author : Gerald W. Lester
  1858  #
  1859  #>>END PUBLIC<<
  1860  #
  1861  # Maintenance History - as this file is modified, please be sure that you
  1862  #                       update this segment of the file header block by
  1863  #                       adding a complete entry at the bottom of the list.
  1864  #
  1865  # Version     Date     Programmer   Comments / Changes / Reasons
  1866  # -------  ----------  ----------   -------------------------------------------
  1867  #       1  10/11/2006  G.Lester     Initial version
  1868  #
  1869  #
  1870  ###########################################################################
  1871  proc ::WS::Client::List {serviceName} {
  1872      variable serviceArr
  1873  
  1874      if {![info exists serviceArr($serviceName)]} {
  1875          return \
  1876              -code error \
  1877              -errorcode [list WS CLIENT UNKSRV $serviceName] \
  1878              "Unknown service '$serviceName'"
  1879      }
  1880  
  1881      set serviceInfo $serviceArr($serviceName)
  1882  
  1883      set procList {}
  1884  
  1885      foreach operationName [lsort -dictionary [dict get $serviceInfo operList]] {
  1886          if {[dict get $serviceInfo operation $operationName cloned]} {
  1887              continue
  1888          }
  1889          set procName $operationName
  1890          set argList {}
  1891          foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] {
  1892              set inputHeaderType [lindex $inputHeaderTypeItem 0]
  1893              if {$inputHeaderType eq {}} {
  1894                  continue
  1895              }
  1896              set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType]
  1897              set headerFields [dict keys [dict get $headerTypeInfo definition]]
  1898              if {$headerFields ne {}} {
  1899                  lappend argList [lsort -dictionary $headerFields]
  1900              }
  1901          }
  1902          set inputMsgType [dict get $serviceInfo operation $operationName inputs]
  1903          if {$inputMsgType ne {}} {
  1904              set inTypeDef [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType]
  1905              if {[dict exists $inTypeDef definition]} {
  1906                  set inputFields [dict keys [dict get $inTypeDef definition]]
  1907                  if {$inputFields ne {}} {
  1908                      lappend argList [lsort -dictionary $inputFields]
  1909                  }
  1910              }
  1911          }
  1912          set argList [join $argList]
  1913  
  1914          append procList "\n\t$procName $argList"
  1915      }
  1916      return "$procList\n"
  1917  }
  1918  
  1919  ###########################################################################
  1920  #
  1921  # Public Procedure Header - as this procedure is modified, please be sure
  1922  #                           that you update this header block. Thanks.
  1923  #
  1924  #>>BEGIN PUBLIC<<
  1925  #
  1926  # Procedure Name : ::WS::Client::ListRest
  1927  #
  1928  # Description : List a Webservice's Operations.
  1929  #
  1930  #               NOTE -- Webservice arguments are position independent, thus
  1931  #                       the proc arguments will be defined in alphabetical order.
  1932  #
  1933  # Arguments :
  1934  #       serviceName     - The service to create stubs for
  1935  #
  1936  # Returns : A string describing the operations.
  1937  #
  1938  # Side-Effects : Existing namespace is deleted.
  1939  #
  1940  # Exception Conditions : None
  1941  #
  1942  # Pre-requisite Conditions : Service must have been defined.
  1943  #
  1944  # Original Author : Gerald W. Lester
  1945  #
  1946  #>>END PUBLIC<<
  1947  #
  1948  # Maintenance History - as this file is modified, please be sure that you
  1949  #                       update this segment of the file header block by
  1950  #                       adding a complete entry at the bottom of the list.
  1951  #
  1952  # Version     Date     Programmer   Comments / Changes / Reasons
  1953  # -------  ----------  ----------   -------------------------------------------
  1954  #       1  10/11/2006  G.Lester     Initial version
  1955  #
  1956  #
  1957  ###########################################################################
  1958  proc ::WS::Client::ListRest {serviceName} {
  1959      variable serviceArr
  1960  
  1961      if {![info exists serviceArr($serviceName)]} {
  1962          return \
  1963              -code error \
  1964              -errorcode [list WS CLIENT UNKSRV $serviceName] \
  1965              "Unknown service '$serviceName'"
  1966      }
  1967  
  1968      set serviceInfo $serviceArr($serviceName)
  1969  
  1970      set procList {}
  1971  
  1972      foreach object [dict get $serviceInfo objList] {
  1973          foreach operationName [dict keys [dict get $serviceInfo object $object operations]] {
  1974              set procName $operationName
  1975              set argList {}
  1976              foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] {
  1977                  set inputHeaderType [lindex $inputHeaderTypeItem 0]
  1978                  if {$inputHeaderType eq {}} {
  1979                      continue
  1980                  }
  1981                  set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType]
  1982                  set headerFields [dict keys [dict get $headerTypeInfo definition]]
  1983                  if {$headerFields ne {}} {
  1984                      lappend argList [lsort -dictionary $headerFields]
  1985                  }
  1986              }
  1987              set inputMsgType [dict get $serviceInfo operation $operationName inputs]
  1988              set inputFields [dict keys [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] definition]]
  1989              if {$inputFields ne {}} {
  1990                  lappend argList [lsort -dictionary $inputFields]
  1991              }
  1992              set argList [join $argList]
  1993  
  1994              append procList "\n\t$object $procName $argList"
  1995          }
  1996      }
  1997      return "$procList\n"
  1998  }
  1999  
  2000  
  2001  ###########################################################################
  2002  #
  2003  # Private Procedure Header - as this procedure is modified, please be sure
  2004  #                            that you update this header block. Thanks.
  2005  #
  2006  #>>BEGIN PRIVATE<<
  2007  #
  2008  # Procedure Name : ::WS::Client::asyncCallDone
  2009  #
  2010  # Description : Called when an asynchronous call is complete.  This routine
  2011  #               will call either the success or error callback depending on
  2012  #               if the operation succeeded or failed -- assuming the callback
  2013  #               is defined.
  2014  #
  2015  # Arguments :
  2016  #    serviceName        - the name of the service called
  2017  #    operationName      - the name of the operation called
  2018  #    succesCmd          - the command prefix to call if no error
  2019  #    errorCmd           - the command prefix to call on an error
  2020  #    token              - the token from the HTTP request
  2021  #
  2022  # Returns : Nothing
  2023  #
  2024  # Side-Effects : None
  2025  #
  2026  # Exception Conditions : None
  2027  #
  2028  # Pre-requisite Conditions : None
  2029  #
  2030  # Original Author : Gerald W. Lester
  2031  #
  2032  #>>END PRIVATE<<
  2033  #
  2034  # Maintenance History - as this file is modified, please be sure that you
  2035  #                       update this segment of the file header block by
  2036  #                       adding a complete entry at the bottom of the list.
  2037  #
  2038  # Version     Date     Programmer   Comments / Changes / Reasons
  2039  # -------  ----------  ----------   -------------------------------------------
  2040  #       1  07/06/2006  G.Lester     Initial version
  2041  #
  2042  #
  2043  ###########################################################################
  2044  proc ::WS::Client::asyncCallDone {serviceName operationName succesCmd errorCmd token} {
  2045      ::log::logsubst debug {Entering [info level 0]}
  2046  
  2047      ##
  2048      ## Check for errors
  2049      ##
  2050      set body [::http::data $token]
  2051      ::log::logsubst info {\nReceived: $body}
  2052      set results {}
  2053      if {[::http::status $token] ne {ok} ||
  2054          ( [::http::ncode $token] != 200 && $body eq {} )} {
  2055          set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
  2056          set hadError 1
  2057          set errorInfo [FormatHTTPError $token]
  2058      } else {
  2059          SaveAndSetOptions $serviceName
  2060          if {[catch {set hadError [catch {parseResults $serviceName $operationName $body} results]} err]} {
  2061              RestoreSavedOptions $serviceName
  2062              return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err
  2063          } else {
  2064              RestoreSavedOptions $serviceName
  2065          }
  2066          if {$hadError} {
  2067              set errorCode $::errorCode
  2068              set errorInfo $::errorInfo
  2069          }
  2070      }
  2071  
  2072      ##
  2073      ## Call the appropriate callback
  2074      ##
  2075      if {$hadError} {
  2076          set cmd $errorCmd
  2077          lappend cmd $errorCode $errorInfo
  2078      } else {
  2079          set cmd $succesCmd
  2080      }
  2081      lappend cmd $results
  2082      catch $cmd
  2083  
  2084      ##
  2085      ## All done
  2086      ##
  2087      ::http::cleanup $token
  2088      return;
  2089  }
  2090  
  2091  ###########################################################################
  2092  #
  2093  # Private Procedure Header - as this procedure is modified, please be sure
  2094  #                            that you update this header block. Thanks.
  2095  #
  2096  #>>BEGIN PRIVATE<<
  2097  #
  2098  # Procedure Name : ::WS::Client::parseResults
  2099  #
  2100  # Description : Convert the returned XML into a dictionary object
  2101  #
  2102  # Arguments :
  2103  #    serviceName        - the name of the service called
  2104  #    operationName      - the name of the operation called
  2105  #    inXML              - the XML returned by the operation
  2106  #
  2107  # Returns : A dictionary object representing the results
  2108  #
  2109  # Side-Effects : None
  2110  #
  2111  # Exception Conditions :
  2112  #       WS CLIENT REMERR         - The remote end raised an exception, the third element of
  2113  #                                 the error code is the remote fault code.
  2114  #                                 Error info is set to the remote fault details.
  2115  #                                 The error message is the remote fault string;
  2116  #       WS CLIENT BADREPLY       - Badly formatted reply, the third element is a list of
  2117  #                                 what message type was received vs what was expected.
  2118  #
  2119  # Pre-requisite Conditions : None
  2120  #
  2121  # Original Author : Gerald W. Lester
  2122  #
  2123  #>>END PRIVATE<<
  2124  #
  2125  # Maintenance History - as this file is modified, please be sure that you
  2126  #                       update this segment of the file header block by
  2127  #                       adding a complete entry at the bottom of the list.
  2128  #
  2129  # Version     Date     Programmer   Comments / Changes / Reasons
  2130  # -------  ----------  ----------   -------------------------------------------
  2131  #       1  07/06/2006  G.Lester     Initial version
  2132  # 2.4.2    2017-08-31  H.Oehlmann   The response node name may also be the
  2133  #                                   output name and not only the output type.
  2134  #                                   (ticket [21f41e22bc]).
  2135  # 2.4.3    2017-11-03  H.Oehlmann   Extended upper commit also to search
  2136  #                                   for multiple child nodes.
  2137  # 2.5.1    2018-05-14  H.Oehlmann   Add support to translate namespace prefixes
  2138  #                                   in attribute values or text values.
  2139  #                                   Translation dict "xnsDistantToLocalDict" is
  2140  #                                   passed to ::WS::Utils::convertTypeToDict
  2141  #                                   to translate abstract types.
  2142  #
  2143  ###########################################################################
  2144  proc ::WS::Client::parseResults {serviceName operationName inXML} {
  2145      variable serviceArr
  2146  
  2147      ::log::logsubst debug {Entering [info level 0]}
  2148  
  2149      set serviceInfo $serviceArr($serviceName)
  2150  
  2151      set expectedMsgType [dict get $serviceInfo operation $operationName outputs]
  2152      set expectedMsgTypeBase [lindex [split $expectedMsgType {:}] end]
  2153  
  2154      set first [string first {<} $inXML]
  2155      if {$first > 0} {
  2156          set inXML [string range $inXML $first end]
  2157      }
  2158      # parse xml and save handle in variable doc and free it when out of scope
  2159      dom parse $inXML doc
  2160  
  2161      # save top node handle in variable top and free it if out of scope
  2162      $doc documentElement top
  2163  
  2164      set xns {
  2165          ENV http://schemas.xmlsoap.org/soap/envelope/
  2166          xsi "http://www.w3.org/2001/XMLSchema-instance"
  2167          xs "http://www.w3.org/2001/XMLSchema"
  2168      }
  2169      foreach {prefixCur URICur} [dict get $serviceInfo targetNamespace] {
  2170          lappend xns $prefixCur $URICur
  2171      }
  2172      ::log::logsubst debug {Using namespaces {$xns}}
  2173      $doc selectNodesNamespaces $xns
  2174  
  2175      ##
  2176      ## When arguments with tags are passed (example: abstract types),
  2177      ## the upper "selectNodesNamespaces translation must be executed manually.
  2178      ## Thus, we need a list of server namespace prefixes to our client namespace
  2179      ## prefixes. (bug 584bfb77)
  2180      ##
  2181      # Example xml:
  2182      # <soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"
  2183      #   xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
  2184      #   xmlns:xsd="http://www.w3.org/2001/XMLSchema"
  2185      #   xmlns:tns="http://www.esri.com/schemas/ArcGIS/10.3">
  2186  
2187 set xnsDistantToLocalDict {} 2188 foreach attributeCur [$top attributes] { 2189 # attributeCur is a list of "prefix local URI", 2190 # which is for xmlns tags: "prefix prefix {}". 2191 set attributeCur [lindex $attributeCur 0] 2192 # Check if this is a namespace prefix 2193 if { ! [$top hasAttribute "xmlns:$attributeCur"] } {continue} 2194 set URIServer [$top getAttribute "xmlns:$attributeCur"] 2195 # Check if it is included in xns 2196 foreach {prefixCur URICur} $xns { 2197 if {$URIServer eq $URICur} { 2198 dict set xnsDistantToLocalDict $attributeCur $prefixCur 2199 break 2200 } 2201 } 2202 } 2203 ::log::logsubst debug {Server to Client prefix dict: $xnsDistantToLocalDict}
2204 2205 ## 2206 ## Get body tag 2207 ## 2208 set body [$top selectNodes ENV:Body] 2209 if {![llength $body]} { 2210 return \ 2211 -code error \ 2212 -errorcode [list WS CLIENT BADREPLY $inXML] \ 2213 "Bad reply type, no SOAP envelope received in: \n$inXML" 2214 } 2215 ## 2216 ## Find the reply root node with the response. 2217 ## 2218 # <SOAP-ENV:Envelope...> 2219 # <SOAP-ENV:Body> 2220 # <i2:TestResponse id="ref-1" xmlns:i2=...> <-- this one 2221 # 2222 # WSDL 1.0: http://xml.coverpages.org/wsdl20000929.html 2223 # Chapter 2.4.2 (name optional) and 2.4.5 (default name) 2224 # The node name could be: 2225 # 1) an error node "Fault" 2226 # 2) equal to the WSDL name property of the output node 2227 # 3) if no name tag, equal to <Operation>Response 2228 # 4) the local output type name 2229 # 2230 # Possibility (2) "OutName" WSDL example: 2231 # <wsdl:portType...><wsdl:operation...> 2232 # <wsdl:output name="{OutName}" message="tns:{OutMsgName}" /> 2233 # This possibility is requested by ticket [21f41e22bc] 2234 # 2235 # Possibility (3) default name "{OperationName}Result" WSDL example: 2236 # <wsdl:portType...><wsdl:operation name="{OperationName}"> 2237 # <wsdl:output message="tns:{OutMsgName}" -> *** no name tag *** 2238 # 2239 # Possibility (4) was not found in wsdl 1.0 standard but was used as only 2240 # solution by TCLWS prior to 2.4.2. 2241 # The following sketch shows the location of the local output type name 2242 # "OutTypeName" in a WSDL file: 2243 # -> In WSDL portType output message name 2244 # <wsdl:portType...><wsdl:operation...> 2245 # <wsdl:output message="tns:{OutMsgName}" /> 2246 # -> then in message, use the element: 2247 # <wsdl:message name="{OutMsgName}"> 2248 # <wsdl:part name="..." element="tns:<{OutTypeName}>" /> 2249 # -> The element "OutTypeName" is also find in a type definition: 2250 # <wsdl:types> 2251 # <s:element name="{OutMsgName}"> 2252 # <s:complexType>... 2253 # 2254 # Build a list of possible names 2255 set nodeNameCandidateList [list Fault $expectedMsgTypeBase] 2256 # We check if the preparsed wsdl contains the name flag. 2257 # This is not the case, if it was parsed with tclws prior 2.4.2 2258 # *** ToDo *** This security may be removed on a major release 2259 if {[dict exists $serviceInfo operation $operationName outputsname]} { 2260 lappend nodeNameCandidateList [dict get $serviceInfo operation $operationName outputsname] 2261 } 2262 2263 set rootNodeList [$body childNodes] 2264 ::log::logsubst debug {Have [llength $rootNodeList] node under Body} 2265 foreach rootNodeCur $rootNodeList { 2266 set rootNameCur [$rootNodeCur localName] 2267 if {$rootNameCur eq {}} { 2268 set rootNameCur [$rootNodeCur nodeName] 2269 } 2270 if {$rootNameCur in $nodeNameCandidateList} { 2271 set rootNode $rootNodeCur 2272 set rootName $rootNameCur 2273 ::log::logsubst debug {Result root name is '$rootName'} 2274 break 2275 } 2276 ::log::logsubst debug {Result root name '$rootNameCur' not in candidates '$nodeNameCandidateList'} 2277 } 2278 ## 2279 ## Exit if there is no such node 2280 ## 2281 if {![info exists rootName]} { 2282 return \ 2283 -code error \ 2284 -errorcode [list WS CLIENT BADREPLY [list $rootName $expectedMsgTypeBase]] \ 2285 "Bad reply type, received '$rootName'; but expected '$expectedMsgTypeBase'." 2286 } 2287 2288 ## 2289 ## See if it is a standard error packet 2290 ## 2291 if {$rootName eq {Fault}} { 2292 set faultcode {} 2293 set faultstring {} 2294 set detail {} 2295 foreach item {faultcode faultstring detail} { 2296 set tmpNode [$rootNode selectNodes ENV:$item] 2297 if {$tmpNode eq {}} { 2298 set tmpNode [$rootNode selectNodes $item] 2299 } 2300 if {$tmpNode ne {}} { 2301 if {[$tmpNode hasAttribute href]} { 2302 set tmpNode [GetReferenceNode $top [$tmpNode getAttribute href]] 2303 } 2304 set $item [$tmpNode asText] 2305 } 2306 } 2307 $doc delete 2308 return \ 2309 -code error \ 2310 -errorcode [list WS CLIENT REMERR $faultcode] \ 2311 -errorinfo $detail \ 2312 $faultstring 2313 } 2314 2315 ## 2316 ## Convert the packet to a dictionary 2317 ## 2318 set results {} 2319 set headerRootNode [$top selectNodes ENV:Header] 2320 if {[llength $headerRootNode]} { 2321 foreach outHeaderType [dict get $serviceInfo operation $operationName soapReplyHeader] { 2322 if {$outHeaderType eq {}} { 2323 continue 2324 } 2325 set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $outHeaderType] xns] 2326 set node [$headerRootNode selectNodes $outHeaderType] 2327 if {![llength $node]} { 2328 set node [$headerRootNode selectNodes $xns:$outHeaderType] 2329 if {![llength $node]} { 2330 continue 2331 } 2332 } 2333 2334 #if {[llength $outHeaderAttrs]} { 2335 # ::WS::Utils::setAttr $node $outHeaderAttrs 2336 #} 2337 ::log::logsubst debug {Calling convertTypeToDict from header node type '$outHeaderType'} 2338 lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode 0 $xnsDistantToLocalDict] 2339 } 2340 } 2341 ## 2342 ## Call Utility function to build result list 2343 ## 2344 if {$rootName ne {}} { 2345 ::log::log debug "Calling convertTypeToDict with root node" 2346 set bodyData [::WS::Utils::convertTypeToDict \ 2347 Client $serviceName $rootNode $expectedMsgType $body 0 $xnsDistantToLocalDict] 2348 if {![llength $bodyData] && ([dict get $serviceInfo skipLevelWhenActionPresent] || [dict get $serviceInfo skipLevelOnReply])} { 2349 ::log::log debug "Calling convertTypeToDict with skipped action level (skipLevelWhenActionPresent was set)" 2350 set bodyData [::WS::Utils::convertTypeToDict \ 2351 Client $serviceName $body $expectedMsgType $body 0 $xnsDistantToLocalDict] 2352 } 2353 lappend results $bodyData 2354 } 2355 set results [join $results] 2356 $doc delete 2357 set ::errorCode {} 2358 set ::errorInfo {} 2359 2360 return $results 2361 2362 } 2363 2364 ########################################################################### 2365 # 2366 # Private Procedure Header - as this procedure is modified, please be sure 2367 # that you update this header block. Thanks. 2368 # 2369 #>>BEGIN PRIVATE<< 2370 # 2371 # Procedure Name : ::WS::Client::buildCallquery 2372 # 2373 # Description : Build the XML request message for the call 2374 # 2375 # Arguments : 2376 # serviceName - the name of the service called 2377 # operationName - the name of the operation called 2378 # url - the URL of the operation 2379 # argList - a dictionary object of the calling arguments 2380 # 2381 # Returns : The XML for the call 2382 # 2383 # Side-Effects : None 2384 # 2385 # Exception Conditions : None 2386 # 2387 # Pre-requisite Conditions : None 2388 # 2389 # Original Author : Gerald W. Lester 2390 # 2391 #>>END PRIVATE<< 2392 # 2393 # Maintenance History - as this file is modified, please be sure that you 2394 # update this segment of the file header block by 2395 # adding a complete entry at the bottom of the list. 2396 # 2397 # Version Date Programmer Comments / Changes / Reasons 2398 # ------- ---------- ---------- ------------------------------------------- 2399 # 1 07/06/2006 G.Lester Initial version 2400 # 2401 # 2402 ########################################################################### 2403 proc ::WS::Client::buildCallquery {serviceName operationName url argList} { 2404 variable serviceArr 2405 2406 set serviceInfo $serviceArr($serviceName) 2407 2408 set style [dict get $serviceInfo operation $operationName style] 2409 set suppressTargetNS [dict get $serviceInfo suppressTargetNS] 2410 set inSuppressNs [::WS::Utils::SetOption suppressNS] 2411 if {$suppressTargetNS} { 2412 ::WS::Utils::SetOption suppressNS tns1 2413 } else { 2414 ::WS::Utils::SetOption suppressNS {} 2415 } 2416 2417 switch -exact -- $style { 2418 document/literal { 2419 set xml [buildDocLiteralCallquery $serviceName $operationName $url $argList] 2420 } 2421 rpc/encoded { 2422 set xml [buildRpcEncodedCallquery $serviceName $operationName $url $argList] 2423 } 2424 default { 2425 return \ 2426 -code error 2427 "Unsupported Style '$style'" 2428 } 2429 } 2430 2431 ::WS::Utils::SetOption suppressNS $inSuppressNs 2432 set inTransform [dict get $serviceInfo inTransform] 2433 if {$inTransform ne {}} { 2434 set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] 2435 } 2436 2437 ::log::logsubst debug {Leaving ::WS::Client::buildCallquery with {$xml}} 2438 return $xml 2439 2440 } 2441 2442 ########################################################################### 2443 # 2444 # Private Procedure Header - as this procedure is modified, please be sure 2445 # that you update this header block. Thanks. 2446 # 2447 #>>BEGIN PRIVATE<< 2448 # 2449 # Procedure Name : ::WS::Client::buildDocLiteralCallquery 2450 # 2451 # Description : Build the XML request message for the call 2452 # 2453 # Arguments : 2454 # serviceName - the name of the service called 2455 # operationName - the name of the operation called 2456 # url - the URL of the operation 2457 # argList - a dictionary object of the calling arguments 2458 # This is for both the Soap Header and Body messages. 2459 # 2460 # Returns : The XML for the call 2461 # 2462 # Side-Effects : None 2463 # 2464 # Exception Conditions : None 2465 # 2466 # Pre-requisite Conditions : None 2467 # 2468 # Original Author : Gerald W. Lester 2469 # 2470 #>>END PRIVATE<< 2471 # 2472 # Maintenance History - as this file is modified, please be sure that you 2473 # update this segment of the file header block by 2474 # adding a complete entry at the bottom of the list. 2475 # 2476 # Version Date Programmer Comments / Changes / Reasons 2477 # ------- ---------- ---------- ------------------------------------------- 2478 # 1 07/06/2006 G.Lester Initial version 2479 # 2480 # 2481 ########################################################################### 2482 proc ::WS::Client::buildDocLiteralCallquery {serviceName operationName url argList} { 2483 variable serviceArr 2484 2485 ::log::logsubst debug {Entering [info level 0]} 2486 set serviceInfo $serviceArr($serviceName) 2487 set msgType [dict get $serviceInfo operation $operationName inputs] 2488 set url [dict get $serviceInfo location] 2489 set xnsList [dict get $serviceInfo targetNamespace] 2490 2491 # save the document in variable doc and free it if out of scope 2492 dom createDocument "SOAP-ENV:Envelope" doc 2493 $doc documentElement env 2494 $env setAttribute \ 2495 "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ 2496 "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \ 2497 "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance" \ 2498 "xmlns:xs" "http://www.w3.org/2001/XMLSchema" 2499 if {[dict exists $serviceInfo noTargetNs] && ![dict get $serviceInfo noTargetNs]} { 2500 $env setAttribute "xmlns" [dict get $xnsList tns1] 2501 } 2502 array unset tnsArray * 2503 array set tnsArray { 2504 "http://schemas.xmlsoap.org/soap/envelope/" "xmlns:SOAP-ENV" 2505 "http://schemas.xmlsoap.org/soap/encoding/" "xmlns:SOAP-ENC" 2506 "http://www.w3.org/2001/XMLSchema-instance" "xmlns:xsi" 2507 "http://www.w3.org/2001/XMLSchema" "xmlns:xs" 2508 } 2509 foreach {tns target} $xnsList { 2510 #set tns [lindex $xns 0] 2511 #set target [lindex $xns 1] 2512 set tnsArray($target) $tns 2513 $env setAttribute \ 2514 xmlns:$tns $target 2515 } 2516 #parray tnsArray 2517 2518 set firstHeader 1 2519 foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { 2520 lassign $inputHeaderTypeItem inputHeaderType attrList 2521 if {$inputHeaderType eq {}} { 2522 continue 2523 } 2524 set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns] 2525 if {[info exists tnsArray($xns)]} { 2526 set xns $tnsArray($xns) 2527 } 2528 if {$firstHeader} { 2529 # side effect: save new node handle in variable header 2530 $env appendChild [$doc createElement "SOAP-ENV:Header" header] 2531 set firstHeader 0 2532 } 2533 if {[dict exists $serviceInfo skipHeaderLevel] && [dict get $serviceInfo skipHeaderLevel]} { 2534 set headerData $header 2535 } else { 2536 set typeInfo [split $inputHeaderType {:}] 2537 if {[llength $typeInfo] > 1} { 2538 set headerType $inputHeaderType 2539 } else { 2540 set headerType $xns:$inputHeaderType 2541 } 2542 $header appendChild [$doc createElement $headerType headerData] 2543 if {[llength $attrList]} { 2544 ::WS::Utils::setAttr $headerData $attrList 2545 } 2546 } 2547 ::WS::Utils::convertDictToType Client $serviceName $doc $headerData $argList $inputHeaderType 2548 } 2549 2550 # side effect: save new element handle in variable bod 2551 $env appendChild [$doc createElement "SOAP-ENV:Body" bod] 2552 #puts "set xns \[dict get \[::WS::Utils::GetServiceTypeDef Client $serviceName $msgType\] xns\]" 2553 #puts "\t [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType]" 2554 set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] 2555 if {[info exists tnsArray($xns)]} { 2556 set xns $tnsArray($xns) 2557 } 2558 set typeInfo [split $msgType {:}] 2559 if {[llength $typeInfo] != 1} { 2560 set xns [lindex $typeInfo 0] 2561 set msgType [lindex $typeInfo 1] 2562 } 2563 2564 if {[dict get $serviceInfo skipLevelWhenActionPresent] && [dict exists $serviceInfo operation $operationName action]} { 2565 set forceNs 1 2566 set reply $bod 2567 } else { 2568 ::log::logsubst debug {$bod appendChild \[$doc createElement $xns:$msgType reply\]} 2569 $bod appendChild [$doc createElement $xns:$msgType reply] 2570 set forceNs 0 2571 } 2572 2573 ::WS::Utils::convertDictToType Client $serviceName $doc $reply $argList $xns:$msgType $forceNs 2574 2575 set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {:}] end] {=}] end] 2576 set xml [format {<?xml version="1.0" encoding="%s"?>} $encoding] 2577 append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] 2578 $doc delete 2579 2580 ::log::logsubst debug {Leaving ::WS::Client::buildDocLiteralCallquery with {$xml}} 2581 2582 return [encoding convertto $encoding $xml] 2583 2584 } 2585 2586 ########################################################################### 2587 # 2588 # Private Procedure Header - as this procedure is modified, please be sure 2589 # that you update this header block. Thanks. 2590 # 2591 #>>BEGIN PRIVATE<< 2592 # 2593 # Procedure Name : ::WS::Client::buildRpcEncodedCallquery 2594 # 2595 # Description : Build the XML request message for the call 2596 # 2597 # Arguments : 2598 # serviceName - the name of the service called 2599 # operationName - the name of the operation called 2600 # url - the URL of the operation 2601 # argList - a dictionary object of the calling arguments 2602 # This is for both the Soap Header and Body messages. 2603 # 2604 # Returns : The XML for the call 2605 # 2606 # Side-Effects : None 2607 # 2608 # Exception Conditions : None 2609 # 2610 # Pre-requisite Conditions : None 2611 # 2612 # Original Author : Gerald W. Lester 2613 # 2614 #>>END PRIVATE<< 2615 # 2616 # Maintenance History - as this file is modified, please be sure that you 2617 # update this segment of the file header block by 2618 # adding a complete entry at the bottom of the list. 2619 # 2620 # Version Date Programmer Comments / Changes / Reasons 2621 # ------- ---------- ---------- ------------------------------------------- 2622 # 1 07/06/2006 G.Lester Initial version 2623 # 2624 # 2625 ########################################################################### 2626 proc ::WS::Client::buildRpcEncodedCallquery {serviceName operationName url argList} { 2627 variable serviceArr 2628 2629 ::log::logsubst debug {Entering [info level 0]} 2630 set serviceInfo $serviceArr($serviceName) 2631 set msgType [dict get $serviceInfo operation $operationName inputs] 2632 set xnsList [dict get $serviceInfo targetNamespace] 2633 2634 dom createDocument "SOAP-ENV:Envelope" doc 2635 $doc documentElement env 2636 $env setAttribute \ 2637 xmlns:SOAP-ENV "http://schemas.xmlsoap.org/soap/envelope/" \ 2638 xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance" \ 2639 xmlns:xs "http://www.w3.org/2001/XMLSchema" 2640 2641 foreach {tns target} $xnsList { 2642 $env setAttribute xmlns:$tns $target 2643 } 2644 2645 set firstHeader 1 2646 foreach inputHeaderType [dict get $serviceInfo operation $operationName soapRequestHeader] { 2647 if {$inputHeaderType eq {}} { 2648 continue 2649 } 2650 set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns] 2651 if {$firstHeader} { 2652 $env appendChild [$doc createElement "SOAP-ENV:Header" header] 2653 set firstHeader 0 2654 } 2655 $header appendChild [$doc createElement $xns:$inputHeaderType headerData] 2656 ::WS::Utils::convertDictToEncodedType Client $serviceName $doc $headerData $argList $inputHeaderType 2657 } 2658 2659 $env appendChild [$doc createElement "SOAP-ENV:Body" bod] 2660 set baseName [dict get $serviceInfo operation $operationName name] 2661 2662 set callXns [dict get $serviceInfo operation $operationName xns] 2663 # side effect: node handle is saved in variable reply 2664 if {![string is space $callXns]} { 2665 $bod appendChild [$doc createElement $callXns:$baseName reply] 2666 } else { 2667 $bod appendChild [$doc createElement $baseName reply] 2668 } 2669 $reply setAttribute \ 2670 SOAP-ENV:encodingStyle "http://schemas.xmlsoap.org/soap/encoding/" 2671 2672 ::WS::Utils::convertDictToEncodedType Client $serviceName $doc $reply $argList $msgType 2673 2674 set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] 2675 set xml [format {<?xml version="1.0" encoding="%s"?>} $encoding] 2676 append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] 2677 $doc delete 2678 ::log::logsubst debug {Leaving ::WS::Client::buildRpcEncodedCallquery with {$xml}} 2679 2680 return [encoding convertto $encoding $xml] 2681 2682 } 2683 2684 ########################################################################### 2685 # 2686 # Private Procedure Header - as this procedure is modified, please be sure 2687 # that you update this header block. Thanks. 2688 # 2689 #>>BEGIN PRIVATE<< 2690 # 2691 # Procedure Name : ::WS::Client::buildServiceInfo 2692 # 2693 # Description : Parse the WSDL into our internal representation 2694 # 2695 # Arguments : 2696 # wsdlNode - The top node of the WSDL 2697 # results - Initial definition. This is optional and defaults to no definition. 2698 # serviceAlias - Alias (unique) name for service. 2699 # This is an optional argument and defaults to the name of the 2700 # service in serviceInfo. 2701 # serviceNumber - Number of service within the WSDL to assign the 2702 # serviceAlias to. Only usable with a serviceAlias. 2703 # First service (default) is addressed by value "1". 2704 # 2705 # Returns : The parsed WSDL 2706 # 2707 # Side-Effects : Defines Client mode types as specified by the WSDL 2708 # 2709 # Exception Conditions : None 2710 # 2711 # Pre-requisite Conditions : None 2712 # 2713 # Original Author : Gerald W. Lester 2714 # 2715 #>>END PRIVATE<< 2716 # 2717 # Maintenance History - as this file is modified, please be sure that you 2718 # update this segment of the file header block by 2719 # adding a complete entry at the bottom of the list. 2720 # 2721 # Version Date Programmer Comments / Changes / Reasons 2722 # ------- ---------- ---------- ------------------------------------------- 2723 # 1 07/06/2006 G.Lester Initial version 2724 # 2.4.6 2017-12-07 H.Oehlmann Added argument "serviceNumber" 2725 # 2726 # 2727 ########################################################################### 2728 proc ::WS::Client::buildServiceInfo {wsdlNode tnsDict {serviceInfo {}} {serviceAlias {}} {serviceNumber 1}} { 2729 ## 2730 ## Need to refactor to foreach service parseService 2731 ## Service drills down to ports, which drills down to bindings and messages 2732 ## 2733 ::log::logsubst debug {Entering [info level 0]} 2734 2735 ## 2736 ## Parse Service information 2737 ## 2738 # WSDL snippet: 2739 # <definitions ...> 2740 # <service name="service1"> 2741 # ... 2742 # </service> 2743 # <service name="service2"> 2744 # ... 2745 # </service> 2746 # </definitions> 2747 # Without serviceAlias and serviceNumber, two services "service1" and 2748 # "service2" are created. 2749 # With serviceAlias = "SE" and serviceNumber=2, "service2" is created as 2750 # "SE". 2751 set serviceNameList [$wsdlNode selectNodes w:service] 2752 # Check for no service node 2753 if {[llength $serviceNameList] == 0} { 2754 return \ 2755 -code error \ 2756 -errorcode [list WS CLIENT NOSVC] \ 2757 "WSDL does not define any services" 2758 } 2759 if {"" ne $serviceAlias} { 2760 if {$serviceNumber < 1 || $serviceNumber > [llength $serviceNameList]} { 2761 return \ 2762 -code error \ 2763 -errorcode [list WS CLIENT INVALDCNT] \ 2764 "WSDL does not define service number $serviceNumber" 2765 } 2766 set serviceNameList [lrange $serviceNameList $serviceNumber-1 $serviceNumber-1] 2767 } 2768 2769 foreach serviceNode $serviceNameList { 2770 lappend serviceInfo [parseService $wsdlNode $serviceNode $serviceAlias $tnsDict] 2771 } 2772 2773 ::log::logsubst debug {Leaving ::WS::Client::buildServiceInfo with $serviceInfo} 2774 return $serviceInfo 2775 } 2776 2777 ########################################################################### 2778 # 2779 # Private Procedure Header - as this procedure is modified, please be sure 2780 # that you update this header block. Thanks. 2781 # 2782 #>>BEGIN PRIVATE<< 2783 # 2784 # Procedure Name : ::WS::Client::parseService 2785 # 2786 # Description : Parse a service from a WSDL into our internal representation 2787 # 2788 # Arguments : 2789 # wsdlNode - The top node of the WSDL 2790 # serviceNode - The DOM node for the service. 2791 # serviceAlias - Alias (unique) name for service. 2792 # This is an optional argument and defaults to the name of the 2793 # service in serviceInfo. 2794 # tnsDict - Dictionary of URI to namespaces used 2795 # 2796 # Returns : The parsed service WSDL 2797 # 2798 # Side-Effects : Defines Client mode types for the service as specified by the WSDL 2799 # 2800 # Exception Conditions : None 2801 # 2802 # Pre-requisite Conditions : None 2803 # 2804 # Original Author : Gerald W. Lester 2805 # 2806 #>>END PRIVATE<< 2807 # 2808 # Maintenance History - as this file is modified, please be sure that you 2809 # update this segment of the file header block by 2810 # adding a complete entry at the bottom of the list. 2811 # 2812 # Version Date Programmer Comments / Changes / Reasons 2813 # ------- ---------- ---------- ------------------------------------------- 2814 # 1 08/06/2006 G.Lester Initial version 2815 # 2816 # 2817 ########################################################################### 2818 proc ::WS::Client::parseService {wsdlNode serviceNode serviceAlias tnsDict} { 2819 variable serviceArr 2820 variable options 2821 2822 ::log::logsubst debug {Entering [info level 0]} 2823 if {[string length $serviceAlias]} { 2824 set serviceName $serviceAlias 2825 } else { 2826 set serviceName [$serviceNode getAttribute name] 2827 } 2828 set addressNodeList [$serviceNode getElementsByTagNameNS http://schemas.xmlsoap.org/wsdl/soap/ address] 2829 if {[llength $addressNodeList] == 1} { 2830 set addressNode [lindex $addressNodeList 0] 2831 set portNode [$addressNode parentNode] 2832 set location [$addressNode getAttribute location] 2833 } else { 2834 foreach addressNode $addressNodeList { 2835 set portNode [$addressNode parentNode] 2836 if {[$addressNode hasAttribute location]} { 2837 set location [$addressNode getAttribute location] 2838 break 2839 } 2840 } 2841 } 2842 if {![info exists location]} { 2843 return \ 2844 -code error \ 2845 -errorcode [list WS CLIENT NOSOAPADDR] \ 2846 "Malformed WSDL -- No SOAP address node found." 2847 } 2848 2849 set xns {} 2850 foreach url [dict keys [dict get $tnsDict url]] { 2851 lappend xns [list [dict get $tnsDict url $url] $url] 2852 } 2853 if {[$wsdlNode hasAttribute targetNamespace]} { 2854 set target [$wsdlNode getAttribute targetNamespace] 2855 } else { 2856 set target $location 2857 } 2858 set tmpTargetNs $::WS::Utils::targetNs 2859 set ::WS::Utils::targetNs $target 2860 CreateService $serviceName WSDL $location $target xns $xns 2861 set serviceInfo $serviceArr($serviceName) 2862 dict set serviceInfo tnsList $tnsDict 2863 set bindingName [lindex [split [$portNode getAttribute binding] {:}] end] 2864 2865 ## 2866 ## Parse types 2867 ## 2868 parseTypes $wsdlNode $serviceName serviceInfo 2869 2870 ## 2871 ## Parse bindings 2872 ## 2873 parseBinding $wsdlNode $serviceName $bindingName serviceInfo 2874 2875 ## 2876 ## All done, so return results 2877 ## 2878 #dict unset serviceInfo tnsList 2879 dict set serviceInfo suppressTargetNS $options(suppressTargetNS) 2880 foreach {key value} [dict get $serviceInfo tnsList url] { 2881 dict set serviceInfo targetNamespace $value $key 2882 } 2883 set serviceArr($serviceName) $serviceInfo 2884 2885 set ::WS::Utils::targetNs $tmpTargetNs 2886 2887 ::log::logsubst debug {Leaving [lindex [info level 0] 0] with $serviceInfo} 2888 return $serviceInfo 2889 } 2890 2891 ########################################################################### 2892 # 2893 # Private Procedure Header - as this procedure is modified, please be sure 2894 # that you update this header block. Thanks. 2895 # 2896 #>>BEGIN PRIVATE<< 2897 # 2898 # Procedure Name : ::WS::Client::parseTypes 2899 # 2900 # Description : Parse the types for a service from a WSDL into 2901 # our internal representation 2902 # 2903 # Arguments : 2904 # wsdlNode - The top node of the WSDL 2905 # serviceNode - The DOM node for the service. 2906 # serviceInfoVar - The name of the dictionary containing the partially 2907 # parsed service. 2908 # 2909 # Returns : Nothing 2910 # 2911 # Side-Effects : Defines Client mode types for the service as specified by the WSDL 2912 # 2913 # Exception Conditions : None 2914 # 2915 # Pre-requisite Conditions : None 2916 # 2917 # Original Author : Gerald W. Lester 2918 # 2919 #>>END PRIVATE<< 2920 # 2921 # Maintenance History - as this file is modified, please be sure that you 2922 # update this segment of the file header block by 2923 # adding a complete entry at the bottom of the list. 2924 # 2925 # Version Date Programmer Comments / Changes / Reasons 2926 # ------- ---------- ---------- ------------------------------------------- 2927 # 1 08/06/2006 G.Lester Initial version 2928 # 2929 # 2930 ########################################################################### 2931 proc ::WS::Client::parseTypes {wsdlNode serviceName serviceInfoVar} { 2932 ::log:::log debug "Entering [info level 0]" 2933 2934 upvar 1 $serviceInfoVar serviceInfo 2935 2936 2937 set tnsCount [llength [dict keys [dict get $serviceInfo tnsList url]]] 2938 set baseUrl [dict get $serviceInfo location] 2939 foreach schemaNode [$wsdlNode selectNodes w:types/xs:schema] { 2940 ::log:::log debug "Parsing node $schemaNode" 2941 ::WS::Utils::parseScheme Client $baseUrl $schemaNode $serviceName serviceInfo tnsCount 2942 } 2943 2944 ::log:::log debug "Leaving [lindex [info level 0] 0]" 2945 } 2946 2947 ########################################################################### 2948 # 2949 # Private Procedure Header - as this procedure is modified, please be sure 2950 # that you update this header block. Thanks. 2951 # 2952 #>>BEGIN PRIVATE<< 2953 # 2954 # Procedure Name : ::WS::Client::parseBinding 2955 # 2956 # Description : Parse the bindings for a service from a WSDL into our 2957 # internal representation 2958 # 2959 # Arguments : 2960 # wsdlNode - The top node of the WSDL 2961 # serviceName - The name service. 2962 # bindingName - The name binding we are to parse. 2963 # serviceInfoVar - The name of the dictionary containing the partially 2964 # parsed service. 2965 # 2966 # Returns : Nothing 2967 # 2968 # Side-Effects : Defines Client mode types for the service as specified by the WSDL 2969 # 2970 # Exception Conditions : None 2971 # 2972 # Pre-requisite Conditions : None 2973 # 2974 # Original Author : Gerald W. Lester 2975 # 2976 #>>END PRIVATE<< 2977 # 2978 # Maintenance History - as this file is modified, please be sure that you 2979 # update this segment of the file header block by 2980 # adding a complete entry at the bottom of the list. 2981 # 2982 # Version Date Programmer Comments / Changes / Reasons 2983 # ------- ---------- ---------- ------------------------------------------- 2984 # 1 08/06/2006 G.Lester Initial version 2985 # 2.4.2 2017-08-31 H.Oehlmann Also set serviceArr operation members 2986 # inputsName and outputsName. 2987 # 2988 # 2989 ########################################################################### 2990 proc ::WS::Client::parseBinding {wsdlNode serviceName bindingName serviceInfoVar} { 2991 ::log:::log debug "Entering [info level 0]" 2992 upvar 1 $serviceInfoVar serviceInfo 2993 variable options 2994 2995 set bindQuery [format {w:binding[attribute::name='%s']} $bindingName] 2996 array set msgToOper {} 2997 foreach binding [$wsdlNode selectNodes $bindQuery] { 2998 array unset msgToOper * 2999 set portName [lindex [split [$binding getAttribute type] {:}] end] 3000 ::log:::log debug "\t Processing binding '$bindingName' on port '$portName'" 3001 set operList [$binding selectNodes w:operation] 3002 set styleNode [$binding selectNodes d:binding] 3003 if {![info exists style]} { 3004 if {[catch {$styleNode getAttribute style} tmpStyle]} { 3005 set styleNode [$binding selectNodes {w:operation[1]/d:operation}] 3006 if {$styleNode eq {}} { 3007 ## 3008 ## This binding is for a SOAP level other than 1.1 3009 ## 3010 ::log:::log debug "Skiping non-SOAP 1.1 binding [$binding asXML]" 3011 continue 3012 } 3013 set style [$styleNode getAttribute style] 3014 #puts "Using style for first operation {$style}" 3015 } else { 3016 set style $tmpStyle 3017 #puts "Using style for first binding {$style}" 3018 } 3019 if {!($style eq {document} || $style eq {rpc} )} { 3020 ::log:::log debug "Leaving [lindex [info level 0] 0] with error @1" 3021 return \ 3022 -code error \ 3023 -errorcode [list WS CLIENT UNSSTY $style] \ 3024 "Unsupported calling style: '$style'" 3025 } 3026 3027 if {![info exists use]} { 3028 set use [[$binding selectNodes {w:operation[1]/w:input/d:body}] getAttribute use] 3029 if {!($style eq {document} && $use eq {literal} ) && 3030 !($style eq {rpc} && $use eq {encoded} )} { 3031 ::log:::log debug "Leaving [lindex [info level 0] 0] with error @2" 3032 return \ 3033 -code error \ 3034 -errorcode [list WS CLIENT UNSMODE $use] \ 3035 "Unsupported mode: $style/$use" 3036 } 3037 } 3038 } 3039 3040 set style $style/$use 3041 3042 ## 3043 ## Process each operation 3044 ## 3045 foreach oper $operList { 3046 set operName [$oper getAttribute name] 3047 set baseName $operName 3048 ::log:::log debug "\t Processing operation '$operName'" 3049 3050 ## 3051 ## Check for overloading 3052 ## 3053 set inNode [$oper selectNodes w:input] 3054 if {[llength $inNode] == 1 && [$inNode hasAttribute name]} { 3055 set inName [$inNode getAttribute name] 3056 } else { 3057 set inName {} 3058 } 3059 if {[dict exists $serviceInfo operation $operName]} { 3060 if {!$options(allowOperOverloading)} { 3061 return -code error \ 3062 -errorcode [list WS CLIENT NOOVERLOAD $operName] 3063 } 3064 ## 3065 ## See if the existing operation needs to be cloned 3066 ## 3067 set origType [lindex [split [dict get $serviceInfo operation $operName inputs] {:}] end] 3068 set newName ${operName}_${origType} 3069 if {![dict exists $serviceInfo operation $newName]} { 3070 ## 3071 ## Clone it 3072 ## 3073 dict set serviceInfo operation $baseName cloned 1 3074 dict lappend serviceInfo operList $newName 3075 dict set serviceInfo operation $newName [dict get $serviceInfo operation $operName] 3076 } 3077 # typNameList contains inType inName outType outName 3078 set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style] 3079 set operName ${operName}_[lindex [split [lindex $typeNameList 0] {:}] end] 3080 set cloneList [dict get $serviceInfo operation $baseName cloneList] 3081 lappend cloneList $operName 3082 dict set serviceInfo operation $baseName cloneList $cloneList 3083 dict set serviceInfo operation $operName isClone 1 3084 } else { 3085 set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style] 3086 dict set serviceInfo operation $operName isClone 0 3087 } 3088 3089 #puts "Processing operation $operName" 3090 set actionNode [$oper selectNodes d:operation] 3091 if {$actionNode eq {}} { 3092 ::log:::log debug "Skiping operation with no action [$oper asXML]" 3093 continue 3094 } 3095 dict lappend serviceInfo operList $operName 3096 dict set serviceInfo operation $operName cloneList {} 3097 dict set serviceInfo operation $operName cloned 0 3098 dict set serviceInfo operation $operName name $baseName 3099 dict set serviceInfo operation $operName style $style 3100 catch { 3101 set action [$actionNode getAttribute soapAction] 3102 dict set serviceInfo operation $operName action $action 3103 if {[dict exists $serviceInfo soapActions $action]} { 3104 set actionList [dict get $serviceInfo soapActions $action] 3105 } else { 3106 set actionList {} 3107 } 3108 lappend actionList $operName 3109 dict set serviceInfo soapActions $action $actionList 3110 } 3111 3112 ## 3113 ## Get the input headers, if any 3114 ## 3115 set soapRequestHeaderList {{}} 3116 foreach inHeader [$oper selectNodes w:input/d:header] { 3117 ##set part [$inHeader getAttribute part] 3118 set tmp [$inHeader getAttribute use] 3119 if {$tmp ne $use} { 3120 ::log:::log debug "Leaving [lindex [info level 0] 0] with error @3" 3121 return \ 3122 -code error \ 3123 -errorcode [list WS CLIENT MIXUSE $use $tmp] \ 3124 "Mixed usageage not supported!'" 3125 } 3126 set msgName [$inHeader getAttribute message] 3127 ::log:::log debug [list messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] 3128 set type [messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] 3129 lappend soapRequestHeaderList $type 3130 } 3131 dict set serviceInfo operation $operName soapRequestHeader $soapRequestHeaderList 3132 if {![dict exists [dict get $serviceInfo operation $operName] action]} { 3133 dict set serviceInfo operation $operName action $serviceName 3134 } 3135 3136 ## 3137 ## Get the output header, if one 3138 ## 3139 set soapReplyHeaderList {{}} 3140 foreach outHeader [$oper selectNodes w:output/d:header] { 3141 ##set part [$outHeader getAttribute part] 3142 set tmp [$outHeader getAttribute use] 3143 if {$tmp ne $use} { 3144 ::log:::log debug "Leaving [lindex [info level 0] 0] with error @4" 3145 return \ 3146 -code error \ 3147 -errorcode [list WS CLIENT MIXUSE $use $tmp] \ 3148 "Mixed usageage not supported!'" 3149 } 3150 set messagePath [$outHeader getAttribute message] 3151 set msgName [lindex [split $messagePath {:}] end] 3152 ::log:::log debug [list messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] 3153 set type [messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] 3154 lappend soapReplyHeaderList $type 3155 } 3156 dict set serviceInfo operation $operName soapReplyHeader $soapReplyHeaderList 3157 3158 ## 3159 ## Validate that the input and output uses are the same 3160 ## 3161 set inUse $use 3162 set outUse $use 3163 catch {set inUse [[$oper selectNodes w:input/d:body] getAttribute use]} 3164 catch {set outUse [[$oper selectNodes w:output/d:body] getAttribute use]} 3165 foreach tmp [list $inUse $outUse] { 3166 if {$tmp ne $use} { 3167 ::log:::log debug "Leaving [lindex [info level 0] 0] with error @5" 3168 return \ 3169 -code error \ 3170 -errorcode [list WS CLIENT MIXUSE $use $tmp] \ 3171 "Mixed usageage not supported!'" 3172 } 3173 } 3174 ::log:::log debug "\t Input/Output types and names are {$typeNameList}" 3175 foreach {type name} $typeNameList mode {inputs outputs} { 3176 dict set serviceInfo operation $operName $mode $type 3177 # also set outputsname which is used to match it as alternate response node name 3178 dict set serviceInfo operation $operName ${mode}name $name 3179 } 3180 set inMessage [dict get $serviceInfo operation $operName inputs] 3181 if {[dict exists $serviceInfo inputMessages $inMessage] } { 3182 set operList [dict get $serviceInfo inputMessages $inMessage] 3183 } else { 3184 set operList {} 3185 } 3186 lappend operList $operName 3187 dict set serviceInfo inputMessages $inMessage $operList 3188 3189 ## 3190 ## Handle target namespace defined at WSDL level for older RPC/Encoded 3191 ## 3192 if {![dict exists $serviceInfo targetNamespace]} { 3193 catch { 3194 #puts "attempting to get tragetNamespace" 3195 dict set serviceInfo targetNamespace tns1 [[$oper selectNodes w:input/d:body] getAttribute namespace] 3196 } 3197 } 3198 set xns tns1 3199 dict set serviceInfo operation $operName xns $xns 3200 } 3201 } 3202 3203 ::log:::log debug "Leaving [lindex [info level 0] 0]" 3204 } 3205 3206 ########################################################################### 3207 # 3208 # Private Procedure Header - as this procedure is modified, please be sure 3209 # that you update this header block. Thanks. 3210 # 3211 #>>BEGIN PRIVATE<< 3212 # 3213 # Procedure Name : ::WS::Client::getTypesForPort 3214 # 3215 # Description : Get the types for a port. 3216 # 3217 # Arguments : 3218 # wsdlNode - The top node of the WSDL 3219 # serviceNode - The DOM node for the service. 3220 # operNode - The DOM node for the operation. 3221 # portName - The name of the port. 3222 # inName - The name of the input message. 3223 # serviceInfoVar - The name of the dictionary containing the partially 3224 # parsed service. 3225 # style - style of call 3226 # 3227 # Returns : A list containing the input and output types and names 3228 # 3229 # Side-Effects : Defines Client mode types for the service as specified by the WSDL 3230 # 3231 # Exception Conditions : None 3232 # 3233 # Pre-requisite Conditions : None 3234 # 3235 # Original Author : Gerald W. Lester 3236 # 3237 #>>END PRIVATE<< 3238 # 3239 # Maintenance History - as this file is modified, please be sure that you 3240 # update this segment of the file header block by 3241 # adding a complete entry at the bottom of the list. 3242 # 3243 # Version Date Programmer Comments / Changes / Reasons 3244 # ------- ---------- ---------- ------------------------------------------- 3245 # 1 08/06/2006 G.Lester Initial version 3246 # 2.4.2 2017-08-31 H.Oehlmann Extend return by names to verify this 3247 # as return output node name. 3248 # 2.4.3 2017-11-03 H.Oehlmann If name is not given, set the default 3249 # name of <OP>Request/Response given by the 3250 # WSDL 1.0 standard. 3251 # 3252 # 3253 ########################################################################### 3254 proc ::WS::Client::getTypesForPort {wsdlNode serviceName operName portName inName serviceInfoVar style} { 3255 ::log:::log debug "Enteringing [info level 0]" 3256 upvar 1 $serviceInfoVar serviceInfo 3257 3258 set inType {} 3259 set outType {} 3260 3261 #set portQuery [format {w:portType[attribute::name='%s']} $portName] 3262 #set portNode [lindex [$wsdlNode selectNodes $portQuery] 0] 3263 if {$inName eq {}} { 3264 set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \ 3265 $portName $operName] 3266 } else { 3267 set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']/w:input[attribute::name='%s']/parent::*} \ 3268 $portName $operName $inName] 3269 } 3270 ::log:::log debug "\t operNode query is {$operQuery}" 3271 set operNode [$wsdlNode selectNodes $operQuery] 3272 if {$operNode eq {} && $inName ne {}} { 3273 set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \ 3274 $portName $operName] 3275 ::log:::log debug "\t operNode query is {$operQuery}" 3276 set operNode [$wsdlNode selectNodes $operQuery] 3277 } 3278 3279 set resList {} 3280 foreach sel {w:input w:output} defaultNameSuffix {Request Response} { 3281 set nodeList [$operNode selectNodes $sel] 3282 if {1 == [llength $nodeList]} { 3283 set nodeCur [lindex $nodeList 0] 3284 set msgPath [$nodeCur getAttribute message] 3285 set msgCur [lindex [split $msgPath {:}] end] 3286 # Append type 3287 lappend resList [messageToType $wsdlNode $serviceName $operName $msgCur serviceInfo $style] 3288 # Append name 3289 if {[$nodeCur hasAttribute name]} { 3290 lappend resList [$nodeCur getAttribute name] 3291 } else { 3292 # Build the default name according WSDL 1.0 as 3293 # <Operation>Request/Response 3294 lappend resList ${operName}$defaultNameSuffix 3295 } 3296 } 3297 } 3298 3299 ## 3300 ## Return the types 3301 ## 3302 ::log:::log debug "Leaving [lindex [info level 0] 0] with $resList" 3303 return $resList 3304 } 3305 3306 ########################################################################### 3307 # 3308 # Private Procedure Header - as this procedure is modified, please be sure 3309 # that you update this header block. Thanks. 3310 # 3311 #>>BEGIN PRIVATE<< 3312 # 3313 # Procedure Name : ::WS::Client::messageToType 3314 # 3315 # Description : Get a type name from a message 3316 # 3317 # Arguments : 3318 # wsdlNode - The top node of the WSDL 3319 # serviceName - The name of the service. 3320 # operName - The name of the operation. 3321 # msgName - The name of the message. 3322 # serviceInfoVar - The name of the dictionary containing the partially 3323 # parsed service. 3324 # style - Style of call 3325 # 3326 # Returns : The requested type name 3327 # 3328 # Side-Effects : Defines Client mode types for the service as specified by the WSDL 3329 # 3330 # Exception Conditions : None 3331 # 3332 # Pre-requisite Conditions : None 3333 # 3334 # Original Author : Gerald W. Lester 3335 # 3336 #>>END PRIVATE<< 3337 # 3338 # Maintenance History - as this file is modified, please be sure that you 3339 # update this segment of the file header block by 3340 # adding a complete entry at the bottom of the list. 3341 # 3342 # Version Date Programmer Comments / Changes / Reasons 3343 # ------- ---------- ---------- ------------------------------------------- 3344 # 1 08/06/2006 G.Lester Initial version 3345 # 3346 # 3347 ########################################################################### 3348 proc ::WS::Client::messageToType {wsdlNode serviceName operName msgName serviceInfoVar style} { 3349 upvar 1 $serviceInfoVar serviceInfo 3350 ::log:::log debug "Enteringing [info level 0]" 3351 3352 #puts "Message to Type $serviceName $operName $msgName" 3353 3354 set msgQuery [format {w:message[attribute::name='%s']} $msgName] 3355 set msg [$wsdlNode selectNodes $msgQuery] 3356 if {$msg eq {} && 3357 [llength [set msgNameList [split $msgName {:}]]] > 1} { 3358 set tmpMsgName [join [lrange $msgNameList 1 end] {:}] 3359 set msgQuery [format {w:message[attribute::name='%s']} $tmpMsgName] 3360 set msg [$wsdlNode selectNodes $msgQuery] 3361 } 3362 if {$msg eq {}} { 3363 return \ 3364 -code error \ 3365 -errorcode [list WS CLIENT BADMSGSEC $msgName] \ 3366 "Can not find message '$msgName'" 3367 } 3368 switch -exact -- $style { 3369 document/literal { 3370 set partNode [$msg selectNodes w:part] 3371 set partNodeCount [llength $partNode] 3372 ::log:::log debug "partNodeCount = {$partNodeCount}" 3373 if {$partNodeCount == 1} { 3374 if {[$partNode hasAttribute element]} { 3375 set type [::WS::Utils::getQualifiedType $serviceInfo [$partNode getAttribute element] tns1] 3376 } 3377 } 3378 if {($partNodeCount > 1) || ![info exist type]} { 3379 set tmpType {} 3380 foreach part [$msg selectNodes w:part] { 3381 set partName [$part getAttribute name] 3382 if {[$part hasAttribute type]} { 3383 set partType [$part getAttribute type] 3384 } else { 3385 set partType [$part getAttribute element] 3386 } 3387 lappend tmpType $partName [list type [::WS::Utils::getQualifiedType $serviceInfo $partType tns1] comment {}] 3388 } 3389 set type tns1:$msgName 3390 dict set serviceInfo types $type $tmpType 3391 ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType tns1 3392 } elseif {!$partNodeCount} { 3393 return \ 3394 -code error \ 3395 -errorcode [list WS CLIENT BADMSGSEC $msgName] \ 3396 "Invalid format for message '$msgName'" 3397 } 3398 } 3399 rpc/encoded { 3400 set tmpType {} 3401 foreach part [$msg selectNodes w:part] { 3402 set partName [$part getAttribute name] 3403 if {[$part hasAttribute type]} { 3404 set partType [$part getAttribute type] 3405 } else { 3406 set partType [$part getAttribute element] 3407 } 3408 lappend tmpType $partName [list type [::WS::Utils::getQualifiedType $serviceInfo $partType tns1] comment {}] 3409 } 3410 set type tns1:$msgName 3411 dict set serviceInfo types $type $tmpType 3412 ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType tns1 3413 } 3414 default { 3415 return \ 3416 -code error \ 3417 -errorcode [list WS CLIENT UNKSTY $style] \ 3418 "Unknown style combination $style" 3419 } 3420 } 3421 3422 ## 3423 ## Return the type name 3424 ## 3425 ::log:::log debug "Leaving [lindex [info level 0] 0] with {$type}" 3426 return $type 3427 } 3428 3429 #--------------------------------------- 3430 #--------------------------------------- 3431 3432 ########################################################################### 3433 # 3434 # Public Procedure Header - as this procedure is modified, please be sure 3435 # that you update this header block. Thanks. 3436 # 3437 #>>BEGIN PUBLIC<< 3438 # 3439 # Procedure Name : ::WS::Client::DoRawRestCall 3440 # 3441 # Description : Call an operation of a web service 3442 # 3443 # Arguments : 3444 # serviceName - The name of the Webservice 3445 # operationName - The name of the Operation to call 3446 # argList - The arguments to the operation as a dictionary object. 3447 # This is for both the Soap Header and Body messages. 3448 # headers - Extra headers to add to the HTTP request. This 3449 # is a key value list argument. It must be a list with 3450 # an even number of elements that alternate between 3451 # keys and values. The keys become header field names. 3452 # Newlines are stripped from the values so the header 3453 # cannot be corrupted. 3454 # This is an optional argument and defaults to {}. 3455 # 3456 # Returns : 3457 # The XML of the operation. 3458 # 3459 # Side-Effects : None 3460 # 3461 # Exception Conditions : 3462 # WS CLIENT HTTPERROR - if an HTTP error occurred 3463 # 3464 # Pre-requisite Conditions : Service must have been defined. 3465 # 3466 # Original Author : Gerald W. Lester 3467 # 3468 #>>END PUBLIC<< 3469 # 3470 # Maintenance History - as this file is modified, please be sure that you 3471 # update this segment of the file header block by 3472 # adding a complete entry at the bottom of the list. 3473 # 3474 # Version Date Programmer Comments / Changes / Reasons 3475 # ------- ---------- ---------- ------------------------------------------- 3476 # 1 07/06/2006 G.Lester Initial version 3477 # 2.4.1 2017-08-31 H.Oehlmann Use utility function 3478 # ::WS::Utils::geturl_fetchbody for http call 3479 # which also follows redirects. 3480 # 3481 # 3482 ########################################################################### 3483 proc ::WS::Client::DoRawRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { 3484 variable serviceArr 3485 3486 ::log::logsubst debug {Entering [info level 0]} 3487 if {![info exists serviceArr($serviceName)]} { 3488 return \ 3489 -code error \ 3490 -errorcode [list WS CLIENT UNKSRV $serviceName] \ 3491 "Unknown service '$serviceName'" 3492 } 3493 set serviceInfo $serviceArr($serviceName) 3494 if {![dict exists $serviceInfo object $objectName]} { 3495 return \ 3496 -code error \ 3497 -errorcode [list WS CLIENT UNKOBJ [list $serviceName $objectName]] \ 3498 "Unknown object '$objectName' for service '$serviceName'" 3499 } 3500 if {![dict exists $serviceInfo object $objectName operation $operationName]} { 3501 return \ 3502 -code error \ 3503 -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ 3504 "Unknown operation '$operationName' for object '$objectName' of service '$serviceName'" 3505 } 3506 3507 ## 3508 ## build call query 3509 ## 3510 3511 if {$location ne {}} { 3512 set url $location 3513 } else { 3514 set url [dict get $serviceInfo object $objectName location] 3515 } 3516 SaveAndSetOptions $serviceName 3517 if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { 3518 RestoreSavedOptions $serviceName 3519 return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err 3520 } else { 3521 RestoreSavedOptions $serviceName 3522 } 3523 if {[dict exists $serviceInfo headers]} { 3524 set headers [concat $headers [dict get $serviceInfo headers]] 3525 } 3526 3527 ## 3528 ## do http call 3529 ## 3530 3531 if {[llength $headers]} { 3532 set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType] -headers $headers] 3533 } else { 3534 set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType]] 3535 } 3536 3537 ::log::logsubst debug {Leaving ::WS::Client::DoRawRestCall with {$body}} 3538 return $body 3539 3540 } 3541 3542 ########################################################################### 3543 # 3544 # Public Procedure Header - as this procedure is modified, please be sure 3545 # that you update this header block. Thanks. 3546 # 3547 #>>BEGIN PUBLIC<< 3548 # 3549 # Procedure Name : ::WS::Client::DoRestCall 3550 # 3551 # Description : Call an operation of a web service 3552 # 3553 # Arguments : 3554 # serviceName - The name of the Webservice 3555 # operationName - The name of the Operation to call 3556 # argList - The arguments to the operation as a dictionary object 3557 # This is for both the Soap Header and Body messages. 3558 # headers - Extra headers to add to the HTTP request. This 3559 # is a key value list argument. It must be a list with 3560 # an even number of elements that alternate between 3561 # keys and values. The keys become header field names. 3562 # Newlines are stripped from the values so the header 3563 # cannot be corrupted. 3564 # This is an optional argument and defaults to {}. 3565 # 3566 # Returns : 3567 # The return value of the operation as a dictionary object. 3568 # 3569 # Side-Effects : None 3570 # 3571 # Exception Conditions : 3572 # WS CLIENT HTTPERROR - if an HTTP error occurred 3573 # others - as raised by called Operation 3574 # 3575 # Pre-requisite Conditions : Service must have been defined. 3576 # 3577 # Original Author : Gerald W. Lester 3578 # 3579 #>>END PUBLIC<< 3580 # 3581 # Maintenance History - as this file is modified, please be sure that you 3582 # update this segment of the file header block by 3583 # adding a complete entry at the bottom of the list. 3584 # 3585 # Version Date Programmer Comments / Changes / Reasons 3586 # ------- ---------- ---------- ------------------------------------------- 3587 # 1 07/06/2006 G.Lester Initial version 3588 # 2.4.1 2017-08-31 H.Oehlmann Use utility function 3589 # ::WS::Utils::geturl_fetchbody for http call 3590 # which also follows redirects. 3591 # 3592 # 3593 ########################################################################### 3594 proc ::WS::Client::DoRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { 3595 variable serviceArr 3596 3597 ::log::logsubst debug {Entering [info level 0]} 3598 if {![info exists serviceArr($serviceName)]} { 3599 return \ 3600 -code error \ 3601 -errorcode [list WS CLIENT UNKSRV $serviceName] \ 3602 "Unknown service '$serviceName'" 3603 } 3604 set serviceInfo $serviceArr($serviceName) 3605 if {![dict exists $serviceInfo object $objectName]} { 3606 return \ 3607 -code error \ 3608 -errorcode [list WS CLIENT UNKOBJ [list $serviceName $objectName]] \ 3609 "Unknown object '$objectName' for service '$serviceName'" 3610 } 3611 if {![dict exists $serviceInfo object $objectName operation $operationName]} { 3612 return \ 3613 -code error \ 3614 -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ 3615 "Unknown operation '$operationName' for object '$objectName' of service '$serviceName'" 3616 } 3617 if {$location ne {}} { 3618 set url $location 3619 } else { 3620 set url [dict get $serviceInfo object $objectName location] 3621 } 3622 3623 ## 3624 ## build call query 3625 ## 3626 3627 SaveAndSetOptions $serviceName 3628 if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { 3629 RestoreSavedOptions $serviceName 3630 return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err 3631 } 3632 RestoreSavedOptions $serviceName 3633 3634 ## 3635 ## Do http call 3636 ## 3637 3638 if {[dict exists $serviceInfo headers]} { 3639 set headers [concat $headers [dict get $serviceInfo headers]] 3640 } 3641 if {[llength $headers]} { 3642 set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType] -headers $headers] 3643 } else { 3644 set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType]] 3645 } 3646 3647 ## 3648 ## Parse results 3649 ## 3650 3651 SaveAndSetOptions $serviceName 3652 if {[catch { 3653 parseRestResults $serviceName $objectName $operationName $body 3654 } results]} { 3655 RestoreSavedOptions $serviceName 3656 ::log::log debug "Leaving (error) ::WS::Client::DoRestCall" 3657 return -code error $results 3658 } 3659 RestoreSavedOptions $serviceName 3660 ::log::logsubst debug {Leaving ::WS::Client::DoRestCall with {$results}} 3661 return $results 3662 3663 } 3664 3665 ########################################################################### 3666 # 3667 # Public Procedure Header - as this procedure is modified, please be sure 3668 # that you update this header block. Thanks. 3669 # 3670 #>>BEGIN PUBLIC<< 3671 # 3672 # Procedure Name : ::WS::Client::DoARestsyncCall 3673 # 3674 # Description : Call an operation of a web service asynchronously 3675 # 3676 # Arguments : 3677 # serviceName - The name of the Webservice 3678 # operationName - The name of the Operation to call 3679 # argList - The arguments to the operation as a dictionary object 3680 # This is for both the Soap Header and Body messages. 3681 # succesCmd - A command prefix to be called if the operations 3682 # does not raise an error. The results, as a dictionary 3683 # object are concatenated to the prefix. 3684 # errorCmd - A command prefix to be called if the operations 3685 # raises an error. The error code and stack trace 3686 # are concatenated to the prefix. 3687 # headers - Extra headers to add to the HTTP request. This 3688 # is a key value list argument. It must be a list with 3689 # an even number of elements that alternate between 3690 # keys and values. The keys become header field names. 3691 # Newlines are stripped from the values so the header 3692 # cannot be corrupted. 3693 # This is an optional argument and defaults to {}. 3694 # 3695 # Returns : 3696 # None. 3697 # 3698 # Side-Effects : None 3699 # 3700 # Exception Conditions : 3701 # WS CLIENT HTTPERROR - if an HTTP error occurred 3702 # others - as raised by called Operation 3703 # 3704 # Pre-requisite Conditions : Service must have been defined. 3705 # 3706 # Original Author : Gerald W. Lester 3707 # 3708 #>>END PUBLIC<< 3709 # 3710 # Maintenance History - as this file is modified, please be sure that you 3711 # update this segment of the file header block by 3712 # adding a complete entry at the bottom of the list. 3713 # 3714 # Version Date Programmer Comments / Changes / Reasons 3715 # ------- ---------- ---------- ------------------------------------------- 3716 # 1 07/06/2006 G.Lester Initial version 3717 # 3718 # 3719 ########################################################################### 3720 proc ::WS::Client::DoRestAsyncCall {serviceName objectName operationName argList succesCmd errorCmd {headers {}}} { 3721 variable serviceArr 3722 3723 set svcHeaders [dict get $serviceArr($serviceName) headers] 3724 if {[llength $svcHeaders]} { 3725 set headers [concat $headers $svcHeaders] 3726 } 3727 ::log::logsubst debug {Entering [info level 0]} 3728 if {![info exists serviceArr($serviceName)]} { 3729 return \ 3730 -code error \ 3731 -errorcode [list WS CLIENT UNKSRV $serviceName] \ 3732 "Unknown service '$serviceName'" 3733 } 3734 set serviceInfo $serviceArr($serviceName) 3735 if {![dict exists $serviceInfo object $objectName operation $operationName]} { 3736 return \ 3737 -code error \ 3738 -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ 3739 "Unknown operation '$operationName' for service '$serviceName'" 3740 } 3741 if {[dict exists $serviceInfo headers]} { 3742 set headers [concat $headers [dict get $serviceInfo headers]] 3743 } 3744 set url [dict get $serviceInfo object $objectName location] 3745 SaveAndSetOptions $serviceName 3746 if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { 3747 RestoreSavedOptions $serviceName 3748 return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err 3749 } else { 3750 RestoreSavedOptions $serviceName 3751 } 3752 if {[llength $headers]} { 3753 ::log::logsubst info {::http::geturl $url \ 3754 -query $query \ 3755 -type [dict get $serviceInfo contentType] \ 3756 -headers $headers \ 3757 -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd]} 3758 ::http::geturl $url \ 3759 -query $query \ 3760 -type [dict get $serviceInfo contentType] \ 3761 -headers $headers \ 3762 -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] 3763 } else { 3764 ::log::logsubst info {::http::geturl $url \ 3765 -query $query \ 3766 -type [dict get $serviceInfo contentType] \ 3767 -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd]} 3768 ::http::geturl $url \ 3769 -query $query \ 3770 -type [dict get $serviceInfo contentType] \ 3771 -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] 3772 } 3773 ::log::log debug "Leaving ::WS::Client::DoAsyncRestCall" 3774 return; 3775 } 3776 3777 ########################################################################### 3778 # 3779 # Private Procedure Header - as this procedure is modified, please be sure 3780 # that you update this header block. Thanks. 3781 # 3782 #>>BEGIN PRIVATE<< 3783 # 3784 # Procedure Name : ::WS::Client::buildRestCallquery 3785 # 3786 # Description : Build the XML request message for the call 3787 # 3788 # Arguments : 3789 # serviceName - the name of the service called 3790 # operationName - the name of the operation called 3791 # url - the URL of the operation 3792 # argList - a dictionary object of the calling arguments 3793 # This is for both the Soap Header and Body messages. 3794 # 3795 # Returns : The XML for the call 3796 # 3797 # Side-Effects : None 3798 # 3799 # Exception Conditions : None 3800 # 3801 # Pre-requisite Conditions : None 3802 # 3803 # Original Author : Gerald W. Lester 3804 # 3805 #>>END PRIVATE<< 3806 # 3807 # Maintenance History - as this file is modified, please be sure that you 3808 # update this segment of the file header block by 3809 # adding a complete entry at the bottom of the list. 3810 # 3811 # Version Date Programmer Comments / Changes / Reasons 3812 # ------- ---------- ---------- ------------------------------------------- 3813 # 1 07/06/2006 G.Lester Initial version 3814 # 3815 # 3816 ########################################################################### 3817 proc ::WS::Client::buildRestCallquery {serviceName objectName operationName url argList} { 3818 variable serviceArr 3819 3820 ::log::logsubst debug {Entering [info level 0]} 3821 set serviceInfo $serviceArr($serviceName) 3822 set msgType [dict get $serviceInfo object $objectName operation $operationName inputs] 3823 set xnsList [dict get $serviceInfo targetNamespace] 3824 3825 dom createDocument "request" doc 3826 $doc documentElement body 3827 $body setAttribute \ 3828 "method" $operationName 3829 foreach {tns target} $xnsList { 3830 #set tns [lindex $xns 0] 3831 #set target [lindex $xns 1] 3832 $body setAttribute \ 3833 xmlns:$tns $target 3834 } 3835 3836 set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] 3837 3838 ::log::logsubst debug {calling [list ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType]} 3839 set options [::WS::Utils::SetOption] 3840 ::WS::Utils::SetOption UseNS 0 3841 ::WS::Utils::SetOption genOutAttr 1 3842 ::WS::Utils::SetOption valueAttr {} 3843 ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType 3844 set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] 3845 foreach {option value} $options { 3846 ::WS::Utils::SetOption $option $value 3847 } 3848 3849 set xml [format {<?xml version="1.0" encoding="%s"?>} $encoding] 3850 append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] 3851 #regsub "<!DOCTYPE\[^>\]*>\n" [::dom::DOMImplementation serialize $doc] {} xml 3852 $doc delete 3853 set xml [encoding convertto $encoding $xml] 3854 3855 set inTransform [dict get $serviceInfo inTransform] 3856 if {$inTransform ne {}} { 3857 set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] 3858 } 3859 3860 ::log::logsubst debug {Leaving ::WS::Client::buildRestCallquery with {$xml}} 3861 3862 return $xml 3863 3864 } 3865 3866 ########################################################################### 3867 # 3868 # Private Procedure Header - as this procedure is modified, please be sure 3869 # that you update this header block. Thanks. 3870 # 3871 #>>BEGIN PRIVATE<< 3872 # 3873 # Procedure Name : ::WS::Client::parseRestResults 3874 # 3875 # Description : Convert the returned XML into a dictionary object 3876 # 3877 # Arguments : 3878 # serviceName - the name of the service called 3879 # operationName - the name of the operation called 3880 # inXML - the XML returned by the operation 3881 # 3882 # Returns : A dictionary object representing the results 3883 # 3884 # Side-Effects : None 3885 # 3886 # Exception Conditions : 3887 # WS CLIENT REMERR - The remote end raised an exception, the third element of 3888 # the error code is the remote fault code. 3889 # Error info is set to the remote fault details. 3890 # The error message is the remote fault string; 3891 # WS CLIENT BADREPLY - Badly formatted reply, the third element is a list of 3892 # what message type was received vs what was expected. 3893 # 3894 # Pre-requisite Conditions : None 3895 # 3896 # Original Author : Gerald W. Lester 3897 # 3898 #>>END PRIVATE<< 3899 # 3900 # Maintenance History - as this file is modified, please be sure that you 3901 # update this segment of the file header block by 3902 # adding a complete entry at the bottom of the list. 3903 # 3904 # Version Date Programmer Comments / Changes / Reasons 3905 # ------- ---------- ---------- ------------------------------------------- 3906 # 1 07/06/2006 G.Lester Initial version 3907 # 3908 # 3909 ########################################################################### 3910 proc ::WS::Client::parseRestResults {serviceName objectName operationName inXML} { 3911 variable serviceArr 3912 3913 ::log::logsubst debug {Entering [info level 0]} 3914 set first [string first {<} $inXML] 3915 if {$first > 0} { 3916 set inXML [string range $inXML $first end] 3917 } 3918 set serviceInfo $serviceArr($serviceName) 3919 set outTransform [dict get $serviceInfo outTransform] 3920 if {$outTransform ne {}} { 3921 set inXML [$outTransform $serviceName $operationName REPLY $inXML] 3922 } 3923 set expectedMsgType [dict get $serviceInfo object $objectName operation $operationName outputs] 3924 # save parsed xml handle in variable doc 3925 dom parse $inXML doc 3926 # save top node handle in variable top 3927 $doc documentElement top 3928 set xns {} 3929 foreach tmp [dict get $serviceInfo targetNamespace] { 3930 lappend xns $tmp 3931 } 3932 ::log::logsubst debug {Using namespaces {$xns}} 3933 set body $top 3934 set status [$body getAttribute status] 3935 3936 ## 3937 ## See if it is a standard error packet 3938 ## 3939 if {$status ne {ok}} { 3940 set faultstring {} 3941 if {[catch {set faultstring [[$body selectNodes error] asText]}]} { 3942 catch {set faultstring [[$body selectNodes error] asText]} 3943 } 3944 $doc delete 3945 return \ 3946 -code error \ 3947 -errorcode [list WS CLIENT REMERR $status] \ 3948 -errorinfo {} \ 3949 $faultstring 3950 } 3951 3952 ## 3953 ## Convert the packet to a dictionary 3954 ## 3955 set results {} 3956 set options [::WS::Utils::SetOption] 3957 ::WS::Utils::SetOption UseNS 0 3958 ::WS::Utils::SetOption parseInAttr 1 3959 ::log::logsubst debug {Calling ::WS::Utils::convertTypeToDict Client $serviceName $body $expectedMsgType $body} 3960 if {$expectedMsgType ne {}} { 3961 set node [$body childNodes] 3962 set nodeName [$node nodeName] 3963 if {$objectName ne $nodeName} { 3964 return \ 3965 -code error \ 3966 -errorcode [list WS CLIENT BADRESPONSE [list $objectName $nodeName]] \ 3967 -errorinfo {} \ 3968 "Unexpected message type {$nodeName}, expected {$objectName}" 3969 } 3970 set results [::WS::Utils::convertTypeToDict \ 3971 Client $serviceName $node $expectedMsgType $body] 3972 } 3973 foreach {option value} $options { 3974 ::WS::Utils::SetOption $option $value 3975 } 3976 $doc delete 3977 3978 return $results 3979 3980 } 3981 3982 ########################################################################### 3983 # 3984 # Private Procedure Header - as this procedure is modified, please be sure 3985 # that you update this header block. Thanks. 3986 # 3987 #>>BEGIN PRIVATE<< 3988 # 3989 # Procedure Name : ::WS::Client::asyncRestobCallDone 3990 # 3991 # Description : Called when an asynchronous call is complete. This routine 3992 # will call either the success or error callback depending on 3993 # if the operation succeeded or failed -- assuming the callback 3994 # is defined. 3995 # 3996 # Arguments : 3997 # serviceName - the name of the service called 3998 # operationName - the name of the operation called 3999 # succesCmd - the command prefix to call if no error 4000 # errorCmd - the command prefix to call on an error 4001 # token - the token from the HTTP request 4002 # 4003 # Returns : Nothing 4004 # 4005 # Side-Effects : None 4006 # 4007 # Exception Conditions : None 4008 # 4009 # Pre-requisite Conditions : None 4010 # 4011 # Original Author : Gerald W. Lester 4012 # 4013 #>>END PRIVATE<< 4014 # 4015 # Maintenance History - as this file is modified, please be sure that you 4016 # update this segment of the file header block by 4017 # adding a complete entry at the bottom of the list. 4018 # 4019 # Version Date Programmer Comments / Changes / Reasons 4020 # ------- ---------- ---------- ------------------------------------------- 4021 # 1 07/06/2006 G.Lester Initial version 4022 # 4023 # 4024 ########################################################################### 4025 proc ::WS::Client::asyncRestCallDone {serviceName objectName operationName succesCmd errorCmd token} { 4026 ::log::logsubst debug {Entering [info level 0]} 4027 4028 ## 4029 ## Check for errors 4030 ## 4031 set body [::http::data $token] 4032 ::log::logsubst info {\nReceived: $body} 4033 if {[::http::status $token] ne {ok} || 4034 ( [::http::ncode $token] != 200 && $body eq {} )} { 4035 set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] 4036 set hadError 1 4037 set errorInfo [FormatHTTPError $token] 4038 } else { 4039 SaveAndSetOptions $serviceName 4040 if {[catch {set hadError [catch {parseRestResults $serviceName $objectName $operationName $body} results]} err]} { 4041 RestoreSavedOptions $serviceName 4042 return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err 4043 } else { 4044 RestoreSavedOptions $serviceName 4045 } 4046 if {$hadError} { 4047 set errorCode $::errorCode 4048 set errorInfo $::errorInfo 4049 } 4050 } 4051 4052 ## 4053 ## Call the appropriate callback 4054 ## 4055 if {$hadError} { 4056 set cmd $errorCmd 4057 lappend cmd $errorCode $errorInfo 4058 } else { 4059 set cmd $succesCmd 4060 } 4061 lappend cmd $results 4062 catch $cmd 4063 4064 ## 4065 ## All done 4066 ## 4067 ::http::cleanup $token 4068 return; 4069 } 4070 4071 4072 ########################################################################### 4073 # 4074 # Private Procedure Header - as this procedure is modified, please be sure 4075 # that you update this header block. Thanks. 4076 # 4077 #>>BEGIN PRIVATE<< 4078 # 4079 # Procedure Name : ::WS::Client::asyncRestobCallDone 4080 # 4081 # Description : Save the global options of the utilities package and 4082 # set them for how this service needs them. 4083 # 4084 # Arguments : 4085 # serviceName - the name of the service called 4086 # 4087 # Returns : Nothing 4088 # 4089 # Side-Effects : None 4090 # 4091 # Exception Conditions : None 4092 # 4093 # Pre-requisite Conditions : None 4094 # 4095 # Original Author : Gerald W. Lester 4096 # 4097 #>>END PRIVATE<< 4098 # 4099 # Maintenance History - as this file is modified, please be sure that you 4100 # update this segment of the file header block by 4101 # adding a complete entry at the bottom of the list. 4102 # 4103 # Version Date Programmer Comments / Changes / Reasons 4104 # ------- ---------- ---------- ------------------------------------------- 4105 # 1 03/06/2012 G.Lester Initial version 4106 # 4107 # 4108 ########################################################################### 4109 proc ::WS::Client::SaveAndSetOptions {serviceName} { 4110 variable serviceArr 4111 variable utilsOptionsList 4112 4113 if {![info exists serviceArr($serviceName)]} { 4114 return \ 4115 -code error \ 4116 -errorcode [list WS CLIENT UNKSRV $serviceName] \ 4117 "Unknown service '$serviceName'" 4118 } 4119 set serviceInfo $serviceArr($serviceName) 4120 set savedDict {} 4121 foreach item $utilsOptionsList { 4122 if {[dict exists $serviceInfo $item] && [string length [set value [dict get $serviceInfo $item]]]} { 4123 dict set savedDict $item [::WS::Utils::SetOption $item] 4124 ::WS::Utils::SetOption $item $value 4125 } 4126 } 4127 dict set serviceArr($serviceName) UtilsSavedOptions $savedDict 4128 return; 4129 } 4130 4131 ########################################################################### 4132 # 4133 # Private Procedure Header - as this procedure is modified, please be sure 4134 # that you update this header block. Thanks. 4135 # 4136 #>>BEGIN PRIVATE<< 4137 # 4138 # Procedure Name : ::WS::Client::RestoreSavedOptions 4139 # 4140 # Description : Restore the saved global options of the utilities package. 4141 # 4142 # Arguments : 4143 # serviceName - the name of the service called 4144 # 4145 # Returns : Nothing 4146 # 4147 # Side-Effects : None 4148 # 4149 # Exception Conditions : None 4150 # 4151 # Pre-requisite Conditions : None 4152 # 4153 # Original Author : Gerald W. Lester 4154 # 4155 #>>END PRIVATE<< 4156 # 4157 # Maintenance History - as this file is modified, please be sure that you 4158 # update this segment of the file header block by 4159 # adding a complete entry at the bottom of the list. 4160 # 4161 # Version Date Programmer Comments / Changes / Reasons 4162 # ------- ---------- ---------- ------------------------------------------- 4163 # 1 03/06/2012 G.Lester Initial version 4164 # 4165 # 4166 ########################################################################### 4167 proc ::WS::Client::RestoreSavedOptions {serviceName} { 4168 variable serviceArr 4169 4170 if {![info exists serviceArr($serviceName)]} { 4171 return \ 4172 -code error \ 4173 -errorcode [list WS CLIENT UNKSRV $serviceName] \ 4174 "Unknown service '$serviceName'" 4175 } 4176 set serviceInfo $serviceArr($serviceName) 4177 set savedDict {} 4178 foreach {item value} [dict get $serviceInfo UtilsSavedOptions] { 4179 ::WS::Utils::SetOption $item $value 4180 } 4181 dict set serviceArr($serviceName) UtilsSavedOptions {} 4182 return; 4183 }