Web Services for Tcl (aka tclws): Check-in [6e84da1680]

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.

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.
#

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.

# 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]]

# 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]]