Check-in [62c4dae5f1]
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:Patch to support ns prefix defined in the element. Ticket [6fbee3208e]
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | ticket-6fbee320-local-ns-prefix
Files: files | file ages | folders
SHA3-256: 62c4dae5f181fd97755c3ada58492696630531b1f61677ac2f4f27b61a71acec
User & Date: oehhar 2018-11-05 08:48:42
Original Comment: Patch to support ns prefix defined in the element. Ticket [6fbee320]
Context
2018-11-05 13:41
Fail in case of a node local namespace, which is not found globally. Before, an identical global prefix (with other namespace) may be picked. Closed-Leaf check-in: 12bb39fa7a user: oehhar tags: ticket-6fbee320-local-ns-prefix
2018-11-05 08:48
Patch to support ns prefix defined in the element. Ticket [6fbee3208e] check-in: 62c4dae5f1 user: oehhar tags: ticket-6fbee320-local-ns-prefix
2018-09-03 17:55
Replaced stderr error print by error log (::WS::Utils::ProcessImportXml). Plus some documentation and ticket numbers. check-in: 07f65e990e user: oehhar tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to Utilities.tcl.

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
....
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420

3421
3422
3423
3424
3425
3426
3427
3428
....
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
....
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
....
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
....
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
....
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
....
4525
4526
4527
4528
4529
4530
4531
4532


4533
4534
4535
4536
4537

4538
4539
4540
4541
4542
4543
4544
....
4551
4552
4553
4554
4555
4556
4557



4558
4559
4560
4561
4562
4563
4564
4565
4566



















4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
        ::log::log $level [uplevel 1 [list subst $text]]
    }
}

package require tdom 0.8
package require struct::set

package provide WS::Utils 2.6.1

namespace eval ::WS {}

namespace eval ::WS::Utils {
    set ::WS::Utils::typeInfo {}
    set ::WS::Utils::currentSchema {}
    array set ::WS::Utils::importedXref {}
................................................................................
                        set refNS [lindex $refTypeInfo 0]
                        if {[string equal $refNS {}]} {
                            set partType $tns:$partType
                        }
                        ##
                        ## Convert the reference to the local tns space
                        ##
                        set partType  [getQualifiedType $results $partType $tns]
                        set refTypeInfo [GetServiceTypeDef $mode $serviceName $partType]
                        set refTypeInfo [dict get $refTypeInfo definition]
                        set tmpList [dict keys $refTypeInfo]
                        if {[llength $tmpList] == 1} {
                            ##
                            ## See if the reference is to an element or a type
                            ##
                            if {![dict exists $results elements $partType]} {
                                ##
                                ## To at type, so redefine the name
                                ##
                                set partName [lindex [dict keys $refTypeInfo] 0]
                            }
                            set partType [getQualifiedType $results [dict get $refTypeInfo $partName type] $tns]
                        }
                        lappend partList $partName [list type $partType]
                    }]} {
                        lappend unknownRef($partType) $typeName
                        return \
                            -code error \
                            -errorcode [list WS $mode UNKREF [list $typeName $partType]] \
                            "Unknown forward type reference {$partType} in {$typeName}"
                    }
                } else {
                    set partName [$middleNode getAttribute name]

                    set partType [string trimright [getQualifiedType $results [$middleNode getAttribute type string:string] $tns] {?}]
                    set partMax [$middleNode getAttribute maxOccurs 1]
                    if {$partMax <= 1} {
                        lappend partList $partName [list type $partType comment $comment]
                    } else {
                        lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment]
                    }
                }
................................................................................
            ##
            ## Do Nothing
            ##
        }
        element {
            catch {
                set partName [$node getAttribute name]
                set partType [string trimright [getQualifiedType $results [$node getAttribute type string] $tns] {?}]
                set partMax [$node getAttribute maxOccurs 1]
                if {$partMax <= 1} {
                    set partList [list $partName [list type $partType comment {}]]
                } else {
                    set partList [list $partName [list type [string trimright ${partType} {()}]() comment {}]]
                }
            }
        }
        extension {
            set baseName [getQualifiedType $results [$node getAttribute base string] $tns]
            set baseTypeInfo [TypeInfo Client $serviceName $baseName]
            ::log::logsubst debug {\t base name of extension is {$baseName} with typeinfo {$baseTypeInfo}}
            if {[lindex $baseTypeInfo 0]} {
                if {[catch {::WS::Utils::GetServiceTypeDef Client $serviceName $baseName}]} {
                    set baseQuery [format {child::*[attribute::name='%s']} $baseName]
                    set baseNode [$currentSchema selectNodes $baseQuery]
                    #puts "$baseQuery gave {$baseNode}"
................................................................................
                                set partType $partName
                                parseComplexType $mode results $serviceName $element $tns
                                if {[info exists simpleTypes($mode,$serviceName,$tns:$partName)]} {
                                  set additional_defininition_elements $simpleTypes($mode,$serviceName,$tns:$partName)
                                  set partType [dict get $additional_defininition_elements baseType]
                                }
                            } else {
                                set partType [getQualifiedType $results [$element getAttribute type string] $tns]
                            }
                        } else {
                            set partType [getQualifiedType $results [$element getAttribute type string] $tns]
                        }
                    }
                    if {[string length $occurs]} {
                        set partMax [$element getAttribute maxOccurs 1]
                        if {$partMax < $occurs} {
                            set partMax $occurs
                        }
................................................................................
    set typeName [$node getAttribute $attributeName]
    if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $tns:$typeName]]} {
        ::log::logsubst debug {\t Type $tns:$typeName is already defined -- leaving}
        return
    }
    set typeType ""
    if {[$node hasAttribute type]} {
        set typeType [getQualifiedType $results [$node getAttribute type string] $tns]
    }
    ::log::logsubst debug {Elemental Type is $typeName}
    set partList {}
    set partType {}
    set isAbstractType false
    if {[$node hasAttribute abstract]} {
        set isAbstractType [$node getAttribute abstract]
................................................................................
            set childList [$element selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element]
            ::log::logsubst debug {\t\t\ has no ref has [llength $childList]}
            if {[llength $childList]} {
                ##
                ## Element defines another element layer
                ##
                set partName [$element getAttribute name]
                set partType [getQualifiedType $results $partName $tns]
                parseElementalType $mode results $serviceName $element $tns
            } else {
                set partName [$element getAttribute name]
                if {[$element hasAttribute type]} {
                    set partType [getQualifiedType $results [$element getAttribute type] $tns]
                } else {
                    set partType xs:string
                }

            }
        }
        set partMax [$element getAttribute maxOccurs -1]
................................................................................
                    ## Placed here to shut up tclchecker
                    ##
                }
            }
        }
        # have an element with a type only, so do the work here
        if {[$node hasAttribute type]} {
            set partType [getQualifiedType $results [$node getAttribute type] $tns]
        } elseif {[$node hasAttribute base]}  {
            set partType [getQualifiedType $results [$node getAttribute base] $tns]
        } else {
            set partType xs:string
        }
        set partMax [$node getAttribute maxOccurs 1]
        if {$partMax <= 1} {
            ##
            ## See if this is just a restriction on a simple type
................................................................................
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Utils::getQualifiedType
#
# Description : Set attributes on a DOM node


#
# Arguments :
#       serviceInfo - service information dictionary
#       type        - type to get local qualified type on
#       tns         - current namespace

#
# Returns :     nothing
#
# Side-Effects :        None
#
# Exception Conditions :        None
#
................................................................................
# 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  02/24/2011  G. Lester    Initial version



#
###########################################################################
proc ::WS::Utils::getQualifiedType {serviceInfo type tns} {

    set typePartsList [split $type {:}]
    if {[llength $typePartsList] == 1} {
        set result $tns:$type
    } else {
        lassign $typePartsList tmpTns tmpType



















        if {[dict exists $serviceInfo tnsList tns $tmpTns]} {
            set result [dict get $serviceInfo tnsList tns $tmpTns]:$tmpType
        } elseif {[dict exists $serviceInfo types $type]} {
            set result $type
        } else {
            ::log::log error $serviceInfo
            ::log::logsubst error {Could not find tns '$tmpTns' in '[dict get $serviceInfo tnsList tns]' for type {$type}}
            set result $tns:$type
            return -code error
        }

    }
    return $result
}

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






|







 







|













|











>
|







 







|









|







 







|


|







 







|







 







|




|







 







|

|







 







|
>
>





>







 







>
>
>


|






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










|
|







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
....
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
....
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
....
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
....
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
....
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
....
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
....
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
....
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
        ::log::log $level [uplevel 1 [list subst $text]]
    }
}

package require tdom 0.8
package require struct::set

package provide WS::Utils 2.6.2

namespace eval ::WS {}

namespace eval ::WS::Utils {
    set ::WS::Utils::typeInfo {}
    set ::WS::Utils::currentSchema {}
    array set ::WS::Utils::importedXref {}
................................................................................
                        set refNS [lindex $refTypeInfo 0]
                        if {[string equal $refNS {}]} {
                            set partType $tns:$partType
                        }
                        ##
                        ## Convert the reference to the local tns space
                        ##
                        set partType [getQualifiedType $results $partType $tns $middleNode]
                        set refTypeInfo [GetServiceTypeDef $mode $serviceName $partType]
                        set refTypeInfo [dict get $refTypeInfo definition]
                        set tmpList [dict keys $refTypeInfo]
                        if {[llength $tmpList] == 1} {
                            ##
                            ## See if the reference is to an element or a type
                            ##
                            if {![dict exists $results elements $partType]} {
                                ##
                                ## To at type, so redefine the name
                                ##
                                set partName [lindex [dict keys $refTypeInfo] 0]
                            }
                            set partType [getQualifiedType $results [dict get $refTypeInfo $partName type] $tns $middleNode]
                        }
                        lappend partList $partName [list type $partType]
                    }]} {
                        lappend unknownRef($partType) $typeName
                        return \
                            -code error \
                            -errorcode [list WS $mode UNKREF [list $typeName $partType]] \
                            "Unknown forward type reference {$partType} in {$typeName}"
                    }
                } else {
                    set partName [$middleNode getAttribute name]
                    set partType [string trimright \
                        [getQualifiedType $results [$middleNode getAttribute type string:string] $tns $middleNode] {?}]
                    set partMax [$middleNode getAttribute maxOccurs 1]
                    if {$partMax <= 1} {
                        lappend partList $partName [list type $partType comment $comment]
                    } else {
                        lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment]
                    }
                }
................................................................................
            ##
            ## Do Nothing
            ##
        }
        element {
            catch {
                set partName [$node getAttribute name]
                set partType [string trimright [getQualifiedType $results [$node getAttribute type string] $tns $node] {?}]
                set partMax [$node getAttribute maxOccurs 1]
                if {$partMax <= 1} {
                    set partList [list $partName [list type $partType comment {}]]
                } else {
                    set partList [list $partName [list type [string trimright ${partType} {()}]() comment {}]]
                }
            }
        }
        extension {
            set baseName [getQualifiedType $results [$node getAttribute base string] $tns $node]
            set baseTypeInfo [TypeInfo Client $serviceName $baseName]
            ::log::logsubst debug {\t base name of extension is {$baseName} with typeinfo {$baseTypeInfo}}
            if {[lindex $baseTypeInfo 0]} {
                if {[catch {::WS::Utils::GetServiceTypeDef Client $serviceName $baseName}]} {
                    set baseQuery [format {child::*[attribute::name='%s']} $baseName]
                    set baseNode [$currentSchema selectNodes $baseQuery]
                    #puts "$baseQuery gave {$baseNode}"
................................................................................
                                set partType $partName
                                parseComplexType $mode results $serviceName $element $tns
                                if {[info exists simpleTypes($mode,$serviceName,$tns:$partName)]} {
                                  set additional_defininition_elements $simpleTypes($mode,$serviceName,$tns:$partName)
                                  set partType [dict get $additional_defininition_elements baseType]
                                }
                            } else {
                                set partType [getQualifiedType $results [$element getAttribute type string] $tns $element]
                            }
                        } else {
                            set partType [getQualifiedType $results [$element getAttribute type string] $tns $element]
                        }
                    }
                    if {[string length $occurs]} {
                        set partMax [$element getAttribute maxOccurs 1]
                        if {$partMax < $occurs} {
                            set partMax $occurs
                        }
................................................................................
    set typeName [$node getAttribute $attributeName]
    if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $tns:$typeName]]} {
        ::log::logsubst debug {\t Type $tns:$typeName is already defined -- leaving}
        return
    }
    set typeType ""
    if {[$node hasAttribute type]} {
        set typeType [getQualifiedType $results [$node getAttribute type string] $tns $node]
    }
    ::log::logsubst debug {Elemental Type is $typeName}
    set partList {}
    set partType {}
    set isAbstractType false
    if {[$node hasAttribute abstract]} {
        set isAbstractType [$node getAttribute abstract]
................................................................................
            set childList [$element selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element]
            ::log::logsubst debug {\t\t\ has no ref has [llength $childList]}
            if {[llength $childList]} {
                ##
                ## Element defines another element layer
                ##
                set partName [$element getAttribute name]
                set partType [getQualifiedType $results $partName $tns $element]
                parseElementalType $mode results $serviceName $element $tns
            } else {
                set partName [$element getAttribute name]
                if {[$element hasAttribute type]} {
                    set partType [getQualifiedType $results [$element getAttribute type] $tns $element]
                } else {
                    set partType xs:string
                }

            }
        }
        set partMax [$element getAttribute maxOccurs -1]
................................................................................
                    ## Placed here to shut up tclchecker
                    ##
                }
            }
        }
        # have an element with a type only, so do the work here
        if {[$node hasAttribute type]} {
            set partType [getQualifiedType $results [$node getAttribute type] $tns $node]
        } elseif {[$node hasAttribute base]}  {
            set partType [getQualifiedType $results [$node getAttribute base] $tns $node]
        } else {
            set partType xs:string
        }
        set partMax [$node getAttribute maxOccurs 1]
        if {$partMax <= 1} {
            ##
            ## See if this is just a restriction on a simple type
................................................................................
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Utils::getQualifiedType
#
# Description : Get a qualified type name from a local reference.
#               Thus return <Prefix>:<Type> which is in the global type list.
#               The <Prefix> is adjusted to point to the global type list.
#
# Arguments :
#       serviceInfo - service information dictionary
#       type        - type to get local qualified type on
#       tns         - current namespace
#       node        - optional XML item to search for xmlns:* attribute
#
# Returns :     nothing
#
# Side-Effects :        None
#
# Exception Conditions :        None
#
................................................................................
# 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  02/24/2011  G. Lester    Initial version
#   2.6.2  2018-09-22  C. Werner    Added parameter "node" to first search a
#                                   namespace attribute "xmlns:yprefix>" in the
#                                   current node.
#
###########################################################################
proc ::WS::Utils::getQualifiedType {serviceInfo type tns {node {}}} {

    set typePartsList [split $type {:}]
    if {[llength $typePartsList] == 1} {
        set result $tns:$type
    } else {
        lassign $typePartsList tmpTns tmpType
        # Search the namespace attribute in the current node for a node-local prefix.
        # Aim is to translate the node-local prefix to a global namespace prefix.
        # Example is: <xs:element name="A_O_S" type="x1:ArrayOfSomething" xmlns:x1="http://foo.org/bar" />
        # Variable setup:
        # - type: x1:ArrayOfSomething
        # - tmpTns: x1
        # - tmpType: ArrayOfSomething
        # Return value: <Prefix in serviceinfo which corresponds to namespace: "http://foo.org/bar">:ArrayOfSomething
        if {$node ne {}} {
            set attr xmlns:$tmpTns
            if {[$node hasAttribute $attr]} {
                set xmlns [$node getAttribute $attr]
                if {[dict exists $serviceInfo tnsList url $xmlns]} {
                    set result [dict get $serviceInfo tnsList url $xmlns]:$tmpType
                    return $result
                }
                # fail later if namespace not found
            }
        }
        if {[dict exists $serviceInfo tnsList tns $tmpTns]} {
            set result [dict get $serviceInfo tnsList tns $tmpTns]:$tmpType
        } elseif {[dict exists $serviceInfo types $type]} {
            set result $type
        } else {
            ::log::log error $serviceInfo
            ::log::logsubst error {Could not find tns '$tmpTns' in '[dict get $serviceInfo tnsList tns]' for type {$type}}
            set result $tns:$type
            return -code error
        }
    }

    return $result
}

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

Changes to pkgIndex.tcl.

10
11
12
13
14
15
16
17
18
19
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.6.0 [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Embeded 2.6.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::Embedded 2.6.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::Server 2.6.0 [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.6.1 [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]]






|


10
11
12
13
14
15
16
17
18
19
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.6.0 [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Embeded 2.6.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::Embedded 2.6.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::Server 2.6.0 [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.6.2 [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]]