Check-in [80103f4d61]

Not logged in

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

Overview
Comment:Also use logsubst for the server side
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256:80103f4d610c8fa25a97e8bbb471828400082412e02b06853ffce1623604f74a
User & Date: oehhar 2018-06-13 07:47:20
Context
2018-06-13 07:57
Change version numbers of changed files to 2.6.0 check-in: fc8e965f20 user: oehhar tags: trunk, Release_2.6.0
2018-06-13 07:47
Also use logsubst for the server side check-in: 80103f4d61 user: oehhar tags: trunk
2018-05-28 11:16
Add support to translate distant namespace prefixes in attribute values or text values to local correspondances, required for abstract types. Ticket [584bfb77]: client.tcl 2.5.1, utilities.tcl 2.4.2 check-in: e406ab9e21 user: oehhar tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ClientSide.tcl.

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

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








|







37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

package require Tcl 8.4
package require WS::Utils 2.4 ; # dict, lassign, logsubst
package require tdom 0.8
package require http 2
package require log
package require uri

package provide WS::Client 2.5.1

Changes to Embedded.tcl.

40
41
42
43
44
45
46










47
48
49
50
51
52
53
54
...
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
...
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
...
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
...
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
}

package require uri
package require base64
package require html
package require log











package provide WS::Embeded 2.4.0

namespace eval ::WS::Embeded {

    array set portInfo {}

    set portList [list]
    set forever {}
................................................................................
            -ssl2 1 \
            -ssl3 1 \
            -tls1 0 \
            -require 0 \
            -request 0
        set handle [::tls::socket -server [list ::WS::Embeded::accept $port] $port]
    } else {
        ::log::log debug [list socket -server [list ::WS::Embeded::accept $port] $port]
        set handle [socket -server [list ::WS::Embeded::accept $port] $port]
    }

    return $handle
}

 
................................................................................
###########################################################################
proc ::WS::Embeded::checkauth {port sock ip auth} {
    variable portInfo

    if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} {
        set realm $portInfo($port,realm)
        respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n"
        ::log::log warning "Unauthorized from $ip"
        return -code error
    }
}

 
###########################################################################
#
................................................................................
#
#
###########################################################################
proc ::WS::Embeded::accept {port sock ip clientport} {
    variable portInfo

    upvar #0 ::WS::Embeded::Httpd$sock query
    ::log::log info "Receviced request on $port for $ip:$clientport"

    array unset query reply
    chan configure $sock -translation crlf
    if {1 == [catch {
        gets $sock line
        ::log::log debug "Request is: $line"
        set auth {}
        set request {}
        while {[gets $sock temp] > 0 && ![eof $sock]} {
            if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                dict set request header [string tolower $key] [string trim $data]
            }
        }
        if {[eof $sock]} {
            ::log::log warning  "Connection closed from $ip"
            return
        }
        if {[dict exists $request header authorization]} {
            regexp -nocase {^basic +([^ ]+)$}\
                [dict get $request header authorization] -> auth
        }
        if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {
            ::log::log warning  "Wrong request: $line"
            return
        }
        switch -exact -- $method {
            POST {
                ##
                ## This is all broken and needs to be fixed
                ##
................................................................................
                #parray query
                handler $port $sock $ip [array get query] $auth
            }
            GET {
                handler $port $sock $ip [uri::split $url] $auth
            }
            default {
                ::log::log warning "Unsupported method '$method' from $ip"
                respond $sock 501 "Method not implemented"
            }
        }
    } msg]} {
        ::log::log error "Error: $msg"
        # catch this against an eventual closed socket
        catch {respond $sock 500 "Server Error"}
    }

    catch {flush $sock}
    catch {close $sock}
    return
}







>
>
>
>
>
>
>
>
>
>
|







 







|







 







|







 







|





|








|







|







 







|













40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
...
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
...
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
...
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
...
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
}

package require uri
package require base64
package require html
package require log

# Emulate the log::logsubst command introduced in log 1.4
if {![llength [info command ::log::logsubst]]} {
	proc ::log::logsubst {level text} {
		if {[::log::lvIsSuppressed $level]} {
			return
		}
		::log::log $level [uplevel 1 [list subst $text]]
	}
}

package provide WS::Embeded 2.4.1

namespace eval ::WS::Embeded {

    array set portInfo {}

    set portList [list]
    set forever {}
................................................................................
            -ssl2 1 \
            -ssl3 1 \
            -tls1 0 \
            -require 0 \
            -request 0
        set handle [::tls::socket -server [list ::WS::Embeded::accept $port] $port]
    } else {
        ::log::logsubst debug {socket -server [list ::WS::Embeded::accept $port] $port}
        set handle [socket -server [list ::WS::Embeded::accept $port] $port]
    }

    return $handle
}

 
................................................................................
###########################################################################
proc ::WS::Embeded::checkauth {port sock ip auth} {
    variable portInfo

    if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} {
        set realm $portInfo($port,realm)
        respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n"
        ::log::logsubst warning {Unauthorized from $ip}
        return -code error
    }
}

 
###########################################################################
#
................................................................................
#
#
###########################################################################
proc ::WS::Embeded::accept {port sock ip clientport} {
    variable portInfo

    upvar #0 ::WS::Embeded::Httpd$sock query
    ::log::logsubst info {Receviced request on $port for $ip:$clientport}

    array unset query reply
    chan configure $sock -translation crlf
    if {1 == [catch {
        gets $sock line
        ::log::logsubst debug {Request is: $line}
        set auth {}
        set request {}
        while {[gets $sock temp] > 0 && ![eof $sock]} {
            if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                dict set request header [string tolower $key] [string trim $data]
            }
        }
        if {[eof $sock]} {
            ::log::logsubst warning  {Connection closed from $ip}
            return
        }
        if {[dict exists $request header authorization]} {
            regexp -nocase {^basic +([^ ]+)$}\
                [dict get $request header authorization] -> auth
        }
        if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {
            ::log::logsubst warning  {Wrong request: $line}
            return
        }
        switch -exact -- $method {
            POST {
                ##
                ## This is all broken and needs to be fixed
                ##
................................................................................
                #parray query
                handler $port $sock $ip [array get query] $auth
            }
            GET {
                handler $port $sock $ip [uri::split $url] $auth
            }
            default {
                ::log::logsubst warning {Unsupported method '$method' from $ip}
                respond $sock 501 "Method not implemented"
            }
        }
    } msg]} {
        ::log::log error "Error: $msg"
        # catch this against an eventual closed socket
        catch {respond $sock 500 "Server Error"}
    }

    catch {flush $sock}
    catch {close $sock}
    return
}

Changes to ServerSide.tcl.

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
...
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
...
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
...
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
...
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
...
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
...
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
...
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
...
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
...
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
...
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
....
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
....
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
....
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
....
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357

1358
1359
1360
1361
1362
1363
1364
....
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
....
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
....
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
....
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
....
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
....
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
....
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
....
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
....
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
....
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
....
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
....
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
....
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
....
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448

package require Tcl 8.4
package require WS::Utils 2.4 ; # provides dict
package require html
package require log
package require tdom

package provide WS::Server 2.4.0

namespace eval ::WS::Server {
    array set ::WS::Server::serviceArr {}
    set ::WS::Server::procInfo {}
    set ::WS::Server::mode {}
}

................................................................................
#
###########################################################################
proc ::WS::Server::Service {args} {
    variable serviceArr
    variable procInfo
    variable mode

    ::log::log debug "Defining Service as $args"

    array set defaults {
        -description    {}
        -checkheader    {::WS::Server::ok}
        -inheaders      {}
        -outheaders     {}
        -intransform    {}
................................................................................
    set mode $defaults(-mode)

    ##
    ## Install wsdl doc
    ##
    interp alias {} ::WS::Server::generateInfo_${service} \
                 {} ::WS::Server::generateInfo ${service}
    ::log::log debug "Installing Generate info for $service at $defaults(-prefix)"
    switch -exact -- $mode {
        embedded {
            package require WS::Embeded 2.1.3
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix) ::WS::Server::generateInfo_${service}
            }
        }
................................................................................


    ##
    ## Install wsdl
    ##
    interp alias {} ::WS::Server::generateWsdl_${service} \
                 {} ::WS::Server::generateWsdl ${service}
    ::log::log debug "Installing GenerateWsdl info for $service at $defaults(-prefix)/wsdl"
    switch -exact -- $mode {
        embedded {
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix)/wsdl ::WS::Server::generateWsdl_${service}
            }
        }
        channel {
................................................................................
    }

    ##
    ## Install operations
    ##
    interp alias {} ::WS::Server::callOperation_${service} \
                 {} ::WS::Server::callOperation ${service}
    ::log::log debug "Installing callOperation info for $service at $defaults(-prefix)/op"
    switch -exact -- $mode {
        embedded {
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix)/op ::WS::Server::callOperation_${service}
            }
        }
        channel {
................................................................................
#
#
###########################################################################
proc ::WS::Server::ServiceProc {service nameInfo arglist documentation body} {
    variable procInfo

    set name [lindex $nameInfo 0]
    ::log::log debug "Defining operation $name for $service"
    set argOrder {}
    ::log::log debug "\targs are {$arglist}"
    foreach {arg data} $arglist {
        lappend argOrder $arg
    }
    if {![dict exists $procInfo $service op$name argList]} {
        set tmpList [dict get $procInfo $service operationList]
        lappend tmpList $name
        dict set procInfo $service operationList $tmpList
................................................................................
proc ::WS::Server::GetWsdl {serviceName {urlPrefix ""}} {
    variable serviceArr
    variable procInfo

    array set serviceData $serviceArr($serviceName)

    set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]]
    ::log::log debug "Generating WSDL for $serviceName"
    if {![info exists serviceArr($serviceName)]} {
        set msg "Unknown service '$serviceName'"
        ::return \
            -code error \
            -errorCode [list WS SERVER UNKSERV $serviceName] \
            $msg
    }
................................................................................
    variable serviceArr
    variable procInfo
    variable mode

    array set serviceData $serviceArr($serviceName)

    set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]]
    ::log::log debug "Generating WSDL for $serviceName on $sock with {$args}"
    if {![info exists serviceArr($serviceName)]} {
        set msg "Unknown service '$serviceName'"
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData \
                    $sock \
                    "text/html; charset=UTF-8" \
................................................................................
###########################################################################
# NOTE: This proc only works with Rivet
# TODO: Update to handle jsonp?
proc ::WS::Server::generateJsonInfo { service sock args } {
    variable serviceArr
    variable procInfo

    ::log::log debug "Generating JSON Documentation for $service on $sock with {$args}"
    set serviceInfo $serviceArr($service)
    array set serviceData $serviceInfo
    set doc [yajl create #auto -beautify $serviceData(-beautifyJson)]

    $doc map_open

    $doc string operations array_open
................................................................................
        $doc string description string $description

        # parameters
        if {[llength [dict get $procInfo $service op$oper argOrder]]} {
            $doc string inputs array_open
            
            foreach arg [dict get $procInfo $service op$oper argOrder] {
                ::log::log debug "\t\t\tDisplaying '$arg'"
                if {[dict exists $procInfo $service op$oper argList $arg comment]} {
                    set comment [dict get $procInfo $service op$oper argList $arg comment]
                } else {
                    set comment {}
                }

                set type [dict get $procInfo $service op$oper argList $arg type]
................................................................................

    $doc array_close

    ::log::log debug "\tDisplay custom types"
    $doc string types array_open
    set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service]
    foreach type [lsort -dictionary [dict keys $localTypeInfo]] {
        ::log::log debug "\t\tDisplaying '$type'"

        $doc map_open
        $doc string name string $type
        $doc string fields array_open
        
        set typeDetails [dict get $localTypeInfo $type definition]
        foreach part [lsort -dictionary [dict keys $typeDetails]] {
            ::log::log debug "\t\t\tDisplaying '$part'"
            set subType [dict get $typeDetails $part type]
            set comment {}
            if {[dict exists $typeDetails $part comment]} {
                set comment [dict get $typeDetails $part comment]
            }
            $doc map_open string field string $part string type string $subType string comment string $comment map_close
        }
................................................................................
#
###########################################################################
proc ::WS::Server::generateInfo {service sock args} {
    variable serviceArr
    variable procInfo
    variable mode

    ::log::log debug "Generating HTML Documentation for $service on $sock with {$args}"
    if {![info exists serviceArr($service)]} {
        set msg "Unknown service '$service'"
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData \
                    $sock \
                    "text/html; charset=UTF-8" \
................................................................................

    # decide if SOAP or REST mode should be used.
    set flavor "soap"
    if {[lsearch -exact $args "-rest"] != -1} {
        set flavor "rest"
    }

    ::log::log debug "In ::WS::Server::callOperation {$service $sock $args}"
    array set serviceInfo $serviceArr($service)
    ::log::log debug "\tDocument is {$inXML}"

    set ::errorInfo {}
    set ::errorCode {}
    set ns $service

    set inTransform $serviceInfo(-intransform)
    set outTransform $serviceInfo(-outtransform)
................................................................................
            set first [string first {<} $inXML]
            if {$first > 0} {
                set inXML [string range $inXML $first end]
            }
            # parse the XML request
            dom parse $inXML doc
            $doc documentElement top
            ::log::log debug [list $doc selectNodesNamespaces \
                                  [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
                                       $service http://$serviceInfo(-host)$serviceInfo(-prefix)]]
            $doc selectNodesNamespaces \
                [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
                     $service http://$serviceInfo(-host)$serviceInfo(-prefix)]
            $doc documentElement rootNode
            
            # extract the name of the method
            set top [$rootNode selectNodes /ENV:Envelope/ENV:Body/*]
................................................................................
            set legacyRpcMode 0
            if {$requestMessage == ""} {
                # older RPC/Encoded clients need to try nodeName instead.
                # Python pySoap needs this.
                catch {$top nodeName} requestMessage
                set legacyRpcMode 1
            }
            ::log::log debug "requestMessage = {$requestMessage}"
            if {[string match {*Request} $requestMessage]} {
                set operation [string range $requestMessage 0 end-7]
            } else {
                # broken clients might not have sent the correct Document Wrapped name.
                # Python pySoap and Perl SOAP::Lite need this.
                set operation $requestMessage
                set legacyRpcMode 1
            }

            set contentType "text/xml"
        }
        default {
            if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} "UnknownMethod" $flavor }
            error "bad flavor"
        }
    }
................................................................................
                    CLIENT \
                    $msg \
                    [list "errorCode" $::errorCode "stackTrace" $::errorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 404
        if {$errorCallback ne {}} { $errorCallback "UNKNOWN_METHOD $msg" httpStatus $operation $flavor }
        ::log::log debug "Leaving @ error 1::WS::Server::callOperation $response"

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {
................................................................................
            rest {
                set tclArgList {}
                foreach argName $methodArgs {
                    set argType [string trim [dict get $argInfo $argName type]]
                    set typeInfoList [::WS::Utils::TypeInfo Server $service $argType]

                    if {![info exists rawargs($argName)]} {
                        ::log::log debug "did not find argument for $argName, leaving blank"
                        lappend tclArgList {}
                        continue
                    }

                    switch -exact -- $typeInfoList {
                        {0 0} {
                            ## Simple non-array
................................................................................
                        } else {
                            # legacyRpcMode only, access arguments by index
                            set path "legacy argument index $argIndex"
                            set node [lindex [$top childNodes] $argIndex]
                            incr argIndex
                        }
                        if {[string equal $node {}]} {
                            ::log::log debug "did not find argument for $argName using $path, leaving blank"
                            lappend tclArgList {}
                            continue
                        }
                        ::log::log debug "found argument $argName using $path, processing $node"
                        set gotAnyArgs 1
                        switch -exact -- $typeInfoList {
                            {0 0} {
                                ## Simple non-array
                                lappend tclArgList [$node asText]
                            }
                            {0 1} {
................................................................................
                                lappend tclArgList $tmp
                            }
                            default {
                                ## Do nothing
                            }
                        }
                    }
                    ::log::log debug "gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode"
                    if {$gotAnyArgs || !$legacyRpcMode} break
                }
            }
            default {
                if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} $operation $flavor }
                error "invalid flavor"
            }
        }
        ::log::log debug "finalargs $tclArgList"
    } errMsg]} {
        ::log::log error $errMsg
        set localerrorCode $::errorCode
        set localerrorInfo $::errorInfo
        set response [generateError \
                    $serviceInfo(-traceEnabled) \
                    CLIENT \
                    "Error Parsing Arguments -- $errMsg" \
                    [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 400
        if {$errorCallback ne {}} { $errorCallback "INVALID_ARGUMENT $errMsg" httpStatus $operation $flavor }
        ::log::log debug "Leaving @ error 3::WS::Server::callOperation $response"

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {
................................................................................
        }
        if {[info exists serviceInfo(-postmonitor)] &&
            [string length $serviceInfo(-postmonitor)]} {
            set precmd $serviceInfo(-postmonitor)
            lappend precmd POST $service $operation OK $results
            catch $precmd
        }
        ::log::log debug "Leaving ::WS::Server::callOperation $response"
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response 200
            }
            embedded {
                ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response 200
            }
................................................................................
                    CLIENT \
                    $msg \
                    [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 500
        if {$errorCallback ne {}} { $errorCallback $msg httpStatus $operation $flavor }
        ::log::log debug "Leaving @ error 2::WS::Server::callOperation $response"

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {
................................................................................
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  07/06/2006  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Server::generateError {includeTrace faultcode faultstring detail flavor} {
    ::log::log debug "Entering ::WS::Server::generateError $faultcode $faultstring {$detail}"
    set code [lindex $detail 1]
    switch -exact -- $code {
        "VersionMismatch" {
            set code "SOAP-ENV:VersionMismatch"
        }
        "MustUnderstand" {
            set code "SOAP-ENV:MustUnderstand"
................................................................................
                [$doc asXML -indent none -doctypeDeclaration 0]
            $doc delete
        }
        default {
            error "unsupported flavor"
        }
    }
    ::log::log debug "Leaving (error) ::WS::Server::generateError $response"
    return $response
}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
................................................................................
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  07/06/2006  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Server::generateReply {serviceName operation results flavor} {
    ::log::log debug "Entering ::WS::Server::generateReply $serviceName $operation {$results}"

    variable serviceArr

    array set serviceData $serviceArr($serviceName)


    switch -exact -- $flavor {
................................................................................
            $doc delete
        }
        default {
            error "Unsupported flavor"
        }
    }

    ::log::log debug "Leaving ::WS::Server::generateReply $output"
    return $output

}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
................................................................................
    foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] {
        lappend operList $oper "#op_$oper"
    }
    append msg [::html::h2 {<a id='OperDetails'>Operation Details</a>}]

    set docFormat [dict get $serviceInfo -docFormat]
    foreach {oper anchor} $operList {
        ::log::log debug "\t\tDisplaying '$oper'"
        append msg [::html::h3 "<a id='op_$oper'>$oper</a>"]

        append msg [::html::h4 {Description}] "\n"

        append msg [::html::openTag div {style="margin-left: 40px;"}]
        switch -exact -- $docFormat {
            "html" {
................................................................................

        append msg [::html::openTag div {style="margin-left: 40px;"}]

        if {[llength [dict get $procInfo $service op$oper argOrder]]} {
            append msg [::html::openTag {table} {border="2"}]
            append msg [::html::hdrRow Name Type Description]
            foreach arg [dict get $procInfo $service op$oper argOrder] {
                ::log::log debug "\t\t\tDisplaying '$arg'"
                if {[dict exists $procInfo $service op$oper argList $arg comment]} {
                    set comment [dict get $procInfo $service op$oper argList $arg comment]
                } else {
                    set comment {}
                }
                append msg [::html::row \
                                $arg \
................................................................................
    ##
    ::log::log debug "\tDisplay custom types"
    set service [dict get $serviceInfo -service]
    append msg [::html::h2 {<a id='CustomTypeDetails'>Custom Types</a>}]

    set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service]
    foreach type [lsort -dictionary [dict keys $localTypeInfo]] {
        ::log::log debug "\t\tDisplaying '$type'"
        set href_type [lindex [split $type :] end]
        set typeOverloadArray($type) 1
        append msg [::html::h3 "<a id='type_${href_type}'>$type</a>"]
        set typeDetails [dict get $localTypeInfo $type definition]
        append msg [::html::openTag {table} {border="2"}]
        append msg [::html::hdrRow Field Type Comment]
        foreach part [lsort -dictionary [dict keys $typeDetails]] {
            ::log::log debug "\t\t\tDisplaying '$part'"
            if {[dict exists $typeDetails $part comment]} {
                set comment [dict get $typeDetails $part comment]
            } else {
                set comment {}
            }
            append msg [::html::row \
                            $part \
................................................................................
    set service [dict get $serviceInfo -service]
    append msg [::html::h2 {<a id='SimpleTypeDetails'>Simple Types</a>}]

    append msg "\n<br/>\n<center>" [::html::minorMenu $menuList] "</center>"
    set localTypeInfo [::WS::Utils::GetServiceSimpleTypeDef Server $service]
    foreach typeDetails [lsort -dictionary -index 0 $localTypeInfo] {
        set type [lindex $typeDetails 0]
        ::log::log debug "\t\tDisplaying '$type'"
        set typeOverloadArray($type) 1
        append msg [::html::h3 "<a id='type_$type'>$type</a>"]
        append msg [::html::openTag {table} {border="2"}]
        append msg [::html::hdrRow Attribute Value]
        foreach part [lsort -dictionary [dict keys [lindex $typeDetails 1]]] {
            ::log::log debug "\t\t\tDisplaying '$part'"
            append msg [::html::row \
                            $part \
                            [dict get [lindex $typeDetails 1] $part]
                       ]
        }
        append msg [::html::closeTag]
    }
    append msg "\n<hr/>\n"

    return $msg
}







|







 







|







 







|







 







|







 







|







 







|

|







 







|







 







|







 







|







 







|







 







|







|







 







|







 







|

|







 







|
|
|







 







|








>







 







|







 







|







 







|



|







 







|








|













|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







|







 







|





|











40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
...
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
...
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
...
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
...
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
...
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
...
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
...
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
...
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
...
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
...
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
....
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
....
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
....
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
....
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
....
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
....
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
....
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
....
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
....
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
....
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
....
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
....
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
....
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
....
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
....
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
....
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
....
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
....
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449

package require Tcl 8.4
package require WS::Utils 2.4 ; # provides dict
package require html
package require log
package require tdom

package provide WS::Server 2.4.1

namespace eval ::WS::Server {
    array set ::WS::Server::serviceArr {}
    set ::WS::Server::procInfo {}
    set ::WS::Server::mode {}
}

................................................................................
#
###########################################################################
proc ::WS::Server::Service {args} {
    variable serviceArr
    variable procInfo
    variable mode

    ::log::logsubst debug {Defining Service as $args}

    array set defaults {
        -description    {}
        -checkheader    {::WS::Server::ok}
        -inheaders      {}
        -outheaders     {}
        -intransform    {}
................................................................................
    set mode $defaults(-mode)

    ##
    ## Install wsdl doc
    ##
    interp alias {} ::WS::Server::generateInfo_${service} \
                 {} ::WS::Server::generateInfo ${service}
    ::log::logsubst debug {Installing Generate info for $service at $defaults(-prefix)}
    switch -exact -- $mode {
        embedded {
            package require WS::Embeded 2.1.3
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix) ::WS::Server::generateInfo_${service}
            }
        }
................................................................................


    ##
    ## Install wsdl
    ##
    interp alias {} ::WS::Server::generateWsdl_${service} \
                 {} ::WS::Server::generateWsdl ${service}
    ::log::logsubst debug {Installing GenerateWsdl info for $service at $defaults(-prefix)/wsdl}
    switch -exact -- $mode {
        embedded {
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix)/wsdl ::WS::Server::generateWsdl_${service}
            }
        }
        channel {
................................................................................
    }

    ##
    ## Install operations
    ##
    interp alias {} ::WS::Server::callOperation_${service} \
                 {} ::WS::Server::callOperation ${service}
    ::log::logsubst debug {Installing callOperation info for $service at $defaults(-prefix)/op}
    switch -exact -- $mode {
        embedded {
            foreach port $defaults(-ports) {
                ::WS::Embeded::AddHandler $port $defaults(-prefix)/op ::WS::Server::callOperation_${service}
            }
        }
        channel {
................................................................................
#
#
###########################################################################
proc ::WS::Server::ServiceProc {service nameInfo arglist documentation body} {
    variable procInfo

    set name [lindex $nameInfo 0]
    ::log::logsubst debug {Defining operation $name for $service}
    set argOrder {}
    ::log::logsubst debug {\targs are {$arglist}}
    foreach {arg data} $arglist {
        lappend argOrder $arg
    }
    if {![dict exists $procInfo $service op$name argList]} {
        set tmpList [dict get $procInfo $service operationList]
        lappend tmpList $name
        dict set procInfo $service operationList $tmpList
................................................................................
proc ::WS::Server::GetWsdl {serviceName {urlPrefix ""}} {
    variable serviceArr
    variable procInfo

    array set serviceData $serviceArr($serviceName)

    set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]]
    ::log::logsubst debug {Generating WSDL for $serviceName}
    if {![info exists serviceArr($serviceName)]} {
        set msg "Unknown service '$serviceName'"
        ::return \
            -code error \
            -errorCode [list WS SERVER UNKSERV $serviceName] \
            $msg
    }
................................................................................
    variable serviceArr
    variable procInfo
    variable mode

    array set serviceData $serviceArr($serviceName)

    set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]]
    ::log::logsubst debug {Generating WSDL for $serviceName on $sock with {$args}}
    if {![info exists serviceArr($serviceName)]} {
        set msg "Unknown service '$serviceName'"
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData \
                    $sock \
                    "text/html; charset=UTF-8" \
................................................................................
###########################################################################
# NOTE: This proc only works with Rivet
# TODO: Update to handle jsonp?
proc ::WS::Server::generateJsonInfo { service sock args } {
    variable serviceArr
    variable procInfo

    ::log::logsubst debug {Generating JSON Documentation for $service on $sock with {$args}}
    set serviceInfo $serviceArr($service)
    array set serviceData $serviceInfo
    set doc [yajl create #auto -beautify $serviceData(-beautifyJson)]

    $doc map_open

    $doc string operations array_open
................................................................................
        $doc string description string $description

        # parameters
        if {[llength [dict get $procInfo $service op$oper argOrder]]} {
            $doc string inputs array_open
            
            foreach arg [dict get $procInfo $service op$oper argOrder] {
                ::log::logsubst debug {\t\t\tDisplaying '$arg'}
                if {[dict exists $procInfo $service op$oper argList $arg comment]} {
                    set comment [dict get $procInfo $service op$oper argList $arg comment]
                } else {
                    set comment {}
                }

                set type [dict get $procInfo $service op$oper argList $arg type]
................................................................................

    $doc array_close

    ::log::log debug "\tDisplay custom types"
    $doc string types array_open
    set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service]
    foreach type [lsort -dictionary [dict keys $localTypeInfo]] {
        ::log::logsubst debug {\t\tDisplaying '$type'}

        $doc map_open
        $doc string name string $type
        $doc string fields array_open
        
        set typeDetails [dict get $localTypeInfo $type definition]
        foreach part [lsort -dictionary [dict keys $typeDetails]] {
            ::log::logsubst debug {\t\t\tDisplaying '$part'}
            set subType [dict get $typeDetails $part type]
            set comment {}
            if {[dict exists $typeDetails $part comment]} {
                set comment [dict get $typeDetails $part comment]
            }
            $doc map_open string field string $part string type string $subType string comment string $comment map_close
        }
................................................................................
#
###########################################################################
proc ::WS::Server::generateInfo {service sock args} {
    variable serviceArr
    variable procInfo
    variable mode

    ::log::logsubst debug {Generating HTML Documentation for $service on $sock with {$args}}
    if {![info exists serviceArr($service)]} {
        set msg "Unknown service '$service'"
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData \
                    $sock \
                    "text/html; charset=UTF-8" \
................................................................................

    # decide if SOAP or REST mode should be used.
    set flavor "soap"
    if {[lsearch -exact $args "-rest"] != -1} {
        set flavor "rest"
    }

    ::log::logsubst debug {In ::WS::Server::callOperation {$service $sock $args}}
    array set serviceInfo $serviceArr($service)
    ::log::logsubst debug {\tDocument is {$inXML}}

    set ::errorInfo {}
    set ::errorCode {}
    set ns $service

    set inTransform $serviceInfo(-intransform)
    set outTransform $serviceInfo(-outtransform)
................................................................................
            set first [string first {<} $inXML]
            if {$first > 0} {
                set inXML [string range $inXML $first end]
            }
            # parse the XML request
            dom parse $inXML doc
            $doc documentElement top
            ::log::logsubst debug {$doc selectNodesNamespaces \
                    [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
                    $service http://$serviceInfo(-host)$serviceInfo(-prefix)]}
            $doc selectNodesNamespaces \
                [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
                     $service http://$serviceInfo(-host)$serviceInfo(-prefix)]
            $doc documentElement rootNode
            
            # extract the name of the method
            set top [$rootNode selectNodes /ENV:Envelope/ENV:Body/*]
................................................................................
            set legacyRpcMode 0
            if {$requestMessage == ""} {
                # older RPC/Encoded clients need to try nodeName instead.
                # Python pySoap needs this.
                catch {$top nodeName} requestMessage
                set legacyRpcMode 1
            }
            ::log::logsubst debug {requestMessage = {$requestMessage} legacyRpcMode=$legacyRpcMode}
            if {[string match {*Request} $requestMessage]} {
                set operation [string range $requestMessage 0 end-7]
            } else {
                # broken clients might not have sent the correct Document Wrapped name.
                # Python pySoap and Perl SOAP::Lite need this.
                set operation $requestMessage
                set legacyRpcMode 1
            }
            ::log::logsubst debug {operation = '$operation' legacyRpcMode=$legacyRpcMode}
            set contentType "text/xml"
        }
        default {
            if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} "UnknownMethod" $flavor }
            error "bad flavor"
        }
    }
................................................................................
                    CLIENT \
                    $msg \
                    [list "errorCode" $::errorCode "stackTrace" $::errorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 404
        if {$errorCallback ne {}} { $errorCallback "UNKNOWN_METHOD $msg" httpStatus $operation $flavor }
        ::log::logsubst debug {Leaving @ error 1::WS::Server::callOperation $response}

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {
................................................................................
            rest {
                set tclArgList {}
                foreach argName $methodArgs {
                    set argType [string trim [dict get $argInfo $argName type]]
                    set typeInfoList [::WS::Utils::TypeInfo Server $service $argType]

                    if {![info exists rawargs($argName)]} {
                        ::log::logsubst debug {did not find argument for $argName, leaving blank}
                        lappend tclArgList {}
                        continue
                    }

                    switch -exact -- $typeInfoList {
                        {0 0} {
                            ## Simple non-array
................................................................................
                        } else {
                            # legacyRpcMode only, access arguments by index
                            set path "legacy argument index $argIndex"
                            set node [lindex [$top childNodes] $argIndex]
                            incr argIndex
                        }
                        if {[string equal $node {}]} {
                            ::log::logsubst debug {did not find argument for $argName using $path, leaving blank (pass $pass)}
                            lappend tclArgList {}
                            continue
                        }
                        ::log::logsubst debug {found argument $argName using $path, processing $node}
                        set gotAnyArgs 1
                        switch -exact -- $typeInfoList {
                            {0 0} {
                                ## Simple non-array
                                lappend tclArgList [$node asText]
                            }
                            {0 1} {
................................................................................
                                lappend tclArgList $tmp
                            }
                            default {
                                ## Do nothing
                            }
                        }
                    }
                    ::log::logsubst debug {gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode}
                    if {$gotAnyArgs || !$legacyRpcMode} break
                }
            }
            default {
                if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} $operation $flavor }
                error "invalid flavor"
            }
        }
        ::log::logsubst debug {finalargs $tclArgList}
    } errMsg]} {
        ::log::log error $errMsg
        set localerrorCode $::errorCode
        set localerrorInfo $::errorInfo
        set response [generateError \
                    $serviceInfo(-traceEnabled) \
                    CLIENT \
                    "Error Parsing Arguments -- $errMsg" \
                    [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 400
        if {$errorCallback ne {}} { $errorCallback "INVALID_ARGUMENT $errMsg" httpStatus $operation $flavor }
        ::log::logsubst debug {Leaving @ error 3::WS::Server::callOperation $response}

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {
................................................................................
        }
        if {[info exists serviceInfo(-postmonitor)] &&
            [string length $serviceInfo(-postmonitor)]} {
            set precmd $serviceInfo(-postmonitor)
            lappend precmd POST $service $operation OK $results
            catch $precmd
        }
        ::log::logsubst debug {Leaving ::WS::Server::callOperation $response}
        switch -exact -- $mode {
            tclhttpd {
                ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response 200
            }
            embedded {
                ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response 200
            }
................................................................................
                    CLIENT \
                    $msg \
                    [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \
                    $flavor]
        catch {$doc delete}
        set httpStatus 500
        if {$errorCallback ne {}} { $errorCallback $msg httpStatus $operation $flavor }
        ::log::logsubst debug {Leaving @ error 2::WS::Server::callOperation $response}

        # wrap in JSONP
        if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
            set response "$rawargs(jsonp_callback)($response)"
        }

        switch -exact -- $mode {
................................................................................
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  07/06/2006  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Server::generateError {includeTrace faultcode faultstring detail flavor} {
    ::log::logsubst debug {Entering ::WS::Server::generateError $faultcode $faultstring {$detail}}
    set code [lindex $detail 1]
    switch -exact -- $code {
        "VersionMismatch" {
            set code "SOAP-ENV:VersionMismatch"
        }
        "MustUnderstand" {
            set code "SOAP-ENV:MustUnderstand"
................................................................................
                [$doc asXML -indent none -doctypeDeclaration 0]
            $doc delete
        }
        default {
            error "unsupported flavor"
        }
    }
    ::log::logsubst debug {Leaving (error) ::WS::Server::generateError $response}
    return $response
}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
................................................................................
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  07/06/2006  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Server::generateReply {serviceName operation results flavor} {
    ::log::logsubst debug {Entering ::WS::Server::generateReply $serviceName $operation {$results}}

    variable serviceArr

    array set serviceData $serviceArr($serviceName)


    switch -exact -- $flavor {
................................................................................
            $doc delete
        }
        default {
            error "Unsupported flavor"
        }
    }

    ::log::logsubst debug {Leaving ::WS::Server::generateReply $output}
    return $output

}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
................................................................................
    foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] {
        lappend operList $oper "#op_$oper"
    }
    append msg [::html::h2 {<a id='OperDetails'>Operation Details</a>}]

    set docFormat [dict get $serviceInfo -docFormat]
    foreach {oper anchor} $operList {
        ::log::logsubst debug {\t\tDisplaying '$oper'}
        append msg [::html::h3 "<a id='op_$oper'>$oper</a>"]

        append msg [::html::h4 {Description}] "\n"

        append msg [::html::openTag div {style="margin-left: 40px;"}]
        switch -exact -- $docFormat {
            "html" {
................................................................................

        append msg [::html::openTag div {style="margin-left: 40px;"}]

        if {[llength [dict get $procInfo $service op$oper argOrder]]} {
            append msg [::html::openTag {table} {border="2"}]
            append msg [::html::hdrRow Name Type Description]
            foreach arg [dict get $procInfo $service op$oper argOrder] {
                ::log::logsubst debug {\t\t\tDisplaying '$arg'}
                if {[dict exists $procInfo $service op$oper argList $arg comment]} {
                    set comment [dict get $procInfo $service op$oper argList $arg comment]
                } else {
                    set comment {}
                }
                append msg [::html::row \
                                $arg \
................................................................................
    ##
    ::log::log debug "\tDisplay custom types"
    set service [dict get $serviceInfo -service]
    append msg [::html::h2 {<a id='CustomTypeDetails'>Custom Types</a>}]

    set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service]
    foreach type [lsort -dictionary [dict keys $localTypeInfo]] {
        ::log::logsubst debug {\t\tDisplaying '$type'}
        set href_type [lindex [split $type :] end]
        set typeOverloadArray($type) 1
        append msg [::html::h3 "<a id='type_${href_type}'>$type</a>"]
        set typeDetails [dict get $localTypeInfo $type definition]
        append msg [::html::openTag {table} {border="2"}]
        append msg [::html::hdrRow Field Type Comment]
        foreach part [lsort -dictionary [dict keys $typeDetails]] {
            ::log::logsubst debug {\t\t\tDisplaying '$part'}
            if {[dict exists $typeDetails $part comment]} {
                set comment [dict get $typeDetails $part comment]
            } else {
                set comment {}
            }
            append msg [::html::row \
                            $part \
................................................................................
    set service [dict get $serviceInfo -service]
    append msg [::html::h2 {<a id='SimpleTypeDetails'>Simple Types</a>}]

    append msg "\n<br/>\n<center>" [::html::minorMenu $menuList] "</center>"
    set localTypeInfo [::WS::Utils::GetServiceSimpleTypeDef Server $service]
    foreach typeDetails [lsort -dictionary -index 0 $localTypeInfo] {
        set type [lindex $typeDetails 0]
        ::log::logsubst debug {\t\tDisplaying '$type'}
        set typeOverloadArray($type) 1
        append msg [::html::h3 "<a id='type_$type'>$type</a>"]
        append msg [::html::openTag {table} {border="2"}]
        append msg [::html::hdrRow Attribute Value]
        foreach part [lsort -dictionary [dict keys [lindex $typeDetails 1]]] {
            ::log::logsubst debug {\t\t\tDisplaying '$part'}
            append msg [::html::row \
                            $part \
                            [dict get [lindex $typeDetails 1] $part]
                       ]
        }
        append msg [::html::closeTag]
    }
    append msg "\n<hr/>\n"

    return $msg
}

Changes to Utilities.tcl.

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
    }
}

package require log

# Emulate the log::logsubst command introduced in log 1.4
if {![llength [info command ::log::logsubst]]} {
    if {![llength [info command ::tailcall]]} {
        proc ::log::logsubst {level text} {
            if {[::log::lvIsSuppressed $level]} {
                return
            }
            ::log::log $level [uplevel 1 [list subst $text]]
        }
    } else {
        proc ::log::logsubst {level text} {
            if {[::log::lvIsSuppressed $level]} {
                return
            }
            tailcall ::log::log $level [uplevel 1 [list subst $text]]
        }
    }
}

package require tdom 0.8
package require struct::set

package provide WS::Utils 2.4.2








<
|
|
|
|
|
|
<
<
<
<
<
<
<
<







55
56
57
58
59
60
61

62
63
64
65
66
67








68
69
70
71
72
73
74
    }
}

package require log

# Emulate the log::logsubst command introduced in log 1.4
if {![llength [info command ::log::logsubst]]} {

	proc ::log::logsubst {level text} {
		if {[::log::lvIsSuppressed $level]} {
			return
		}
		::log::log $level [uplevel 1 [list subst $text]]
	}








}

package require tdom 0.8
package require struct::set

package provide WS::Utils 2.4.2

Changes to pkgIndex.tcl.

7
8
9
10
11
12
13
14
15
16
17
18
# 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.5.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.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]]







|
|



7
8
9
10
11
12
13
14
15
16
17
18
# 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.5.1 [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Embeded 2.4.1 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::Server 2.4.1 [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.4.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]]