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 tclconference@googlegroups.com
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 Unified Diffs Ignore Whitespace Patch

Changes to ClientSide.tcl.

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
....
1917
1918
1919
1920
1921
1922
1923



1924
1925
1926
1927
1928
1929
1930
....
2008
2009
2010
2011
2012
2013
2014

2015
2016

2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
....
2662
2663
2664
2665
2666
2667
2668


2669
2670
2671
2672
2673
2674
2675
....
2752
2753
2754
2755
2756
2757
2758

2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
....
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858


2859
2860
2861
2862
2863
2864
2865
....
2919
2920
2921
2922
2923
2924
2925


2926
2927
2928
2929
2930
2931
2932
....
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965




2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
package require Tcl 8.4
package require WS::Utils 2.4 ; # dict, lassign
package require tdom 0.8
package require http 2
package require log
package require uri

package provide WS::Client 2.4.1

namespace eval ::WS::Client {
    # register https only if not yet registered
    if {[catch { http::unregister https } lPortCmd]} {
        # not registered -> register on my own
        if {[catch {
            package require tls
................................................................................
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  07/06/2006  G.Lester     Initial version



#
#
###########################################################################
proc ::WS::Client::parseResults {serviceName operationName inXML} {
    variable serviceArr

    ::log::log debug "In parseResults $serviceName $operationName {$inXML}"
................................................................................
            -errorcode [list WS CLIENT REMERR $faultcode] \
            -errorinfo $detail \
            $faultstring
    }

    ##
    ## Validated that it is the expected packet type

    ##
    if {$rootName ne $expectedMsgTypeBase} {

        $doc delete
        return \
            -code error \
            -errorcode [list WS CLIENT BADREPLY [list $rootName $expectedMsgTypeBase]] \
            "Bad reply type, received '$rootName; but expected '$expectedMsgTypeBase'."
    }

    ##
    ## Convert the packet to a dictionary
    ##
    set results {}
    set headerRootNode [$top selectNodes ENV:Header]
................................................................................
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  08/06/2006  G.Lester     Initial version


#
#
###########################################################################
proc ::WS::Client::parseBinding {wsdlNode serviceName bindingName serviceInfoVar} {
    ::log:::log debug "Entering [info level 0]"
    upvar 1 $serviceInfoVar serviceInfo
    variable options
................................................................................
                    ##
                    ## Clone it
                    ##
                    dict set serviceInfo operation $baseName cloned 1
                    dict lappend serviceInfo operList $newName
                    dict set serviceInfo operation $newName [dict get $serviceInfo operation $operName]
                }

                set typeList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
                set operName ${operName}_[lindex [split [lindex $typeList 0] {:}] end]
                set cloneList [dict get $serviceInfo operation $baseName cloneList]
                lappend cloneList $operName
                dict set serviceInfo operation $baseName cloneList $cloneList
                dict set serviceInfo operation $operName isClone 1
            } else {
                set typeList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
                dict set serviceInfo operation $operName isClone 0
            }

            #puts "Processing operation $operName"
            set actionNode [$oper selectNodes d:operation]
            if {$actionNode eq {}} {
                ::log:::log debug "Skiping operation with no action [$oper asXML]"
................................................................................
                    ::log:::log debug "Leaving [lindex [info level 0] 0] with error @5"
                    return \
                        -code error \
                        -errorcode [list WS CLIENT MIXUSE $use $tmp] \
                        "Mixed usageage not supported!'"
                }
            }
            #set typeList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
            ::log:::log debug "\t Messages are {$typeList}"
            foreach type $typeList mode {inputs outputs} {
                dict set serviceInfo operation $operName $mode $type


            }
            set inMessage [dict get $serviceInfo operation $operName inputs]
            if {[dict exists $serviceInfo inputMessages $inMessage] } {
                set operList [dict get $serviceInfo inputMessages $inMessage]
            } else {
                set operList {}
            }
................................................................................
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  08/06/2006  G.Lester     Initial version


#
#
###########################################################################
proc ::WS::Client::getTypesForPort {wsdlNode serviceName operName portName inName serviceInfoVar style} {
    ::log:::log debug "Enteringing [info level 0]"
    upvar 1 $serviceInfoVar serviceInfo

................................................................................
    set operNode [$wsdlNode selectNodes $operQuery]
    if {$operNode eq {} && $inName ne {}} {
        set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \
                        $portName $operName]
        ::log:::log debug "\t operNode query is {$operQuery}"
        set operNode [$wsdlNode selectNodes $operQuery]
    }

    set inputMsgNode [$operNode selectNodes {w:input}]
    if {$inputMsgNode ne {}} {
        set inputMsgPath [$inputMsgNode getAttribute message]
        set inputMsg [lindex [split $inputMsgPath {:}] end]
        set inType [messageToType $wsdlNode $serviceName $operName $inputMsg serviceInfo $style]
    }

    set outputMsgNode [$operNode selectNodes {w:output}]
    if {$outputMsgNode ne {}} {
        set outputMsgPath [$outputMsgNode getAttribute message]
        set outputMsg [lindex [split $outputMsgPath {:}] end]
        set outType [messageToType $wsdlNode $serviceName $operName $outputMsg serviceInfo $style]




    }

    ##
    ## Return the types
    ##
    ::log:::log debug "Leaving [lindex [info level 0] 0] with [list $inType $outType]"
    return [list $inType $outType]
}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#







|







 







>
>
>







 







>

|
>




|







 







>
>







 







>
|
|





|







 







<
|
|

>
>







 







>
>







 







|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>





|
|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
....
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
....
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
....
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
....
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
....
2856
2857
2858
2859
2860
2861
2862

2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
....
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
....
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
package require Tcl 8.4
package require WS::Utils 2.4 ; # dict, lassign
package require tdom 0.8
package require http 2
package require log
package require uri

package provide WS::Client 2.4.2

namespace eval ::WS::Client {
    # register https only if not yet registered
    if {[catch { http::unregister https } lPortCmd]} {
        # not registered -> register on my own
        if {[catch {
            package require tls
................................................................................
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  07/06/2006  G.Lester     Initial version
# 2.4.2    2017-08-31  H.Oehlmann   The response node name may also be the
#                                   output name and not only the output type.
#                                   (ticket [21f41e22bc]).
#
#
###########################################################################
proc ::WS::Client::parseResults {serviceName operationName inXML} {
    variable serviceArr

    ::log::log debug "In parseResults $serviceName $operationName {$inXML}"
................................................................................
            -errorcode [list WS CLIENT REMERR $faultcode] \
            -errorinfo $detail \
            $faultstring
    }

    ##
    ## Validated that it is the expected packet type
    ## The outputsname is also verified (see ticket [21f41e22bc])
    ##
    if {$rootName ne $expectedMsgTypeBase
            && $rootName ne [dict get $serviceInfo operation $operationName outputsname]} {
        $doc delete
        return \
            -code error \
            -errorcode [list WS CLIENT BADREPLY [list $rootName $expectedMsgTypeBase]] \
            "Bad reply type, received '$rootName'; but expected '$expectedMsgTypeBase'."
    }

    ##
    ## Convert the packet to a dictionary
    ##
    set results {}
    set headerRootNode [$top selectNodes ENV:Header]
................................................................................
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  08/06/2006  G.Lester     Initial version
# 2.4.2    2017-08-31  H.Oehlmann   Also set serviceArr operation members
#                                   inputsName and outputsName.
#
#
###########################################################################
proc ::WS::Client::parseBinding {wsdlNode serviceName bindingName serviceInfoVar} {
    ::log:::log debug "Entering [info level 0]"
    upvar 1 $serviceInfoVar serviceInfo
    variable options
................................................................................
                    ##
                    ## Clone it
                    ##
                    dict set serviceInfo operation $baseName cloned 1
                    dict lappend serviceInfo operList $newName
                    dict set serviceInfo operation $newName [dict get $serviceInfo operation $operName]
                }
                # typNameList contains inType inName outType outName
                set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
                set operName ${operName}_[lindex [split [lindex $typeNameList 0] {:}] end]
                set cloneList [dict get $serviceInfo operation $baseName cloneList]
                lappend cloneList $operName
                dict set serviceInfo operation $baseName cloneList $cloneList
                dict set serviceInfo operation $operName isClone 1
            } else {
                set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style]
                dict set serviceInfo operation $operName isClone 0
            }

            #puts "Processing operation $operName"
            set actionNode [$oper selectNodes d:operation]
            if {$actionNode eq {}} {
                ::log:::log debug "Skiping operation with no action [$oper asXML]"
................................................................................
                    ::log:::log debug "Leaving [lindex [info level 0] 0] with error @5"
                    return \
                        -code error \
                        -errorcode [list WS CLIENT MIXUSE $use $tmp] \
                        "Mixed usageage not supported!'"
                }
            }

            ::log:::log debug "\t Input/Output types and names are {$typeNameList}"
            foreach {type name} $typeNameList mode {inputs outputs} {
                dict set serviceInfo operation $operName $mode $type
                # also set outputsname which is used to match it as alternate response node name
                dict set serviceInfo operation $operName ${mode}name $name
            }
            set inMessage [dict get $serviceInfo operation $operName inputs]
            if {[dict exists $serviceInfo inputMessages $inMessage] } {
                set operList [dict get $serviceInfo inputMessages $inMessage]
            } else {
                set operList {}
            }
................................................................................
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  08/06/2006  G.Lester     Initial version
# 2.4.1    2017-08-31  H.Oehlmann   Extend return by names to verify this
#                                   as return output node name.
#
#
###########################################################################
proc ::WS::Client::getTypesForPort {wsdlNode serviceName operName portName inName serviceInfoVar style} {
    ::log:::log debug "Enteringing [info level 0]"
    upvar 1 $serviceInfoVar serviceInfo

................................................................................
    set operNode [$wsdlNode selectNodes $operQuery]
    if {$operNode eq {} && $inName ne {}} {
        set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \
                        $portName $operName]
        ::log:::log debug "\t operNode query is {$operQuery}"
        set operNode [$wsdlNode selectNodes $operQuery]
    }
    
    set resList {}
    foreach sel {w:input w:output} {
        set nodeList [$operNode selectNodes $sel]
        if {1 == [llength $nodeList]} {
            set nodeCur [lindex $nodeList 0]
            set msgPath [$nodeCur getAttribute message]
            set msgCur [lindex [split $msgPath {:}] end]
            # Append type
            lappend resList [messageToType $wsdlNode $serviceName $operName $msgCur serviceInfo $style]
            # Append name
            if {[$nodeCur hasAttribute name]} {
                lappend resList [$nodeCur getAttribute name]
            } else {
                lappend resList {}
            }
        }
    }

    ##
    ## Return the types
    ##
    ::log:::log debug "Leaving [lindex [info level 0] 0] with $resList"
    return $resList
}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#

Changes to pkgIndex.tcl.

6
7
8
9
10
11
12
13
14
15
16
17
18
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded WS::AOLserver 2.4.0 [list source [file join $dir AOLserver.tcl]]
package ifneeded WS::Channel 2.4.0 [list source [file join $dir ChannelServer.tcl]]
package ifneeded WS::Client 2.4.1 [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Embeded 2.4.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::Server 2.4.0 [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.4.0 [list source [file join $dir Utilities.tcl]]
package ifneeded WS::Wub 2.4.0 [list source [file join $dir WubServer.tcl]]
package ifneeded Wsdl 2.4.0 [list source [file join $dir WubServer.tcl]]







|





6
7
8
9
10
11
12
13
14
15
16
17
18
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded WS::AOLserver 2.4.0 [list source [file join $dir AOLserver.tcl]]
package ifneeded WS::Channel 2.4.0 [list source [file join $dir ChannelServer.tcl]]
package ifneeded WS::Client 2.4.2 [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Embeded 2.4.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::Server 2.4.0 [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.4.0 [list source [file join $dir Utilities.tcl]]
package ifneeded WS::Wub 2.4.0 [list source [file join $dir WubServer.tcl]]
package ifneeded Wsdl 2.4.0 [list source [file join $dir WubServer.tcl]]