Check-in [6e84da1680]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:The response node name may also be the output name and not only the output type [21f41e22bc]
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 6e84da168040e26b892624f6f72c9deb172d414a
User & Date: oehhar 2017-08-31 09:05:13
References
2017-08-31 09:07 Closed ticket [21f41e22bc]: "Bad reply type" when calling a service plus 2 other changes artifact: ba565753f9 user: oehhar
Context
2017-08-31 09:10
Documented wrong version check-in: 3b9fcbf29a user: oehhar tags: trunk
2017-08-31 09:05
The response node name may also be the output name and not only the output type [21f41e22bc] check-in: 6e84da1680 user: oehhar tags: trunk
2017-08-31 08:51
Use utility function ::WS::Utils::geturl_fetchbody for http::geturl calls which handles errors and follows redirects. Exception are calls with a -command argument check-in: 118a1dadf5 user: oehhar tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to ClientSide.tcl.

    43     43   package require Tcl 8.4
    44     44   package require WS::Utils 2.4 ; # dict, lassign
    45     45   package require tdom 0.8
    46     46   package require http 2
    47     47   package require log
    48     48   package require uri
    49     49   
    50         -package provide WS::Client 2.4.1
           50  +package provide WS::Client 2.4.2
    51     51   
    52     52   namespace eval ::WS::Client {
    53     53       # register https only if not yet registered
    54     54       if {[catch { http::unregister https } lPortCmd]} {
    55     55           # not registered -> register on my own
    56     56           if {[catch {
    57     57               package require tls
................................................................................
  1917   1917   # Maintenance History - as this file is modified, please be sure that you
  1918   1918   #                       update this segment of the file header block by
  1919   1919   #                       adding a complete entry at the bottom of the list.
  1920   1920   #
  1921   1921   # Version     Date     Programmer   Comments / Changes / Reasons
  1922   1922   # -------  ----------  ----------   -------------------------------------------
  1923   1923   #       1  07/06/2006  G.Lester     Initial version
         1924  +# 2.4.2    2017-08-31  H.Oehlmann   The response node name may also be the
         1925  +#                                   output name and not only the output type.
         1926  +#                                   (ticket [21f41e22bc]).
  1924   1927   #
  1925   1928   #
  1926   1929   ###########################################################################
  1927   1930   proc ::WS::Client::parseResults {serviceName operationName inXML} {
  1928   1931       variable serviceArr
  1929   1932   
  1930   1933       ::log::log debug "In parseResults $serviceName $operationName {$inXML}"
................................................................................
  2008   2011               -errorcode [list WS CLIENT REMERR $faultcode] \
  2009   2012               -errorinfo $detail \
  2010   2013               $faultstring
  2011   2014       }
  2012   2015   
  2013   2016       ##
  2014   2017       ## Validated that it is the expected packet type
         2018  +    ## The outputsname is also verified (see ticket [21f41e22bc])
  2015   2019       ##
  2016         -    if {$rootName ne $expectedMsgTypeBase} {
         2020  +    if {$rootName ne $expectedMsgTypeBase
         2021  +            && $rootName ne [dict get $serviceInfo operation $operationName outputsname]} {
  2017   2022           $doc delete
  2018   2023           return \
  2019   2024               -code error \
  2020   2025               -errorcode [list WS CLIENT BADREPLY [list $rootName $expectedMsgTypeBase]] \
  2021         -            "Bad reply type, received '$rootName; but expected '$expectedMsgTypeBase'."
         2026  +            "Bad reply type, received '$rootName'; but expected '$expectedMsgTypeBase'."
  2022   2027       }
  2023   2028   
  2024   2029       ##
  2025   2030       ## Convert the packet to a dictionary
  2026   2031       ##
  2027   2032       set results {}
  2028   2033       set headerRootNode [$top selectNodes ENV:Header]
................................................................................
  2662   2667   # Maintenance History - as this file is modified, please be sure that you
  2663   2668   #                       update this segment of the file header block by
  2664   2669   #                       adding a complete entry at the bottom of the list.
  2665   2670   #
  2666   2671   # Version     Date     Programmer   Comments / Changes / Reasons
  2667   2672   # -------  ----------  ----------   -------------------------------------------
  2668   2673   #       1  08/06/2006  G.Lester     Initial version
         2674  +# 2.4.2    2017-08-31  H.Oehlmann   Also set serviceArr operation members
         2675  +#                                   inputsName and outputsName.
  2669   2676   #
  2670   2677   #
  2671   2678   ###########################################################################
  2672   2679   proc ::WS::Client::parseBinding {wsdlNode serviceName bindingName serviceInfoVar} {
  2673   2680       ::log:::log debug "Entering [info level 0]"
  2674   2681       upvar 1 $serviceInfoVar serviceInfo
  2675   2682       variable options
................................................................................
  2752   2759                       ##
  2753   2760                       ## Clone it
  2754   2761                       ##
  2755   2762                       dict set serviceInfo operation $baseName cloned 1
  2756   2763                       dict lappend serviceInfo operList $newName
  2757   2764                       dict set serviceInfo operation $newName [dict get $serviceInfo operation $operName]
  2758   2765                   }
  2759         -                set typeList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
  2760         -                set operName ${operName}_[lindex [split [lindex $typeList 0] {:}] end]
         2766  +                # typNameList contains inType inName outType outName
         2767  +                set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
         2768  +                set operName ${operName}_[lindex [split [lindex $typeNameList 0] {:}] end]
  2761   2769                   set cloneList [dict get $serviceInfo operation $baseName cloneList]
  2762   2770                   lappend cloneList $operName
  2763   2771                   dict set serviceInfo operation $baseName cloneList $cloneList
  2764   2772                   dict set serviceInfo operation $operName isClone 1
  2765   2773               } else {
  2766         -                set typeList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
         2774  +                set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
  2767   2775                   dict set serviceInfo operation $operName isClone 0
  2768   2776               }
  2769   2777   
  2770   2778               #puts "Processing operation $operName"
  2771   2779               set actionNode [$oper selectNodes d:operation]
  2772   2780               if {$actionNode eq {}} {
  2773   2781                   ::log:::log debug "Skiping operation with no action [$oper asXML]"
................................................................................
  2848   2856                       ::log:::log debug "Leaving [lindex [info level 0] 0] with error @5"
  2849   2857                       return \
  2850   2858                           -code error \
  2851   2859                           -errorcode [list WS CLIENT MIXUSE $use $tmp] \
  2852   2860                           "Mixed usageage not supported!'"
  2853   2861                   }
  2854   2862               }
  2855         -            #set typeList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
  2856         -            ::log:::log debug "\t Messages are {$typeList}"
  2857         -            foreach type $typeList mode {inputs outputs} {
         2863  +            ::log:::log debug "\t Input/Output types and names are {$typeNameList}"
         2864  +            foreach {type name} $typeNameList mode {inputs outputs} {
  2858   2865                   dict set serviceInfo operation $operName $mode $type
         2866  +                # also set outputsname which is used to match it as alternate response node name
         2867  +                dict set serviceInfo operation $operName ${mode}name $name
  2859   2868               }
  2860   2869               set inMessage [dict get $serviceInfo operation $operName inputs]
  2861   2870               if {[dict exists $serviceInfo inputMessages $inMessage] } {
  2862   2871                   set operList [dict get $serviceInfo inputMessages $inMessage]
  2863   2872               } else {
  2864   2873                   set operList {}
  2865   2874               }
................................................................................
  2919   2928   # Maintenance History - as this file is modified, please be sure that you
  2920   2929   #                       update this segment of the file header block by
  2921   2930   #                       adding a complete entry at the bottom of the list.
  2922   2931   #
  2923   2932   # Version     Date     Programmer   Comments / Changes / Reasons
  2924   2933   # -------  ----------  ----------   -------------------------------------------
  2925   2934   #       1  08/06/2006  G.Lester     Initial version
         2935  +# 2.4.1    2017-08-31  H.Oehlmann   Extend return by names to verify this
         2936  +#                                   as return output node name.
  2926   2937   #
  2927   2938   #
  2928   2939   ###########################################################################
  2929   2940   proc ::WS::Client::getTypesForPort {wsdlNode serviceName operName portName inName serviceInfoVar style} {
  2930   2941       ::log:::log debug "Enteringing [info level 0]"
  2931   2942       upvar 1 $serviceInfoVar serviceInfo
  2932   2943   
................................................................................
  2946   2957       set operNode [$wsdlNode selectNodes $operQuery]
  2947   2958       if {$operNode eq {} && $inName ne {}} {
  2948   2959           set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \
  2949   2960                           $portName $operName]
  2950   2961           ::log:::log debug "\t operNode query is {$operQuery}"
  2951   2962           set operNode [$wsdlNode selectNodes $operQuery]
  2952   2963       }
  2953         -
  2954         -    set inputMsgNode [$operNode selectNodes {w:input}]
  2955         -    if {$inputMsgNode ne {}} {
  2956         -        set inputMsgPath [$inputMsgNode getAttribute message]
  2957         -        set inputMsg [lindex [split $inputMsgPath {:}] end]
  2958         -        set inType [messageToType $wsdlNode $serviceName $operName $inputMsg serviceInfo $style]
  2959         -    }
  2960         -
  2961         -    set outputMsgNode [$operNode selectNodes {w:output}]
  2962         -    if {$outputMsgNode ne {}} {
  2963         -        set outputMsgPath [$outputMsgNode getAttribute message]
  2964         -        set outputMsg [lindex [split $outputMsgPath {:}] end]
  2965         -        set outType [messageToType $wsdlNode $serviceName $operName $outputMsg serviceInfo $style]
         2964  +    
         2965  +    set resList {}
         2966  +    foreach sel {w:input w:output} {
         2967  +        set nodeList [$operNode selectNodes $sel]
         2968  +        if {1 == [llength $nodeList]} {
         2969  +            set nodeCur [lindex $nodeList 0]
         2970  +            set msgPath [$nodeCur getAttribute message]
         2971  +            set msgCur [lindex [split $msgPath {:}] end]
         2972  +            # Append type
         2973  +            lappend resList [messageToType $wsdlNode $serviceName $operName $msgCur serviceInfo $style]
         2974  +            # Append name
         2975  +            if {[$nodeCur hasAttribute name]} {
         2976  +                lappend resList [$nodeCur getAttribute name]
         2977  +            } else {
         2978  +                lappend resList {}
         2979  +            }
         2980  +        }
  2966   2981       }
  2967   2982   
  2968   2983       ##
  2969   2984       ## Return the types
  2970   2985       ##
  2971         -    ::log:::log debug "Leaving [lindex [info level 0] 0] with [list $inType $outType]"
  2972         -    return [list $inType $outType]
         2986  +    ::log:::log debug "Leaving [lindex [info level 0] 0] with $resList"
         2987  +    return $resList
  2973   2988   }
  2974   2989   
  2975   2990   ###########################################################################
  2976   2991   #
  2977   2992   # Private Procedure Header - as this procedure is modified, please be sure
  2978   2993   #                            that you update this header block. Thanks.
  2979   2994   #

Changes to pkgIndex.tcl.

     6      6   # information so that packages will be loaded automatically
     7      7   # in response to "package require" commands.  When this
     8      8   # script is sourced, the variable $dir must contain the
     9      9   # full path name of this file's directory.
    10     10   
    11     11   package ifneeded WS::AOLserver 2.4.0 [list source [file join $dir AOLserver.tcl]]
    12     12   package ifneeded WS::Channel 2.4.0 [list source [file join $dir ChannelServer.tcl]]
    13         -package ifneeded WS::Client 2.4.1 [list source [file join $dir ClientSide.tcl]]
           13  +package ifneeded WS::Client 2.4.2 [list source [file join $dir ClientSide.tcl]]
    14     14   package ifneeded WS::Embeded 2.4.0 [list source [file join $dir Embedded.tcl]]
    15     15   package ifneeded WS::Server 2.4.0 [list source [file join $dir ServerSide.tcl]]
    16     16   package ifneeded WS::Utils 2.4.0 [list source [file join $dir Utilities.tcl]]
    17     17   package ifneeded WS::Wub 2.4.0 [list source [file join $dir WubServer.tcl]]
    18     18   package ifneeded Wsdl 2.4.0 [list source [file join $dir WubServer.tcl]]