Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch trunk Excluding Merge-Ins
This is equivalent to a diff from 1165efefab to 940f1b929d
2023-11-30 10:14 | Update all package require commands to also allow TCL 9 Leaf check-in: 940f1b929d user: oehhar tags: trunk | |
2021-10-18 16:48 | Correct two comment issues check-in: 9e9012477f user: oehhar tags: trunk | |
2011-03-19 01:43 | Correct typo check-in: 9697f83d44 user: gerald tags: trunk | |
2011-03-18 19:59 | correct package version numbers to 1.4.1 Closed-Leaf check-in: 1165efefab user: gerald tags: Release_1.4.1 | |
2011-03-17 05:09 | Fixes for tickets: [668852fcac], [aa05504f11] and [7eb636dce1] check-in: 112f7b64d7 user: gerald tags: Release_1.4.1 | |
Changes to AOLserver.tcl.
1 2 3 4 5 6 7 | namespace eval ::WS::AOLserver { if {![info exists logVersion]} { variable logVersion [package require log] } if {![info exists wsVersion]} { | > | 1 2 3 4 5 6 7 8 | package require Tcl 8.6- namespace eval ::WS::AOLserver { if {![info exists logVersion]} { variable logVersion [package require log] } if {![info exists wsVersion]} { |
︙ | ︙ | |||
107 108 109 110 111 112 113 | default { ns_return 200 text/plain "prefix = $prefix service = $service requestType = $requestType" } } } } | | | 108 109 110 111 112 113 114 115 | default { ns_return 200 text/plain "prefix = $prefix service = $service requestType = $requestType" } } } } package provide WS::AOLserver 2.4.0 |
Changes to ChannelServer.tcl.
︙ | ︙ | |||
28 29 30 31 32 33 34 35 36 37 38 39 | ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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 uri package require base64 package require html | > > > > > > > > > > > > > > > > > | | 28 29 30 31 32 33 34 35 36 37 38 39 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 | ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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.6- # XXX WS::Utils usable here? (provide dict, lassign) if {![llength [info command dict]]} { package require dict } if {![llength [info command lassign]]} { proc lassign {inList args} { set numArgs [llength $args] set i -1 foreach var $args { incr i uplevel 1 [list set $var [lindex $inList $i]] } return [lrange $inList $numArgs end] } } package require uri package require base64 package require html package provide WS::Channel 2.4.0 namespace eval ::WS::Channel { array set portInfo {} array set dataArray {} } |
︙ | ︙ | |||
55 56 57 58 59 60 61 | # # Procedure Name : ::WS::Channel::AddHandler # # Description : Register a handler for a url on a port. # # Arguments : # ports -- The port to register the callback on | | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | # # Procedure Name : ::WS::Channel::AddHandler # # Description : Register a handler for a url on a port. # # Arguments : # ports -- The port to register the callback on # operation -- {} for WSDL callback, otherwise operation callback # callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : # None # |
︙ | ︙ |
Deleted CheckAndBuild.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to ClientSide.tcl.
1 2 | ############################################################################### ## ## | > | | 1 2 3 4 5 6 7 8 9 10 11 | ############################################################################### ## ## ## Copyright (c) 2016-2019, Harald Oehlmann ## ## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Arnulf Wiedemann ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## ## Copyright (c) 2001-2006, Pat Thoyts ## ## All rights reserved. ## |
︙ | ︙ | |||
35 36 37 38 39 40 41 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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. ## ## ## ############################################################################### | | < < | < > > > > > > | | | > > > > > | > > | > | > > | > | | 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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.6- package require WS::Utils ; # logsubst package require tdom 0.8 package require http 2 package require log package require uri package provide WS::Client 3.0.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 http::register https 443 ::tls::socket } err]} { log::log warning "No TLS package: $err" if { [catch { package require twapi_crypto http::register https 443 ::twapi::tls_socket } Err] } { log::log warning "No https support. No TWAPI package: $err" } } } else { # Ok, was registered - reregister http::register https {*}$lPortCmd } unset -nocomplain err lPortCmd ## ## serviceArr is indexed by service name and contains a dictionary that ## defines the service. The dictionary has the following structure: ## targetNamespace - the target namespace ## operList - list of operations ## objList - list of operations ## headers - list of http headers |
︙ | ︙ | |||
87 88 89 90 91 92 93 | ## is the operations name and each with the following structure: ## inputs --- list of fields with type info ## outputs --- return type ## ## Note -- all type information is formated suitable to be passed ## to ::WS::Utils::ServiceTypeDef ## | | | > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | ## is the operations name and each with the following structure: ## inputs --- list of fields with type info ## outputs --- return type ## ## Note -- all type information is formated suitable to be passed ## to ::WS::Utils::ServiceTypeDef ## array set ::WS::Client::serviceArr {} set ::WS::Client::currentBaseUrl {} array set ::WS::Client::options { skipLevelWhenActionPresent 0 skipLevelOnReply 0 skipHeaderLevel 0 suppressTargetNS 0 allowOperOverloading 1 contentType {text/xml;charset=utf-8} UseNS {} parseInAttr {} genOutAttr {} valueAttrCompatiblityMode 1 suppressNS {} useTypeNs {} nsOnChangeOnly {} noTargetNs 0 errorOnRedefine 0 inlineElementNS 1 queryTimeout 60000 } ## ## List of options which are copied to the service array ## set ::WS::Client::serviceLocalOptionsList { skipLevelWhenActionPresent skipLevelOnReply skipHeaderLevel suppressTargetNS allowOperOverloading contentType UseNS parseInAttr genOutAttr valueAttrCompatiblityMode suppressNS useTypeNs nsOnChangeOnly noTargetNs queryTimeout } ## ## List of options which are set and restored in the Utilities module ## when we do a call into the module ## set ::WS::Client::utilsOptionsList { UseNS parseInAttr genOutAttr valueAttrCompatiblityMode suppressNS useTypeNs nsOnChangeOnly } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::SetOption # # Description : Set or get file global or default option. # Global option control the service creation process. # Default options are takren as defaults to new created services. # # Arguments : # -globalonly # - Return list of global options/values # -defaultonly # - Return list of default options/values # -- # option - Option to be set/retrieved # Return all option/values if omitted # args - Value to set the option to # Return the value if not given # # Returns : The value of the option # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 04/272009 G.Lester Initial version # 2.4.5 2017-12-04 H.Oehlmann Return all current options if no argument # given. Options -globalonly or -defaultonly # limit this to options which are (not) # copied to the service. # ########################################################################### proc ::WS::Client::SetOption {args} { variable options variable serviceLocalOptionsList if {0 == [llength $args]} { return [array get options] } set args [lassign $args option] switch -exact -- $option { -globalonly { ## ## Return list of global options ## # A list convertible to a dict is build for performance reasons: # - lappend does not test existence for each element # - if a list is needed, dict build burden is avoided set res {} foreach option [array names options] { if {$option ni $serviceLocalOptionsList} { lappend res $option $options($option) } } return $res } -defaultonly { ## ## Return list of default options ## set res {} foreach option [array names options] { if {$option in $serviceLocalOptionsList} { lappend res $option $options($option) } } return $res } -- { ## ## End of options ## set args [lassign $args option] } } ## ## Check if given option exists ## if {![info exists options($option)]} { return -code error \ -errorcode [list WS CLIENT UNKOPT $option] \ "Unknown option: '$option'" } ## ## Check if value is given ## switch -exact -- [llength $args] { 0 { return $options($option) } 1 { set value [lindex $args 0] set options($option) $value return $value } default { return -code error \ -errorcode [list WS CLIENT INVALDCNT $args] \ "To many parameters: '$args'" } } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # |
︙ | ︙ | |||
129 130 131 132 133 134 135 | # 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 04/14/2009 G.Lester Initial version | | > > | > > > > > > > > | > > > > > | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 | # 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 04/14/2009 G.Lester Initial version # 2.4.5 2017-12-04 H.Oehlmann Use distinct list of option items, which are # copied to the service array. Not all options # are used in the service array. # ########################################################################### proc ::WS::Client::CreateService {serviceName type url target args} { variable serviceArr variable options variable serviceLocalOptionsList if {$options(errorOnRedefine) && [info exists serviceArr($serviceName)]} { return -code error "Service '$serviceName' already exists" } elseif {[info exists serviceArr($serviceName)]} { unset serviceArr($serviceName) } dict set serviceArr($serviceName) types {} dict set serviceArr($serviceName) operList {} dict set serviceArr($serviceName) objList {} dict set serviceArr($serviceName) headers {} dict set serviceArr($serviceName) targetNamespace tns1 $target dict set serviceArr($serviceName) name $serviceName dict set serviceArr($serviceName) location $url dict set serviceArr($serviceName) style $type dict set serviceArr($serviceName) imports {} dict set serviceArr($serviceName) inTransform {} dict set serviceArr($serviceName) outTransform {} foreach item $serviceLocalOptionsList { dict set serviceArr($serviceName) $item $options($item) } foreach {name value} $args { set name [string trimleft $name {-}] dict set serviceArr($serviceName) $name $value } ::log::logsubst debug {Setting Target Namespace tns1 as $target} if {[dict exists $serviceArr($serviceName) xns]} { foreach xnsItem [dict get $serviceArr($serviceName) xns] { lassign $xnsItem tns xns ::log::logsubst debug {Setting targetNamespace $tns for $xns} dict set serviceArr($serviceName) targetNamespace $tns $xns } } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::Config # # Description : Configure a service information # # Arguments : # serviceName - Service name to add namespace to. # Return a list of items/values of default options if not # given. # item - The item to configure. Return a list of all items/values # if not given. # value - Optional, the new value. Return the value, if not given. # # Returns : The value of the option or a list of item/value pairs. # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 04/14/2009 G.Lester Initial version # 2.4.5 2017-12-04 H.Oehlmann Allow to set an option to the empty string. # Return all option/values, if called without # item. Return default items/values if no # service given. # ########################################################################### proc ::WS::Client::Config {args} { variable serviceArr variable options variable serviceLocalOptionsList set validOptionList $serviceLocalOptionsList lappend validOptionList location targetNamespace if {0 == [llength $args]} { # A list convertible to a dict is build for performance reasons: # - lappend does not test existence for each element # - if a list is needed, dict build burden is avoided set res {} foreach item $validOptionList { lappend res $item if {[info exists options($item)]} { lappend res $options($item) } else { lappend res {} } } return $res } set args [lassign $args serviceName] if {0 == [llength $args]} { set res {} foreach item $validOptionList { lappend res $item [dict get $serviceArr($serviceName) $item] } return $res } set args [lassign $args item] if { $item ni $validOptionList } { return -code error "Uknown option '$item' -- must be one of: [join $validOptionList {, }]" } switch -exact -- [llength $args] { 0 { return [dict get $serviceArr($serviceName) $item] } 1 { set value [lindex $args 0] dict set serviceArr($serviceName) $item $value return $value } default { ::log::log debug "To many arguments arguments {$args}" return \ -code error \ -errorcode [list WS CLIENT INVARGCNT $args] \ "To many arguments '$args'" } } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. |
︙ | ︙ | |||
205 206 207 208 209 210 211 | ########################################################################### proc ::WS::Client::SetServiceTransforms {serviceName {inTransform {}} {outTransform {}}} { variable serviceArr dict set serviceArr($serviceName) inTransform $inTransform dict set serviceArr($serviceName) outTransform $outTransform | | | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 | ########################################################################### proc ::WS::Client::SetServiceTransforms {serviceName {inTransform {}} {outTransform {}}} { variable serviceArr dict set serviceArr($serviceName) inTransform $inTransform dict set serviceArr($serviceName) outTransform $outTransform return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
265 266 267 268 269 270 271 | #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DefineRestMethod # # Description : Define a method # # Arguments : | | > | | | | 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 | #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DefineRestMethod # # Description : Define a method # # Arguments : # serviceName - Service name to add namespace to # objectName - Name of the object # operationName - The name of the method to add # inputArgs - List of input argument definitions where each argument # definition is of the format: name typeInfo # returnType - The type, if any returned by the procedure. Format is: # xmlTag typeInfo # # where, typeInfo is of the format {type typeName comment commentString} # # Returns : The current service definition # # Side-Effects : None |
︙ | ︙ | |||
300 301 302 303 304 305 306 | # # ########################################################################### proc ::WS::Client::DefineRestMethod {serviceName objectName operationName inputArgs returnType {location {}}} { variable serviceArr if {[lsearch -exact [dict get $serviceArr($serviceName) objList] $objectName] == -1} { | | | | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 | # # ########################################################################### proc ::WS::Client::DefineRestMethod {serviceName objectName operationName inputArgs returnType {location {}}} { variable serviceArr if {[lsearch -exact [dict get $serviceArr($serviceName) objList] $objectName] == -1} { dict lappend serviceArr($serviceName) objList $objectName } if {![llength $location]} { set location [dict get $serviceArr($serviceName) location] } if {$inputArgs ne {}} { set inType $objectName.$operationName.Request ::WS::Utils::ServiceTypeDef Client $serviceName $inType $inputArgs } else { set inType {} } if {$returnType ne {}} { set outType $objectName.$operationName.Results ::WS::Utils::ServiceTypeDef Client $serviceName $outType $returnType } else { set outType {} } dict set serviceArr($serviceName) object $objectName location $location |
︙ | ︙ | |||
359 360 361 362 363 364 365 366 367 368 369 370 371 | # 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 01/30/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::ImportNamespace {serviceName url} { variable serviceArr | > > > > > | | < | < | < < < < < | < | | | | | | 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 | # 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 01/30/2009 G.Lester Initial version # 2.4.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # which also follows redirects. # 3.0.0 2020-10-26 H.Oehlmann Add geturl timeout # # ########################################################################### proc ::WS::Client::ImportNamespace {serviceName url} { variable serviceArr set serviceInfo $serviceArr($serviceName) switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set xml $token(data) unset token } http - https { set xml [::WS::Utils::geturl_fetchbody $url\ -timeout [dict get $serviceInfo queryTimeout]] } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } } set tnsCount [expr {[llength [dict get $serviceArr($serviceName) targetNamespace]]/2}] dict lappend serviceInfo imports $url ::WS::Utils::ProcessImportXml Client $url $xml $serviceName serviceInfo tnsCount set serviceArr($serviceName) $serviceInfo set result {} foreach {result target} [dict get $serviceArr($serviceName) targetNamespace] { if {$target eq $url} { break } } return $result } ########################################################################### # |
︙ | ︙ | |||
443 444 445 446 447 448 449 | # 1 01/30/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::GetOperationList {serviceName {object {}}} { variable serviceArr | | | | | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 | # 1 01/30/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::GetOperationList {serviceName {object {}}} { variable serviceArr if {$object eq {}} { return [dict get $serviceArr($serviceName) operList] } else { return [list $object [dict get $serviceArr($serviceName) operation $object inputs] [dict get $serviceArr($serviceName) operation $object outputs]] } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::AddInputHeader # # Description : Import and additional namespace into the service # # Arguments : # serviceName - Service name to of the operation # operation - name of operation to add an input header to # headerType - the type name to add as a header # attrList - list of name value pairs of attributes and their # values to add to the XML # # Returns : Nothing # |
︙ | ︙ | |||
499 500 501 502 503 504 505 | variable serviceArr set serviceInfo $serviceArr($serviceName) set soapRequestHeader [dict get $serviceInfo operation $operationName soapRequestHeader] lappend soapRequestHeader [list $headerType $attrList] dict set serviceInfo operation $operationName soapRequestHeader $soapRequestHeader set serviceArr($serviceName) $serviceInfo | | | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 | variable serviceArr set serviceInfo $serviceArr($serviceName) set soapRequestHeader [dict get $serviceInfo operation $operationName soapRequestHeader] lappend soapRequestHeader [list $headerType $attrList] dict set serviceInfo operation $operationName soapRequestHeader $soapRequestHeader set serviceArr($serviceName) $serviceInfo return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::AddOutputHeader # # Description : Import any additional namespace into the service # # Arguments : # serviceName - Service name to of the oepration # operation - name of operation to add an output header to # headerType - the type name to add as a header # attrList - list of name value pairs of attributes and their # values to add to the XML |
︙ | ︙ | |||
547 548 549 550 551 552 553 | # # ########################################################################### proc ::WS::Client::AddOutputHeader {serviceName operation headerType} { variable serviceArr set serviceInfo $serviceArr($serviceName) | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | > | > | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 | # # ########################################################################### proc ::WS::Client::AddOutputHeader {serviceName operation headerType} { variable serviceArr set serviceInfo $serviceArr($serviceName) set soapReplyHeader [dict get $serviceInfo operation $operation soapReplyHeader] lappend soapReplyHeader $headerType dict set serviceInfo operation $operation soapReplyHeader $soapReplyHeader set serviceArr($serviceName) $serviceInfo return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::GetParsedWsdl # # Description : Get a service definition # # Arguments : # serviceName - Name of the service. # # Returns : The parsed service information # # Side-Effects : None # # Exception Conditions : UNKSERVICE # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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::GetParsedWsdl {serviceName} { variable serviceArr if {![info exists serviceArr($serviceName)]} { return \ -code error "Unknown service '$serviceName'" \ -errorcode [list UNKSERVICE $serviceName] } return $serviceArr($serviceName) } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # |
︙ | ︙ | |||
599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 | # 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::LoadParsedWsdl {serviceInfo {headers {}} {serviceAlias {}}} { variable serviceArr if {[string length $serviceAlias]} { set serviceName $serviceAlias } else { set serviceName [dict get $serviceInfo name] } if {[llength $headers]} { dict set serviceInfo headers $headers } set serviceArr($serviceName) $serviceInfo if {[dict exists $serviceInfo types]} { foreach {typeName partList} [dict get $serviceInfo types] { | > > > > > > > > > > > > > > > > > > > > > > > > | | < | | | > | | | | | | | | > > | > | > > > | > | | > | < < > | | < | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 | # 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 # 3.0.0 2020-10-30 H.Oehlmann Smooth option migration. # # ########################################################################### proc ::WS::Client::LoadParsedWsdl {serviceInfo {headers {}} {serviceAlias {}}} { variable serviceArr variable options variable serviceLocalOptionsList if {[string length $serviceAlias]} { set serviceName $serviceAlias } else { set serviceName [dict get $serviceInfo name] } if {$options(errorOnRedefine) && [info exists serviceArr($serviceName)]} { return -code error "Service '$serviceName' already exists" } elseif {[info exists serviceArr($serviceName)]} { unset serviceArr($serviceName) } if {[llength $headers]} { dict set serviceInfo headers $headers } set serviceArr($serviceName) $serviceInfo ## ## Copy any not present options from the default values ## This allows smooth migration, if a new version of the package define ## new options and the preparsed service of the old version was stored. ## foreach item $serviceLocalOptionsList { if {![dict exists $serviceArr($serviceName) $item]} { dict set serviceArr($serviceName) $item $options($item) } } if {[dict exists $serviceInfo types]} { foreach {typeName partList} [dict get $serviceInfo types] { set definition [dict get $partList definition] set xns [dict get $partList xns] set isAbstarct [dict get $partList abstract] if {[lindex [split $typeName {:}] 1] eq {}} { ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition tns1 $isAbstarct } else { #set typeName [lindex [split $typeName {:}] 1] ::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition $xns $isAbstarct } } } if {[dict exists $serviceInfo simpletypes]} { foreach partList [dict get $serviceInfo simpletypes] { lassign $partList typeName definition if {[lindex [split $typeName {:}] 1] eq {}} { ::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $definition tns1 } else { set xns [lindex [split $typeName {:}] 0] #set typeName [lindex [split $typeName {:}] 1] ::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $definition $xns } } } return $serviceName } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::GetAndParseWsdl # # Description : # # Arguments : # url - The url of the WSDL # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the name # of the service in serviceInfo. # serviceNumber - Number of service within the WSDL to assign the # serviceAlias to. Only usable with a serviceAlias. # First service (default) is addressed by value "1". # # Returns : The parsed service definition # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # 2.4.6 2017-12-07 H.Oehlmann Added argument "serviceNumber". # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # ########################################################################### proc ::WS::Client::GetAndParseWsdl {url {headers {}} {serviceAlias {}} {serviceNumber 1}} { variable currentBaseUrl variable options set currentBaseUrl $url switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set wsdlInfo [ParseWsdl $token(data) -headers $headers -serviceAlias $serviceAlias -serviceNumber $serviceNumber] unset token } http - https { set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody $url\ -timeout $options(queryTimeout) {*}$largs] set wsdlInfo [ParseWsdl $body -headers $headers -serviceAlias $serviceAlias -serviceNumber $serviceNumber] } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } |
︙ | ︙ | |||
730 731 732 733 734 735 736 | # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::ParseWsdl # | | < < < | | | > > > > > | > > > > > > > > > > > > > | > > | > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | | | > > | > | 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 | # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::ParseWsdl # # Description : Parse a WSDL and create the service. Create stubs if specified. # # Arguments : # wsdlXML - XML of the WSDL # # Optional Arguments: # -createStubs 0|1 - create stub routines for the service # -headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # -serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the # name of the service in serviceInfo. # -serviceNumber - Number of service within the WSDL to assign the # serviceAlias to. Only usable with a serviceAlias. # First service (default) is addressed by value "1". # # NOTE -- Arguments are position independent. # # Returns : The parsed service definition # # Side-Effects : None # # Exception Conditions :None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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.4 2017-11-03 H.Oehlmann Included ticket [dcce437d7a] with # solution by Wolfgang Winkler: # Search namespace prfix also in element # nodes and not only in definition node # of wsdl file. # 2.4.4 2017-11-06 H.Oehlmann Added check (for nested namespace prefix # case), that a namespace prefix is not # reused for another URI. # 2.4.5 2017-11-24 H.Oehlmann Added option "inlineElementNS" to activate # namespace definition search in element nodes # 2.4.6 2017-12-07 H.Oehlmann Added argument "-serviceNumber". # ########################################################################### proc ::WS::Client::ParseWsdl {wsdlXML args} { variable currentBaseUrl variable serviceArr variable options # Build the argument array with the following defaults array set argument { -createStubs 0 -headers {} -serviceAlias {} -serviceNumber 1 } array set argument $args set first [string first {<} $wsdlXML] if {$first > 0} { set wsdlXML [string range $wsdlXML $first end] } ::log::logsubst debug {Parsing WSDL: $wsdlXML} # save parsed document node to tmpdoc dom parse $wsdlXML tmpdoc # save transformed document handle in variable wsdlDoc $tmpdoc xslt $::WS::Utils::xsltSchemaDom wsdlDoc $tmpdoc delete # save top node in variable wsdlNode $wsdlDoc documentElement wsdlNode set nsCount 1 set targetNs [$wsdlNode getAttribute targetNamespace] set ::WS::Utils::targetNs $targetNs ## ## Build the namespace prefix dict ## # nsDict contains two tables: # 1) Lookup URI, get internal prefix # url <URI> <tns> # 2) Lookup wsdl namespace prefix, get internal namespace prefix # tns <ns> <tns> # <URI>: unique ID, mostly URL # <ns>: namespace prefix used in wsdl # <tns> internal namespace prefix which allows to use predefined prefixes # not to clash with the wsdl prefix in <ns> # Predefined: # - tns1 : targetNamespace # - w: http://schemas.xmlsoap.org/wsdl/ # - d: http://schemas.xmlsoap.org/wsdl/soap/ # - xs: http://www.w3.org/2001/XMLSchema # # The top node # <wsdl:definitions # targetNamespace="http://www.webserviceX.NET/"> # xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/ ...> # contains the target namespace and all namespace definitions dict set nsDict url $targetNs tns$nsCount $wsdlDoc selectNodesNamespaces { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ xs http://www.w3.org/2001/XMLSchema } ## ## build list of namespace definition nodes ## ## the top node is always used set NSDefinitionNodeList [list $wsdlNode] ## ## get namespace definitions in element nodes ## ## Element nodes may declare namespaces inline like: ## <xs:element xmlns:q1="myURI" type="q1:MessageQ1"/> ## ticket [dcce437d7a] # This is only done, if option inlineElementNS is set in the default # options. Service dependent options may not be used at this stage, # as serviceArr is not created jet (Client::Config will fail) and the # service name is not known jet. if {$options(inlineElementNS)} { lappend NSDefinitionNodeList {*}[$wsdlDoc selectNodes {//xs:element}] } foreach elemNode $NSDefinitionNodeList { # Get list of xmlns attributes # This list looks for the example like: {{q1 q1 {}} ... } set xmlnsAttributes [$elemNode attributes xmlns:*] # Loop over found namespaces foreach itemList $xmlnsAttributes { set ns [lindex $itemList 0] set url [$elemNode getAttribute xmlns:$ns] if {[dict exists $nsDict url $url]} { set tns [dict get $nsDict url $url] } else { ## ## Check for hardcoded namespaces ## switch -exact -- $url { http://schemas.xmlsoap.org/wsdl/ { set tns w } http://schemas.xmlsoap.org/wsdl/soap/ { set tns d } http://www.w3.org/2001/XMLSchema { set tns xs } default { set tns tns[incr nsCount] } } dict set nsDict url $url $tns } ## ## Check if same namespace prefix was already assigned to a ## different URL ## # This may happen, if the element namespace prefix overwrites # a global one, like # <wsdl:definitions xmlns:q1="URI1" ...> # <xs:element xmlns:q1="URI2" type="q1:MessageQ1"/> if { [dict exists $nsDict tns $ns] && $tns ne [dict get $nsDict tns $ns] } { ::log::logsubst debug {Namespace prefix '$ns' with different URI '$url': $nsDict} return \ -code error \ -errorcode [list WS CLIENT AMBIGNSPREFIX] \ "element namespace prefix '$ns' used again for different URI '$url'.\ Sorry, this is a current implementation limitation of TCLWS." } dict set nsDict tns $ns $tns } } if {[info exists currentBaseUrl]} { set url $currentBaseUrl } else { set url $targetNs } array unset ::WS::Utils::includeArr ::WS::Utils::ProcessIncludes $wsdlNode $url set serviceInfo {} foreach serviceInfo [buildServiceInfo $wsdlNode $nsDict $serviceInfo $argument(-serviceAlias) $argument(-serviceNumber)] { set serviceName [dict get $serviceInfo name] if {[llength $argument(-headers)]} { dict set serviceInfo headers $argument(-headers) } dict set serviceInfo types [::WS::Utils::GetServiceTypeDef Client $serviceName] dict set serviceInfo simpletypes [::WS::Utils::GetServiceSimpleTypeDef Client $serviceName] set serviceArr($serviceName) $serviceInfo if {$argument(-createStubs)} { catch {namespace delete $serviceName} namespace eval $serviceName {} CreateStubs $serviceName } } $wsdlDoc delete unset -nocomplain ::WS::Utils::targetNs return $serviceInfo } ########################################################################### # |
︙ | ︙ | |||
880 881 882 883 884 885 886 887 888 889 890 | } set serviceInfo $serviceArr($serviceName) set procList {} foreach operationName [dict get $serviceInfo operList] { set procName [format {::%s::%s} $serviceName $operationName] set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] | > > > | | | | | | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 | } set serviceInfo $serviceArr($serviceName) set procList {} foreach operationName [dict get $serviceInfo operList] { if {[dict get $serviceInfo operation $operationName cloned]} { continue } set procName [format {::%s::%s} $serviceName $operationName] set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] if {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] if {$headerFields ne {}} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] ## Petasis, 14 July 2008: If an input message has no elements, just do ## not add any arguments... set inputMsgTypeDefinition [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] if {[dict exists $inputMsgTypeDefinition definition]} { set inputFields [dict keys [dict get $inputMsgTypeDefinition definition]] } else { ::log::logsubst debug {no definition found for inputMsgType $inputMsgType} set inputFields {} } if {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } set argList [join $argList] set body { set procName [lindex [info level 0] 0] set serviceName [string trim [namespace qualifiers $procName] {:}] set operationName [string trim [namespace tail $procName] {:}] set argList {} foreach var [namespace eval ::${serviceName}:: [list info args $operationName]] { lappend argList $var [set $var] } ::log::logsubst debug {::WS::Client::DoCall $serviceName $operationName $argList} ::WS::Client::DoCall $serviceName $operationName $argList } proc $procName $argList $body append procList "\n\t[list $procName $argList]" } return "$procList\n" } |
︙ | ︙ | |||
939 940 941 942 943 944 945 | # Procedure Name : ::WS::Client::DoRawCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call | | | > > > > | > > > > > > | > > > > > | < < < < | < < | | < < < < < | | < < > < < < | | < | > | | | | < | | > > > > | > > > > > > > | > > > > > | > > > > > > < | < < < > | > > > > | | < | > > > > > > > | < > > | | < < | > | > | > | < < > > > > > > > > | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 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 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 | # Procedure Name : ::WS::Client::DoRawCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object. # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # The XML of the operation. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # which also follows redirects. # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRawCall {serviceName operationName argList {headers {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } ## ## build query ## set url [dict get $serviceInfo location] SaveAndSetOptions $serviceName if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } if {[dict exists $serviceInfo operation $operationName action]} { lappend headers SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]] } ## ## do http call ## set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody $url\ -query $query\ -type [dict get $serviceInfo contentType]\ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs] ::log::logsubst debug {Leaving ::WS::Client::DoRawCall with {$body}} return $body } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # The return value of the operation as a dictionary object. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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.1 2017-08-30 H.Oehlmann Use ::WS::Utils::geturl_fetchbody to do # http call. This automates a lot and follows # redirects. # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoCall {serviceName operationName argList {headers {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } elseif {[dict get $serviceInfo operation $operationName cloned]} { return \ -code error \ -errorcode [list WS CLIENT MUSTCALLCLONE [list $serviceName $operationName]] \ "Operation '$operationName' for service '$serviceName' is overloaded, you must call one of its clones." } set url [dict get $serviceInfo location] SaveAndSetOptions $serviceName if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo "buildCallquery error -- $err" } else { RestoreSavedOptions $serviceName } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } if {[dict exists $serviceInfo operation $operationName action]} { lappend headers SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]] } ## ## Do the http request ## # This will directly return with correct error # side effect: sets the variable httpCode set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody -codeok {200 500} -codevar httpCode $url\ -query $query\ -type [dict get $serviceInfo contentType]\ -headers $headers\ {*}$largs] # numerical http code was saved in variable httpCode ## ## Process body ## set outTransform [dict get $serviceInfo outTransform] if {$httpCode == 500} { ## Code 500 treatment if {$outTransform ne {}} { SaveAndSetOptions $serviceName catch {set body [$outTransform $serviceName $operationName REPLY $body]} RestoreSavedOptions $serviceName } set hadError [catch {parseResults $serviceName $operationName $body} results] if {$hadError} { lassign $::errorCode mainError subError if {$mainError eq {WSCLIENT} && $subError eq {NOSOAP}} { ::log::logsubst debug {\tHTTP error $body} set results $body set errorCode [list WSCLIENT HTTPERROR $body] set errorInfo {} } else { ::log::logsubst debug {Reply was $body} set errorCode $::errorCode set errorInfo $::errorInfo } } } else { if {$outTransform ne {}} { SaveAndSetOptions $serviceName catch {set body [$outTransform $serviceName $operationName REPLY $body]} RestoreSavedOptions $serviceName } SaveAndSetOptions $serviceName set hadError [catch {parseResults $serviceName $operationName $body} results] RestoreSavedOptions $serviceName if {$hadError} { ::log::logsubst debug {Reply was $body} set errorCode $::errorCode set errorInfo $::errorInfo } } if {$hadError} { ::log::log debug "Leaving (error) ::WS::Client::DoCall" return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $results } else { ::log::logsubst debug {Leaving ::WS::Client::DoCall with {$results}} return $results } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::FormatHTTPError # # Description : Format error after a http::geturl failure. # A failure consists wether in the HTTP return code unequal to 200 # or in the status equal "error". Status "timeout" is untreated, as this # http feature is not used in the package. # # Arguments : # tolken - tolken of the http::geturl request # # Returns : # Error message # # Side-Effects : None # # Pre-requisite Conditions : HTTP failure must be present # # Original Author : Harald Oehlmann # #>>END PUBLIC<< # # 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 06/02/2015 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Client::FormatHTTPError {token} { if {[::http::status $token] eq {ok}} { if {[::http::size $token] == 0} { return "HTTP failure socket closed" } return "HTTP failure code [::http::ncode $token]" } else { return "HTTP error: [::http::error $token]" } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoAsyncCall # # Description : Call an operation of a web service asynchronously # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # succesCmd - A command prefix to be called if the operations # does not raise an error. The results, as a dictionary # object are concatenated to the prefix. # errorCmd - A command prefix to be called if the operations # raises an error. The error code and stack trace # are concatenated to the prefix. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # None. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< |
︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::DoAsyncCall {serviceName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr | | > | > > > > > > > > | | < | > | | | | | > | | | | 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::DoAsyncCall {serviceName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } set url [dict get $serviceInfo location] SaveAndSetOptions $serviceName if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } set largs {} if {[llength $headers]} { lappend largs -headers $headers } ::log::logsubst info {::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]\ -timeout [dict get $serviceInfo queryTimeout] \ {*}$largs} ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] \ -timeout [dict get $serviceInfo queryTimeout] \ {*}$largs ::log::logsubst debug {Leaving ::WS::Client::DoAsyncCall} return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
1304 1305 1306 1307 1308 1309 1310 | "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set procList {} | > | > > | | > | > > | | > > | 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 | "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set procList {} foreach operationName [lsort -dictionary [dict get $serviceInfo operList]] { if {[dict get $serviceInfo operation $operationName cloned]} { continue } set procName $operationName set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] if {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] if {$headerFields ne {}} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] if {$inputMsgType ne {}} { set inTypeDef [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] if {[dict exists $inTypeDef definition]} { set inputFields [dict keys [dict get $inTypeDef definition]] if {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } } } set argList [join $argList] append procList "\n\t$procName $argList" } return "$procList\n" } |
︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 | foreach object [dict get $serviceInfo objList] { foreach operationName [dict keys [dict get $serviceInfo object $object operations]] { set procName $operationName set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] | | | | | 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 | foreach object [dict get $serviceInfo objList] { foreach operationName [dict keys [dict get $serviceInfo object $object operations]] { set procName $operationName set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] if {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] if {$headerFields ne {}} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] set inputFields [dict keys [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] definition]] if {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } set argList [join $argList] append procList "\n\t$object $procName $argList" } } |
︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncCallDone {serviceName operationName succesCmd errorCmd token} { | | > > | | | > | > > > > | | > | > < | | 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncCallDone {serviceName operationName succesCmd errorCmd token} { ::log::logsubst debug {Entering [info level 0]} ## ## Check for errors ## set body [::http::data $token] ::log::logsubst info {\nReceived: $body} set results {} if {[::http::status $token] ne {ok} || ( [::http::ncode $token] != 200 && $body eq {} )} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 set results [FormatHTTPError $token] set errorInfo "" } else { SaveAndSetOptions $serviceName set hadError [catch {parseResults $serviceName $operationName $body} results] RestoreSavedOptions $serviceName if {$hadError} { set errorCode $::errorCode set errorInfo $::errorInfo } } ::http::cleanup $token ## ## Call the appropriate callback ## if {$hadError} { set cmd $errorCmd lappend cmd $errorCode $errorInfo } else { set cmd $succesCmd } if {$cmd ne ""} { lappend cmd $results if {[catch $cmd cmdErr]} { ::log::log error "Error invoking callback '$cmd': $cmdErr" } } ## ## All done ## return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 | # inXML - the XML returned by the operation # # Returns : A dictionary object representing the results # # Side-Effects : None # # Exception Conditions : | | | | | > > > > > > > > > | | < | > | > > > | < > > > > | | | | > > | > | > > > > > > | > > > > > > > > > | < | < | | < < < | > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | < < < < < < | < < > | < < | > > > | > | > | > > | < < < < | > | | | < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | > > > > > > > | | < > | | | < > > > > | > | | > > > > > > | 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 | # inXML - the XML returned by the operation # # Returns : A dictionary object representing the results # # Side-Effects : None # # Exception Conditions : # WS CLIENT REMERR - The remote end raised an exception, the third element of # the error code is the remote fault code. # Error info is set to the remote fault details. # The error message is the remote fault string. # WS CLIENT BADREPLY - Badly formatted reply, the third element is a list of # what message type was received vs what was expected. # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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]). # 2.4.3 2017-11-03 H.Oehlmann Extended upper commit also to search # for multiple child nodes. # 2.5.1 2018-05-14 H.Oehlmann Add support to translate namespace prefixes # in attribute values or text values. # Translation dict "xnsDistantToLocalDict" is # passed to ::WS::Utils::convertTypeToDict # to translate abstract types. # ########################################################################### proc ::WS::Client::parseResults {serviceName operationName inXML} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set expectedMsgType [dict get $serviceInfo operation $operationName outputs] set expectedMsgTypeBase [lindex [split $expectedMsgType {:}] end] set first [string first {<} $inXML] if {$first > 0} { set inXML [string range $inXML $first end] } # parse xml and save handle in variable doc and free it when out of scope dom parse $inXML doc # save top node handle in variable top and free it if out of scope $doc documentElement top set xns { ENV http://schemas.xmlsoap.org/soap/envelope/ xsi "http://www.w3.org/2001/XMLSchema-instance" xs "http://www.w3.org/2001/XMLSchema" } foreach {prefixCur URICur} [dict get $serviceInfo targetNamespace] { lappend xns $prefixCur $URICur } ::log::logsubst debug {Using namespaces {$xns}} $doc selectNodesNamespaces $xns ## ## When arguments with tags are passed (example: abstract types), ## the upper "selectNodesNamespaces translation must be executed manually. ## Thus, we need a list of server namespace prefixes to our client namespace ## prefixes. (bug 584bfb77) ## # Example xml: # <soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/" # xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" # xmlns:xsd="http://www.w3.org/2001/XMLSchema" # xmlns:tns="http://www.esri.com/schemas/ArcGIS/10.3"> set xnsDistantToLocalDict {} foreach attributeCur [$top attributes] { # attributeCur is a list of "prefix local URI", # which is for xmlns tags: "prefix prefix {}". set attributeCur [lindex $attributeCur 0] # Check if this is a namespace prefix if { ! [$top hasAttribute "xmlns:$attributeCur"] } {continue} set URIServer [$top getAttribute "xmlns:$attributeCur"] # Check if it is included in xns foreach {prefixCur URICur} $xns { if {$URIServer eq $URICur} { dict set xnsDistantToLocalDict $attributeCur $prefixCur break } } } ::log::logsubst debug {Server to Client prefix dict: $xnsDistantToLocalDict} ## ## Get body tag ## set body [$top selectNodes ENV:Body] if {![llength $body]} { return \ -code error \ -errorcode [list WS CLIENT BADREPLY $inXML] \ "Bad reply type, no SOAP envelope received in: \n$inXML" } ## ## Find the reply root node with the response. ## # <SOAP-ENV:Envelope...> # <SOAP-ENV:Body> # <i2:TestResponse id="ref-1" xmlns:i2=...> <-- this one # # WSDL 1.0: http://xml.coverpages.org/wsdl20000929.html # Chapter 2.4.2 (name optional) and 2.4.5 (default name) # The node name could be: # 1) an error node "Fault" # 2) equal to the WSDL name property of the output node # 3) if no name tag, equal to <Operation>Response # 4) the local output type name # # Possibility (2) "OutName" WSDL example: # <wsdl:portType...><wsdl:operation...> # <wsdl:output name="{OutName}" message="tns:{OutMsgName}" /> # This possibility is requested by ticket [21f41e22bc] # # Possibility (3) default name "{OperationName}Result" WSDL example: # <wsdl:portType...><wsdl:operation name="{OperationName}"> # <wsdl:output message="tns:{OutMsgName}" -> *** no name tag *** # # Possibility (4) was not found in wsdl 1.0 standard but was used as only # solution by TCLWS prior to 2.4.2. # The following sketch shows the location of the local output type name # "OutTypeName" in a WSDL file: # -> In WSDL portType output message name # <wsdl:portType...><wsdl:operation...> # <wsdl:output message="tns:{OutMsgName}" /> # -> then in message, use the element: # <wsdl:message name="{OutMsgName}"> # <wsdl:part name="..." element="tns:<{OutTypeName}>" /> # -> The element "OutTypeName" is also find in a type definition: # <wsdl:types> # <s:element name="{OutMsgName}"> # <s:complexType>... # # Build a list of possible names set nodeNameCandidateList [list Fault $expectedMsgTypeBase] # We check if the preparsed wsdl contains the name flag. # This is not the case, if it was parsed with tclws prior 2.4.2 # *** ToDo *** This security may be removed on a major release if {[dict exists $serviceInfo operation $operationName outputsname]} { lappend nodeNameCandidateList [dict get $serviceInfo operation $operationName outputsname] } set rootNodeList [$body childNodes] ::log::logsubst debug {Have [llength $rootNodeList] node under Body} foreach rootNodeCur $rootNodeList { set rootNameCur [$rootNodeCur localName] if {$rootNameCur eq {}} { set rootNameCur [$rootNodeCur nodeName] } if {$rootNameCur in $nodeNameCandidateList} { set rootNode $rootNodeCur set rootName $rootNameCur ::log::logsubst debug {Result root name is '$rootName'} break } ::log::logsubst debug {Result root name '$rootNameCur' not in candidates '$nodeNameCandidateList'} } ## ## Exit if there is no such node ## if {![info exists rootName]} { return \ -code error \ -errorcode [list WS CLIENT BADREPLY [list $rootNameCur $expectedMsgTypeBase]] \ "Bad reply type, received '$rootNameCur'; but expected '$expectedMsgTypeBase'." } ## ## See if it is a standard error packet ## if {$rootName eq {Fault}} { set faultcode {} set faultstring {} set detail {} foreach item {faultcode faultstring detail} { set tmpNode [$rootNode selectNodes ENV:$item] if {$tmpNode eq {}} { set tmpNode [$rootNode selectNodes $item] } if {$tmpNode ne {}} { if {[$tmpNode hasAttribute href]} { set tmpNode [GetReferenceNode $top [$tmpNode getAttribute href]] } set $item [$tmpNode asText] } } $doc delete return \ -code error \ -errorcode [list WS CLIENT REMERR $faultcode] \ -errorinfo $detail \ $faultstring } ## ## Convert the packet to a dictionary ## set results {} set headerRootNode [$top selectNodes ENV:Header] if {[llength $headerRootNode]} { foreach outHeaderType [dict get $serviceInfo operation $operationName soapReplyHeader] { if {$outHeaderType eq {}} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $outHeaderType] xns] set node [$headerRootNode selectNodes $outHeaderType] if {![llength $node]} { set node [$headerRootNode selectNodes $xns:$outHeaderType] if {![llength $node]} { continue } } #if {[llength $outHeaderAttrs]} { # ::WS::Utils::setAttr $node $outHeaderAttrs #} ::log::logsubst debug {Calling convertTypeToDict from header node type '$outHeaderType'} lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode 0 $xnsDistantToLocalDict] } } ## ## Call Utility function to build result list ## if {$rootName ne {}} { ::log::log debug "Calling convertTypeToDict with root node" set bodyData [::WS::Utils::convertTypeToDict \ Client $serviceName $rootNode $expectedMsgType $body 0 $xnsDistantToLocalDict] if {![llength $bodyData] && ([dict get $serviceInfo skipLevelWhenActionPresent] || [dict get $serviceInfo skipLevelOnReply])} { ::log::log debug "Calling convertTypeToDict with skipped action level (skipLevelWhenActionPresent was set)" set bodyData [::WS::Utils::convertTypeToDict \ Client $serviceName $body $expectedMsgType $body 0 $xnsDistantToLocalDict] } lappend results $bodyData } set results [join $results] $doc delete set ::errorCode {} set ::errorInfo {} return $results |
︙ | ︙ | |||
1696 1697 1698 1699 1700 1701 1702 | ########################################################################### proc ::WS::Client::buildCallquery {serviceName operationName url argList} { variable serviceArr set serviceInfo $serviceArr($serviceName) set style [dict get $serviceInfo operation $operationName style] | > > > > > > | > | > > > > | | > > | | | | 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 | ########################################################################### proc ::WS::Client::buildCallquery {serviceName operationName url argList} { variable serviceArr set serviceInfo $serviceArr($serviceName) set style [dict get $serviceInfo operation $operationName style] set suppressTargetNS [dict get $serviceInfo suppressTargetNS] set inSuppressNs [::WS::Utils::SetOption suppressNS] if {$suppressTargetNS} { ::WS::Utils::SetOption suppressNS tns1 } else { ::WS::Utils::SetOption suppressNS {} } switch -exact -- $style { document/literal { set xml [buildDocLiteralCallquery $serviceName $operationName $url $argList] } rpc/encoded { set xml [buildRpcEncodedCallquery $serviceName $operationName $url $argList] } default { return \ -code error \ "Unsupported Style '$style'" } } ::WS::Utils::SetOption suppressNS $inSuppressNs set inTransform [dict get $serviceInfo inTransform] if {$inTransform ne {}} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } ::log::logsubst debug {Leaving ::WS::Client::buildCallquery with {$xml}} return $xml } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure |
︙ | ︙ | |||
1759 1760 1761 1762 1763 1764 1765 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildDocLiteralCallquery {serviceName operationName url argList} { variable serviceArr | | > | > > > | | > > > > > | | | | > > > > > > > > > > | | | > > > > > > > > | > > > > > | | > | | | < > | < | < | | | 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildDocLiteralCallquery {serviceName operationName url argList} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo operation $operationName inputs] set url [dict get $serviceInfo location] set xnsList [dict get $serviceInfo targetNamespace] # save the document in variable doc and free it if out of scope dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \ "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance" \ "xmlns:xs" "http://www.w3.org/2001/XMLSchema" if {[dict exists $serviceInfo noTargetNs] && ![dict get $serviceInfo noTargetNs]} { $env setAttribute "xmlns" [dict get $xnsList tns1] } array unset tnsArray * array set tnsArray { "http://schemas.xmlsoap.org/soap/envelope/" "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/encoding/" "xmlns:SOAP-ENC" "http://www.w3.org/2001/XMLSchema-instance" "xmlns:xsi" "http://www.w3.org/2001/XMLSchema" "xmlns:xs" } foreach {tns target} $xnsList { #set tns [lindex $xns 0] #set target [lindex $xns 1] set tnsArray($target) $tns $env setAttribute \ xmlns:$tns $target } #parray tnsArray set firstHeader 1 foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { lassign $inputHeaderTypeItem inputHeaderType attrList if {$inputHeaderType eq {}} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns] if {[info exists tnsArray($xns)]} { set xns $tnsArray($xns) } if {$firstHeader} { # side effect: save new node handle in variable header $env appendChild [$doc createElement "SOAP-ENV:Header" header] set firstHeader 0 } if {[dict exists $serviceInfo skipHeaderLevel] && [dict get $serviceInfo skipHeaderLevel]} { set headerData $header } else { set typeInfo [split $inputHeaderType {:}] if {[llength $typeInfo] > 1} { set headerType $inputHeaderType } else { set headerType $xns:$inputHeaderType } $header appendChild [$doc createElement $headerType headerData] if {[llength $attrList]} { ::WS::Utils::setAttr $headerData $attrList } } ::WS::Utils::convertDictToType Client $serviceName $doc $headerData $argList $inputHeaderType } # side effect: save new element handle in variable bod $env appendChild [$doc createElement "SOAP-ENV:Body" bod] #puts "set xns \[dict get \[::WS::Utils::GetServiceTypeDef Client $serviceName $msgType\] xns\]" #puts "\t [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType]" set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] if {[info exists tnsArray($xns)]} { set xns $tnsArray($xns) } set typeInfo [split $msgType {:}] if {[llength $typeInfo] != 1} { set xns [lindex $typeInfo 0] set msgType [lindex $typeInfo 1] } if {[dict get $serviceInfo skipLevelWhenActionPresent] && [dict exists $serviceInfo operation $operationName action]} { set forceNs 1 set reply $bod } else { ::log::logsubst debug {$bod appendChild \[$doc createElement $xns:$msgType reply\]} $bod appendChild [$doc createElement $xns:$msgType reply] set forceNs 0 } ::WS::Utils::convertDictToType Client $serviceName $doc $reply $argList $xns:$msgType $forceNs set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {:}] end] {=}] end] set xml [format {<?xml version="1.0" encoding="%s"?>} $encoding] append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] $doc delete ::log::logsubst debug {Leaving ::WS::Client::buildDocLiteralCallquery with {$xml}} return [encoding convertto $encoding $xml] } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. |
︙ | ︙ | |||
1872 1873 1874 1875 1876 1877 1878 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildRpcEncodedCallquery {serviceName operationName url argList} { variable serviceArr | | < < | | | < < | > | > | > > > > | | | | < | < | | | | | > > > > | | > > > > > > > > > > > > > < < < < | | > > > > > > | > | > | > > > | 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildRpcEncodedCallquery {serviceName operationName url argList} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo operation $operationName inputs] set xnsList [dict get $serviceInfo targetNamespace] dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ xmlns:SOAP-ENV "http://schemas.xmlsoap.org/soap/envelope/" \ xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance" \ xmlns:xs "http://www.w3.org/2001/XMLSchema" foreach {tns target} $xnsList { $env setAttribute xmlns:$tns $target } set firstHeader 1 foreach inputHeaderType [dict get $serviceInfo operation $operationName soapRequestHeader] { if {$inputHeaderType eq {}} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns] if {$firstHeader} { $env appendChild [$doc createElement "SOAP-ENV:Header" header] set firstHeader 0 } $header appendChild [$doc createElement $xns:$inputHeaderType headerData] ::WS::Utils::convertDictToEncodedType Client $serviceName $doc $headerData $argList $inputHeaderType } $env appendChild [$doc createElement "SOAP-ENV:Body" bod] set baseName [dict get $serviceInfo operation $operationName name] set callXns [dict get $serviceInfo operation $operationName xns] # side effect: node handle is saved in variable reply if {![string is space $callXns]} { $bod appendChild [$doc createElement $callXns:$baseName reply] } else { $bod appendChild [$doc createElement $baseName reply] } $reply setAttribute \ SOAP-ENV:encodingStyle "http://schemas.xmlsoap.org/soap/encoding/" ::WS::Utils::convertDictToEncodedType Client $serviceName $doc $reply $argList $msgType set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] set xml [format {<?xml version="1.0" encoding="%s"?>} $encoding] append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] $doc delete ::log::logsubst debug {Leaving ::WS::Client::buildRpcEncodedCallquery with {$xml}} return [encoding convertto $encoding $xml] } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::buildServiceInfo # # Description : Parse the WSDL into our internal representation # # Arguments : # wsdlNode - The top node of the WSDL # results - Initial definition. This is optional and defaults to no definition. # serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the name of the # service in serviceInfo. # serviceNumber - Number of service within the WSDL to assign the # serviceAlias to. Only usable with a serviceAlias. # First service (default) is addressed by value "1". # # Returns : The parsed WSDL # # Side-Effects : Defines Client mode types as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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.6 2017-12-07 H.Oehlmann Added argument "serviceNumber" # # ########################################################################### proc ::WS::Client::buildServiceInfo {wsdlNode tnsDict {serviceInfo {}} {serviceAlias {}} {serviceNumber 1}} { ## ## Need to refactor to foreach service parseService ## Service drills down to ports, which drills down to bindings and messages ## ::log::logsubst debug {Entering [info level 0]} ## ## Parse Service information ## # WSDL snippet: # <definitions ...> # <service name="service1"> # ... # </service> # <service name="service2"> # ... # </service> # </definitions> # Without serviceAlias and serviceNumber, two services "service1" and # "service2" are created. # With serviceAlias = "SE" and serviceNumber=2, "service2" is created as # "SE". set serviceNameList [$wsdlNode selectNodes w:service] # Check for no service node if {[llength $serviceNameList] == 0} { return \ -code error \ -errorcode [list WS CLIENT NOSVC] \ "WSDL does not define any services" } if {"" ne $serviceAlias} { if {$serviceNumber < 1 || $serviceNumber > [llength $serviceNameList]} { return \ -code error \ -errorcode [list WS CLIENT INVALDCNT] \ "WSDL does not define service number $serviceNumber" } set serviceNameList [lrange $serviceNameList $serviceNumber-1 $serviceNumber-1] } foreach serviceNode $serviceNameList { lappend serviceInfo [parseService $wsdlNode $serviceNode $serviceAlias $tnsDict] } ::log::logsubst debug {Leaving ::WS::Client::buildServiceInfo with $serviceInfo} return $serviceInfo } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::parseService # # Description : Parse a service from a WSDL into our internal representation # # Arguments : # wsdlNode - The top node of the WSDL # serviceNode - The DOM node for the service. # serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the name of the # service in serviceInfo. # tnsDict - Dictionary of URI to namespaces used # # Returns : The parsed service WSDL # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # |
︙ | ︙ | |||
2037 2038 2039 2040 2041 2042 2043 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### | | > > | 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseService {wsdlNode serviceNode serviceAlias tnsDict} { variable serviceArr variable options ::log::logsubst debug {Entering [info level 0]} if {[string length $serviceAlias]} { set serviceName $serviceAlias } else { set serviceName [$serviceNode getAttribute name] } set addressNodeList [$serviceNode getElementsByTagNameNS http://schemas.xmlsoap.org/wsdl/soap/ address] if {[llength $addressNodeList] == 1} { |
︙ | ︙ | |||
2066 2067 2068 2069 2070 2071 2072 | if {![info exists location]} { return \ -code error \ -errorcode [list WS CLIENT NOSOAPADDR] \ "Malformed WSDL -- No SOAP address node found." } | > > > > > > > > > > > | > > > > > > > > > > | 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 | if {![info exists location]} { return \ -code error \ -errorcode [list WS CLIENT NOSOAPADDR] \ "Malformed WSDL -- No SOAP address node found." } set xns {} foreach url [dict keys [dict get $tnsDict url]] { lappend xns [list [dict get $tnsDict url $url] $url] } if {[$wsdlNode hasAttribute targetNamespace]} { set target [$wsdlNode getAttribute targetNamespace] } else { set target $location } set tmpTargetNs $::WS::Utils::targetNs set ::WS::Utils::targetNs $target CreateService $serviceName WSDL $location $target xns $xns set serviceInfo $serviceArr($serviceName) dict set serviceInfo tnsList $tnsDict set bindingName [lindex [split [$portNode getAttribute binding] {:}] end] ## ## Parse types ## parseTypes $wsdlNode $serviceName serviceInfo ## ## Parse bindings ## parseBinding $wsdlNode $serviceName $bindingName serviceInfo ## ## All done, so return results ## #dict unset serviceInfo tnsList dict set serviceInfo suppressTargetNS $options(suppressTargetNS) foreach {key value} [dict get $serviceInfo tnsList url] { dict set serviceInfo targetNamespace $value $key } set serviceArr($serviceName) $serviceInfo set ::WS::Utils::targetNs $tmpTargetNs ::log::logsubst debug {Leaving [lindex [info level 0] 0] with $serviceInfo} return $serviceInfo } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. |
︙ | ︙ | |||
2128 2129 2130 2131 2132 2133 2134 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseTypes {wsdlNode serviceName serviceInfoVar} { | > > | > | | > > | 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseTypes {wsdlNode serviceName serviceInfoVar} { ::log::log debug "Entering [info level 0]" upvar 1 $serviceInfoVar serviceInfo set tnsCount [llength [dict keys [dict get $serviceInfo tnsList url]]] set baseUrl [dict get $serviceInfo location] foreach schemaNode [$wsdlNode selectNodes w:types/xs:schema] { ::log::log debug "Parsing node $schemaNode" ::WS::Utils::parseScheme Client $baseUrl $schemaNode $serviceName serviceInfo tnsCount } ::log::log debug "Leaving [lindex [info level 0] 0]" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 | # 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} { | > > > | > > | > | > | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > | > > | > > > > > > > > > > | > | | | < | | | > | | | | | | > | | < > | > > > > > > > > > > > | < < < < < < < < < < < < < < < < < > > > > > > | > > > > > | > | < | | > | | > > > | | | | < > | > > > > | | > | | > | > > > > > > > > > > | > | 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 | # 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 set bindQuery [format {w:binding[attribute::name='%s']} $bindingName] array set msgToOper {} foreach binding [$wsdlNode selectNodes $bindQuery] { array unset msgToOper * set portName [lindex [split [$binding getAttribute type] {:}] end] ::log::log debug "\t Processing binding '$bindingName' on port '$portName'" set operList [$binding selectNodes w:operation] set styleNode [$binding selectNodes d:binding] if {![info exists style]} { if {[catch {$styleNode getAttribute style} tmpStyle]} { set styleNode [$binding selectNodes {w:operation[1]/d:operation}] if {$styleNode eq {}} { ## ## This binding is for a SOAP level other than 1.1 ## ::log::log debug "Skiping non-SOAP 1.1 binding [$binding asXML]" continue } set style [$styleNode getAttribute style] #puts "Using style for first operation {$style}" } else { set style $tmpStyle #puts "Using style for first binding {$style}" } if {!($style eq {document} || $style eq {rpc} )} { ::log::log debug "Leaving [lindex [info level 0] 0] with error @1" return \ -code error \ -errorcode [list WS CLIENT UNSSTY $style] \ "Unsupported calling style: '$style'" } if {![info exists use]} { set use [[$binding selectNodes {w:operation[1]/w:input/d:body}] getAttribute use] if {!($style eq {document} && $use eq {literal} ) && !($style eq {rpc} && $use eq {encoded} )} { ::log::log debug "Leaving [lindex [info level 0] 0] with error @2" return \ -code error \ -errorcode [list WS CLIENT UNSMODE $use] \ "Unsupported mode: $style/$use" } } } set style $style/$use ## ## Process each operation ## foreach oper $operList { set operName [$oper getAttribute name] set baseName $operName ::log::log debug "\t Processing operation '$operName'" ## ## Check for overloading ## set inNode [$oper selectNodes w:input] if {[llength $inNode] == 1 && [$inNode hasAttribute name]} { set inName [$inNode getAttribute name] } else { set inName {} } if {[dict exists $serviceInfo operation $operName]} { if {!$options(allowOperOverloading)} { return -code error \ -errorcode [list WS CLIENT NOOVERLOAD $operName] } ## ## See if the existing operation needs to be cloned ## set origType [lindex [split [dict get $serviceInfo operation $operName inputs] {:}] end] set newName ${operName}_${origType} if {![dict exists $serviceInfo operation $newName]} { ## ## 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]" continue } dict lappend serviceInfo operList $operName dict set serviceInfo operation $operName cloneList {} dict set serviceInfo operation $operName cloned 0 dict set serviceInfo operation $operName name $baseName dict set serviceInfo operation $operName style $style catch { set action [$actionNode getAttribute soapAction] dict set serviceInfo operation $operName action $action if {[dict exists $serviceInfo soapActions $action]} { set actionList [dict get $serviceInfo soapActions $action] } else { set actionList {} } lappend actionList $operName dict set serviceInfo soapActions $action $actionList } ## ## Get the input headers, if any ## set soapRequestHeaderList {{}} foreach inHeader [$oper selectNodes w:input/d:header] { ##set part [$inHeader getAttribute part] set tmp [$inHeader getAttribute use] if {$tmp ne $use} { ::log::log debug "Leaving [lindex [info level 0] 0] with error @3" return \ -code error \ -errorcode [list WS CLIENT MIXUSE $use $tmp] \ "Mixed usage not supported!'" } set msgName [$inHeader getAttribute message] ::log::log debug [list messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] set type [messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] lappend soapRequestHeaderList $type } dict set serviceInfo operation $operName soapRequestHeader $soapRequestHeaderList if {![dict exists [dict get $serviceInfo operation $operName] action]} { dict set serviceInfo operation $operName action $serviceName } ## ## Get the output header, if one ## set soapReplyHeaderList {{}} foreach outHeader [$oper selectNodes w:output/d:header] { ##set part [$outHeader getAttribute part] set tmp [$outHeader getAttribute use] if {$tmp ne $use} { ::log::log debug "Leaving [lindex [info level 0] 0] with error @4" return \ -code error \ -errorcode [list WS CLIENT MIXUSE $use $tmp] \ "Mixed usage not supported!'" } set messagePath [$outHeader getAttribute message] set msgName [lindex [split $messagePath {:}] end] ::log::log debug [list messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] set type [messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] lappend soapReplyHeaderList $type } dict set serviceInfo operation $operName soapReplyHeader $soapReplyHeaderList ## ## Validate that the input and output uses are the same ## set inUse $use set outUse $use catch {set inUse [[$oper selectNodes w:input/d:body] getAttribute use]} catch {set outUse [[$oper selectNodes w:output/d:body] getAttribute use]} foreach tmp [list $inUse $outUse] { if {$tmp ne $use} { ::log::log debug "Leaving [lindex [info level 0] 0] with error @5" return \ -code error \ -errorcode [list WS CLIENT MIXUSE $use $tmp] \ "Mixed usage 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 {} } lappend operList $operName dict set serviceInfo inputMessages $inMessage $operList ## ## Handle target namespace defined at WSDL level for older RPC/Encoded ## if {![dict exists $serviceInfo targetNamespace]} { catch { #puts "attempting to get tragetNamespace" dict set serviceInfo targetNamespace tns1 [[$oper selectNodes w:input/d:body] getAttribute namespace] } } set xns tns1 dict set serviceInfo operation $operName xns $xns } } ::log::log debug "Leaving [lindex [info level 0] 0]" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::getTypesForPort # # Description : Get the types for a port. # # Arguments : # wsdlNode - The top node of the WSDL # serviceNode - The DOM node for the service. # operNode - The DOM node for the operation. # portName - The name of the port. # inName - The name of the input message. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # style - style of call # # Returns : A list containing the input and output types and names # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 Extend return by names to verify this # as return output node name. # 2.4.3 2017-11-03 H.Oehlmann If name is not given, set the default # name of <OP>Request/Response given by the # WSDL 1.0 standard. # # ########################################################################### proc ::WS::Client::getTypesForPort {wsdlNode serviceName operName portName inName serviceInfoVar style} { ::log::log debug "Entering [info level 0]" upvar 1 $serviceInfoVar serviceInfo set inType {} set outType {} #set portQuery [format {w:portType[attribute::name='%s']} $portName] #set portNode [lindex [$wsdlNode selectNodes $portQuery] 0] if {$inName eq {}} { set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \ $portName $operName] } else { set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']/w:input[attribute::name='%s']/parent::*} \ $portName $operName $inName] } ::log::log debug "\t operNode query is {$operQuery}" 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} defaultNameSuffix {Request Response} { 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 { # Build the default name according WSDL 1.0 as # <Operation>Request/Response lappend resList ${operName}$defaultNameSuffix } } } ## ## 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. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::messageToType # # Description : Get a type name from a message # # Arguments : # wsdlNode - The top node of the WSDL # serviceName - The name of the service. # operName - The name of the operation. # msgName - The name of the message. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # style - Style of call # # Returns : The requested type name # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # |
︙ | ︙ | |||
2449 2450 2451 2452 2453 2454 2455 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### | | | > < > > > > > > > > > > > > | > | < | | | | | | | | | | | > | | > > > > | > > > > > | > | > > > > > < < < < | < < | | < < < < < | | < < > < < < | | < | > | | | | < | | > > > > | | > > > > > > | > > > > > > > > > > | < < > | > > > | < < < < < < < < < < < < < < | < < > | | | < < < < < < < > < | < < > | < | | < | | | | | 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 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 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 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 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::messageToType {wsdlNode serviceName operName msgName serviceInfoVar style} { upvar 1 $serviceInfoVar serviceInfo ::log::log debug "Entering [info level 0]" #puts "Message to Type $serviceName $operName $msgName" set msgQuery [format {w:message[attribute::name='%s']} $msgName] set msg [$wsdlNode selectNodes $msgQuery] if {$msg eq {} && [llength [set msgNameList [split $msgName {:}]]] > 1} { set tmpMsgName [join [lrange $msgNameList 1 end] {:}] set msgQuery [format {w:message[attribute::name='%s']} $tmpMsgName] set msg [$wsdlNode selectNodes $msgQuery] } if {$msg eq {}} { return \ -code error \ -errorcode [list WS CLIENT BADMSGSEC $msgName] \ "Can not find message '$msgName'" } switch -exact -- $style { document/literal { set partNode [$msg selectNodes w:part] set partNodeCount [llength $partNode] ::log::log debug "partNodeCount = {$partNodeCount}" if {$partNodeCount == 1} { if {[$partNode hasAttribute element]} { set type [::WS::Utils::getQualifiedType $serviceInfo [$partNode getAttribute element] tns1] } } if {($partNodeCount > 1) || ![info exist type]} { set tmpType {} foreach part [$msg selectNodes w:part] { set partName [$part getAttribute name] if {[$part hasAttribute type]} { set partType [$part getAttribute type] } else { set partType [$part getAttribute element] } lappend tmpType $partName [list type [::WS::Utils::getQualifiedType $serviceInfo $partType tns1] comment {}] } set type tns1:$msgName dict set serviceInfo types $type $tmpType ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType tns1 } elseif {!$partNodeCount} { return \ -code error \ -errorcode [list WS CLIENT BADMSGSEC $msgName] \ "Invalid format for message '$msgName'" } } rpc/encoded { set tmpType {} foreach part [$msg selectNodes w:part] { set partName [$part getAttribute name] if {[$part hasAttribute type]} { set partType [$part getAttribute type] } else { set partType [$part getAttribute element] } lappend tmpType $partName [list type [::WS::Utils::getQualifiedType $serviceInfo $partType tns1] comment {}] } set type tns1:$msgName dict set serviceInfo types $type $tmpType ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType tns1 } default { return \ -code error \ -errorcode [list WS CLIENT UNKSTY $style] \ "Unknown style combination $style" } } ## ## Return the type name ## ::log::log debug "Leaving [lindex [info level 0] 0] with {$type}" return $type } #--------------------------------------- #--------------------------------------- ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoRawRestCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object. # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # The XML of the operation. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # which also follows redirects. # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRawRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo object $objectName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOBJ [list $serviceName $objectName]] \ "Unknown object '$objectName' for service '$serviceName'" } if {![dict exists $serviceInfo object $objectName operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ "Unknown operation '$operationName' for object '$objectName' of service '$serviceName'" } ## ## build call query ## if {$location ne {}} { set url $location } else { set url [dict get $serviceInfo object $objectName location] } SaveAndSetOptions $serviceName if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } ## ## do http call ## set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody $url\ -query $query\ -type [dict get $serviceInfo contentType]\ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs] ::log::logsubst debug {Leaving ::WS::Client::DoRawRestCall with {$body}} return $body } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoRestCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # The return value of the operation as a dictionary object. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # which also follows redirects. # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo object $objectName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOBJ [list $serviceName $objectName]] \ "Unknown object '$objectName' for service '$serviceName'" } if {![dict exists $serviceInfo object $objectName operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ "Unknown operation '$operationName' for object '$objectName' of service '$serviceName'" } if {$location ne {}} { set url $location } else { set url [dict get $serviceInfo object $objectName location] } ## ## build call query ## SaveAndSetOptions $serviceName if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } RestoreSavedOptions $serviceName ## ## Do http call ## if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody $url\ -query $query\ -type [dict get $serviceInfo contentType]\ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs] ## ## Parse results ## SaveAndSetOptions $serviceName if {[catch { parseRestResults $serviceName $objectName $operationName $body } results]} { RestoreSavedOptions $serviceName ::log::log debug "Leaving (error) ::WS::Client::DoRestCall" return -code error $results } RestoreSavedOptions $serviceName ::log::logsubst debug {Leaving ::WS::Client::DoRestCall with {$results}} return $results } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoARestsyncCall # # Description : Call an operation of a web service asynchronously # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # succesCmd - A command prefix to be called if the operations # does not raise an error. The results, as a dictionary # object are concatenated to the prefix. # errorCmd - A command prefix to be called if the operations # raises an error. The error code and stack trace # are concatenated to the prefix. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # None. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< |
︙ | ︙ | |||
2827 2828 2829 2830 2831 2832 2833 | # ########################################################################### proc ::WS::Client::DoRestAsyncCall {serviceName objectName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr set svcHeaders [dict get $serviceArr($serviceName) headers] if {[llength $svcHeaders]} { | | | > | > > > > > > > > | | < | > | | | > | > | | | 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 | # ########################################################################### proc ::WS::Client::DoRestAsyncCall {serviceName objectName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr set svcHeaders [dict get $serviceArr($serviceName) headers] if {[llength $svcHeaders]} { set headers [concat $headers $svcHeaders] } ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo object $objectName operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } set url [dict get $serviceInfo object $objectName location] SaveAndSetOptions $serviceName if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } set largs {} if {[llength $headers]} { lappend largs -headers $headers } ::log::logsubst info {::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs} ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers $headers \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs ::log::log debug "Leaving ::WS::Client::DoAsyncRestCall" return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
2907 2908 2909 2910 2911 2912 2913 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildRestCallquery {serviceName objectName operationName url argList} { variable serviceArr | | | | | | > > < | < | > | | | 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildRestCallquery {serviceName objectName operationName url argList} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo object $objectName operation $operationName inputs] set xnsList [dict get $serviceInfo targetNamespace] dom createDocument "request" doc $doc documentElement body $body setAttribute \ "method" $operationName foreach {tns target} $xnsList { #set tns [lindex $xns 0] #set target [lindex $xns 1] $body setAttribute \ xmlns:$tns $target } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] ::log::logsubst debug {calling [list ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType]} set options [::WS::Utils::SetOption] ::WS::Utils::SetOption UseNS 0 ::WS::Utils::SetOption genOutAttr 1 ::WS::Utils::SetOption valueAttr {} ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] foreach {option value} $options { ::WS::Utils::SetOption $option $value } set xml [format {<?xml version="1.0" encoding="%s"?>} $encoding] append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] #regsub "<!DOCTYPE\[^>\]*>\n" [::dom::DOMImplementation serialize $doc] {} xml $doc delete set xml [encoding convertto $encoding $xml] set inTransform [dict get $serviceInfo inTransform] if {$inTransform ne {}} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } ::log::logsubst debug {Leaving ::WS::Client::buildRestCallquery with {$xml}} return $xml } ########################################################################### # |
︙ | ︙ | |||
2973 2974 2975 2976 2977 2978 2979 | # inXML - the XML returned by the operation # # Returns : A dictionary object representing the results # # Side-Effects : None # # Exception Conditions : | | | | | 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 | # inXML - the XML returned by the operation # # Returns : A dictionary object representing the results # # Side-Effects : None # # Exception Conditions : # WS CLIENT REMERR - The remote end raised an exception, the third element of # the error code is the remote fault code. # Error info is set to the remote fault details. # The error message is the remote fault string. # WS CLIENT BADREPLY - Badly formatted reply, the third element is a list of # what message type was received vs what was expected. # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< |
︙ | ︙ | |||
2999 3000 3001 3002 3003 3004 3005 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseRestResults {serviceName objectName operationName inXML} { variable serviceArr | | > > > > | > > | | | | | | | | | 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseRestResults {serviceName objectName operationName inXML} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set first [string first {<} $inXML] if {$first > 0} { set inXML [string range $inXML $first end] } set serviceInfo $serviceArr($serviceName) set outTransform [dict get $serviceInfo outTransform] if {$outTransform ne {}} { set inXML [$outTransform $serviceName $operationName REPLY $inXML] } set expectedMsgType [dict get $serviceInfo object $objectName operation $operationName outputs] # save parsed xml handle in variable doc dom parse $inXML doc # save top node handle in variable top $doc documentElement top set xns {} foreach tmp [dict get $serviceInfo targetNamespace] { lappend xns $tmp } ::log::logsubst debug {Using namespaces {$xns}} set body $top set status [$body getAttribute status] ## ## See if it is a standard error packet ## if {$status ne {ok}} { set faultstring {} if {[catch {set faultstring [[$body selectNodes error] asText]}]} { catch {set faultstring [[$body selectNodes error] asText]} } $doc delete return \ -code error \ -errorcode [list WS CLIENT REMERR $status] \ -errorinfo {} \ $faultstring } ## ## Convert the packet to a dictionary ## set results {} set options [::WS::Utils::SetOption] ::WS::Utils::SetOption UseNS 0 ::WS::Utils::SetOption parseInAttr 1 ::log::logsubst debug {Calling ::WS::Utils::convertTypeToDict Client $serviceName $body $expectedMsgType $body} if {$expectedMsgType ne {}} { set node [$body childNodes] set nodeName [$node nodeName] if {$objectName ne $nodeName} { return \ -code error \ -errorcode [list WS CLIENT BADRESPONSE [list $objectName $nodeName]] \ -errorinfo {} \ "Unexpected message type {$nodeName}, expected {$objectName}" } set results [::WS::Utils::convertTypeToDict \ Client $serviceName $node $expectedMsgType $body] } foreach {option value} $options { |
︙ | ︙ | |||
3106 3107 3108 3109 3110 3111 3112 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncRestCallDone {serviceName objectName operationName succesCmd errorCmd token} { | | > | | | | > | > > > > > | 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncRestCallDone {serviceName objectName operationName succesCmd errorCmd token} { ::log::logsubst debug {Entering [info level 0]} ## ## Check for errors ## set body [::http::data $token] ::log::logsubst info {\nReceived: $body} if {[::http::status $token] ne {ok} || ( [::http::ncode $token] != 200 && $body eq {} )} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 set errorInfo [FormatHTTPError $token] } else { SaveAndSetOptions $serviceName if {[catch {set hadError [catch {parseRestResults $serviceName $objectName $operationName $body} results]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } if {$hadError} { set errorCode $::errorCode set errorInfo $::errorInfo } } ## |
︙ | ︙ | |||
3141 3142 3143 3144 3145 3146 3147 | lappend cmd $results catch $cmd ## ## All done ## ::http::cleanup $token | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 | lappend cmd $results catch $cmd ## ## All done ## ::http::cleanup $token return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::asyncRestobCallDone # # Description : Save the global options of the utilities package and # set them for how this service needs them. # # Arguments : # serviceName - the name of the service called # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 03/06/2012 G.Lester Initial version # # ########################################################################### proc ::WS::Client::SaveAndSetOptions {serviceName} { variable serviceArr variable utilsOptionsList if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set savedDict {} foreach item $utilsOptionsList { if {[dict exists $serviceInfo $item] && [string length [set value [dict get $serviceInfo $item]]]} { dict set savedDict $item [::WS::Utils::SetOption $item] ::WS::Utils::SetOption $item $value } } dict set serviceArr($serviceName) UtilsSavedOptions $savedDict return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::RestoreSavedOptions # # Description : Restore the saved global options of the utilities package. # # Arguments : # serviceName - the name of the service called # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 03/06/2012 G.Lester Initial version # # ########################################################################### proc ::WS::Client::RestoreSavedOptions {serviceName} { variable serviceArr if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set savedDict {} foreach {item value} [dict get $serviceInfo UtilsSavedOptions] { ::WS::Utils::SetOption $item $value } dict set serviceArr($serviceName) UtilsSavedOptions {} return } |
Changes to Embedded.tcl.
1 2 3 4 5 6 7 8 9 | ############################################################################### ## ## ## Copyright (c) 2008, Gerald W. Lester ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## | > | 1 2 3 4 5 6 7 8 9 10 | ############################################################################### ## ## ## Copyright (c) 2016-2020, Harald Oehlmann ## ## Copyright (c) 2008, Gerald W. Lester ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## |
︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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 uri package require base64 package require html | > > > > > > > > > > > > > | | | > | > > | > > | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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.6- 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 3.3.1 namespace eval ::WS::Embeded { variable portInfo {} variable handlerInfoDict {} variable returnCodeText [dict create 200 OK 404 "Not Found" \ 500 "Internal Server Error" 501 "Not Implemented"] variable socketStateArray } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::AddHandler # # Description : Register a handler for a url on a port. # # Arguments : # port -- The port to register the callback on # urlPath -- The URL path to register the callback for # method -- HTTP method: GET or POST # callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : # None # |
︙ | ︙ | |||
128 129 130 131 132 133 134 135 136 137 | # 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 03/28/2008 G.Lester Initial version # # ########################################################################### | > > > | | | > > | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | > | > > > > > > > | | > > > > | | > > > > > | | > > > > > | | > > > > | > > | > > > | > | > > > > > > > > > > | > > | > > > | < > | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | | | | < < < | | | > < | < < < < | < < > | < | > | > | < | < < < < < > | | < | < > > | < | < > | > | < > | < > | < < < < < < < < < < < | < < | | | | | > | | < < | | | > | | > > | > > > > > | > > > > > > > > > | | | | | | | | | > > | < < < | | > | > > | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | # 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 03/28/2008 G.Lester Initial version # 3.2.0 2021-03-17 H.Oehlmann Also pass method. # 3.3.0 2021-03-19 H.Oehlmann Put handler info to own dict, so order of # Listen and AddHandler call is not important. # # ########################################################################### proc ::WS::Embeded::AddHandler {port urlPath method callback} { variable handlerInfoDict dict set handlerInfoDict $port $urlPath $method $callback return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::GetValue # # Description : Get a value found in this module # # Arguments : # index -- type of value to get. Possible values: # -- isHTTPS : true, if https protocol is used. # port -- concerned port. May be ommitted, if not relevant for value. # # Returns : the distinct value # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port # # Original Author : Harald Oehlmann # #>>END PUBLIC<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 2.7.0 2020-10-26 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::GetValue {index {port ""}} { variable portInfo switch -exact -- $index { isHTTPS { return [dict get $portInfo $port $index] } default {return -code error "Unknown index '$index'"} } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::Listen # # Description : Instruct the module to listen on a Port, security information. # # Arguments : # port -- Port number to listen on # certfile -- Name of the certificate file or a pfx archive for twapi. # Defaults to {}. # keyfile -- Name of the key file. Defaults to {}. # To use twapi TLS, specify a list with the following elements: # -- "-twapi": Flag, that TWAPI TLS should be used # -- password: password of PFX file passed by # [::twapi::conceal]. The concealing makes sure that the # password is not readable in the error stack trace # -- ?subject?: optional search string in pfx file, if # multiple certificates are included. # userpwds -- A list of username:password. Defaults to {}. # realm -- The security realm. Defaults to {}. # timeout -- A time in ms the sender may use to send the request. # If a sender sends wrong data (Example: TLS if no TLS is # used), the process will just stand and a timeout is required # to clear the connection. Set to 0 to not use a timeout. # Default: 60000 (1 Minuit). # # Returns : socket handle # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 03/28/2008 G.Lester Initial version # 3.0.0 2020-10-30 H.Oehlmann Add twapi tls support # 3.3.0 2021-03-18 H.Oehlmann Add timeout option. Remove unused portList. # Call Close, if we use the port already. # Do not leave portInfo data, if open fails. # 3.3.1 2021-03-23 H.Oehlmann Fix bug: pfx subject had added ")". # # ########################################################################### proc ::WS::Embeded::Listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}} {timeout 600000}} { variable portInfo ## ## Check if port already used by us. If yes, close it. ## if {[dict exists $portInfo $port]} { Close $port } ## ## Check if HTTPS protocol is used ## set isHTTPS [expr {$certfile ne ""}] if {$isHTTPS } { if { [string is list $keyfile] && [lindex $keyfile 0] eq "-twapi"} { ## ## Use TWAPI TLS ## package require twapi_crypto # Decode parameters # # certfile is the pfx file name # keyfile is a list of: # -twapi: fix element # password of the pfx file, passed by twapi::conceal # Optional Subject of the certificate, if there are multiple # certificates contained. # If not given, the first certificate is used. set pfxpassword [lindex $keyfile 1] set pfxsubject "" if {[llength $keyfile] > 2} { set pfxsubject [lindex $keyfile 2] } # Create certificate selection tring if {$pfxsubject eq ""} { set pfxselection any } else { set pfxselection [list subject_substring $pfxsubject] } set hFile [open $certfile rb] set PFXCur [read $hFile] close $hFile # Set up the store containing the certificates # Import the PFX file and search the certificate. set certstore [twapi::cert_temporary_store -pfx $PFXCur \ -password $pfxpassword] set servercert [twapi::cert_store_find_certificate $certstore \ {*}$pfxselection] if {"" eq $servercert} { # There was no certificate included in the pfx file catch {twapi::cert_store_release $certstore} return -code error "no certificate found in file '$certfile'" } # The following is catched to clean-up in case of any error if {![catch { # Start the TLS socket with the credentials set creds [twapi::sspi_schannel_credentials \ -certificates [list $servercert] \ -protocols [list ssl3 tls1.1 tls1.2]] set creds [twapi::sspi_acquire_credentials \ -credentials $creds -package unisp -role server] set handle [::twapi::tls_socket \ -server [list ::WS::Embeded::accept $port] \ -credentials $creds $port] } errormsg errordict]} { # All ok, clear error flag unset errormsg } # Clean up certificate and certificate store if {[info exists servercert]} { catch {twapi::cert_release $servercert} } catch {twapi::cert_store_release $certstore} # Return error if happened above if {[info exists errormsg]} { dict unset errordict -level return -options $errordict $errormsg } } else { ## ## Use TLS Package ## package require tls ::tls::init \ -certfile $certfile \ -keyfile $keyfile \ -require 0 \ -request 0 set handle [::tls::socket -server [list ::WS::Embeded::accept $port] $port] } } else { ## ## Use http protocol without encryption ## ::log::logsubst debug {socket -server [list ::WS::Embeded::accept $port] $port} set handle [socket -server [list ::WS::Embeded::accept $port] $port] } ## ## Prepare basic authentication ## set authlist {} foreach up $userpwds { lappend authlist [base64::encode $up] } ## ## Save the port information dict entry ## dict set portInfo $port [dict create\ port $port\ realm $realm\ timeout $timeout\ auths $authlist\ isHTTPS $isHTTPS\ handle $handle] return $handle } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::Close # # Description : End listening, close the port. # # Arguments : # port -- Port number to listen on # # Returns : none # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PUBLIC<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::Close {port} { variable socketStateArray variable portInfo # Check, if port exists if {![dict exists $portInfo $port handle]} {return} ::log::log info "closing server socket for port $port" # close server port if {[catch {close [dict get $portInfo $port handle]} msg]} { ::log::log error "error closing server socket for port $port: $msg" } # close existing connections foreach sock [array names socketStateArray] { if {[dict get $socketStateArray($sock) port] eq $port} { cleanup $sock } } # remove registered data dict unset portInfo $port return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::CloseAll # # Description : End listening, close all ports. # # Arguments : # port -- Port number to listen on # # Returns : none # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PUBLIC<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::CloseAll {} { variable portInfo foreach port [dict keys $portInfo] { Close $port } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::respond # # Description : Send response back to user. # # Arguments : # sock -- Socket to send reply on # code -- Code to send # body -- HTML body to send # head -- Additional HTML headers to send # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None |
︙ | ︙ | |||
394 395 396 397 398 399 400 401 402 403 | # 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 03/28/2008 G.Lester Initial version # # ########################################################################### | > > | > > > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | < < < | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 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 | # 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 03/28/2008 G.Lester Initial version # 2.3.0 11/06/2012 H.Oehlmann Separate head and body, # correct Content-length # # ########################################################################### proc ::WS::Embeded::respond {sock code body {head ""}} { set body [encoding convertto iso8859-1 $body\r\n] if {[catch { chan configure $sock -translation crlf puts $sock "[httpreturncode $code]\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]" if {"" ne $head} { puts -nonewline $sock $head } # Separator head and body puts $sock "" chan configure $sock -translation binary puts -nonewline $sock $body close $sock } msg]} { log::log error "Error sending response: $msg" cleanup $sock } else { cleanup $sock 1 } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::httpreturncode # # Description : Format the first line of a http return including the status code # # Arguments : # code -- numerical http return code # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 10/05/2012 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::httpreturncode {code} { variable returnCodeText if {[dict exist $returnCodeText $code]} { set textCode [dict get $returnCodeText $code] } else { set textCode "???" } return "HTTP/1.0 $code $textCode" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::handler # # Description : Handle a request. # # Arguments : # sock -- Incoming socket # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None |
︙ | ︙ | |||
440 441 442 443 444 445 446 | # 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 03/28/2008 G.Lester Initial version | | < < < < < | | < < < | < < < < < < < < > > | | > | | < | > > > | < < < < < < < < < < < < < < < < < < < | | < | < < > | < < | | < < < < < < < < < < > | | | | | | | < > | | < > | < > | < < > > | | < > | < > | | < | > | | | < < < < < < | | < < < | < < < < < < < < | < < < | < < < < < < < < | | < | | | | < > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > | < > > > | < > | > | < > > > > > > > | | | > > > | > > > > > > > | > | | | | > > | < > | > > > | > > > > > > > > > | > > > > > | > > | > > | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 | # 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 03/28/2008 G.Lester Initial version # 2.3.0 10/31/2012 G.Lester bug fix for [68310fe3bd] -- correct encoding and data length # 2.6.1 2020-10-22 H.Oehlmann Do not pass parameter reqstring. # The corresponding value is found in global # array anyway. # Use charset handler of request decoding. # 2.7.0 2020-10-26 H.Oehlmann Pass additional port parameter to handle # functions. This helps to get isHTTPS # status for WSDL. # 3.1.0 2020-11-05 H.Oehlmann Pass additional port parameter with leading # -port specifier to avoid clash with # other parameters. # 3.2.0 2021-03-17 H.Oehlmann Return the result directly by the call. # Replace global parameter dict by parameter # url and dataDict (for POST method). # 3.3.0 2021-03-18 H.Oehlmann Use state array, move checks to Receive, # do query recode here. # ########################################################################### proc ::WS::Embeded::handler {sock} { variable socketStateArray set cmd [dict get $socketStateArray($sock) cmd] if {[dict get $socketStateArray($sock) method] eq "POST"} { # Recode the query data dict set socketStateArray($sock) query [encoding convertfrom\ [dict get $socketStateArray($sock) requestEncoding]\ [dict get $socketStateArray($sock) query]] # The following dict keys are attended: query, ipaddr, headers if {[catch { lassign [$cmd $sock -data $socketStateArray($sock)] type data code } msg]} { ::log::log error "Return 404 due to post eval error: $msg" tailcall respond $sock 404 "Error: $msg" } } else { if {[catch { lassign [$cmd $sock -port [dict get $socketStateArray($sock) port]] type data code } msg]} { ::log::log error "Return 404 due to get eval error: $msg" tailcall respond $sock 404 "Error: $msg" } } # This may modify the type variable, if encoding is not found set encoding [contentTypeParse 0 type] set data [encoding convertto $encoding $data] set reply "[httpreturncode $code]\n" append reply "Content-Type: $type\n" append reply "Connection: close\n" append reply "Content-length: [string length $data]\n" # Note: to avoid delay, full buffering is used on the channel. # In consequence, the data is sent in the background after the close. # Socket errors may not be detected, but the event queue is free. # This is specially important with the Edge browser, which sometimes delays # data reception. if {[catch { chan configure $sock -translation crlf puts $sock $reply chan configure $sock -translation binary puts -nonewline $sock $data close $sock } msg]} { ::log::log error "Error sending reply: $msg" tailcall cleanup $sock } ::log::log debug ok tailcall cleanup $sock 1 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::accept # # Description : Accept an incoming connection and register callback. # # Arguments : # port -- Port number # sock -- Incoming socket # ip -- Requester's IP address # clientport -- Requester's port number # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::accept {port sock ip clientport} { variable portInfo variable socketStateArray ::log::logsubst info {Received request on $port for $ip:$clientport} # Setup events if {[catch { chan configure $sock -blocking 0 -translation crlf chan event $sock readable [list ::WS::Embeded::receive $sock] } msg]} { catch {chan close $sock} ::log::log error "Error installing accepted socket on ip '$ip': $msg" return } # Prepare socket state dict set stateDict [dict create port $port ip $ip phase request] # Install timeout if {0 < [dict get $portInfo $port timeout]} { dict set stateDict timeoutHandle [after\ [dict get $portInfo $port timeout]\ [list ::WS::Embeded::timeout $sock]] } # Save state dict set socketStateArray($sock) $stateDict } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::receive # # Description : handle a readable socket # # Arguments : # sock -- Incoming socket # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::receive {sock} { variable socketStateArray variable portInfo variable handlerInfoDict ## ## Make data read attempts in this read loop. ## while 1 { ::log::logsubst debug {Top of loop with dict: $socketStateArray($sock)} ## ## Read data ## if {[catch { if {[dict get $socketStateArray($sock) phase] eq "body"} { # Read binary data set line [chan read $sock [dict get $socketStateArray($sock) readMax]] } else { # read line data set line [chan gets $sock] } } msg]} { ::log::log error "Data read error: $msg" tailcall cleanup $sock } ::log::logsubst debug {Read: len [string length $line] eof [eof $sock] block [chan blocked $sock] data '$line'} ## ## Check for early EOF ## if { [eof $sock] } { ::log::log warning {Connection closed from client} tailcall cleanup $sock } ## ## Check for no new data, so wait for next file event. ## ## For gets: ## This makes also the difference between empty data read (crlf ## terminated line) and no read (true). ## For read with limit: ## If not all characters could be read, block is flagged with data. ## So check the data length to 0 for this case. ## if {[string length $line] == 0 && [chan blocked $sock]} { return } ## ## Handle the received data ## switch -exact -- [dict get $socketStateArray($sock) phase] { request { ## ## Handle Request line ## if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} { ::log::logsubst warning {Wrong request: $line} tailcall cleanup $sock } if {$method ni {"GET" "POST"}} { ::log::logsubst warning {Unsupported method '$method'} tailcall respond $sock 501 "Method not implemented" } # Check if we have a handler for this method and URL path set urlPath "/[string trim [dict get [uri::split $url] path] /]" set port [dict get $socketStateArray($sock) port] if {![dict exists $handlerInfoDict $port $urlPath $method]} { ::log::log warning "404 Error: URL path '$urlPath' not found" tailcall respond $sock 404 "URL not found" } # Save data and pass to header phase dict set socketStateArray($sock) cmd [dict get $handlerInfoDict $port $urlPath $method] dict set socketStateArray($sock) phase header dict set socketStateArray($sock) method $method dict set socketStateArray($sock) header "" } header { ## ## Handle Header lines ## if {[string length $line] > 0} { if {[regexp {^([^:]*):(.*)$} $line -> key data]} { dict set socketStateArray($sock) header [string tolower $key] [string trim $data] } } else { # End of header by empty line ## ## Get authorization failure condition ## # Authorization is ok, if no authrization required # Authorization fails, if: # - no authentication in current request # - or current credentials incorrect set port [dict get $socketStateArray($sock) port] if { 0 != [llength [dict get $portInfo $port auths]] && ! ( [dict exists $socketStateArray($sock) header authorization] && [regexp -nocase {^basic +([^ ]+)$} \ [dict get $socketStateArray($sock) header authorization] -> auth] && $auth in [dict get $portInfo $port auths] ) } { set realm [dict get $portInfo $port realm] ::log::log warning {Unauthorized} tailcall respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n" } # Within the GET method, we have all we need if {[dict get $socketStateArray($sock) method] eq "GET"} { tailcall handler $sock } # Post method requires content-encoding header if {![dict exists $socketStateArray($sock) header content-type]} { ::log::logsubst warning {Header missing: 'Content-Type'} tailcall cleanup $sock } set contentType [dict get $socketStateArray($sock) header content-type] dict set socketStateArray($sock) requestEncoding [contentTypeParse 1 contentType] # Post method requires query data dict set socketStateArray($sock) query "" set fChunked [expr { [dict exists $socketStateArray($sock) header transfer-encoding] && [dict get $socketStateArray($sock) header transfer-encoding] eq "chunked"}] dict set socketStateArray($sock) fChunked $fChunked if {$fChunked} { dict set socketStateArray($sock) phase chunk } else { # Check for content length if { ! [dict exists $socketStateArray($sock) header content-length] || 0 == [scan [dict get $socketStateArray($sock) header content-length] %d contentLength] } { ::log::log warning "Header content-length missing" tailcall cleanup $sock } dict set socketStateArray($sock) readMax $contentLength dict set socketStateArray($sock) phase body # Switch to binary data if {[catch { chan configure $sock -translation binary } msg]} { ::log::log error "Channel config error: $msg" tailcall cleanup $sock } } } } body { ## ## Read body data ## set query [dict get $socketStateArray($sock) query] append query $line dict set socketStateArray($sock) query $query set readMax [expr { [dict get $socketStateArray($sock) readMax] - [string length $line] } ] if {$readMax > 0} { # Data missing, so loop dict set socketStateArray($sock) readMax $readMax } else { # We have all data if {[dict get $socketStateArray($sock) fChunked]} { # Chunk read # Switch to line mode if {[catch { chan configure $sock -translation crlf } msg]} { ::log::log error "Channel config error: $msg" tailcall cleanup $sock } dict set socketStateArray($sock) phase chunk } else { # no chunk -> all data -> call handler tailcall handler $sock } } } chunk { ## ## Handle chunk header ## if {[scan $line %x length] != 1} { ::log::log warning "No chunk length in '$line'" tailcall cleanup $sock } if {$length > 0} { # Receive chunk data # Switch to binary data if {[catch { chan configure $sock -translation binary } msg]} { ::log::log error "Channel config error: $msg" tailcall cleanup $sock } dict set socketStateArray($sock) readMax $length dict set socketStateArray($sock) phase body } else { # We have all data tailcall handler $sock } } } } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::timeout # # Description : socket timeout fired # # Arguments : # sock -- Incoming socket # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::timeout {sock} { variable socketStateArray # The timeout fired, so the cancel handle is not required any more dict unset socketStateArray($sock) timeoutHandle ::log::log warning "Cancelling request due to timeout" tailcall cleanup $sock } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::cleanup # # Description : cleanup a socket # # Arguments : # sock -- Incoming socket # fClosed -- Socket already closed # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::cleanup {sock {fClosed 0}} { variable socketStateArray if {!$fClosed} { catch { chan close $sock } } if {[dict exists $socketStateArray($sock) timeoutHandle]} { after cancel [dict get $socketStateArray($sock) timeoutHandle] } unset socketStateArray($sock) } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::contentTypeParse # # Description : Parse a content-type value and get the encoding. # When receiving, only the encoding is required. # When sending, we have to correct the encoding, if not known # by TCL. Thus, the content-type string is changed. # # Arguments : # fReceiving -- When receiving, we only need the extracted codepage. # If sending, the content-type string must be modified, # if the codepage is not found in tcl # contentTypeName -- The variable containing the content type string. # # Returns : # tcl encoding to apply # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 2.6.1 2020-10-22 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::contentTypeParse {fReceiving contentTypeName} { upvar 1 $contentTypeName contentType ## ## Extract charset parameter from content-type header ## # content-type example content: text/xml;charset=utf-8 set paramList [lassign [split $contentType ";"] typeOnly] foreach parameterCur $paramList { set parameterCur [string trim $parameterCur] # Check for 'charset="<data>', where data may contain '\"' if {[regexp -nocase {^charset\s*=\s*\"((?:[^""]|\\\")*)\"$} \ $parameterCur -> requestEncoding] } { set requestEncoding [string map {{\"} \"} $requestEncoding] break } else { # check for 'charset=<data>' regexp -nocase {^charset\s*=\s*(\S+?)$} \ $parameterCur -> requestEncoding break } } ## ## Find the corresponding TCL encoding name ## if {[info exists requestEncoding]} { if {[llength [info commands ::http::CharsetToEncoding]]} { # Use private http package routine set requestEncoding [::http::CharsetToEncoding $requestEncoding] # Output is "binary" if not found if {$requestEncoding eq "binary"} { unset requestEncoding } } else { # Reduced version of the http package version only honoring ISO8859-x # and encoding names identical to tcl encoding names set requestEncoding [string tolower $requestEncoding] if {[regexp {iso-?8859-([0-9]+)} $requestEncoding -> num]} { set requestEncoding "iso8859-$num" } if {$requestEncoding ni [encoding names]} { unset requestEncoding } } } ## ## Output found encoding and eventually content type ## # If encoding was found, just return it if {[info exists requestEncoding]} { return $requestEncoding } # encoding was not found if {$fReceiving} { # This is the http default so use that ::log::logsubst info {Use default encoding as content type header has missing/unknown charset in '$contentType'} return iso8859-1 } # When sending, be sure to cover all characters, so use utf-8 # correct content-type string (upvar) ::log::logsubst info {Set send charset to utf-8 due missing/unknown charset in '$contentType'} if {[info exists typeOnly]} { set contentType "${typeOnly};charset=utf-8" } else { set contentType "text/xml;charset=utf-8" } return utf-8 } |
Changes to Examples/Echo/CallEchoWebService.tcl.
︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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 WS::Client ## ## Get Definition of the offered services ## ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsEchoExample/wsdl | > > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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. ## ## ## ############################################################################### set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] package require WS::Utils package require WS::Client ## ## Get Definition of the offered services ## ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsEchoExample/wsdl |
︙ | ︙ |
Added Examples/Echo/EchoEmbeddedService.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | ############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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. ## ## ## ############################################################################### set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] package require WS::Server package require WS::Utils package require WS::Embeded catch {console show} ## ## Define the service ## ::WS::Server::Service \ -service wsEchoExample \ -description {Echo Example - Tcl Web Services} \ -host localhost:8015 \ -mode embedded \ -ports [list 8015] ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { echoBack {type string} echoTS {type dateTime} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsEchoExample \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { ::log::lvSuppressLE debug 0 return [list SimpleEchoResult $TestString] } ::WS::Server::ServiceProc \ wsEchoExample \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } set ::errorInfo {} set SocketHandle [::WS::Embeded::Listen 8015] set ::errorInfo {} proc x {} { close $::SocketHandle exit } puts stdout {Server started. Press x and Enter to stop} flush stdout fileevent stdin readable {set QuitNow 1} vwait QuitNow x |
Added Examples/Echo/EchoWibbleService.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | ############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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 WS::Server package require WS::Utils ## ## Define the service ## ::WS::Server::Service \ -service wsEchoExample \ -description {Echo Example - Tcl Web Services} \ -mode wibble \ -host $::Config(host):$::Config(port) ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { echoBack {type string} echoTS {type dateTime} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsEchoExample \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { return [list SimpleEchoResult $TestString] } ::WS::Server::ServiceProc \ wsEchoExample \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } |
Added Examples/Echo/EchoWibbleStart.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | ############# tclws.tcl, start script for wibble 24 (not included) ######## # Adjust auto_path to your needs lappend auto_path [file dir [info script]] lib source wibble.tcl # Set the root directory. set root html set ::Config(host) 127.0.0.1 set ::Config(port) 8015 source EchoWebService.tcl # Define zone handlers. ::wibble::handle /vars vars ::wibble::handle / dirslash root $root ::wibble::handle / indexfile root $root indexfile index.html ::wibble::handle / static root $root ::wibble::handle / template root $root ::wibble::handle / script root $root ::wibble::handle / dirlist root $root ::wibble::handle / notfound # Start a server and enter the event loop. catch { ::wibble::listen 8015 vwait forever } |
Changes to Examples/Math/CallMathWebService.tcl.
︙ | ︙ | |||
39 40 41 42 43 44 45 | ## Get Definition of the offered services ## ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsMathExample/wsdl ## ## Add two numbers ## | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | ## Get Definition of the offered services ## ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsMathExample/wsdl ## ## Add two numbers ## puts stdout "Calling Add via DoCalls!" set inputs [list N1 12 N2 34] set results [::WS::Client::DoCall wsMathExample Add $inputs] puts stdout "\t Received: {$results}" ## ## Divide two numbers ## puts stdout "Calling Divide via DoCalls!" set inputs [list Dividend 34 Divisor 12] set results [::WS::Client::DoCall wsMathExample Divide $inputs] puts stdout "\t Received: {$results}" ## ## Multiply two numbers ## puts stdout "Calling Multiply via DoCalls!" set inputs [list N1 12.0 N2 34] set results [::WS::Client::DoCall wsMathExample Multiply $inputs] puts stdout "\t Received: {$results}" ## ## Subtract two numbers ## puts stdout "Calling Subtract via DoCalls!" set inputs [list Subtrahend 12 Minuend 34] set results [::WS::Client::DoCall wsMathExample Subtract $inputs] puts stdout "\t Received: {$results}" ## ## Sqrt a number ## puts stdout "Calling Sqrt via DoCalls!" set inputs [list X 12] set results [::WS::Client::DoCall wsMathExample Sqrt $inputs] puts stdout "\t Received: {$results}" ## ## Set up to evaluate a polynomial ## dict set term var X dict set term value 2.0 dict lappend varList $term dict set term var Y dict set term value 3.0 dict lappend varList $term set term {} set powerTerm {} dict set powerTerm coef 2.0 dict set term var X dict set term pow 2.0 dict lappend terms $term dict set term var Y dict set term pow 3.0 dict lappend terms $term dict set powerTerm powerTerms $terms dict set powerTerm coef -2.0 dict set term var X dict set term pow 3.0 dict lappend terms $term dict set term var Y dict set term pow 2.0 dict lappend terms $term dict set powerTerm powerTerms $terms dict lappend polynomial powerTerms $powerTerm dict set input varList $varList dict set input polynomial $polynomial ## ## Call service ## puts stdout "Calling EvaluatePolynomial with {$input}" set resultsDict [::WS::Client::DoCall wsMathExample EvaluatePolynomial $input] puts stdout "Results are {$resultsDict}" |
Changes to Examples/Math/MathWebService.tcl.
︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 | ## ## Define the service ## ::WS::Server::Service \ -service wsMathExample \ -description {Math Example - Tcl Web Services} \ -host $::Config(host):$::Config(port) ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsMathExample \ {Add {type string comment {Sum of two number}}} \ | > > > > > > > > > > > > > > > > > > | 39 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 65 66 67 68 69 70 | ## ## Define the service ## ::WS::Server::Service \ -service wsMathExample \ -description {Math Example - Tcl Web Services} \ -host $::Config(host):$::Config(port) ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsMathExample Term { `coef {type float} powerTerms {type PowerTerm()} } ::WS::Utils::ServiceTypeDef Server wsMathExample PowerTerm { var {type string} exponet {type float} } ::WS::Utils::ServiceTypeDef Server wsMathExample Variables { var {type string} value {type float} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsMathExample \ {Add {type string comment {Sum of two number}}} \ |
︙ | ︙ | |||
95 96 97 98 99 100 101 | if {$Divisor == 0.0} { return \ -code error \ -errorcode [list MATH DIVBYZERO] \ "Can not divide by zero" } | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | if {$Divisor == 0.0} { return \ -code error \ -errorcode [list MATH DIVBYZERO] \ "Can not divide by zero" } return [list DivideResult [expr {$Dividend / $Divisor}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Sqrt {type string comment {Square root of a non-negative number}}} \ { X {type double comment {Number raised to the half power}} } \ {The the square root of a number} { if {$X < 0.0} { return \ -code error \ -errorcode [list MATH RANGERR] \ "Can not take the square root of a negative number, $X" } return [list SqrtResult [expr {sqrt($X)}]] } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsMathExample \ {EvaluatePolynomial {type float comment {Result of evaluating a polynomial}}} \ { varList {type Variables() comment {The variables to be substitued into the polynomial}} polynomial {type Term() comment {The polynomial}} } \ {Evaluate a polynomial} { set equation {0 } foreach varDict $varList { set var dict get $varDict var set val dict get $varDict value set vars($var) $val } foreach term $polynomial { if {dict exists $term coef} { set coef dict get $term coef } else { set coef 1 } append equation "+ ($coef" foreach pow dict get $term powerTerms { if {dict exists $pow exponet} { set exp dict get $pow exponet } else { set exp 1 } append equation format { * pow($vars(%s),%s} [dict get $pow var $exp] } append equation ")" } set result expr $equation return list SimpleEchoResult $result } |
Added Examples/redirect_test/redirect_call.tcl.
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | # Call redirect server # 2015-11-09 Harald Oehlmann # Start the redirect_server.tcl and the embedded echo sample to test. set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] package require WS::Utils package require WS::Client catch {console show} ::log::lvSuppressLE debug 0 ::WS::Client::GetAndParseWsdl http://localhost:8014/service/wsEchoExample/wsdl |
Added Examples/redirect_test/redirect_server.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | # Test tclws redirection # 2015-11-09 by Harald Oehlmann # # If (set loop 1), infinite redirect is tested, otherwise one redirect. # Start the embedded test server and use redirect_call to call. # set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] catch {console show} package require uri proc ::Listen {port} { return [socket -server ::Accept $port] } proc ::Accept {sock ip clientport} { if {1 == [catch { gets $sock line 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]} { puts "Connection closed from $ip" return } if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} { puts "Wrong request: $line" return } array set uri [::uri::split $url] if {[info exists ::loop]} { set uri(host) "localhost:8014" } else { set uri(host) "localhost:8015" } set url [eval ::uri::join [array get uri]] puts "Redirecting to $url" puts $sock "HTTP/1.1 301 Moved Permanently" puts $sock "Location: $url" puts $sock "Content-Type: text/html" puts $sock "Content-Length: 0\n\n" close $sock } Err]} { puts "Socket Error: $Err" return } } Listen 8014 |
Changes to License.txt.
1 |
| | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | Copyright (c) 2006-2013, Gerald W. Lester Copyright (c) 2006, Visiprise Software, Inc Copyright (c) 2006, Colin McCormack Copyright (c) 2006, Rolf Ade Copyright (c) 2001-2006, Pat Thoyts All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the Visiprise Software, Inc nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 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. |
Changes to ServerSide.tcl.
1 2 | ############################################################################### ## ## | > | | 1 2 3 4 5 6 7 8 9 10 11 | ############################################################################### ## ## ## Copyright (c) 2016-2021, Harald Oehlmann ## ## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## ## Copyright (c) 2001-2006, Pat Thoyts ## ## All rights reserved. ## ## ## |
︙ | ︙ | |||
34 35 36 37 38 39 40 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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. ## ## ## ############################################################################### | | < < | < | | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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.6- package require WS::Utils package require html package require log package require tdom package provide WS::Server 3.4.0 namespace eval ::WS::Server { array set ::WS::Server::serviceArr {} set ::WS::Server::procInfo {} set ::WS::Server::mode {} } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. |
︙ | ︙ | |||
70 71 72 73 74 75 76 | # Displays an HTML page describing the service # /service/<ServiceName>/wsdl # Returns a WSDL describing the service # /service/<ServiceName>/op # Invoke an operation # # Arguments : this procedure uses position independent arguments, they are: | > > > | > > > > > > > > > > > > > > > > > > > > > > | > > | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | # Displays an HTML page describing the service # /service/<ServiceName>/wsdl # Returns a WSDL describing the service # /service/<ServiceName>/op # Invoke an operation # # Arguments : this procedure uses position independent arguments, they are: # -hostcompatibility32 bool - Activate version 3.2.0 compatibility # mode for -host parameter. # Defaults to true. # -host - The host specification within XML namespaces # of the transmitted XML files. # This should be unique. # Defaults to localhost. # If 3.2 compatibility is activated, the default # value is changed to ip:port in embedded mode. # -hostlocation - The host name, which is promoted within the # generated WSDL file. Defaults to localhost. # If 3.2 compatibility is activated, the # default value is equal to the -host parameter. # -hostlocationserver bool - If true, the host location is set by # the current server settings. # In case of httpd server, this value is imported. # For other servers or if this fails, the value # is the current ip:port. # The default value is true. # In case of 3.2 compatibility, the default # value is true for tclhttpd, false otherwise. # -hostprotocol - Define the host protocol (http, https) for the # WSDL location URL. The special value "server" # (default) follows the TCP/IP server specification. # This is implemented for Embedded server and tclhttpd. # Remark that the protocol for XML namespaces # is always "http". # -description - The HTML description for this service # -service - The service name (this will also be used for # the Tcl namespace of the procedures that implement # the operations. # -premonitor - This is a command prefix to be called before # an operation is called. The following arguments are # added to the command prefix: # PRE serviceName operationName operArgList # -postmonitor - This is a command prefix to be called after # an operation is called. The following arguments are # added to the command prefix: # POST serviceName operationName OK|ERROR results # -inheaders - List of input header types. # -outheaders - List of output header types. # -intransform - Inbound (request) transform procedure. # -outtransform - Outbound (reply) transform procedure. # -checkheader - Command prefix to check headers. # If the call is not to be allowed, this command # should raise an error. # The signature of the command must be: # cmd \ # service \ # operation \ |
︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 135 136 137 | # -prefix - Path prefix used for the namespace and endpoint # Defaults to "/service/" plus the service name # -traceEnabled - Boolean to enable/disable trace being passed back in exception # Defaults to "Y" # -docFormat - Format of the documentation for operations ("text" or "html"). # Defaults to "text" # -stylesheet - The CSS stylesheet URL used in the HTML documentation # # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : | > > > > > > | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | # -prefix - Path prefix used for the namespace and endpoint # Defaults to "/service/" plus the service name # -traceEnabled - Boolean to enable/disable trace being passed back in exception # Defaults to "Y" # -docFormat - Format of the documentation for operations ("text" or "html"). # Defaults to "text" # -stylesheet - The CSS stylesheet URL used in the HTML documentation # -errorCallback - Callback to be invoked in the event of an error being produced # -verifyUserArgs - Boolean to enable/disable validating user supplied arguments # Defaults to "N" # -enforceRequired - Throw an error if a required field is not included in the # response. # Defaults to "N" # # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : |
︙ | ︙ | |||
146 147 148 149 150 151 152 | # 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 | | > > > > > > > > > > > > > > > > > > | | < < | | | > > | | | | | | | | > > > > > | | | | > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | < | > > | | > > > > > > > > > > > > > > > > | > | | | | | | > > > | | | | | > > | | > | > > > > > > > > > > > > > > > > > | > > | > | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 | # 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.7.0 2020-10-26 H.Oehlmann Embedded server: Do not add port 443 to default url # 3.0.0 2020-10-30 H.Oehlmann New option -hostProtocol # 3.2.0 2021-03-17 H.Oehlmann Add HTTP method to embedded registration. # Change default of -checkheader from # ::WS::Server::ok to the empty string. # 3.4.0 2021-10-15 H.Oehlmann Rename option -hostProtocol to -hostprotocol. # Still accept -hostProtocol. # The logic on .hostprotocol=server is changed # to default to http and set an update flag. # The default value of -host in embedded mode # is <current IP>:port. This is critial, if # the IP changes and thus the XML namespace. # If the old WSDL with old IP is used, there # are no input parameters recognized, as the # XML namespace has changed. # In consequence, a new parameter set including # options -host, -hostlocation, -hostlocationserver # and -hostcompatibility32 is defined as # described above. # ########################################################################### proc ::WS::Server::Service {args} { variable serviceArr variable procInfo variable mode ::log::logsubst debug {Defining Service as $args} set defaults [dict create\ -checkheader {}\ -inheaders {}\ -outheaders {}\ -intransform {}\ -outtransform {}\ -htmlhead {TclHttpd Based Web Services}\ -author {}\ -description {}\ -mode {tclhttpd}\ -ports {80}\ -traceEnabled {Y}\ -docFormat {text}\ -stylesheet {}\ -beautifyJson {N}\ -errorCallback {}\ -verifyUserArgs {N}\ -enforceRequired {N}\ -hostcompatibility32 1] set defaults [dict merge $defaults $args] # Set default -ports value if mode equal channel if { [dict get $defaults -mode] eq "channel" && ! [dict exists $args -ports] } { dict set defaults -ports {stdin stdout} } set requiredList {-service} set missingList {} foreach opt $requiredList { if {![dict exists $defaults $opt]} { lappend missingList $opt } } if {[llength $missingList]} { return \ -code error \ -errorcode [list WSSERVER MISSREQARG $missingList] \ "Missing required arguments '[join $missingList {,}]'" } set service [dict get $defaults -service] if {![dict exists $defaults -prefix]} { dict set defaults -prefix /service/$service } # find default host/host location if {[dict get $defaults -hostcompatibility32]} { ## ## Version 3.2.x compatibility mode: ## -host: default value is changed to ip:port in embedded mode. ## -hostlocation : default value is equal to the -host parameter. ## -hostlocationserver: default true for tclhttpd, false otherwise. ## if { ! [dict exists $defaults -hostlocationserver]} { dict set defaults -hostlocationserver [expr { [dict get $defaults -mode] eq "tclhttpd" }] } if {![dict exists $defaults -host]} { if { [dict get $defaults -mode] eq "embedded" } { set myHostLocation [MyHostLocationGet [dict get $defaults -ports]] dict set defaults -host $myHostLocation # Note: myHostLocation may be reused below } else { dict set defaults -host localhost } } if { ! [dict exists $defaults -hostlocation]} { dict set defaults -hostlocation [dict get $defaults -host] } } else { ## ## No Version 3.2.x compatibility mode: ## -host: defaults to localhost. ## -hostlocation : defaults to localhost. ## -hostlocationserver bool: defaults to true. ## set defaults [dict merge \ [dict create \ -hostlocation "localhost" \ -hostlocationserver 1 \ -host "localhost"] \ $defaults] } # Compatibility has done its work, remove it: dict unset defaults -hostcompatibility32 ## ## Update host location server to current value if specified ## if { [dict get $defaults -hostlocationserver] } { if {![info exists myHostLocation]} { set myHostLocation [MyHostLocationGet [dict get $defaults -ports]] } dict set defaults -hostlocation $myHostLocation } ## ## Resolve -hostprotocol setting. ## Also accept -hostProtocol ## if {![dict exists $defaults -hostprotocol]} { if {[dict exists $defaults -hostProtocol]} { dict set defaults -hostprotocol [dict get $defaults -hostProtocol] } else { dict set defaults -hostprotocol server } } dict unset defaults -hostProtocol ## ## Resolve server protocol to http and set flag for server protocol. ## If the flag is set, the protocol is corrected when required ## dict set defaults hostProtocolServer [expr { [dict get $defaults -hostprotocol] eq "server"}] if {[dict get $defaults hostProtocolServer]} { dict set defaults -hostprotocol http } dict set defaults -uri $service namespace eval ::$service {} set serviceArr($service) $defaults if {![dict exists $procInfo $service operationList]} { dict set procInfo $service operationList {} } set mode [dict get $defaults -mode] ## ## Install wsdl doc ## interp alias {} ::WS::Server::generateInfo_${service} \ {} ::WS::Server::generateInfo ${service} ::log::logsubst debug {Installing Generate info for $service at [dict get $defaults -prefix]} switch -exact -- $mode { embedded { package require WS::Embeded foreach port [dict get $defaults -ports] { ::WS::Embeded::AddHandler $port [dict get $defaults -prefix] GET ::WS::Server::generateInfo_${service} } } tclhttpd { ::Url_PrefixInstall [dict get $defaults -prefix] ::WS::Server::generateInfo_${service} \ -thread 0 } wub { package require WS::Wub } aolserver { package require WS::AOLserver } rivet { package require Rivet } wibble { ## ## Define zone handler - get code from andy ## proc ::wibble::webservice {state} { dict with state options {} switch -exact -- $suffix { "" - / { ::WS::Server::generateInfo $name 0 response sendresponse $response } /op { ::WS::Server::callOperation $name 0 [dict get $state request] response sendresponse $response } /wsdl { ::WS::Server::generateWsdl $name 0 -responsename response sendresponse $response } default { ## Do nothing } } } if {[package present Wibble] eq "0.1"} { proc ::WS::Wibble::ReturnData {responseDictVar type text status} { upvar 1 $responseDictVar responseDict dict set responseDict header content-type $type dict set responseDict content $text dict set responseDict status $status } } else { proc ::WS::Wibble::ReturnData {responseDictVar type text status} { upvar 1 $responseDictVar responseDict dict set responseDict header content-type "" $type dict set responseDict content $text dict set responseDict status $status } } ::wibble::handle [dict get $defaults -prefix] webservice name $service } default { return \ -code error \ -errorcode [list WSSERVER UNSUPMODE $mode] \ "-mode '$mode' not supported" } } ## ## Install wsdl ## interp alias {} ::WS::Server::generateWsdl_${service} \ {} ::WS::Server::generateWsdl ${service} ::log::logsubst debug {Installing GenerateWsdl info for $service at [dict get $defaults -prefix]/wsdl} switch -exact -- $mode { embedded { foreach port [dict get $defaults -ports] { ::WS::Embeded::AddHandler $port [dict get $defaults -prefix]/wsdl GET ::WS::Server::generateWsdl_${service} } } channel { package require WS::Channel ::WS::Channel::AddHandler [dict get $defaults -ports] {} ::WS::Server::generateWsdl_${service} } tclhttpd { ::Url_PrefixInstall [dict get $defaults -prefix]/wsdl ::WS::Server::generateWsdl_${service} \ -thread 0 } default { ## Do nothing } } ## ## Install operations ## interp alias {} ::WS::Server::callOperation_${service} \ {} ::WS::Server::callOperation ${service} ::log::logsubst debug {Installing callOperation info for $service at [dict get $defaults -prefix]/op} switch -exact -- $mode { embedded { foreach port [dict get $defaults -ports] { ::WS::Embeded::AddHandler $port [dict get $defaults -prefix]/op POST ::WS::Server::callOperation_${service} } } channel { package require WS::Channel ::WS::Channel::AddHandler [dict get $defaults -ports] {op} ::WS::Server::callOperation_${service} } tclhttpd { ::Url_PrefixInstall [dict get $defaults -prefix]/op ::WS::Server::callOperation_${service} \ -thread 1 } default { ## Do nothing } } return } # Get my computers IP address proc ::WS::Server::MyHostLocationGet {ports} { if {[catch { set me [socket -server garbage_word -myaddr [info hostname] 0] set myHostLocation [lindex [fconfigure $me -sockname] 0] close $me } errorMessage]} { ::log::logsubst error {Error '$errorMessage' when querying my own IP\ address. Use 'localhost' instead.} set myHostLocation "localhost" } if { 0 !=[llength $ports] && [lindex $ports 0] ni {80 433} } { append myHostLocation ":[lindex $ports 0]" } return $myHostLocation } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Server::ServiceProc # # Description : Register an operation for a service and declare the procedure to handle # the operations. # # Arguments : # ServiceName -- Name of the service this operation is for # NameInfo -- List of four elements: # 1) OperationName -- the name of the operation # 2) ReturnType -- the type of the procedure return, # this can be a simple or complex type # 3) Description -- description of the return method # 4) Version -- optional version for the service # if ommitted then available in all versions # Arglist -- List of argument definitions, # each list element must be of the form: # 1) ArgumentName -- the name of the argument # 2) ArgumentTypeInfo -- A list of: # {type typeName comment commentString version versionCode} # typeName can be any simple or defined type. # commentString is a quoted string describing the field. # versionCode is the version which this argument is available for # Documentation -- HTML describing what this operation does # Body -- The tcl code to be called when the operation is invoked. . This # code should return a dictionary with <OperationName>Result as a # key and the operation's result as the value. # # Returns : Nothing # |
︙ | ︙ | |||
364 365 366 367 368 369 370 | # # ########################################################################### proc ::WS::Server::ServiceProc {service nameInfo arglist documentation body} { variable procInfo set name [lindex $nameInfo 0] | > | | > | | | | > > > > | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 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 | # # ########################################################################### proc ::WS::Server::ServiceProc {service nameInfo arglist documentation body} { variable procInfo set name [lindex $nameInfo 0] set version [expr {[llength $nameInfo] > 3 ? [lindex $nameInfo 3] : {}}] ::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 } dict set procInfo $service op$name argList $arglist dict set procInfo $service op$name argOrder $argOrder dict set procInfo $service op$name docs $documentation dict set procInfo $service op$name returnInfo [lindex $nameInfo 1] set typeInfo [dict get $procInfo $service op$name returnInfo] dict set procInfo $service op$name version $version ::WS::Utils::ServiceTypeDef Server $service ${name}Results [list ${name}Result $typeInfo] {} {} $version ::WS::Utils::ServiceTypeDef Server $service ${name}Request $arglist {} {} $version set tclArgList [list] foreach {arg typeinfo} $arglist { lappend tclArgList [list [lindex $arg 0] ""] } lappend tclArgList [list tclws_op_version ""] proc ::${service}::${name} $tclArgList $body } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::GetWsdl # # Description : Generates a WSDL for a registered service. # # Arguments : # serviceName - The name of the service # urlPrefix - (optional) Prefix to use for location; defaults to http://<host> # version - (optional) specific version of service to generate. If ommitted # then returns the lastest # # Returns : # XML for the WSDL # # Side-Effects : None # # Exception Conditions : |
︙ | ︙ | |||
427 428 429 430 431 432 433 434 435 436 | # 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 12/12/2009 W.Kocjan Support for services over SSL in Tclhttpd # # ########################################################################### | > > > > > > | | > | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 | # 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 12/12/2009 W.Kocjan Support for services over SSL in Tclhttpd # 3 11/13/2018 J.Cone Version support # 2.7.0 2020-10-26 H.Oehlmann urlPrefix is a mandatory parameter. # The caller has to think about it. # 3.3.0 2021-10-15 H.Oehlmann Build default location from options # -hostprotocol and -hostlocation replacing # http and option -host. # # ########################################################################### proc ::WS::Server::GetWsdl {serviceName {urlPrefix ""} {version {}}} { variable serviceArr variable procInfo set serviceData $serviceArr($serviceName) set operList {} foreach oper [lsort -dictionary [dict get $procInfo $serviceName operationList]] { if {$version ne {} && [dict exists $procInfo $serviceName op$oper version] && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper version] $version]} { continue } lappend operList $oper } ::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 } set msg {} set reply [::dom createDocument wsdl:definitions] $reply documentElement definition $definition setAttribute \ xmlns:wsdl "http://schemas.xmlsoap.org/wsdl/" \ xmlns:http "http://schemas.xmlsoap.org/wsdl/http/" \ xmlns:mime "http://schemas.xmlsoap.org/wsdl/mime/" \ xmlns:xs "http://www.w3.org/2001/XMLSchema" \ xmlns:soap "http://schemas.xmlsoap.org/wsdl/soap/" \ xmlns:soapenc "http://schemas.xmlsoap.org/soap/encoding/" \ xmlns:${serviceName} "http://[dict get $serviceData -host][dict get $serviceData -prefix]" \ targetNamespace "http://[dict get $serviceData -host][dict get $serviceData -prefix]" foreach topLevel {types} { $definition appendChild [$reply createElement wsdl:$topLevel $topLevel] } ## ## Messages ## ## Operations foreach oper $operList { $definition appendChild [$reply createElement wsdl:message input] $input setAttribute name ${oper}In $input appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${oper}Request $definition appendChild [$reply createElement wsdl:message output] $output setAttribute name ${oper}Out $output appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${oper}Results } ## Input headers foreach headerType [dict get $serviceData -inheaders] { $definition appendChild [$reply createElement wsdl:message header] $header setAttribute name $headerType $header appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${headerType} } ## Output headers foreach headerType [dict get $serviceData -outheaders] { $definition appendChild [$reply createElement wsdl:message header] $header setAttribute name $headerType $header appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${headerType} } ## ## Add the rest of the toplevels in ## foreach topLevel {portType binding service} { $definition appendChild [$reply createElement wsdl:$topLevel $topLevel] } ## ## Service ## $service setAttribute name $serviceName $service appendChild [$reply createElement wsdl:documentation documentation] $documentation appendChild [$reply createTextNode [dict get $serviceData -description]] $service appendChild [$reply createElement wsdl:port port] $port setAttribute \ name ${serviceName}Soap \ binding ${serviceName}:${serviceName}Soap $port appendChild [$reply createElement soap:address address] if {$urlPrefix == ""} { set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" } $address setAttribute \ location "$urlPrefix[dict get $serviceData -prefix]/op" ## ## Bindings ## $binding setAttribute \ name ${serviceName}Soap \ type ${serviceName}:${serviceName}Soap $binding appendChild [$reply createElement soap:binding b2] $b2 setAttribute \ style document \ transport "http://schemas.xmlsoap.org/soap/http" foreach oper $operList { $binding appendChild [$reply createElement wsdl:operation operNode] $operNode setAttribute name $oper $operNode appendChild [$reply createElement soap:operation o2] $o2 setAttribute \ soapAction $serviceName:$oper \ style document ## Input message $operNode appendChild [$reply createElement wsdl:input input] $input appendChild [$reply createElement soap:body tmp] $tmp setAttribute use literal foreach headerType [dict get $serviceData -inheaders] { $operNode appendChild [$reply createElement wsdl:header header] $header appendChild [$reply createElement soap:header tmp] $tmp setAttribute \ use literal \ message ${serviceName}:${headerType} \ part $headerType } ## Output message $operNode appendChild [$reply createElement wsdl:output output] $output appendChild [$reply createElement soap:body tmp] $tmp setAttribute use literal foreach headerType [dict get $serviceData -outheaders] { $operNode appendChild [$reply createElement wsdl:header header] $header appendChild [$reply createElement soap:header tmp] $tmp setAttribute \ use literal \ message ${serviceName}:${headerType} \ part $headerType } } ## ## Ports ## $portType setAttribute name ${serviceName}Soap foreach oper $operList { $portType appendChild [$reply createElement wsdl:operation operNode] $operNode setAttribute name $oper $operNode appendChild [$reply createElement wsdl:input input] $input setAttribute message ${serviceName}:${oper}In $operNode appendChild [$reply createElement wsdl:output output] $output setAttribute message ${serviceName}:${oper}Out } ## ## Types ## GenerateScheme Server $serviceName $reply $types $version append msg \ {<?xml version="1.0" encoding="utf-8"?>} \ "\n" \ [$reply asXML \ -indent 4 \ -escapeNonASCII \ |
︙ | ︙ | |||
622 623 624 625 626 627 628 | # Procedure Name : ::WS::Server::generateWsdl # # Description : Generates a WSDL for a registered service. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on | | > > > | | | > > > > > > > > > > < < | > > > > > > > > | < | | | | | < < | > > > > > > > > > > > > > > > > > > > > > > | < > > | < | | > > | | | > > > > > > > > > > > > > > > > > > > | | | | | > > > > > > | < | > > | > > > | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 | # Procedure Name : ::WS::Server::generateWsdl # # Description : Generates a WSDL for a registered service. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on # args - Multi-function depending on server: # embedded: -port number: embedded server port number # unknown server: -version number: version # wibble: -responsename name: response variable name # # Returns : # Embedded mode: return list of contentType, message, httpcode # Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 12/12/2009 W.Kocjan Support for services over SSL in Tclhttpd # 3 11/13/2018 J.Cone Version support # 2.7.0 2020-10-26 H.Oehlmann Support https for embedded server. # 3.1.0 2020-11-06 H.Oehlmann Pass port parameter from embedded server # with prefix "-port" to be compatible with # the -version parameter. # Pass wibble responsename also with prefix # "-responsename". # 3.2.0 2021-03-17 H.Oehlmann In embedded mode, directly return the data # 3.3.0 2021-10-15 H.Oehlmann Change the setting/update of the host location # by using the new parameter -hostlocationserver # and -hostlocation. # ########################################################################### proc ::WS::Server::generateWsdl {serviceName sock args} { variable serviceArr variable procInfo variable mode set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]] ::log::logsubst debug {Generating WSDL for $serviceName on $sock with {$args}} # ToDo HaO 2020-11-06: if confirmed, args may be interpreted as a dict # and the code may be simplified. It is not clear, if any server does not # pass any unused data not being a dict. set version "" set argsIdx [lsearch -exact $args "-version"] if {$argsIdx != -1} { set version [lindex $args [expr {$argsIdx + 1}]] } if {![info exists serviceArr($serviceName)]} { set msg "Unknown service '$serviceName'" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData \ $sock \ "text/html; charset=UTF-8" \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404 } embedded { return [list\ "text/html; charset=UTF-8" \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404] } channel { ::WS::Channel::ReturnData \ $sock \ "text/xml; charset=UTF-8" \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404 } rivet { headers type "text/html; charset=UTF-8" headers numeric 404 puts "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" } aolserver { ::WS::AOLserver::ReturnData \ $sock \ text/html \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404 } wibble { upvar 1 [lindex $args 0] responseDict ::WS::Wibble::ReturnData responseDict text/html "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" 404 } default { ## Do nothing } } return 1 } set serviceData $serviceArr($serviceName) ## ## Check if the server protocol (and host) should be used ## ## ## Prepare default URL prefix ## set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" ## ## Return the WSDL ## switch -exact -- $mode { tclhttpd { upvar #0 ::Httpd$sock s # Get protocol and host location from server if configured if { [dict get $serviceData hostProtocolServer] } { catch { dict set serviceData -hostprotocol [lindex $s(self) 0] } } if { [dict get $serviceData -hostlocationserver] } { catch { dict set serviceData -hostprotocol $s(mime,host) } } set urlPrefix [dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation] set xml [GetWsdl $serviceName $urlPrefix $version] ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } channel { set xml [GetWsdl $serviceName $urlPrefix $version] ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } embedded { if {[dict get $serviceData hostProtocolServer]} { ## ## For https, change the URL prefix ## set argsIdx [lsearch -exact $args "-port"] if {$argsIdx == -1} { ::log::logsubst error {Parameter '-port' missing from\ embedded server in arguments '$args'} } elseif { [::WS::Embeded::GetValue isHTTPS\ [lindex $args [expr {$argsIdx + 1}]]] } { dict set serviceData -hostprotocol https } else { dict set serviceData -hostprotocol http } set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" } set xml [GetWsdl $serviceName $urlPrefix $version] return [list "text/xml; charset=UTF-8" $xml 200] } rivet { set xml [GetWsdl $serviceName $urlPrefix $version] headers type "text/xml; charset=UTF-8" headers numeric 200 puts $xml } aolserver { set xml [GetWsdl $serviceName $urlPrefix $version] ::WS::AOLserver::ReturnData $sock text/xml $xml 200 } wibble { set xml [GetWsdl $serviceName $urlPrefix $version] set argsIdx [lsearch -exact $args "-responsename"] if {$argsIdx == -1} { ::log::logsubst error {Parameter '-responsename' missing from\ wibble server in arguments '$args'} } else { upvar 1 [lindex $args [expr {$argsIdx + 1}]] responseDict ::WS::Wibble::ReturnData responseDict text/xml $xml 200 } } default { ## Do nothing } } return 0 } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Server::GenerateScheme # # Description : Generate a scheme # # Arguments : # mode - Client/Server # serviceName - The service name # doc - The document to add the scheme to # parent - The parent node of the scheme # version - Service version # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # |
︙ | ︙ | |||
782 783 784 785 786 787 788 789 790 | # 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/15/2008 G.Lester Made Scheme generation a utility # 2 02/03/2008 G.Lester Moved scheme generation into WS::Utils namespace # ########################################################################### | > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | > > | | > > > > > > | | | < | | | | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 | # 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/15/2008 G.Lester Made Scheme generation a utility # 2 02/03/2008 G.Lester Moved scheme generation into WS::Utils namespace # 3 11/13/2018 J.Cone Version support # ########################################################################### proc ::WS::Server::GenerateScheme {mode serviceName doc parent {version {}}} { variable serviceArr set serviceData $serviceArr($serviceName) set targetNamespace "http://[dict get $serviceData -host][dict get $serviceData -prefix]" return [::WS::Utils::GenerateScheme $mode $serviceName $doc $parent $targetNamespace $version] } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateJsonInfo # # Description : Generate an json description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on # args - supports passing service version info. # Eg: -version 3 # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : James Sulak # #>>END PRIVATE<< # # 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 05/16/2012 J.Sulak Initial version # 2 09/04/2018 A.Brooks Send an 'example' field # 3 11/13/2018 J.Cone Version support # # ########################################################################### # NOTE: This proc only works with Rivet # TODO: Update to handle jsonp? proc ::WS::Server::generateJsonInfo { serviceName sock args } { variable serviceArr variable procInfo ::log::logsubst debug {Generating JSON Documentation for $serviceName on $sock with {$args}} set version {} set versionIdx [lsearch -exact $args "-version"] if {$versionIdx != -1} { set version [lindex $args [expr {$versionIdx + 1}]] } set serviceData $serviceArr($serviceName) set doc [yajl create #auto -beautify [dict get $serviceData -beautifyJson]] $doc map_open $doc string operations array_open ::log::log debug "\tDisplay Operations (json)" foreach oper [lsort -dictionary [dict get $procInfo $serviceName operationList]] { # version check if {$version ne {} && [dict exists $procInfo $serviceName op$oper version] && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper version] $version]} { continue } $doc map_open # operation name $doc string name string $oper # description set description [dict get $procInfo $serviceName op$oper docs] $doc string description string $description # parameters if {[llength [dict get $procInfo $serviceName op$oper argOrder]]} { $doc string inputs array_open foreach arg [dict get $procInfo $serviceName op$oper argOrder] { # version check if {$version ne {} && [dict exists $procInfo $serviceName op$oper argList $arg version] && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper argList $arg version] $version]} { continue } ::log::logsubst debug {\t\t\tDisplaying '$arg'} set comment {} if {[dict exists $procInfo $serviceName op$oper argList $arg comment]} { set comment [dict get $procInfo $serviceName op$oper argList $arg comment] } set example {} if {[dict exists $procInfo $serviceName op$oper argList $arg example]} { set example [dict get $procInfo $serviceName op$oper argList $arg example] } set type [dict get $procInfo $serviceName op$oper argList $arg type] $doc map_open \ string name string $arg \ string type string $type \ string comment string $comment \ string example string $example \ map_close } $doc array_close } else { $doc string inputs array_open array_close } $doc string returns map_open set comment {} if {[dict exists $procInfo $serviceName op$oper returnInfo comment]} { set comment [dict get $procInfo $serviceName op$oper returnInfo comment] } set example {} if {[dict exists $procInfo $serviceName op$oper returnInfo example]} { set example [dict get $procInfo $serviceName op$oper returnInfo example] } set type [dict get $procInfo $serviceName op$oper returnInfo type] $doc string comment string $comment string type string $type string example string $example $doc map_close $doc map_close } $doc array_close ::log::log debug "\tDisplay custom types" $doc string types array_open set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $serviceName] foreach type [lsort -dictionary [dict keys $localTypeInfo]] { # version check if {$version ne {} && [dict exists $localTypeInfo $type version] && ![::WS::Utils::check_version [dict get $localTypeInfo $type version] $version]} { continue } ::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]] { # version check if {$version ne {} && [dict exists $typeDetails $part version] && ![::WS::Utils::check_version [dict get $typeDetails $part version] $version]} { continue } ::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] } set example {} if {[dict exists $typeDetails $part example]} { set example [dict get $typeDetails $part example] } $doc map_open \ string field string $part \ string type string $subType \ string comment string $comment \ string example string $example \ map_close } $doc array_close $doc map_close } $doc array_close $doc map_close set contentType "application/json; charset=UTF-8" headers type $contentType headers numeric 200 puts [$doc get] $doc delete } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on # args - Supports passing a wibble dictionary ref or a # service version. Eg: -version 3 # # Returns : # Embedded mode: return list of contentType, message, httpcode # Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 11/13/2018 J.Cone Version support # 3.2.0 2021-03-17 H.Oehlmann In embedded mode, directly return the data # # ########################################################################### proc ::WS::Server::generateInfo {serviceName sock args} { variable serviceArr variable procInfo variable mode ::log::logsubst debug {Generating HTML Documentation for $serviceName on $sock with {$args}} set version {} if {$args ne {}} { if {[lindex $args 0] eq {-version}} { set version [lindex $args 1] } } if {![info exists serviceArr($serviceName)]} { set msg "Unknown service '$serviceName'" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData \ $sock \ "text/html; charset=UTF-8" \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404 } embedded { return [list\ "text/html; charset=UTF-8" \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404] } channel { ::WS::Channel::ReturnData \ $sock \ text/html \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404 |
︙ | ︙ | |||
878 879 880 881 882 883 884 | $sock \ text/html \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404 } wibble { upvar 1 [lindex $args 0] responseDict | < | > | > > > > | | | | | | | | < | < > > | | > | 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 | $sock \ text/html \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404 } wibble { upvar 1 [lindex $args 0] responseDict ::WS::Wibble::ReturnData responseDict \ text/html \ "<html><head><title>Webservice Error</title></head><body><h2>$msg</h2></body></html>" \ 404 } default { ## Do nothing } } return 1 } set menuList { {List of Operations} {#TOC} {Operation Details} {#OperDetails} {Simple Types} {#SimpleTypeDetails} {Custom Types} {#CustomTypeDetails} } ## ## Display Service General Information ## append msg [generateGeneralInfo $serviceArr($serviceName) $menuList] ## ## Display TOC ## append msg [generateTocInfo $serviceArr($serviceName) $menuList $version] ## ## Display Operations ## ::log::log debug "\tDisplay Operations" append msg [generateOperationInfo $serviceArr($serviceName) $menuList $version] ## ## Display custom types ## ::log::log debug "\tDisplay custom types" append msg [generateCustomTypeInfo $serviceArr($serviceName) $menuList $version] ## ## Display list of simple types ## ::log::log debug "\tDisplay list of simply types" append msg [generateSimpleTypeInfo $serviceArr($serviceName) $menuList] ## ## All Done ## append msg [::html::end] switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "text/html; charset=UTF-8" $msg 200 } embedded { return [list "text/html; charset=UTF-8" $msg 200] } channel { ::WS::Channel::ReturnData $sock "text/html; charset=UTF-8" $msg 200 } rivet { headers numeric 200 headers type "text/html; charset=UTF-8" puts $msg } aolserver { ::WS::AOLserver::ReturnData $sock text/html $msg 200 } wibble { upvar 1 [lindex $args 0] responseDict ::WS::Wibble::ReturnData responseDict text/html $msg 200 } default { ## Do nothing } } return 0 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
991 992 993 994 995 996 997 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::displayType {serviceName type} { | | | 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::displayType {serviceName type} { set testType [string trimright $type {()?}] if {([lindex [::WS::Utils::TypeInfo Server $serviceName $testType] 0] == 0) && ([info exists ::WS::Utils::simpleTypes($testType)])} { set result $type } else { set result [format {<a href="#type_%1$s">%2$s</a>} $testType $type] } return $result |
︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 | # Description : Process the call to an operation. If an error occurs, a standard # error packet is sent, otherwise the appropriate message type # is sent. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on | > > | > > > > > | | > > > > > > > > | | > > > > > > | > > > > > > > > > > > > > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | < < | < | | | | | | | | | | | | | | | | | | > > | > > > | > > | | > > | | | > > > | > > > > > > | < > | | | | < | > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | > > > > > > | | | | | | | | | < | < | | | < | < | | | | | | | < | < > | | | < | < | | | | | | | > > | | > | | | > > > > > > > > > > > | | | | > > > | > > > > > > | < > | | | | | < | > | > | | | | | | | > | | | | | | | | | > > > | | | | > | > | > > > > > > > > | > > > | > > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > > > | | | > > | > > > > > > > > > > | > > > > > | < > | > > > > | | | | < | > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 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 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 | # Description : Process the call to an operation. If an error occurs, a standard # error packet is sent, otherwise the appropriate message type # is sent. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on # -rest - Use Rest flavor call instead of SOAP # -version - specify service version # args - additional arguments and flags: # -rest: choose rest flavor instead soap # -version num: choose a version number # -data dict: data dict in embedded mode. # Used keys are: query, ipaddr, headers. # first element: response dict name in wibble mode # # Returns : # Embedded mode: return list of contentType, message, httpcode # Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 11/13/2018 J.Cone Version support # 3.1.0 2020-11-06 H.Oehlmann Get global validHttpStatusCodes in this # module, was deleted in Utilities.tcl. # 3.2.0 2021-03-17 H.Oehlmann Embedded mode: directly return data. # Embedded mode: directly receive data via # argument -data dict. # The result return is not protected any more # by a catch to allow direct return. # # ########################################################################### proc ::WS::Server::callOperation {serviceName sock args} { variable procInfo variable serviceArr variable mode switch -exact -- $mode { embedded { # Get the data dict as argument behind call flag "-data" set embeddedServerDataDict [lindex $args\ [lsearch -exact $args "-data"]+1] set inXML [dict get $embeddedServerDataDict query] } wibble { set requestDict [lindex $args 0] upvar 1 [lindex $args 1] responseDict set inXML [dict get $requestDict post xml ""] } default { upvar #0 Httpd$sock data set inXML $data(query) } } # decide if SOAP or REST mode should be used. set flavor "soap" if {[lsearch -exact $args "-rest"] != -1} { set flavor "rest" } # check if a version number was passed set version {} set versionIdx [lsearch -exact $args "-version"] if {$versionIdx != -1} { set version [lindex $args [expr {$versionIdx + 1}]] } ::log::logsubst debug {In ::WS::Server::callOperation {$serviceName $sock $args}} set serviceData $serviceArr($serviceName) ::log::logsubst debug {\tDocument is {$inXML}} set ::errorInfo {} set ::errorCode {} set ns $serviceName set inTransform [dict get $serviceData -intransform] set outTransform [dict get $serviceData -outtransform] if {$inTransform ne {}} { set inXML [$inTransform REQUEST $inXML] } # Get a reference to the error callback set errorCallback [dict get $serviceData -errorCallback] ## ## Parse the input and determine the name of the method being invoked. ## switch -exact -- $flavor { rest { package require yajltcl ; # only needed for rest, not soap. set operation [lindex $inXML 0] set contentType "application/json" set doc "" array set rawargs [lindex $inXML 1] if {[info exists rawargs(jsonp_callback)]} { if {![regexp {^[a-zA-Z_0-9]+$} $rawargs(jsonp_callback)]} { # sanitize the JSONP callback function name for security. set rawargs(jsonp_callback) JsonpCallback } set contentType "text/javascript" } } soap { # skip any XML header 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/ \ $serviceName http://[dict get $serviceData -host][dict get $serviceData -prefix]]} $doc selectNodesNamespaces \ [list ENV http://schemas.xmlsoap.org/soap/envelope/ \ $serviceName http://[dict get $serviceData -host][dict get $serviceData -prefix]] $doc documentElement rootNode # extract the name of the method set top [$rootNode selectNodes /ENV:Envelope/ENV:Body/*] catch {$top localName} requestMessage 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" } } ## ## Check that the method exists and version checks out. ## if {![dict exists $procInfo $serviceName op$operation argList] || ([dict exists $procInfo $serviceName op$operation version] && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$operation version] $version])} { set msg "Method $operation not found" ::log::log error $msg set ::errorInfo {} set ::errorCode [list Server UNKNOWN_METHOD $operation] set response [generateError \ [dict get $serviceData -traceEnabled] \ 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 { tclhttpd { ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } embedded { return [list "$contentType; charset=UTF-8" $response $httpStatus] } rivet { headers type "$contentType; charset=UTF-8" headers numeric $httpStatus puts $response } aolserver { ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } wibble { ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } return 1 } set baseName $operation set cmdName op$baseName set methodName "${ns}::$baseName" ## ## Parse the arguments for the method. ## set argInfo [dict get $procInfo $ns $cmdName argList] if {[catch { # Check that all supplied arguments are valid set methodArgs {} foreach arg [dict get $procInfo $ns $cmdName argOrder] { lappend methodArgs $arg } if {$flavor eq "rest"} { lappend methodArgs jsonp_callback "_" } if {[dict get $serviceData -verifyUserArgs]} { foreach {key value} [array get rawargs] { if {[lsearch -exact $methodArgs $key] == -1} { error "Invalid argument '$key' supplied" } } } switch -exact -- $flavor { rest { set tclArgList {} foreach argName $methodArgs { if {$argName eq "jsonp_callback" || $argName eq "_"} { continue } set argType [string trim [dict get $argInfo $argName type]] set typeInfoList [::WS::Utils::TypeInfo Server $serviceName $argType] if {[dict exists $procInfo $ns $cmdName argList $argName version] && ![::WS::Utils::check_version [dict get $procInfo $ns $cmdName argList $argName version] $version]} { ::log::log debug "user supplied argument not supported in the requested version" lappend tclArgList {} continue } 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 lappend tclArgList $rawargs($argName) } {0 1} { ## Simple array lappend tclArgList $rawargs($argName) } {1 0} { ## Non-simple non-array error "TODO JSON" #lappend tclArgList [::WS::Utils::convertTypeToDict Server $serviceName $node $argType $top] } {1 1} { ## Non-simple array error "TODO JSON" #set tmp {} #set argType [string trimright $argType {()?}] #foreach row $node { # lappend tmp [::WS::Utils::convertTypeToDict Server $serviceName $row $argType $top] #} #lappend tclArgList $tmp } default { ## Do nothing } } } } soap { foreach pass [list 1 2 3] { set tclArgList {} set gotAnyArgs 0 set argIndex 0 foreach argName $methodArgs { set argType [string trim [dict get $argInfo $argName type]] set typeInfoList [::WS::Utils::TypeInfo Server $serviceName $argType] if {$pass == 1} { # access arguments by name using full namespace set path $serviceName:$argName set node [$top selectNodes $path] } elseif {$pass == 2} { # legacyRpcMode only, access arguments by unqualified name set path $argName set node [$top selectNodes $path] } else { # legacyRpcMode only, access arguments by index set path "legacy argument index $argIndex" set node [lindex [$top childNodes] $argIndex] incr argIndex } if {[dict exists $procInfo $ns $cmdName argList $argName version] && ![::WS::Utils::check_version [dict get $procInfo $ns $cmdName argList $argName version] $version]} { ::log::log debug "user supplied argument not supported in the requested version" lappend tclArgList {} continue } 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} { ## Simple array set tmp {} foreach row $node { lappend tmp [$row asText] } lappend tclArgList $tmp } {1 0} { ## Non-simple non-array set argType [string trimright $argType {?}] lappend tclArgList [::WS::Utils::convertTypeToDict Server $serviceName $node $argType $top] } {1 1} { ## Non-simple array set tmp {} set argType [string trimright $argType {()?}] foreach row $node { lappend tmp [::WS::Utils::convertTypeToDict Server $serviceName $row $argType $top] } 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" } } # If the user passed a version, pass that along if {$version ne {}} { lappend tclArgList $version } ::log::logsubst debug {finalargs $tclArgList} } errMsg]} { ::log::log error $errMsg set localerrorCode $::errorCode set localerrorInfo $::errorInfo set response [generateError \ [dict get $serviceData -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 { tclhttpd { ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } embedded { return [list "$contentType; charset=UTF-8" $response $httpStatus] } channel { ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } rivet { headers type "$contentType; charset=UTF-8" headers numeric $httpStatus puts $response } aolserver { ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } wibble { ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } return 1 } ## ## Run the premonitor hook, if necessary. ## if {[dict exists $serviceData -premonitor] && "" ne [dict get $serviceData -premonitor]} { set precmd [dict get $serviceData -premonitor] lappend precmd PRE $serviceName $operation $tclArgList catch $precmd } ## ## Convert the HTTP request headers. ## set headerList {} foreach headerType [dict get $serviceData -inheaders] { if {[string equal $headerType {}]} { continue } foreach node [$top selectNodes data:$headerType] { lappend headerList [::WS::Utils::convertTypeToDict Server $serviceName $node $headerType $top] } } ## ## Actually execute the method. ## if {[catch { set cmd [dict get $serviceData -checkheader] if {$cmd ne ""} { switch -exact -- $mode { wibble { lappend cmd \ $ns \ $baseName \ [dict get $requestDict peerhost] \ [dict keys [dict get $requestDict header]] \ $headerList } embedded { lappend cmd $ns $baseName [dict get $embeddedServerDataDict ipaddr] [dict get $embeddedServerDataDict headers] $headerList } default { lappend cmd $ns $baseName $data(ipaddr) $data(headerlist) $headerList } } # This will return with error, if the header is not ok eval $cmd } set results [eval \$methodName $tclArgList] # generate a reply packet set response [generateReply $ns $baseName $results $flavor] # wrap in JSONP if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} { set response "$rawargs(jsonp_callback)($response)" } # mangle the XML declaration if {$flavor == "soap"} { # regsub "<!DOCTYPE\[^>\]+>\n" $response {} response set response [string map {{<?xml version="1.0"?>} {<?xml version="1.0" encoding="utf-8"?>}} $response] } catch {$doc delete} if {![string equal $outTransform {}]} { set response [$outTransform REPLY $response $operation $results] } if {[dict exists $serviceData -postmonitor] && "" ne [dict get $serviceData -postmonitor]} { set precmd [dict get $serviceData -postmonitor] lappend precmd POST $serviceName $operation OK $results catch $precmd } } msg]} { ## ## Handle errors ## set localerrorCode $::errorCode set localerrorInfo $::errorInfo if {[dict exists $serviceData -postmonitor] && "" ne [dict get $serviceData -postmonitor]} { set precmd [dict get $serviceData -postmonitor] lappend precmd POST $serviceName $operation ERROR $msg catch $precmd } catch {$doc delete} set httpStatus 500 if {$errorCallback ne {}} { $errorCallback $msg httpStatus $operation $flavor } set response [generateError \ [dict get $serviceData -traceEnabled] \ CLIENT \ $msg \ [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \ $flavor] ::log::logsubst debug {Leaving @ error 2::WS::Server::callOperation $response} # Check if the localerrorCode is a valid http status code set validHttpStatusCodes {100 101 102 200 201 202 203 204 205 206 207 208 226 300 301 302 303 304 305 306 307 308 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 421 422 423 424 425 426 427 428 429 430 431 451 500 501 502 503 504 505 506 507 508 509 510 511 } if {[lsearch -exact $validHttpStatusCodes $localerrorCode] > -1} { set httpStatus $localerrorCode } # wrap in JSONP if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} { set response "$rawargs(jsonp_callback)($response)" } switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } embedded { return [list "$contentType; charset=UTF-8" $response $httpStatus] } channel { ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } rivet { if {[lindex $localerrorCode 0] == "RIVET" && [lindex $localerrorCode 1] == "ABORTPAGE"} { # if we caught an abort_page, then re-trigger it. abort_page } headers type "$contentType; charset=UTF-8" headers numeric $httpStatus puts $response } aolserver { ::WS::AOLserver::ReturnData $sock $contentType $response $httpStatus } wibble { ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } return 1 } ## ## Return result ## ::log::logsubst debug {Leaving ::WS::Server::callOperation $response} switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response 200 } embedded { return [list "$contentType; charset=UTF-8" $response 200] } channel { ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response 200 } rivet { headers type "$contentType; charset=UTF-8" headers numeric 200 puts $response } aolserver { ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response 200 } wibble { ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response 200 } default { ## Do nothing } } return 0 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateError # # Description : Generate a standard error packet # # Arguments : # includeTrace - Boolean indicate if the trace is to be included. # faultcode - The code describing the error # faultstring - The string describing the error. # detail - Optional details of error. # flavor - Output mode: "soap" or "rest" # # Returns : XML formatted standard error packet # # Side-Effects : None # # Exception Conditions : None # |
︙ | ︙ | |||
1419 1420 1421 1422 1423 1424 1425 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### | | | > > | > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > | | > > | 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 | # # 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" } "Client" { set code "SOAP-ENV:Client" } "Server" { set code "SOAP-ENV:Server" } default { ## Do nothing } } switch -exact -- $flavor { rest { set doc [yajl create #auto] $doc map_open string "error" string $faultstring map_close set response [$doc get] $doc delete } soap { dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \ "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \ "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" $env appendChild [$doc createElement "SOAP-ENV:Body" bod] $bod appendChild [$doc createElement "SOAP-ENV:Fault" flt] $flt appendChild [$doc createElement "faultcode" fcd] $fcd appendChild [$doc createTextNode $faultcode] $flt appendChild [$doc createElement "faultstring" fst] $fst appendChild [$doc createTextNode $faultstring] if { $detail != {} } { $flt appendChild [$doc createElement "SOAP-ENV:detail" dtl0] $dtl0 appendChild [$doc createElement "e:errorInfo" dtl] $dtl setAttribute "xmlns:e" "urn:TclErrorInfo" foreach {detailName detailInfo} $detail { if {!$includeTrace && $detailName == "stackTrace"} { continue } $dtl appendChild [$doc createElement $detailName err] $err appendChild [$doc createTextNode $detailInfo] } } # serialize the DOM document and return the XML text append response \ {<?xml version="1.0" encoding="utf-8"?>} \ "\n" \ [$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. # #>>BEGIN PRIVATE<< # # Procedure Name : :WS::Server::generateReply # # Description : Generate the reply packet for an operation # # Arguments : # serviceName - The name of the service # operation - The name of the operation # results - The results as a dictionary object # flavor - Output mode: "soap" or "rest" # version - Requested service version # # # Returns : The results as an XML formatted packet. # # Side-Effects : None # # Exception Conditions : None |
︙ | ︙ | |||
1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 | # 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 # # ########################################################################### | > | | | > > > > > > > > > > > > > | > > | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | < < < < < | < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < | | | 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 | # 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 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Server::generateReply {serviceName operation results flavor {version {}}} { ::log::logsubst debug {Entering ::WS::Server::generateReply $serviceName $operation {$results}} variable serviceArr set serviceData $serviceArr($serviceName) switch -exact -- $flavor { rest { set doc [yajl create #auto -beautify [dict get $serviceData -beautifyJson]] $doc map_open ::WS::Utils::convertDictToJson Server $serviceName $doc $results ${serviceName}:${operation}Results [dict get $serviceData -enforceRequired] $version $doc map_close set output [$doc get] $doc delete } soap { if {[info exists ::Config(docRoot)] && [file exists [file join $::Config(docRoot) $serviceName $operation.css]]} { # *** Bug: the -hostprotocol in -hostprotocol=server is not # *** corrected, if no WSDL is required before this call. set replaceText [format {<?xml-stylesheet type="text/xsl" href="%s://%s/css/%s/%s.css"?>}\ [dict get $serviceData -hostprotocol] \ [dict get $serviceData -hostlocation] \ $serviceName \ $operation] append replaceText "\n" } else { set replaceText {} } dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \ "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \ "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \ xmlns:$serviceName "http://[dict get $serviceData -host][dict get $serviceData -prefix]" if {0 != [llength [dict get $serviceData -outheaders]]} { $env appendChild [$doc createElement "SOAP-ENV:Header" header] foreach headerType [dict get $serviceData -outheaders] { #$header appendChild [$doc createElement ${serviceName}:${headerType} part] #::WS::Utils::convertDictToType Server $serviceName $doc $part $results $headerType ::WS::Utils::convertDictToType Server $serviceName $doc $header $results $headerType 0 [dict get $serviceData -enforceRequired] $version } } $env appendChild [$doc createElement "SOAP-ENV:Body" body] $body appendChild [$doc createElement ${serviceName}:${operation}Results reply] ::WS::Utils::convertDictToType Server $serviceName $doc $reply $results ${serviceName}:${operation}Results 0 [dict get $serviceData -enforceRequired] $version append output \ {<?xml version="1.0" encoding="utf-8"?>} \ "\n" \ [$doc asXML -indent none -doctypeDeclaration 0] #regsub "<!DOCTYPE\[^>\]*>\n" [::dom::DOMImplementation serialize $doc] $replaceText xml $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 # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service information dict # menuList -- html menu # args - not used # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None |
︙ | ︙ | |||
1647 1648 1649 1650 1651 1652 1653 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### | | < | | | | | | | | | | | | | | | 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::generateGeneralInfo {serviceData menuList} { variable procInfo ::log::log debug "\tDisplay Service General Information" set service [dict get $serviceData -service] ::html::init ::html::author [dict get $serviceData -author] if {"" eq [dict get $serviceData -description]} { ::html::description "Automatically generated human readable documentation for '$service'" } else { ::html::description [dict get $serviceData -description] } if {[dict get $serviceData -stylesheet] ne ""} { ::html::headTag "link rel=\"stylesheet\" type=\"text/css\" href=\"[dict get $serviceData -stylesheet]\"" } set head [dict get $serviceData -htmlhead] set msg [::html::head $head] append msg [::html::bodyTag] dict unset serviceData -service if {[dict exists $serviceData -description]} { dict set serviceData -description [::html::nl2br [dict get $serviceData -description]] } set wsdl [format {<a href="%s/%s">WSDL(xml)</a>} [dict get $serviceData -prefix] wsdl] append msg [::html::openTag center] [::html::h1 "$head -- $wsdl"] [::html::closeTag] \ [::html::openTag table {border="2"}] foreach key [lsort -dictionary [dict keys $serviceData]] { if {"" eq [dict get $serviceData $key]} { append msg [::html::row [string range $key 1 end] {<i>N/A</i>}] } else { append msg [::html::row [string range $key 1 end] [dict get $serviceData $key]] } } append msg [::html::closeTag] \ "\n<hr/>\n" return $msg } |
︙ | ︙ | |||
1702 1703 1704 1705 1706 1707 1708 | # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : | | | | | 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 | # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service option dict # menuList -- html menu # version - Requested service version # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # |
︙ | ︙ | |||
1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 | # 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 # # ########################################################################### | > | | > > > > > > | 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 | # 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 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Server::generateTocInfo {serviceData menuList version} { variable procInfo ## ## Display TOC ## ::log::log debug "\tTOC" set service [dict get $serviceData -service] append msg [::html::h2 {<a id='TOC'>List of Operations</a>}] set operList {} foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] { if {$version ne {} && [dict exists $procInfo $service op$oper version]} { if {![::WS::Utils::check_version [dict get $procInfo $service op$oper version] $version]} { ::log::log debug "Skipping operation '$oper' because version is incompatible" continue } } lappend operList $oper "#op_$oper" } append msg [::html::minorList $operList] append msg "\n<br/>\n<center>" [::html::minorMenu $menuList] "</center>" append msg "\n<hr/>\n" |
︙ | ︙ | |||
1765 1766 1767 1768 1769 1770 1771 | # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : | | | | | 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 | # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service option dict # menuList -- html menu # version - Requested service version # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # |
︙ | ︙ | |||
1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 | # 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 # # ########################################################################### | > | | | > > > > > > > | > | > > > > > > > > > > > > | | < < > > | | | | | | | | | | | > | > > > > > | 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 | # 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 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Server::generateOperationInfo {serviceData menuList version} { variable procInfo ## ## Display Operations ## ::log::log debug "\tDisplay Operations" set service [dict get $serviceData -service] set operList {} 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 $serviceData -docFormat] set opCount 0 foreach {oper anchor} $operList { if {$version ne {} && [dict exists $procInfo $service op$oper version]} { if {![::WS::Utils::check_version [dict get $procInfo $service op$oper version] $version]} { ::log::log debug "Skipping operation '$oper' because version is incompatible" continue } } ::log::logsubst debug {\t\tDisplaying '$oper'} incr opCount 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 [dict get $procInfo $service op$oper docs] } "text" - default { append msg [::html::nl2br [::html::html_entities [dict get $procInfo $service op$oper docs]]] } } append msg [::html::closeTag] append msg "\n" append msg [::html::h4 {Inputs}] "\n" append msg [::html::openTag div {style="margin-left: 40px;"}] set inputCount 0 if {[llength [dict get $procInfo $service op$oper argOrder]]} { foreach arg [dict get $procInfo $service op$oper argOrder] { if {$version ne {} && [dict exists $procInfo $service op$oper argList $arg version]} { if {![::WS::Utils::check_version [dict get $procInfo $service op$oper argList $arg version] $version]} { ::log::log debug "Skipping field '$arg' because version is incompatible" continue } } ::log::logsubst debug {\t\t\tDisplaying '$arg'} if {!$inputCount} { append msg [::html::openTag {table} {border="2"}] append msg [::html::hdrRow Name Type Description] } incr inputCount 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 \ [displayType $service [dict get $procInfo $service op$oper argList $arg type]] \ $comment \ ] } if {$inputCount} { append msg [::html::closeTag] } } if {!$inputCount} { append msg "No inputs." } append msg [::html::closeTag] ::log::log debug "\t\tReturns" append msg [::html::h4 {Returns}] "\n" append msg [::html::openTag div {style="margin-left: 40px;"}] append msg [::html::openTag {table} {border="2"}] |
︙ | ︙ | |||
1871 1872 1873 1874 1875 1876 1877 | append msg [::html::closeTag] append msg [::html::closeTag] append msg "\n<br/>\n<center>" [::html::minorMenu $menuList] "</center>" append msg "\n<hr/>\n" } | | | 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 | append msg [::html::closeTag] append msg [::html::closeTag] append msg "\n<br/>\n<center>" [::html::minorMenu $menuList] "</center>" append msg "\n<hr/>\n" } if {!$opCount} { append msg "\n<br/>\n<center>" [::html::minorMenu $menuList] "</center>" append msg "\n<hr/>\n" } return $msg } |
︙ | ︙ | |||
1893 1894 1895 1896 1897 1898 1899 | # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > | 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 | # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service option dict # menuList -- html menu # version - Requested service version # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Server::generateCustomTypeInfo {serviceData menuList version} { variable procInfo ## ## Display custom types ## ::log::log debug "\tDisplay custom types" set service [dict get $serviceData -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]] { if {$version ne {} && [dict exists $localTypeInfo $type version]} { set typeVersion [dict get $localTypeInfo $type version] if {![::WS::Utils::check_version $typeVersion $version]} { ::log::log debug "Skipping type '$type' because version is incompatible" continue } } ::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]] { if {$version ne {} && [dict exists $typeDetails $part version]} { if {![::WS::Utils::check_version [dict get $typeDetails $part version] $version]} { ::log::log debug "Skipping field '$part' because version is incompatible" continue } } ::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 \ [displayType $service [dict get $typeDetails $part type]] \ $comment \ ] } append msg [::html::closeTag] } append msg "\n<br/>\n<center>" [::html::minorMenu $menuList] "</center>" append msg "\n<hr/>\n" return $msg } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateSimpleTypeInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service option dict # menuList -- html menu # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # |
︙ | ︙ | |||
1921 1922 1923 1924 1925 1926 1927 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 | # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::generateSimpleTypeInfo {serviceData menuList} { variable procInfo ## ## Display list of simple types ## ::log::log debug "\tDisplay list of simply types" set service [dict get $serviceData -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.
1 2 | ############################################################################### ## ## | | | 1 2 3 4 5 6 7 8 9 10 | ############################################################################### ## ## ## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Arnulf Wiedemann ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## ## Copyright (c) 2001-2006, Pat Thoyts ## ## All rights reserved. ## |
︙ | ︙ | |||
35 36 37 38 39 40 41 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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. ## ## ## ############################################################################### | | | | | > > > > > > > > > | | | | | > > | > > > > > > > > > > > > > > > > > > > > > > | > | 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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.6- 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 3.1.0 namespace eval ::WS {} namespace eval ::WS::Utils { set ::WS::Utils::typeInfo {} set ::WS::Utils::currentSchema {} array set ::WS::Utils::importedXref {} variable redirectArray array set redirectArray {} set nsList { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ xs http://www.w3.org/2001/XMLSchema } # mapping of how the simple SOAP types should be serialized using YAJL into JSON. array set ::WS::Utils::simpleTypesJson { boolean "bool" float "number" double "double" integer "integer" int "integer" long "integer" short "integer" byte "integer" nonPositiveInteger "integer" negativeInteger "integer" nonNegativeInteger "integer" unsignedLong "integer" unsignedInt "integer" unsignedShort "integer" unsignedByte "integer" positiveInteger "integer" decimal "number" } array set ::WS::Utils::simpleTypes { anyType 1 string 1 boolean 1 decimal 1 float 1 double 1 duration 1 dateTime 1 |
︙ | ︙ | |||
102 103 104 105 106 107 108 | nonNegativeInteger 1 unsignedLong 1 unsignedInt 1 unsignedShort 1 unsignedByte 1 positiveInteger 1 } | | > > > > > > > | > > > > > > | > > > > > > > > > > | > > > > > > > > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | nonNegativeInteger 1 unsignedLong 1 unsignedInt 1 unsignedShort 1 unsignedByte 1 positiveInteger 1 } array set ::WS::Utils::options { UseNS 1 StrictMode error parseInAttr 0 genOutAttr 0 valueAttrCompatiblityMode 1 includeDirectory {} suppressNS {} useTypeNs 0 nsOnChangeOnly 0 anyType string queryTimeout 60000 } set ::WS::Utils::standardAttributes { baseType comment example pattern length fixed maxLength minLength minInclusive maxInclusive enumeration type } dom parse { <xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" xmlns:xs="http://www.w3.org/2001/XMLSchema" version="1.0"> <xsl:template priority="1" match="comment()"/> <xsl:template match="xs:choice"> <xsl:apply-templates/> </xsl:template> <!-- Copy all the attributes and other nodes --> <xsl:template match="@*|node()"> <xsl:copy> <xsl:apply-templates select="@*|node()"/> </xsl:copy> </xsl:template> </xsl:stylesheet> } ::WS::Utils::xsltSchemaDom set currentNs {} } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # |
︙ | ︙ | |||
171 172 173 174 175 176 177 | proc ::WS::Utils::GetCrossreference {mode service} { variable typeInfo array set crossreference {} dict for {type typeDict} [dict get $typeInfo $mode $service] { foreach {field fieldDict} [dict get $typeDict definition] { | | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | proc ::WS::Utils::GetCrossreference {mode service} { variable typeInfo array set crossreference {} dict for {type typeDict} [dict get $typeInfo $mode $service] { foreach {field fieldDict} [dict get $typeDict definition] { set fieldType [string trimright [dict get $fieldDict type] {()?}] incr crossreference($fieldType,count) lappend crossreference($fieldType,usedBy) $type.$field } if {![info exists crossreference($type,count) ]} { set crossreference($type,count) 0 set crossreference($type,usedBy) {} } |
︙ | ︙ | |||
229 230 231 232 233 234 235 | variable options if {[llength $args] == 0} { ::log::log debug {Return all options} return [array get options] } elseif {[llength $args] == 1} { set opt [lindex $args 0] | | | | | | | | > > > | | > > > > > > > | | | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 | variable options if {[llength $args] == 0} { ::log::log debug {Return all options} return [array get options] } elseif {[llength $args] == 1} { set opt [lindex $args 0] ::log::logsubst debug {One Option {$opt}} if {[info exists options($opt)]} { return $options($opt) } else { ::log::logsubst debug {Unknown option {$opt}} return \ -code error \ -errorcode [list WS CLIENT UNKOPTION $opt] \ "Unknown option'$opt'" } } elseif {([llength $args] % 2) == 0} { ::log::log debug {Multiple option pairs} foreach {opt value} $args { if {[info exists options($opt)]} { ::log::logsubst debug {Setting Option {$opt} to {$value}} set options($opt) $value } else { ::log::logsubst debug {Unknown option {$opt}} return \ -code error \ -errorcode [list WS CLIENT UNKOPTION $opt] \ "Unknown option'$opt'" } } } else { ::log::logsubst debug {Bad number of arguments {$args}} return \ -code error \ -errorcode [list WS CLIENT INVARGCNT $args] \ "Invalid argument count'$args'" } return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::ServiceTypeDef # # Description : Define a type for a service. # # Arguments : # mode - Client|Server # service - The name of the service this type definition is for # type - The type to be defined/redefined # definition - The definition of the type's fields. This consist of one # or more occurence of a field definition. Each field definition # consist of: fieldName fieldInfo # Where field info is: {type typeName comment commentString} # typeName can be any simple or defined type. # commentString is a quoted string describing the field. # xns - The namespace # abstract - Boolean indicating if this is an abstract, and hence mutable type # version - Version code for the custom type # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Utils::ServiceTypeDef {mode service type definition {xns {}} {abstract {false}} {version {}}} { ::log::logsubst debug {Entering [info level 0]} variable typeInfo if {![string length $xns]} { set xns $service } if {[llength [split $type {:}]] == 1} { set type $xns:$type } dict set typeInfo $mode $service $type definition $definition dict set typeInfo $mode $service $type xns $xns dict set typeInfo $mode $service $type abstract $abstract if {$version ne {}} { dict set typeInfo $mode $service $type version $version } return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::MutableTypeDef # # Description : Define a mutable type for a service. # # Arguments : # mode - Client|Server # service - The name of the service this type definition is for # type - The type to be defined/redefined # fromSwitchCmd - The cmd to determine the actaul type when converting # from DOM to a dictionary. The actual call will have # the following arguments appended to the command: # mode service type xns DOMnode # toSwitchCmd - The cmd to determine the actual type when converting # from a dictionary to a DOM. The actual call will have # the following arguments appended to the command: # mode service type xns remainingDictionaryTree # xns - The namespace # # Returns : Nothing # |
︙ | ︙ | |||
375 376 377 378 379 380 381 | variable mutableTypeInfo if {![string length $xns]} { set xns $service } set mutableTypeInfo([list $mode $service $type]) \ [list $fromSwitchCmd $toSwitchCmd] | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 | variable mutableTypeInfo if {![string length $xns]} { set xns $service } set mutableTypeInfo([list $mode $service $type]) \ [list $fromSwitchCmd $toSwitchCmd] return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
436 437 438 439 440 441 442 443 444 445 446 447 | # # ########################################################################### proc ::WS::Utils::ServiceSimpleTypeDef {mode service type definition {xns {tns1}}} { variable simpleTypes variable typeInfo if {![dict exists $definition xns]} { set simpleTypes($mode,$service,$type) [concat $definition xns $xns] } else { set simpleTypes($mode,$service,$type) $definition } | > | > > | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | # # ########################################################################### proc ::WS::Utils::ServiceSimpleTypeDef {mode service type definition {xns {tns1}}} { variable simpleTypes variable typeInfo ::log::logsubst debug {Entering [info level 0]} if {![dict exists $definition xns]} { set simpleTypes($mode,$service,$type) [concat $definition xns $xns] } else { set simpleTypes($mode,$service,$type) $definition } if {[dict exists $typeInfo $mode $service $type]} { ::log::logsubst debug {\t Unsetting typeInfo $mode $service $type} ::log::logsubst debug {\t Was [dict get $typeInfo $mode $service $type]} dict unset typeInfo $mode $service $type } return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
509 510 511 512 513 514 515 516 517 518 519 | # # ########################################################################### proc ::WS::Utils::GetServiceTypeDef {mode service {type {}}} { variable typeInfo variable simpleTypes if {[string equal $type {}]} { set results [dict get $typeInfo $mode $service] } else { set typeInfoList [TypeInfo $mode $service $type] | > > > > > > | | > | | > | | > | < | > | 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 618 619 620 621 622 623 624 | # # ########################################################################### proc ::WS::Utils::GetServiceTypeDef {mode service {type {}}} { variable typeInfo variable simpleTypes set type [string trimright $type {()?}] set results {} if {[string equal $type {}]} { ::log::log debug "@1" set results [dict get $typeInfo $mode $service] } else { set typeInfoList [TypeInfo $mode $service $type] if {[string equal -nocase -length 3 $type {xs:}]} { set type [string range $type 3 end] } ::log::logsubst debug {Type = {$type} typeInfoList = {$typeInfoList}} if {[info exists simpleTypes($mode,$service,$type)]} { ::log::log debug "@2" set results $simpleTypes($mode,$service,$type) } elseif {[info exists simpleTypes($type)]} { ::log::log debug "@3" set results [list type xs:$type xns xs] } elseif {[dict exists $typeInfo $mode $service $service:$type]} { ::log::log debug "@5" set results [dict get $typeInfo $mode $service $service:$type] } elseif {[dict exists $typeInfo $mode $service $type]} { ::log::log debug "@6" set results [dict get $typeInfo $mode $service $type] } } return $results } |
︙ | ︙ | |||
590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::GetServiceSimpleTypeDef {mode service {type {}}} { variable simpleTypes if {[string equal $type {}]} { set results {} foreach {key value} [array get simpleTypes $mode,$service,*] { lappend results [list [lindex [split $key {,}] end] $simpleTypes($key)] } } else { if {[info exists simpleTypes($mode,$service,$type)]} { set results $simpleTypes($mode,$service,$type) } elseif {[info exists simpleTypes($type)]} { | > > > > | | 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 | # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::GetServiceSimpleTypeDef {mode service {type {}}} { variable simpleTypes set type [string trimright $type {()?}] if {[string equal -nocase -length 3 $type {xs:}]} { return [::WS::Utils::GetServiceTypeDef $mode $service $type] } if {[string equal $type {}]} { set results {} foreach {key value} [array get simpleTypes $mode,$service,*] { lappend results [list [lindex [split $key {,}] end] $simpleTypes($key)] } } else { if {[info exists simpleTypes($mode,$service,$type)]} { set results $simpleTypes($mode,$service,$type) } elseif {[info exists simpleTypes($type)]} { set results [list type $type xns xs] } else { return \ -code error \ -errorcode [list WS CLIENT UNKSMPTYP $type] \ "Unknown simple type '$type'" } } |
︙ | ︙ | |||
625 626 627 628 629 630 631 632 633 634 635 636 637 638 | # Procedure Name : ::WS::Utils::ProcessImportXml # # Description : Parse the bindings for a service from a WSDL into our # internal representation # # Arguments : # mode - The mode, Client or Server # xml - The XML string to parse # serviceName - The name service. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # tnsCountVar - The name of the variable containing the count of the # namespace. # | > | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 | # Procedure Name : ::WS::Utils::ProcessImportXml # # Description : Parse the bindings for a service from a WSDL into our # internal representation # # Arguments : # mode - The mode, Client or Server # baseUrl - The URL we are processing # xml - The XML string to parse # serviceName - The name service. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # tnsCountVar - The name of the variable containing the count of the # namespace. # |
︙ | ︙ | |||
651 652 653 654 655 656 657 | # 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 | | > > > | | | > > > > > > | | > > | > > > > > > | > | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 | # 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.6.1 07/20/2018 A.Goth Correct variable access problems. Ticket [7bb1cd7b43] # Corrected access of right document. Ticket [61fd346dc3] # Bugs introduced 2015-05-24 Checkin [9c7e118edb] # 2018-09-03 H.Oehlmann Replaced stderr error print by error log. # ########################################################################### proc ::WS::Utils::ProcessImportXml {mode baseUrl xml serviceName serviceInfoVar tnsCountVar} { ::log::logsubst debug {Entering [info level 0]} upvar 1 $serviceInfoVar serviceInfo upvar 1 $tnsCountVar tnsCount variable currentSchema variable nsList variable xsltSchemaDom set first [string first {<} $xml] if {$first > 0} { set xml [string range $xml $first end] } if {[catch {dom parse $xml tmpdoc}]} { set first [string first {?>} $xml] incr first 2 set xml [string range $xml $first end] dom parse $xml tmpdoc } $tmpdoc xslt $xsltSchemaDom doc $tmpdoc delete $doc selectNodesNamespaces { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ xs http://www.w3.org/2001/XMLSchema } $doc documentElement schema if {[catch {ProcessIncludes $schema $baseUrl} errMsg]} { ::log::log error "Error processing include $schema $baseUrl: $errMsg" } set prevSchema $currentSchema set nodeList [$doc selectNodes -namespaces $nsList descendant::xs:schema] foreach node $nodeList { set currentSchema $node parseScheme $mode $baseUrl $node $serviceName serviceInfo tnsCount } set currentSchema $prevSchema $doc delete } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::ProcessIncludes # # Description : Replace all include nodes with the contents of the included url. # # Arguments : # rootNode - the root node of the document # baseUrl - The URL being processed # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 25/05/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::ProcessIncludes {rootNode baseUrl {includePath {}}} { variable xsltSchemaDom variable nsList variable options variable includeArr ::log::logsubst debug {Entering [info level 0]} set includeNodeList [concat \ [$rootNode selectNodes -namespaces $nsList descendant::xs:include] \ [$rootNode selectNodes -namespaces $nsList descendant::w:include] \ [$rootNode selectNodes -namespaces $nsList descendant::w:import] \ ] set inXml [$rootNode asXML] set included 0 foreach includeNode $includeNodeList { ::log::logsubst debug {\t Processing Include [$includeNode asXML]} if {[$includeNode hasAttribute schemaLocation]} { set urlTail [$includeNode getAttribute schemaLocation] set url [::uri::resolve $baseUrl $urlTail] } elseif {[$includeNode hasAttribute location]} { set url [$includeNode getAttribute location] set urlTail [file tail [dict get [::uri::split $url] path]] } else { continue } if {[lsearch -exact $includePath $url] != -1} { log::logsubst warning {Include loop detected: [join $includePath { -> }]} continue } elseif {[info exists includeArr($url)]} { continue } else { set includeArr($url) 1 } incr included ::log::logsubst info {\t Including {$url} from base {$baseUrl}} switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set xml $token(data) unset token } https - http { set ncode -1 catch { ::log::logsubst info {[list ::http::geturl $url\ -timeout $options(queryTimeout)]} set token [::http::geturl $url -timeout $options(queryTimeout)] set ncode [::http::ncode $token] set xml [::http::data $token] ::log::logsubst info {Received Ncode = ($ncode), $xml} ::http::cleanup $token } if {($ncode != 200) && [string equal $options(includeDirectory) {}]} { return \ -code error \ -errorcode [list WS CLIENT HTTPFAIL $url $ncode] \ "HTTP get of import file failed '$url'" } elseif {($ncode != 200) && ![string equal $options(includeDirectory) {}]} { set fn [file join $options(includeDirectory) $urlTail] set ifd [open $fn r] set xml [read $ifd] close $ifd } } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } } set parentNode [$includeNode parentNode] set nextSibling [$includeNode nextSibling] set first [string first {<} $xml] if {$first > 0} { set xml [string range $xml $first end] } dom parse $xml tmpdoc $tmpdoc xslt $xsltSchemaDom doc $tmpdoc delete set children 0 set top [$doc documentElement] ::WS::Utils::ProcessIncludes $top $url [concat $includePath $baseUrl] foreach childNode [$top childNodes] { if {[catch { #set newNode [$parentNode appendXML [$childNode asXML]] #$parentNode removeChild $newNode #$parentNode insertBefore $newNode $includeNode $parentNode insertBefore $childNode $includeNode }]} { continue } incr children } $doc delete $includeNode delete } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::TypeInfo # # Description : Return a list indicating if the type is simple or complex # and if it is a scalar or an array. Also if it is optional # # Arguments : # type - the type name, possibly with a () to specify it is an array # # Returns : A list of two elements, as follows: # 0|1 - 0 means a simple type, 1 means a complex type # 0|1 - 0 means a scalar, 1 means an array # # Side-Effects : None # |
︙ | ︙ | |||
717 718 719 720 721 722 723 | # 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 | | > | > > > > > | > > > > > > | 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 | # 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.3.0 10/16/2012 G. Lester Corrected detection of service specific simple type. # 2.3.0 10/31/2012 G. Lester Corrected missing newline. # ########################################################################### proc ::WS::Utils::TypeInfo {mode service type {findOptional 0}} { variable simpleTypes variable typeInfo set type [string trim $type] set isOptional 0 if {[string equal [string index $type end] {?}]} { set isOptional 1 set type [string trimright $type {?}] } if {[string equal [string range $type end-1 end] {()}]} { set isArray 1 set type [string range $type 0 end-2] } elseif {[string equal $type {array}]} { set isArray 1 } else { set isArray 0 } #set isNotSimple [dict exists $typeInfo $mode $service $type] #set isNotSimple [expr {$isNotSimple || [dict exists $typeInfo $mode $service $service:$type]}] lassign [split $type {:}] tns baseType set isNotSimple [expr {!([info exist simpleTypes($type)] || [info exist simpleTypes($baseType)] || [info exist simpleTypes($mode,$service,$type)] || [info exist simpleTypes($mode,$service,$baseType)] )}] if {$findOptional} { return [list $isNotSimple $isArray $isOptional] } return [list $isNotSimple $isArray] } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure |
︙ | ︙ | |||
758 759 760 761 762 763 764 | # Arguments : # mode - Client/Server # serviceName - The service name # xmlString - The XML string to validate # tagName - The name of the starting tag # typeName - The type for the tag # | | | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 | # Arguments : # mode - Client/Server # serviceName - The service name # xmlString - The XML string to validate # tagName - The name of the starting tag # typeName - The type for the tag # # Returns : 1 if validation ok, 0 if not # # Side-Effects : # ::errorCode - cleared if validation ok # - contains validation failure information if validation # failed. # # Exception Conditions : |
︙ | ︙ | |||
787 788 789 790 791 792 793 794 795 796 797 798 799 800 | # 1 08/14/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to handle qualified XML # # ########################################################################### proc ::WS::Utils::Validate {mode serviceName xmlString tagName typeName} { dom parse $xmlString resultTree $resultTree documentElement currNode set nodeName [$currNode localName] if {![string equal $nodeName $tagName]} { return \ -code error \ -errorcode [list WS CHECK START_NODE_DIFFERS [list $tagName $nodeName]] \ | > > > > | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 | # 1 08/14/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to handle qualified XML # # ########################################################################### proc ::WS::Utils::Validate {mode serviceName xmlString tagName typeName} { set first [string first {<} $xmlString] if {$first > 0} { set xmlString [string range $xmlString $first end] } dom parse $xmlString resultTree $resultTree documentElement currNode set nodeName [$currNode localName] if {![string equal $nodeName $tagName]} { return \ -code error \ -errorcode [list WS CHECK START_NODE_DIFFERS [list $tagName $nodeName]] \ |
︙ | ︙ | |||
845 846 847 848 849 850 851 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to generate qualified XML # ########################################################################### proc ::WS::Utils::BuildRequest {mode serviceName tagName typeName valueInfos} { | | | 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to generate qualified XML # ########################################################################### proc ::WS::Utils::BuildRequest {mode serviceName tagName typeName valueInfos} { upvar 1 $valueInfos values variable resultTree variable currNode set resultTree [::dom createDocument $tagName] set typeInfo [GetServiceTypeDef $mode $serviceName $typeName] $resultTree documentElement currNode if {[catch {buildTags $mode $serviceName $typeName $valueInfos $resultTree $currNode} msg]} { |
︙ | ︙ | |||
936 937 938 939 940 941 942 943 944 945 946 947 948 949 | # # Arguments : # mode - Client/Server # serviceName - The service name # doc - The document to add the scheme to # parent - The parent node of the scheme # targetNamespace - Target namespace # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # | > | 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 | # # Arguments : # mode - Client/Server # serviceName - The service name # doc - The document to add the scheme to # parent - The parent node of the scheme # targetNamespace - Target namespace # version - Requested service version # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # |
︙ | ︙ | |||
957 958 959 960 961 962 963 964 965 | # 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/15/2008 G.Lester Made Scheme generation a utility # 2 02/03/2008 G.Lester Moved scheme generation into WS::Utils namespace # ########################################################################### | > | | | > > > > > | | > | | | | | | > > > > > | | | 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 | # 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/15/2008 G.Lester Made Scheme generation a utility # 2 02/03/2008 G.Lester Moved scheme generation into WS::Utils namespace # 3 11/13/2018 J.Cone Version support # ########################################################################### proc ::WS::Utils::GenerateScheme {mode serviceName doc parent targetNamespace {version {}}} { set localTypeInfo [GetServiceTypeDef $mode $serviceName] array set typeArr {} foreach type [dict keys $localTypeInfo] { set typeArr($type) 1 } if {[string equal $parent {}]} { $doc documentElement schema $schema setAttribute \ xmlns:xs "http://www.w3.org/2001/XMLSchema" } else { $parent appendChild [$doc createElement xs:schema schema] } $schema setAttribute \ elementFormDefault qualified \ targetNamespace $targetNamespace foreach baseType [lsort -dictionary [array names typeArr]] { if {$version ne {} && [dict exists $localTypeInfo $baseType version]} { if {![check_version [dict get $localTypeInfo $baseType version] $version]} { continue } } ::log::logsubst debug {Outputing $baseType} $schema appendChild [$doc createElement xs:element elem] set name [lindex [split $baseType {:}] end] $elem setAttribute name $name $elem setAttribute type $baseType $schema appendChild [$doc createElement xs:complexType comp] $comp setAttribute name $name $comp appendChild [$doc createElement xs:sequence seq] set baseTypeInfo [dict get $localTypeInfo $baseType definition] ::log::logsubst debug {\t parts {$baseTypeInfo}} foreach {field tmpTypeInfo} $baseTypeInfo { if {$version ne {} && [dict exists $tmpTypeInfo version]} { if {![check_version [dict get $tmpTypeInfo version] $version]} { continue } } $seq appendChild [$doc createElement xs:element tmp] set tmpType [dict get $tmpTypeInfo type] ::log::logsubst debug {Field $field of $tmpType} foreach {name value} [getTypeWSDLInfo $mode $serviceName $field $tmpType] { $tmp setAttribute $name $value } } } } |
︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 | # 1 07/06/2006 G.Lester Initial version # 2 02/03/2008 G.Lester Moved into WS::Utils namespace # ########################################################################### proc ::WS::Utils::getTypeWSDLInfo {mode serviceName field type} { set typeInfo {maxOccurs 1 minOccurs 1 name * type *} dict set typeInfo name $field | | | | > > > | > > | 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 | # 1 07/06/2006 G.Lester Initial version # 2 02/03/2008 G.Lester Moved into WS::Utils namespace # ########################################################################### proc ::WS::Utils::getTypeWSDLInfo {mode serviceName field type} { set typeInfo {maxOccurs 1 minOccurs 1 name * type *} dict set typeInfo name $field set typeList [TypeInfo $mode $serviceName $type 1] if {[lindex $typeList 0] == 0} { dict set typeInfo type xs:[string trimright $type {()?}] } else { dict set typeInfo type $serviceName:[string trimright $type {()?}] } if {[lindex $typeList 1]} { dict set typeInfo maxOccurs unbounded } if {[lindex $typeList 2]} { dict set typeInfo minOccurs 0 } return $typeInfo } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::convertTypeToDict # # Description : Convert the XML, in DOM representation, to a dictionary object for # a given type. # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # node - The base node for the type. # type - The name of the type # root - The root node of the document # isArray - We are looking for array elements # # Returns : A dictionary object for a given type. # # Side-Effects : None # # Exception Conditions : None # |
︙ | ︙ | |||
1094 1095 1096 1097 1098 1099 1100 1101 1102 | # 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 # # ########################################################################### | > > > | > > > > > > > > > | > > > > > > > > > > > > > > > | | | | | | | | > > > > > > > | > | | | | > > > > | < < > > > > > > > < | > > > > | > > > > > | > > > > > > > > > | | | | > > > > > > > > | | | > > > > > > | > | > > > > > > > | > | | > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | | | | > | | > > > > | > | > > > > > > > | > | | > | | > > > > | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 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 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 | # 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 2018-05-14 H.Oehlmann Add support to translate namespace prefixes # in attribute values or text values. # New parameter "xnsDistantToLocalDict". # ########################################################################### proc ::WS::Utils::convertTypeToDict { mode serviceName node type root {isArray 0} {xnsDistantToLocalDict {}} } { variable typeInfo variable mutableTypeInfo variable options if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} } set xsiNsUrl {http://www.w3.org/2001/XMLSchema-instance} ::log::logsubst debug {Entering [info level 0]} if {[dict exists $typeInfo $mode $serviceName $type]} { set typeName $type } elseif {[dict exists $typeInfo $mode $serviceName $serviceName:$type]} { set typeName $serviceName:$type } else { ## ## Assume this is a simple type ## set baseType [::WS::Utils::GetServiceTypeDef $mode $serviceName $type] if {[string equal $baseType {XML}]} { set results [$node asXML] } else { set results [$node asText] } return $results } set typeDefInfo [dict get $typeInfo $mode $serviceName $typeName] ::log::logsubst debug {\t type def = {$typeDefInfo}} set xns [dict get $typeDefInfo xns] if {[$node hasAttribute href]} { set node [GetReferenceNode $root [$node getAttribute href]] } ::log::logsubst debug {\t XML of node is [$node asXML]} if {[info exists mutableTypeInfo([list $mode $serviceName $typeName])]} { set type [(*)[lindex mutableTypeInfo([list $mode $serviceName $type]) 0] $mode $serviceName $typeName $xns $node] set typeDefInfo [dict get $typeInfo $mode $serviceName $typeName] ::log::logsubst debug {\t type def replaced with = {$typeDefInfo}} } set results {} #if {$options(parseInAttr)} { # foreach attr [$node attributes] { # if {[llength $attr] == 1} { # dict set results $attr [$node getAttribute $attr] # } # } #} set partsList [dict keys [dict get $typeDefInfo definition]] ::log::logsubst debug {\t partsList is {$partsList}} set arrayOverride [expr {$isArray && ([llength $partsList] == 1)}] foreach partName $partsList { set partType [dict get $typeDefInfo definition $partName type] set partType [string trimright $partType {?}] if {[dict exists $typeDefInfo definition $partName allowAny] && [dict get $typeDefInfo definition $partName allowAny]} { set allowAny 1 } else { set allowAny 0 } if {[string equal $partName *] && [string equal $partType *]} { ## ## Type infomation being handled dynamically for this part ## set savedTypeInfo $typeInfo parseDynamicType $mode $serviceName $node $type set tmp [convertTypeToDict $mode $serviceName $node $type $root 0 $xnsDistantToLocalDict] foreach partName [dict keys $tmp] { dict set results $partName [dict get $tmp $partName] } set typeInfo $savedTypeInfo continue } set partXns $xns catch {set partXns [dict get $typeInfo $mode $serviceName $partType xns]} set typeInfoList [TypeInfo $mode $serviceName $partType] set tmpTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType] ::log::logsubst debug {\tpartName $partName partType $partType xns $xns typeInfoList $typeInfoList} ## ## Try for fully qualified name ## ::log::logsubst debug {Trying #1 [list $node selectNodes $partXns:$partName]} if {[catch {llength [set item [$node selectNodes $partXns:$partName]]} len] || ($len == 0)} { ::log::logsubst debug {Trying #2 [list $node selectNodes $xns:$partName]} if {[catch {llength [set item [$node selectNodes $xns:$partName]]} len] || ($len == 0)} { ## ## Try for unqualified name ## ::log::logsubst debug {Trying #3 [list $node selectNodes $partName]} if {[catch {llength [set item [$node selectNodes $partName]]} len] || ($len == 0)} { ::log::log debug "Trying #4 -- search of children" set item {} set matchList [list $partXns:$partName $xns:$partName $partName] foreach childNode [$node childNodes] { set nodeType [$childNode nodeType] ::log::logsubst debug {\t\t Looking at {[$childNode localName],[$childNode nodeName]} ($allowAny,$isArray,$nodeType,$partName)} # From SOAP1.1 Spec: # Within an array value, element names are not significant # for distinguishing accessors. Elements may have any name. # Here we don't need check the element name, just simple check # it's a element node if {$allowAny || ($arrayOverride && [string equal $nodeType "ELEMENT_NODE"])} { ::log::logsubst debug {\t\t Found $partName [$childNode asXML]} lappend item $childNode } } if {![string length $item]} { ::log::log debug "\tSkipping" continue } } else { ::log::logsubst debug {\t\t Found [llength $item] $partName} } } else { ::log::logsubst debug {\t\t Found [llength $item] $partName} } } else { ::log::logsubst debug {\t\t Found [llength $item] $partName} } set origItemList $item set newItemList {} foreach item $origItemList { if {[$item hasAttribute href]} { set oldXML [$item asXML] ::log::logsubst debug {\t\t Replacing: $oldXML} set item [GetReferenceNode $root [$item getAttribute href]] ::log::logsubst debug {\t\t With: [$item asXML]} } lappend newItemList $item } set item $newItemList set isAbstract false if {[dict exists $typeInfo $mode $serviceName $partType abstract]} { set isAbstract [dict get $typeInfo $mode $serviceName $partType abstract] } switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## if {[dict exists $tmpTypeInfo base]} { set baseType [dict get $tmpTypeInfo base] } else { set baseType string } if {$options(parseInAttr)} { foreach attrList [$item attributes] { catch { lassign $attrList attr nsAlias nsUrl if {[string equal $nsUrl $xsiNsUrl]} { set attrValue [$item getAttribute ${nsAlias}:$attr] dict set results $partName ::$attr $attrValue } elseif {![string equal $nsAlias {}]} { set attrValue [$item getAttribute ${nsAlias}:$attr] dict set results $partName $attr $attrValue } else { set attrValue [$item getAttribute $attr] dict set results $partName $attr $attrValue } } } if {[string equal $baseType {XML}]} { dict set results $partName $valueAttr [$item asXML] } else { dict set results $partName $valueAttr [$item asText] } } else { if {[string equal $baseType {XML}]} { dict set results $partName [$item asXML] } else { dict set results $partName [$item asText] } } } {0 1} { ## ## Simple array ## if {[dict exists $tmpTypeInfo base]} { set baseType [dict get $tmpTypeInfo base] } else { set baseType string } set tmp {} foreach row $item { if {$options(parseInAttr)} { set rowList {} foreach attrList [$row attributes] { catch { lassign $attrList attr nsAlias nsUrl if {[string equal $nsUrl $xsiNsUrl]} { set attrValue [$row getAttribute ${nsAlias}:$attr] lappend rowList ::$attr $attrValue } elseif {![string equal $nsAlias {}]} { set attrValue [$row getAttribute ${nsAlias}:$attr] lappend rowList $attr $attrValue } else { set attrValue [$row getAttribute $attr] lappend rowList $attr $attrValue } } } if {[string equal $baseType {XML}]} { lappend rowList $valueAttr [$row asXML] } else { lappend rowList $valueAttr [$row asText] } lappend tmp $rowList } else { if {[string equal $baseType {XML}]} { lappend tmp [$row asXML] } else { lappend tmp [$row asText] } } } dict set results $partName $tmp } {1 0} { ## ## Non-simple non-array ## if {$options(parseInAttr)} { ## Translate an abstract type from the WSDL to a type given ## in the response ## Example xml response from bug 584bfb772: ## <soap:Envelope ... ## xmlns:tns="http://www.esri.com/schemas/ArcGIS/10.3"> ## <soap:Body> ## <tns:GetServerInfoResponse> ## <Result xsi:type="tns:MapServerInfo"> ## <Name>Layers</Name> ## <Description></Description> ## <FullExtent xsi:type="tns:EnvelopeN"> ## ## The element FullExtend gets type "tns:EnvelopeN". ## ## xnsDistantToLocalDict if {$isAbstract && [$item hasAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]} { # partType is now tns::EnvelopeN set partType [XNSDistantToLocal $xnsDistantToLocalDict \ [$item getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]] # Remove this type attribute from the snippet. # So, it is not handled in the loop below. $item removeAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type } foreach attrList [$item attributes] { catch { lassign $attrList attr nsAlias nsUrl if {[string equal $nsUrl $xsiNsUrl]} { set attrValue [$item getAttribute ${nsAlias}:$attr] dict set results $partName ::$attr $attrValue } elseif {![string equal $nsAlias {}]} { set attrValue [$item getAttribute ${nsAlias}:$attr] dict set results $partName $attr $attrValue } else { set attrValue [$item getAttribute $attr] dict set results $partName $attr $attrValue } } } dict set results $partName $valueAttr [convertTypeToDict $mode $serviceName $item $partType $root 0 $xnsDistantToLocalDict] } else { dict set results $partName [convertTypeToDict $mode $serviceName $item $partType $root 0 $xnsDistantToLocalDict] } } {1 1} { ## ## Non-simple array ## set partType [string trimright $partType {()}] set tmp [list] foreach row $item { if {$options(parseInAttr)} { set rowList {} if {$isAbstract && [$row hasAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]} { set partType [$row getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type] $row removeAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type } foreach attrList [$row attributes] { catch { lassign $attrList attr nsAlias nsUrl if {[string equal $nsUrl $xsiNsUrl]} { set attrValue [$row getAttribute ${nsAlias}:$attr] lappend rowList ::$attr $attrValue } elseif {![string equal $nsAlias {}]} { set attrValue [$row getAttribute ${nsAlias}:$attr] lappend rowList $attr $attrValue } else { set attrValue [$row getAttribute $attr] lappend rowList $attr $attrValue } } } lappend rowList $valueAttr [convertTypeToDict $mode $serviceName $row $partType $root 1 $xnsDistantToLocalDict] lappend tmp $rowList } else { lappend tmp [convertTypeToDict $mode $serviceName $row $partType $root 1 $xnsDistantToLocalDict] } } dict set results $partName $tmp } default { ## ## Placed here to shut up tclchecker ## } } } ::log::logsubst debug {Leaving ::WS::Utils::convertTypeToDict with result '$results'} return $results } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::XNSDistantToLocal # # Description : Get a reference node. # # Arguments : # xnsDistantToLocalDict - Dict to translate distant to local NS prefixes # typeDistant - Type string with possible distant namespace prefix # # Returns : type with local namespace prefix # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 2.4.2 2017-11-03 H.Oehlmann Initial version # ########################################################################### proc ::WS::Utils::XNSDistantToLocal {xnsDistantToLocalDict type} { set collonPos [string first ":" $type] # check for namespace prefix present if {-1 < $collonPos} { set prefixDistant [string range $type 0 $collonPos-1] if {[dict exists $xnsDistantToLocalDict $prefixDistant]} { set type [dict get $xnsDistantToLocalDict $prefixDistant][string range $type $collonPos end] log::logsubst debug {Mapped distant namespace prefix '$prefixDistant' to type '$type'} } else { log::logsubst warning {Distant type '$type' does not have a known namespace prefix ([dict keys $xnsDistantToLocalDict])} } } return $type } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< |
︙ | ︙ | |||
1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 | # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. # doc - The document # dict - The dictionary to convert # type - The name of the type # # Returns : None # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 # # ########################################################################### | > > > > | | > > | > > > > > > > > > > > > > > > > > > | | | > | > > > > > | | | | | | > | > > > > > | > > > > > > > > | | > | < > > > > | < > | | > > | > > > > > > > > > | | | > > > > > > > > | > > > | > > | > | > > > | > | | > > > | > | > > > > | > > > | > > > | > | > > > | > > > > | > > | > > > > > > | > > > | > | | > > > | > > > | | > > > | > > > > > > > | > > > | > | > > > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > | > > > > > | > > > | > > > > > | > > > | | | > | > | > > > | > | > | > > > | > | | > > > > > | > > > | > | | | | > > > > | > > > | > | | > > > > > > | | | 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 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 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 | # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. # doc - The document # dict - The dictionary to convert # type - The name of the type # forceNs - Force the response to use a namespace # enforceRequired - Boolean setting for enforcing required vars be set # version - Requested service version # # Returns : None # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Utils::convertDictToType {mode service doc parent dict type {forceNs 0} {enforceRequired 0} {version {}}} { ::log::logsubst debug {Entering [info level 0]} # ::log::logsubst debug { Parent xml: [$parent asXML]} variable typeInfo variable simpleTypes variable options variable standardAttributes variable currentNs if {!$options(UseNS)} { return [::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent $dict $type $enforceRequired $version] } if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} } set typeInfoList [TypeInfo $mode $service $type] set type [string trimright $type {?}] ::log::logsubst debug {\t typeInfoList = {$typeInfoList}} if {[dict exists $typeInfo $mode $service $service:$type]} { set typeName $service:$type } else { set typeName $type } if {$version ne {} && [dict exists $typeInfo $mode $service $typeName version]} { if {![check_version [dict get $typeInfo $mode $service $typeName version] $version]} { return } } set itemList {} if {[lindex $typeInfoList 0] && [dict exists $typeInfo $mode $service $typeName definition]} { set itemList [dict get $typeInfo $mode $service $typeName definition] set xns [dict get $typeInfo $mode $service $typeName xns] } else { if {[info exists simpleTypes($mode,$service,$typeName)]} { set xns [dict get $simpleTypes($mode,$service,$typeName) xns] } elseif {[info exists simpleTypes($mode,$service,$currentNs:$typeName)]} { set xns [dict get $simpleTypes($mode,$service,$currentNs:$typeName) xns] } else { error "Simple type cannot be found: $typeName" } set itemList [list $typeName {type string}] } if {[info exists mutableTypeInfo([list $mode $service $typeName])]} { set typeName [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict] set typeInfoList [TypeInfo $mode $service $typeName] if {[lindex $typeInfoList 0]} { set itemList [dict get $typeInfo $mode $service $typeName definition] set xns [dict get $typeInfo $mode $service $typeName xns] } else { if {[info exists simpleTypes($mode,$service,$typeName)]} { set xns [dict get $simpleTypes($mode,$service,$typeName) xns] } elseif {[info exists simpleTypes($mode,$service,$currentNs:$typeName)]} { set xns [dict get $simpleTypes($mode,$service,$currentNs:$typeName) xns] } else { error "Simple type cannot be found: $typeName" } set itemList [list $type {type string}] } } ::log::logsubst debug {\titemList is {$itemList} in $xns} set entryNs $currentNs if {!$forceNs} { set currentNs $xns } set fieldList {} foreach {itemName itemDef} $itemList { if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { continue } set baseName [lindex [split $itemName {:}] end] lappend fieldList $itemName set itemType [dict get $itemDef type] ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} itemType ={$itemType}} set typeInfoList [TypeInfo $mode $service $itemType 1] ::log::logsubst debug {Expr [list ![dict exists $dict $itemName] && ![dict exists $dict $baseName]]} if {![dict exists $dict $itemName] && ![dict exists $dict $baseName]} { ::log::logsubst debug {Neither {$itemName} nor {$baseName} are in dictionary {$dict}, skipping} # If required parameters are being enforced and this field is not optional, throw an error if {$enforceRequired && ![lindex $typeInfoList 2]} { error "Required field $itemName is missing from response" } continue } elseif {[dict exists $dict $baseName]} { set useName $baseName } else { set useName $itemName } set itemXns $xns set tmpInfo [GetServiceTypeDef $mode $service [string trimright $itemType {()?}]] if {$options(useTypeNs) && [dict exists $tmpInfo xns]} { set itemXns [dict get $tmpInfo xns] } set attrList {} if {$options(useTypeNs) && [string equal $itemXns xs]} { set itemXns $xns } if {$options(nsOnChangeOnly) && [string equal $itemXns $currentNs]} { set itemXns {} } foreach key [dict keys $itemDef] { if {[lsearch -exact $standardAttributes $key] == -1 && $key ne "isList" && $key ne "xns"} { lappend attrList $key [dict get $itemDef $key] ::log::logsubst debug {key = {$key} standardAttributes = {$standardAttributes}} } } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} itemXns = {$itemXns} tmpInfo = {$tmpInfo} attrList = {$attrList}} set isAbstract false set baseType [string trimright $itemType {()?}] if {$options(genOutAttr) && [dict exists $typeInfo $mode $service $baseType abstract]} { set isAbstract [dict get $typeInfo $mode $service $baseType abstract] } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} isAbstract = {$isAbstract}} # Strip the optional flag off the typeInfoList set typeInfoList [lrange $typeInfoList 0 1] switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $itemXns:$itemName retNode] } if {$options(genOutAttr)} { set resultValue {} set dictList [dict keys [dict get $dict $useName]] #::log::log debug "$useName <$dict> '$dictList'" foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $useName $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $dict $useName $attr] } } } else { set resultValue [dict get $dict $useName] } if {[dict exists $tmpInfo base] && [string equal [dict get $tmpInfo base] {XML}]} { $retNode appendXML $resultValue } else { $retNode appendChild [$doc createTextNode $resultValue] } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {0 1} { ## ## Simple array ## set dataList [dict get $dict $useName] #::log::log debug "\t\t [llength $dataList] rows {$dataList}" foreach row $dataList { if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $itemXns:$itemName retNode] } if {$options(genOutAttr)} { set dictList [dict keys $row] ::log::logsubst debug {<$row> '$dictList'} set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } if {[dict exists $tmpInfo base] && [string equal [dict get $tmpInfo base] {XML}]} { $retNode appendXML $resultValue } else { $retNode appendChild [$doc createTextNode $resultValue] } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } } {1 0} { ## ## Non-simple non-array ## if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $itemXns:$itemName retNode] } if {$options(genOutAttr)} { #::log::log debug "Before 150 useName {$useName} dict {$dict}" set dictList [dict keys [dict get $dict $useName]] #::log::log debug "$useName <$dict> '$dictList'" set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { set itemType [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $itemType set itemType $itemXns:$itemType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $useName $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $dict $useName $attr] } } } else { set resultValue [dict get $dict $useName] } if {![string equal $currentNs $itemXns] && ![string equal $itemXns {}]} { set tmpNs $currentNs set currentNs $itemXns convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired $version } else { convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired $version } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $useName] #::log::log debug "\t\t [llength $dataList] rows {$dataList}" foreach row $dataList { if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $itemXns:$itemName retNode] } if {$options(genOutAttr)} { set dictList [dict keys $row] set resultValue {} #::log::log debug "<$row> '$dictList'" foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { set tmpType [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $tmpType set tmpType $itemXns:$tmpType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } if {[string index $itemType end] eq {?}} { set tmpType "[string trimright $itemType {()?}]?" } else { set tmpType [string trimright $itemType {()}] } if {![string equal $currentNs $itemXns] && ![string equal $itemXns {}]} { set tmpNs $currentNs set currentNs $itemXns convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired $version } else { convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired $version } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } } default { ## ## Placed here to shut up tclchecker ## } } #if {$options(genOutAttr)} { # set dictList [dict keys $dict] # foreach attr [lindex [::struct::set intersect3 $fieldList $dictList] end] { # $parent setAttribute $attr [dict get $dict $attr] # } #} } set currentNs $entryNs ::log::logsubst debug {Leaving ::WS::Utils::convertDictToType with xml: [$parent asXML]} return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::convertDictToJson # # Description : Convert a dictionary object into a JSON tree. # # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # doc - The document (yajltcl) # dict - The dictionary to convert # type - The name of the type # enforceRequired - Boolean setting for enforcing required vars be set # version - The requested service version # # Returns : None # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Jeff Lawson # #>>END PRIVATE<< # # 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 03/23/2011 J.Lawson Initial version # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Utils::convertDictToJson {mode service doc dict type {enforceRequired 0} {version {}}} { ::log::logsubst debug {Entering [info level 0]} variable typeInfo variable simpleTypes variable simpleTypesJson variable options variable standardAttributes set typeInfoList [TypeInfo $mode $service $type] set type [string trimright $type {?}] if {[dict exists $typeInfo $mode $service $service:$type]} { set typeName $service:$type } else { set typeName $type } if {$version ne {} && [dict exists $typeInfo $mode $service $typeName version]} { if {![check_version [dict get $typeInfo $mode $service $typeName version] $version]} { return } } set itemList {} if {[lindex $typeInfoList 0] && [dict exists $typeInfo $mode $service $typeName definition]} { set itemList [dict get $typeInfo $mode $service $typeName definition] set xns [dict get $typeInfo $mode $service $typeName xns] } else { set xns $simpleTypes($mode,$service,$typeName) set itemList [list $typeName {type string}] } if {[info exists mutableTypeInfo([list $mode $service $typeName])]} { set typeName [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict] set typeInfoList [TypeInfo $mode $service $typeName] if {[lindex $typeInfoList 0]} { set itemList [dict get $typeInfo $mode $service $typeName definition] } else { set itemList [list $type {type string}] } } ::log::logsubst debug {\titemList is {$itemList}} set fieldList {} foreach {itemName itemDef} $itemList { if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { continue } lappend fieldList $itemName set itemType [dict get $itemDef type] ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} itemType = {$itemType}} set typeInfoList [TypeInfo $mode $service $itemType 1] if {![dict exists $dict $itemName]} { if {$enforceRequired && ![lindex $typeInfoList 2]} { error "Required field $itemName is missing from response" } continue } if {[info exists simpleTypesJson([string trimright $itemType {()?}])]} { set yajlType $simpleTypesJson([string trimright $itemType {()?}]) } else { set yajlType "string" } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}} set typeInfoList [lrange $typeInfoList 0 1] switch -- $typeInfoList { {0 0} { ## ## Simple non-array ## set resultValue [dict get $dict $itemName] $doc string $itemName $yajlType $resultValue } {0 1} { ## ## Simple array ## set dataList [dict get $dict $itemName] $doc string $itemName array_open foreach row $dataList { $doc $yajlType $row } $doc array_close } {1 0} { ## ## Non-simple non-array ## $doc string $itemName map_open set resultValue [dict get $dict $itemName] convertDictToJson $mode $service $doc $resultValue $itemType $enforceRequired $version $doc map_close } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $itemName] $doc string $itemName array_open if {[string index $itemType end] eq {?}} { set tmpType "[string trimright $itemType {()?}]?" } else { set tmpType [string trimright $itemType {()}] } foreach row $dataList { $doc map_open convertDictToJson $mode $service $doc $row $tmpType $enforceRequired $version $doc map_close } $doc array_close } } } return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::convertDictToTypeNoNs # # Description : Convert a dictionary object into a XML DOM tree. # # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. # dict - The dictionary to convert # type - The name of the type # enforceRequired - Boolean setting for enforcing required vars be set # version - The requested service version # # Returns : None # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type {enforceRequired 0} {version {}}} { ::log::logsubst debug {Entering [info level 0]} # ::log::log debug " Parent xml: [$parent asXML]" variable typeInfo variable simpleTypes variable options variable standardAttributes variable currentNs if {$version ne {} && [dict exists $typeInfo $mode $service $type version]} { if {![check_version [dict get $typeInfo $mode $service $type version] $version]} { return } } if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} } set typeInfoList [TypeInfo $mode $service $type] if {[lindex $typeInfoList 0]} { set itemList [dict get $typeInfo $mode $service $type definition] set xns [dict get $typeInfo $mode $service $type xns] } else { if {[info exists simpleTypes($mode,$service,$type)]} { set xns [dict get $simpleTypes($mode,$service,$type) xns] } elseif {[info exists simpleTypes($mode,$service,$currentNs:$type)]} { set xns [dict get $simpleTypes($mode,$service,$currentNs:$type) xns] } else { error "Simple type cannot be found: $type" } set itemList [list $type {type string}] } ::log::logsubst debug {\titemList is {$itemList}} foreach {itemName itemDef} $itemList { if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { continue } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef}} set itemType [dict get $itemDef type] set isAbstract false set baseType [string trimright $itemType {()?}] if {$options(genOutAttr) && [dict exists $typeInfo $mode $service $baseType abstract]} { set isAbstract [dict get $typeInfo $mode $service $baseType abstract] } set typeInfoList [TypeInfo $mode $service $itemType 1] if {![dict exists $dict $itemName]} { if {$enforceRequired && ![lindex $typeInfoList 2]} { error "Required field $itemName is missing from response" } continue } set attrList {} foreach key [dict keys $itemDef] { if {[lsearch -exact $standardAttributes $key] == -1 && $key ne "isList" && $key ne "xns"} { lappend attrList $key [dict get $itemDef $key] ::log::logsubst debug {key = {$key} standardAttributes = {$standardAttributes}} } } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}} set typeInfoList [lrange $typeInfoList 0 1] switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys [dict get $dict $itemName]] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $itemName $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $dict $itemName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $dict $itemName $attr] } } } else { set resultValue [dict get $dict $itemName] } $retNode appendChild [$doc createTextNode $resultValue] if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {0 1} { ## ## Simple array ## set dataList [dict get $dict $itemName] foreach row $dataList { $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys $row] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } $retNode appendChild [$doc createTextNode $resultValue] if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } } {1 0} { ## ## Non-simple non-array ## $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys [dict get $dict $itemName]] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { # *** HaO: useName is never defined set itemType [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $itemType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $itemName $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $dict $itemName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $dict $itemName $attr] } } } else { set resultValue [dict get $dict $itemName] } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } convertDictToTypeNoNs $mode $service $doc $retNode $resultValue $itemType $enforceRequired $version } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $itemName] set tmpType [string trimright $itemType {()}] foreach row $dataList { $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys $row] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { set tmpType [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $tmpType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } convertDictToTypeNoNs $mode $service $doc $retNode $resultValue $tmpType $enforceRequired $version } } default { ## ## Placed here to shut up tclchecker ## } } } # ::log::log debug "Leaving ::WS::Utils::convertDictToTypeNoNs with xml: [$parent asXML]" return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::convertDictToEncodedType # # Description : Convert a dictionary object into a XML DOM tree with type # encoding. # # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. # dict - The dictionary to convert # type - The name of the type |
︙ | ︙ | |||
1728 1729 1730 1731 1732 1733 1734 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::convertDictToEncodedType {mode service doc parent dict type} { | | > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > | | > > > | > > > | > > > > > > | > > > > > > > > | > | < > > > | > > > > > > | | | > > > > > > > > > > > > > | > | > > > > | | > | | | | 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::convertDictToEncodedType {mode service doc parent dict type} { ::log::logsubst debug {Entering [info level 0]} variable typeInfo variable options set typeInfoList [TypeInfo $mode $service $type] ::log::logsubst debug {\t typeInfoList = {$typeInfoList}} set type [string trimright $type {?}] if {[lindex $typeInfoList 0]} { set itemList [dict get $typeInfo $mode $service $type definition] set xns [dict get $typeInfo $mode $service $type xns] } else { if {[info exists simpleTypes($mode,$service,$type)]} { set xns [dict get $simpleTypes($mode,$service,$type) xns] } else { error "Simple type cannot be found: $type" } set itemList [list $type {type string}] } if {[info exists mutableTypeInfo([list $mode $service $type])]} { set type [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict] set typeInfoList [TypeInfo $mode $service $type] if {[lindex $typeInfoList 0]} { set itemList [dict get $typeInfo $mode $service $type definition] set xns [dict get $typeInfo $mode $service $type xns] } else { if {[info exists simpleTypes($mode,$service,$type)]} { set xns [dict get $simpleTypes($mode,$service,$type) xns] } else { error "Simple type cannot be found: $type" } set itemList [list $type {type string}] } } ::log::logsubst debug {\titemList is {$itemList} in $xns} foreach {itemName itemDef} $itemList { set itemType [string trimright [dict get $itemList $itemName type] {?}] set typeInfoList [TypeInfo $mode $service $itemType] ::log::logsubst debug {\t\t Looking for {$itemName} in {$dict}} if {![dict exists $dict $itemName]} { ::log::log debug "\t\t Not found, skipping" continue } ::log::logsubst debug {\t\t Type info is {$typeInfoList}} switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## if {[string equal $xns $options(suppressNS)]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $xns:$itemName retNode] } if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } $retNode setAttribute xsi:type $attrType set resultValue [dict get $dict $itemName] $retNode appendChild [$doc createTextNode $resultValue] } {0 1} { ## ## Simple array ## set dataList [dict get $dict $itemName] set tmpType [string trimright $itemType {()}] if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } foreach resultValue $dataList { if {[string equal $xns $options(suppressNS)]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $xns:$itemName retNode] } $retNode setAttribute xsi:type $attrType $retNode appendChild [$doc createTextNode $resultValue] } } {1 0} { ## ## Non-simple non-array ## if {[string equal $xns $options(suppressNS)]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $xns:$itemName retNode] } if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } $retNode setAttribute xsi:type $attrType convertDictToEncodedType $mode $service $doc $retNode [dict get $dict $itemName] $itemType } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $itemName] set tmpType [string trimright $itemType {()}] if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } set attrType [string trim $attrType {()?}] $parent setAttribute xmlns:soapenc {http://schemas.xmlsoap.org/soap/encoding/} $parent setAttribute soapenc:arrayType [format {%s[%d]} $attrType [llength $dataList]] $parent setAttribute xsi:type soapenc:Array #set itemName [$parent nodeName] foreach item $dataList { if {[string equal $xns $options(suppressNS)]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $xns:$itemName retNode] } $retNode setAttribute xsi:type $attrType convertDictToEncodedType $mode $service $doc $retNode $item $tmpType } } default { ## ## Placed here to shut up tclchecker ## } } } return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::parseDynamicType # # Description : Parse the schema for a dynamically typed part. # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # node - The base node for the type. # type - The name of the type # # Returns : A dictionary object for a given type. # # Side-Effects : Type definitions added # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # |
︙ | ︙ | |||
1831 1832 1833 1834 1835 1836 1837 | # # ########################################################################### proc ::WS::Utils::parseDynamicType {mode serviceName node type} { variable typeInfo variable nsList | | | | | | | | 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 | # # ########################################################################### proc ::WS::Utils::parseDynamicType {mode serviceName node type} { variable typeInfo variable nsList ::log::logsubst debug {Entering [info level 0]} foreach child [$node childNodes] { ::log::logsubst debug {\t Child $child is [$child nodeName]} } ## ## Get type being defined ## set schemeNode [$node selectNodes -namespaces $nsList xs:schema] set newTypeNode [$node selectNodes -namespaces $nsList xs:schema/xs:element] set newTypeName [lindex [split [$newTypeNode getAttribute name] :] end] ## ## Get sibling node to scheme and add tempory type definitions ## ## type == sibing of temp type ## temp_type == newType of newType ## set tnsCountVar [llength [dict get $::WS::Client::serviceArr($serviceName) targetNamespace]] set tns tns$tnsCountVar set dataNode {} $schemeNode nextSibling dataNode if {![info exists dataNode] || ![string length $dataNode]} { $schemeNode previousSibling dataNode } set dataNodeNameList [split [$dataNode nodeName] :] set dataTnsName [lindex $dataNodeNameList 0] set dataNodeName [lindex $dataNodeNameList end] set tempTypeName 1_temp_type dict set typeInfo $mode $serviceName $tempTypeName [list xns $tns definition [list $newTypeName [list type $newTypeName comment {}]]] dict set typeInfo $mode $serviceName $type [list xns $dataTnsName definition [list $dataNodeName [list type $tempTypeName comment {}]]] ## ## Parse the Scheme --gwl ## parseScheme $mode {} $schemeNode $serviceName typeInfo tnsCountVar ## ## All done ## return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
1918 1919 1920 1921 1922 1923 1924 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseScheme {mode baseUrl schemaNode serviceName serviceInfoVar tnsCountVar} { | | | | > < < < < < < < < > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > | > > > > > > > | > > | < | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | < < < | < < < < < | < < | < < < < < < < < < | < < < < < < < < < < < < < < < | < < < < < < < < < < < < | | < < | < < < < < < < < < < < < < < < < < < < < < | 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseScheme {mode baseUrl schemaNode serviceName serviceInfoVar tnsCountVar} { ::log::logsubst debug {Entering [info level 0]} upvar 1 $tnsCountVar tnsCount upvar 1 $serviceInfoVar serviceInfo variable currentSchema variable nsList variable options variable unknownRef set currentSchema $schemaNode set tmpTargetNs $::WS::Utils::targetNs foreach attr [$schemaNode attributes] { set value {?} catch {set value [$schemaNode getAttribute $attr]} ::log::logsubst debug {Attribute $attr = $value} } if {[$schemaNode hasAttribute targetNamespace]} { set xns [$schemaNode getAttribute targetNamespace] ::log::logsubst debug {In Parse Scheme, found targetNamespace attribute with {$xns}} set ::WS::Utils::targetNs $xns } else { set xns $::WS::Utils::targetNs } ::log::logsubst debug {@3a {$xns} {[dict get $serviceInfo tnsList url]}} if {![dict exists $serviceInfo tnsList url $xns]} { set tns [format {tns%d} [incr tnsCount]] dict set serviceInfo targetNamespace $tns $xns dict set serviceInfo tnsList url $xns $tns dict set serviceInfo tnsList tns $tns $tns } else { set tns [dict get $serviceInfo tnsList url $xns] } ::log::logsubst debug {@3 TNS count for $xns is $tnsCount {$tns}} set prevTnsDict [dict get $serviceInfo tnsList tns] dict set serviceInfo tns {} foreach itemList [$schemaNode attributes xmlns:*] { set ns [lindex $itemList 0] set url [$schemaNode getAttribute xmlns:$ns] if {[dict exists $serviceInfo tnsList url $url]} { set tmptns [dict get $serviceInfo tnsList url $url] } else { ## ## Check for hardcoded namespaces ## switch -exact -- $url { http://schemas.xmlsoap.org/wsdl/ { set tmptns w } http://schemas.xmlsoap.org/wsdl/soap/ { set tmptns d } http://www.w3.org/2001/XMLSchema { set tmptns xs } default { set tmptns tns[incr tnsCount] } } dict set serviceInfo tnsList url $url $tmptns } dict set serviceInfo tnsList tns $ns $tmptns } ## ## Process the scheme in multiple passes to handle forward references and extensions ## set pass 1 set lastUnknownRefCount 0 array unset unknownRef while {($pass == 1) || ($lastUnknownRefCount != [array size unknownRef])} { ::log::logsubst debug {Pass $pass over schema} incr pass set lastUnknownRefCount [array size unknownRef] array unset unknownRef foreach element [$schemaNode selectNodes -namespaces $nsList xs:import] { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { ::log::logsubst notice {Import failed due to: {$msg}. Trace: $::errorInfo} } } foreach element [$schemaNode selectNodes -namespaces $nsList w:import] { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { ::log::logsubst notice {Import failed due to: {$msg}. Trace: $::errorInfo} } } ::log::logsubst debug {Parsing Element types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:element] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} } } ::log::logsubst debug {Parsing Attribute types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:attribute] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} } } ::log::logsubst debug {Parsing Simple types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:simpleType] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} } } ::log::logsubst debug {Parsing Complex types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:complexType] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} } } } set lastUnknownRefCount [array size unknownRef] foreach {unkRef usedByTypeList} [array get unknownRef] { foreach usedByType $usedByTypeList { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Unknown type reference $unkRef in type $usedByType} } error - default { ::log::logsubst error {Unknown type reference $unkRef in type $usedByType} } } } } if {$lastUnknownRefCount} { switch -exact -- $options(StrictMode) { debug - warning { set ::WS::Utils::targetNs $tmpTargetNs ::log::logsubst $options(StrictMode) {Found $lastUnknownRefCount forward type references: [join [array names unknownRef] {,}]} } error - default { set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode [list WS $mode UNKREFS [list $lastUnknownRefCount]] \ "Found $lastUnknownRefCount forward type references: [join [array names unknownRef] {,}]" } } } ## ## Ok, one more pass to report errors ## set importNodeList [concat \ [$schemaNode selectNodes -namespaces $nsList xs:import] \ [$schemaNode selectNodes -namespaces $nsList w:import] \ ] foreach element $importNodeList { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::logsubst debug {Parsing Element types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:element] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t last element: $::elementName} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::logsubst debug {Parsing Attribute types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:attribute] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} ::log::logsubst error {\t last element: $::elementName} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::logsubst debug {Parsing Simple types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:simpleType] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::logsubst debug {Parsing Complex types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:complexType] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } set ::WS::Utils::targetNs $tmpTargetNs ::log::logsubst debug {Leaving :WS::Utils::parseScheme $mode $baseUrl $schemaNode $serviceName $serviceInfoVar $tnsCountVar} ::log::logsubst debug {Target NS is now: $::WS::Utils::targetNs} dict set serviceInfo tnsList tns $prevTnsDict } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # |
︙ | ︙ | |||
2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 | # 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::Utils::processImport {mode baseUrl importNode serviceName serviceInfoVar tnsCountVar} { | > > > | | > > | < < | | | < | | | | | | > > > | > > > > > > > > | | > > > > > > > > > > > > > > > > > | > | > > < > > > | | > > < | < | > | | < < | > > > > > > > > > > > > | 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 | # 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 # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # 3.1.0 2020-11-06 H.Oehlmann Access namespace variable redirectArray # via variable command # # ########################################################################### proc ::WS::Utils::processImport {mode baseUrl importNode serviceName serviceInfoVar tnsCountVar} { upvar 1 $serviceInfoVar serviceInfo upvar 1 $tnsCountVar tnsCount variable currentSchema variable importedXref variable options variable redirectArray ::log::logsubst debug {Entering [info level 0]} ## ## Get the xml ## set attrName schemaLocation if {![$importNode hasAttribute $attrName]} { set attrName namespace if {![$importNode hasAttribute $attrName]} { ::log::log debug "\t No schema location, existing" return \ -code error \ -errorcode [list WS CLIENT MISSCHLOC $baseUrl] \ "Missing Schema Location in '$baseUrl'" } } set urlTail [$importNode getAttribute $attrName] set url [::uri::resolve $baseUrl $urlTail] ::log::logsubst debug {Including $url} set lastPos [string last / $url] set testUrl [string range $url 0 [expr {$lastPos - 1}]] if { [info exists redirectArray($testUrl)] } { set newUrl $redirectArray($testUrl) append newUrl [string range $url $lastPos end] ::log::logsubst debug {newUrl = $newUrl} set url $newUrl } ::log::logsubst debug {\t Importing {$url}} ## ## Skip "known" namespace ## switch -exact -- $url { http://schemas.xmlsoap.org/wsdl/ - http://schemas.xmlsoap.org/wsdl/soap/ - http://www.w3.org/2001/XMLSchema { return } default { ## ## Do nothing ## } } ## ## Short-circuit infinite loop on inports ## if { [info exists importedXref($mode,$serviceName,$url)] } { ::log::logsubst debug {$mode,$serviceName,$url was already imported: $importedXref($mode,$serviceName,$url)} return } dict lappend serviceInfo imports $url set importedXref($mode,$serviceName,$url) [list $mode $serviceName $tnsCount] set urlScheme [dict get [::uri::split $url] scheme] ::log::logsubst debug {URL Scheme of {$url} is {$urlScheme}} switch -exact -- $urlScheme { file { ::log::logsubst debug {In file processor -- {$urlTail}} set fn [file join $options(includeDirectory) [string range $urlTail 8 end]] set ifd [open $fn r] set xml [read $ifd] close $ifd ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar } https - http { ::log::log debug "In http/https processor" set ncode -1 set token [geturl_followRedirects $url -timeout $options(queryTimeout)] set ncode [::http::ncode $token] ::log::log debug "returned code {$ncode}" set xml [::http::data $token] ::http::cleanup $token if {($ncode != 200) && [string equal $options(includeDirectory) {}]} { return \ -code error \ -errorcode [list WS CLIENT HTTPFAIL $url $ncode] \ "HTTP get of import file failed '$url'" } elseif {($ncode == 200) && ![string equal $options(includeDirectory) {}]} { set fn [file join $options(includeDirectory) [file tail $urlTail]] ::log::logsubst info {Could not access $url -- using $fn} set ifd [open $fn r] set xml [read $ifd] close $ifd } if {[catch {ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar} err]} { ::log::logsubst info {Error during processing of XML: $err} #puts stderr "error Info: $::errorInfo" } else { #puts stderr "import successful" } } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" |
︙ | ︙ | |||
2202 2203 2204 2205 2206 2207 2208 | # # Procedure Name : ::WS::Utils::parseComplexType # # Description : Parse a complex type declaration from the Schema into our # internal representation # # Arguments : | | | | 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 | # # Procedure Name : ::WS::Utils::parseComplexType # # Description : Parse a complex type declaration from the Schema into our # internal representation # # Arguments : # dictVar - The name of the results dictionary # serviceName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # # Side-Effects : Defines mode type as specified by the Schema # |
︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseComplexType {mode dictVar serviceName node tns} { | | > > | > > | > > > > > > > > > > | | > | | | < | > > > > > > | | > | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | | | | | > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | | | < | | | < | > | > > > | | | > > > > > > > > > > > > > > | | | > > | | > > | > > > > > > > > > > > > > | > > > > > | | | | 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 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 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseComplexType {mode dictVar serviceName node tns} { upvar 1 $dictVar results variable currentSchema variable nsList variable unknownRef variable defaultType ::log::logsubst debug {Entering [info level 0]} set isAbstractType false set defaultType string set typeName $tns:[$node getAttribute name] ::log::logsubst debug {Complex Type is $typeName} if {[$node hasAttribute abstract]} { set isAbstractType [$node getAttribute abstract] ::log::logsubst debug {\t Abstract type = $isAbstractType} } #if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $typeName]]} { # ::log::log debug "\t Type $typeName is already defined -- leaving" # return #} set partList {} set nodeFound 0 array set attrArr {} set comment {} set middleNodeList [$node childNodes] foreach middleNode $middleNodeList { set commentNodeList [$middleNode selectNodes -namespaces $nsList xs:annotation] if {[llength $commentNodeList]} { set commentNode [lindex $commentNodeList 0] set comment [string trim [$commentNode asText]] } set middle [$middleNode localName] ::log::logsubst debug {Complex Type is $typeName, middle is $middle} #if {$isAbstractType && [string equal $middle attribute]} { # ## # ## Abstract type, so treat like an element # ## # set middle element #} switch -exact -- $middle { attribute - annotation { ## ## Do nothing ## continue } element { set nodeFound 1 if {[$middleNode hasAttribute ref]} { set partType [$middleNode getAttribute ref] ::log::logsubst debug {\t\t has a ref of {$partType}} if {[catch { set refTypeInfo [split $partType {:}] set partName [lindex $refTypeInfo end] 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] } } } extension { #set baseName [lindex [split [$middleNode getAttribute base] {:}] end] set tmp [partList $mode $middleNode $serviceName results $tns] if {[llength $tmp]} { set nodeFound 1 set partList [concat $partList $tmp] } } choice - sequence - all { # set elementList [$middleNode selectNodes -namespaces $nsList xs:element] set partMax [$middleNode getAttribute maxOccurs 1] set tmp [partList $mode $middleNode $serviceName results $tns $partMax] if {[llength $tmp]} { ::log::logsubst debug {\tadding {$tmp} to partslist} set nodeFound 1 set partList [concat $partList $tmp] } elseif {!$nodeFound} { ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base string comment $comment] $tns return } # simpleType { # $middleNode setAttribute name [$node getAttribute name] # parseSimpleType $mode results $serviceName $middleNode $tns # return # } } complexType { $middleNode setAttribute name $typeName parseComplexType $mode results $serviceName $middleNode $tns } simpleContent - complexContent { ## ## Save simple or complex content for abstract types, which ## may have content type with no fields. [Bug 584bfb77] ## Example xml type snippet: ## <xs:complexType name="Envelope" abstract="true"> ## <xs:annotation><xs:documentation /></xs:annotation> ## <xs:complexContent mixed="false"> ## <xs:extension base="Geometry" /> ## </xs:complexContent> ## </xs:complexType> ## ... ## <xs:complexType name="Geometry"> ## <xs:annotation><xs:documentation /></xs:annotation> ## </xs:complexType> set isComplexContent [expr {$middle eq "complexContent"}] ::log::logsubst debug {isComplexContent = $isComplexContent} ## ## Loop over the components of the type ## foreach child [$middleNode childNodes] { set parent [$child parent] set contentType [$child localName] ::log::logsubst debug {Content Type is {$contentType}} switch -exact -- $contentType { restriction { set nodeFound 1 set restriction $child set element [$child selectNodes -namespaces $nsList xs:attribute] set typeInfoList [list baseType [$restriction getAttribute base]] array unset attrArr foreach attr [$element attributes] { if {[llength $attr] > 1} { set name [lindex $attr 0] set ref [lindex $attr 1]:[lindex $attr 0] } else { set name $attr set ref $attr } catch {set attrArr($name) [$element getAttribute $ref]} } set partName item set partType [getQualifiedType $results $attrArr(arrayType) $tns] set partType [string map {{[]} {()}} $partType] lappend partList $partName [list type [string trimright ${partType} {()?}]() comment $comment allowAny 1] set nodeFound 1 } extension { ::log::logsubst debug {Calling partList for $contentType of $typeName} if {[catch {set tmp [partList $mode $child $serviceName results $tns]} msg]} { ::log::logsubst debug {Error in partList {$msg}, errorInfo: $errorInfo} } ::log::logsubst debug {partList for $contentType of $typeName is {$tmp}} if {[llength $tmp] && ![string equal [lindex $tmp 0] {}]} { set nodeFound 1 set partList [concat $partList $tmp] } elseif {[llength $tmp]} { ## ## Found extension, but it is an empty type ## } else { ::log::log debug "Unknown extension!" return } } default { ## ## Placed here to shut up tclchecker ## } } } } restriction { if {!$nodeFound} { parseSimpleType $mode results $serviceName $node $tns return } } default { if {!$nodeFound} { parseElementalType $mode results $serviceName $node $tns return } } } } ::log::logsubst debug {at end of foreach {$typeName} with {$partList}} if {[llength $partList] || $isAbstractType} { #dict set results types $tns:$typeName $partList dict set results types $typeName $partList ::log::logsubst debug {Defining $typeName as '$partList'} ## ## Add complex type definition, if: ## * there is a part list ## * or it is an abstract type announced as complex ## (see xml snipped above about [Bug 584bfb77]) ## -> will set dict typeInfo client $service tns1:envelope { ## definition {} xns tns1 abstract true} ## if { ([llength $partList] && ![string equal [lindex $partList 0] {}]) || ($isAbstractType && [info exists isComplexContent] && $isComplexContent) } { ::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns $isAbstractType } else { ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base $defaultType comment {}] $tns } } elseif {!$nodeFound} { #puts "Defined $typeName as simple type" #::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns $isAbstractType ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base $defaultType comment {}] $tns } else { set xml [string trim [$node asXML]] return \ -code error \ -errorcode [list WS $mode BADCPXTYPDEF [list $typeName $xml]] \ "Bad complex type definition for '$typeName' :: '$xml'" } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::partList # # Description : Parse the list of parts of a type definition from the Schema into our # internal representation # # Arguments : # dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # # Side-Effects : Defines mode type as specified by the Schema |
︙ | ︙ | |||
2400 2401 2402 2403 2404 2405 2406 2407 | # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::partList {mode node serviceName dictVar tns {occurs {}}} { variable currentSchema variable nsList | > > > > | | | | > > > > > | | | < | > > | | | | > > > > > > > > > > > > > | | | > > > > | > > > > > > | | | | | > > > > > > > | | | | | | > > > > > | | | | | | > > > > > > > > | | 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 | # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::partList {mode node serviceName dictVar tns {occurs {}}} { variable currentSchema variable unknownRef variable nsList variable defaultType variable options variable simpleTypes upvar 1 $dictVar results set partList {} set middle [$node localName] ::log::logsubst debug {Entering [info level 0] -- for $middle} switch -exact -- $middle { anyAttribute - attribute { ## ## 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 baseNodeType [$baseNode localName] switch -exact -- $baseNodeType { complexType { parseComplexType $mode results $serviceName $baseNode $tns } element { parseElementalType $mode results $serviceName $baseNode $tns } simpleType { parseSimpleType $mode results $serviceName $baseNode $tns } default { ## ## Placed here to shut up tclchecker ## } } } set baseInfo [GetServiceTypeDef $mode $serviceName $baseName] ::log::logsubst debug {\t baseInfo is {$baseInfo}} if {[llength $baseInfo] == 0} { ::log::logsubst debug {\t Unknown reference '$baseName'} set unknownRef($baseName) 1 return } catch {set partList [concat $partList [dict get $baseInfo definition]]} } else { ::log::logsubst debug {\t Simple type} } foreach elementNode [$node childNodes] { set tmp [partList $mode $elementNode $serviceName results $tns] if {[llength $tmp]} { set partList [concat $partList $tmp] } } } choice - sequence - all { set elementList [$node selectNodes -namespaces $nsList xs:element] set elementsFound 0 ::log::logsubst debug {\telement list is {$elementList}} foreach element $elementList { ::log::logsubst debug {\t\tprocessing $element ([$element nodeName])} set comment {} set additional_defininition_elements {} if {[catch { set elementsFound 1 set attrName name set isRef 0 if {![$element hasAttribute name]} { set attrName ref set isRef 1 } set partName [$element getAttribute $attrName] if {$isRef} { set partType {} set partTypeInfo {} set partType [string trimright [getQualifiedType $results $partName $tns] {?}] set partTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType] set partName [lindex [split $partName {:}] end] ::log::logsubst debug {\t\t\t part name is {$partName} type is {$partTypeInfo}} if {[dict exists $partTypeInfo definition $partName]} { set partType [dict get $partTypeInfo definition $partName type] } ::log::logsubst debug {\t\t\t part name is {$partName} type is {$partType}} } else { ## ## See if really a complex definition ## if {[$element hasChildNodes]} { set isComplex 0; set isSimple 0 foreach child [$element childNodes] { switch -exact -- [$child localName] { annotation {set comment [string trim [$child asText]]} simpleType {set isSimple 1} default {set isComplex 1} } } if {$isComplex} { set partType $partName parseComplexType $mode results $serviceName $element $tns } elseif {$isSimple} { 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 } } else { set partMax [$element getAttribute maxOccurs 1] } if {$partMax <= 1} { lappend partList $partName [concat [list type $partType comment $comment] $additional_defininition_elements] } else { lappend partList $partName [concat [list type [string trimright ${partType} {()?}]() comment $comment] $additional_defininition_elements] } } msg]} { ::log::logsubst error {\tError processing {$msg} for [$element asXML]} if {$isRef} { ::log::log error "\t\t Was a reference. Additionally information is:" ::log::logsubst error {\t\t\t part name is {$partName} type is {$partType} with {$partTypeInfo}} } } } if {!$elementsFound} { set defaultType $options(anyType) return } } complexContent { set contentType [[$node childNodes] localName] switch -exact -- $contentType { restriction { set restriction [$node selectNodes -namespaces $nsList xs:restriction] set element [$node selectNodes -namespaces $nsList xs:restriction/xs:attribute] set typeInfoList [list baseType [$restriction getAttribute base]] array unset attrArr foreach attr [$element attributes] { if {[llength $attr] > 1} { set name [lindex $attr 0] set ref [lindex $attr 1]:[lindex $attr 0] } else { set name $attr set ref $attr } catch {set attrArr($name) [$element getAttribute $ref]} } set partName item set partType [getQualifiedType $results $attrArr(arrayType) $tns] set partType [string map {{[]} {()}} $partType] set partList [list $partName [list type [string trimright ${partType} {()?}]() comment {} allowAny 1]] } extension { set extension [$node selectNodes -namespaces $nsList xs:extension] set partList [partList $mode $extension $serviceName results $tns] } default { ## ## Placed here to shut up tclchecker ## } } } simpleContent { foreach elementNode [$node childNodes] { set tmp [partList $mode $elementNode $serviceName results $tns] if {[llength $tmp]} { set partList [concat $partList $tmp] } } } restriction { parseSimpleType $mode results $serviceName $node $tns return } default { parseElementalType $mode results $serviceName $node $tns return } } if {[llength $partList] == 0} { set partList {{}} } return $partList } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::parseElementalType # # Description : Parse an elemental type declaration from the Schema into our # internal representation # # Arguments : # dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # # Side-Effects : Defines mode type as specified by the Schema |
︙ | ︙ | |||
2606 2607 2608 2609 2610 2611 2612 | # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseElementalType {mode dictVar serviceName node tns} { | | > | > > > > | | > > > > > > | | > | | > > | > | | > > > > > > | < < < | | < | < < > > > | > > > > | < > > > | > > | | < > > > | | > > > > > > > > > | | > | > > > | | | > > | | | > > > | | | | | | > > > > > > > > > > | > | | | < | | | | > > | | | 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 | # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseElementalType {mode dictVar serviceName node tns} { upvar 1 $dictVar results variable importedXref variable nsList variable unknownRef ::log::logsubst debug {Entering [info level 0]} set attributeName name if {![$node hasAttribute $attributeName]} { set attributeName ref } 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] ::log::logsubst debug {\t Abstract type = $isAbstractType} } set elements [$node selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element] ::log::logsubst debug {\t element list is {$elements} partList {$partList}} foreach element $elements { set ::elementName [$element asXML] ::log::logsubst debug {\t\t Processing element {[$element nodeName]}} set elementsFound 1 set typeAttribute "" if {[$element hasAttribute ref]} { set partType [$element getAttribute ref] ::log::logsubst debug {\t\t has a ref of {$partType}} if {[catch { set refTypeInfo [split $partType {:}] set partName [lindex $refTypeInfo end] 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] log::logsubst debug {looking up ref {$partType} got {$refTypeInfo}} if {![llength $refTypeInfo]} { error "lookup failed" } if {[dict exists $refTypeInfo definition]} { 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] } if {[dict exists $refTypeInfo $partName type]} { set partType [getQualifiedType $results [dict get $refTypeInfo $partName type] $tns] } else { ## ## Not a simple element, so point type to type of same name as element ## set partType [getQualifiedType $results $partName $tns] } } } msg]} { lappend unknownRef($partType) $typeName log::logsubst debug {Unknown ref {$partType,$typeName} error: {$msg} trace: $::errorInfo} return \ -code error \ -errorcode [list WS $mode UNKREF [list $typeName $partType]] \ "Unknown forward type reference {$partType} in {$typeName}" } } else { ::log::logsubst debug {\t\t\t has no ref has {[$element attributes]}} 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] ::log::logsubst debug {\t\t\t part is {$partName} {$partType} {$partMax}} if {[string equal $partMax -1]} { set partMax [[$element parent] getAttribute maxOccurs -1] } if {$partMax <= 1} { lappend partList $partName [list type $partType comment {}] } else { lappend partList $partName [list type [string trimright ${partType} {()?}]() comment {}] } } if {[llength $elements] == 0} { # # Validate this is not really a complex or simple type # set childList [$node childNodes] foreach childNode $childList { if {[catch {$childNode setAttribute name $typeName}]} { continue } set childNodeType [$childNode localName] switch -exact -- $childNodeType { complexType { parseComplexType $mode results $serviceName $childNode $tns return } element { parseElementalType $mode results $serviceName $childNode $tns return } simpleType { parseSimpleType $mode results $serviceName $childNode $tns return } default { ## ## 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 ## if {([lindex [TypeInfo $mode $serviceName $partType] 0] == 0) && [string equal $tns:$typeName $partType]} { return } else { lappend partList $typeName [list type $partType comment {}] } } else { lappend partList $typeName [list type [string trimright ${partType} {()?}]() comment {}] } } if {[llength $partList]} { ::WS::Utils::ServiceTypeDef $mode $serviceName $tns:$typeName $partList $tns $isAbstractType } else { if {![dict exists $results types $tns:$typeName]} { set partList [list base string comment {} xns $tns] ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $tns:$typeName $partList $tns dict set results simpletypes $tns:$typeName $partList } } dict set results elements $tns:$typeName 1 ::log::log debug "\t returning" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::parseSimpleType # # Description : Parse a simple type declaration from the Schema into our # internal representation # # Arguments : # dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # # Side-Effects : Defines mode type as specified by the Schema |
︙ | ︙ | |||
2774 2775 2776 2777 2778 2779 2780 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseSimpleType {mode dictVar serviceName node tns} { | | | > > > > | > > > > | | > > > > > > > > > > | > | | | | > > | > | 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseSimpleType {mode dictVar serviceName node tns} { upvar 1 $dictVar results variable nsList ::log::logsubst debug {Entering [info level 0]} set typeName [$node getAttribute name] if {$typeName in {SAP_VALID_FROM}} { set foo 1 } set isList no ::log::logsubst debug {Simple Type is $typeName} if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $tns:$typeName]]} { ::log::logsubst debug {\t Type $tns:$typeName is already defined -- leaving} return } #puts "Simple Type is $typeName" set restrictionNode [$node selectNodes -namespaces $nsList xs:restriction] if {[string equal $restrictionNode {}]} { set restrictionNode [$node selectNodes -namespaces $nsList xs:simpleType/xs:restriction] } if {[string equal $restrictionNode {}]} { set restrictionNode [$node selectNodes -namespaces $nsList xs:list/xs:simpleType/xs:restriction] } if {[string equal $restrictionNode {}]} { set restrictionNode [$node selectNodes -namespaces $nsList xs:list] set isList yes } if {[string equal $restrictionNode {}]} { set xml [string trim [$node asXML]] return \ -code error \ -errorcode [list WS $mode BADSMPTYPDEF [list $typeName $xml]] \ "Bad simple type definition for '$typeName' :: \n'$xml'" } if {$isList} { set baseType [lindex [split [$restrictionNode getAttribute itemType] {:}] end] } else { set baseType [lindex [split [$restrictionNode getAttribute base] {:}] end] } set partList [list baseType $baseType xns $tns isList $isList] set enumList {} foreach item [$restrictionNode childNodes] { set itemName [$item localName] set value [$item getAttribute value] #puts "\t Item {$itemName} = {$value}" if {[string equal $itemName {enumeration}]} { lappend enumList $value } else { lappend partList $itemName $value } if {[$item hasAttribute fixed]} { lappend partList fixed [$item getAttribute fixed] } } if {[llength $enumList]} { lappend partList enumeration $enumList } if {![dict exists $results types $tns:$typeName]} { ServiceSimpleTypeDef $mode $serviceName $tns:$typeName $partList $tns dict set results simpletypes $tns:$typeName $partList } else { ::log::logsubst debug {\t type already exists as $tns:$typeName} } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # |
︙ | ︙ | |||
2871 2872 2873 2874 2875 2876 2877 | ## set result 1 ## ## Get the type information ## set typeInfoList [TypeInfo $mode $serviceName $typeName] | | > | 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 | ## set result 1 ## ## Get the type information ## set typeInfoList [TypeInfo $mode $serviceName $typeName] set baseTypeName [string trimright $typeName {()?}] set typeName [string trimright $typeName {?}] set typeInfo [GetServiceTypeDef $mode $serviceName $baseTypeName] set isComplex [lindex $typeInfoList 0] set isArray [lindex $typeInfoList 1] if {$isComplex} { ## ## Is complex |
︙ | ︙ | |||
2899 2900 2901 2902 2903 2904 2905 | array unset fieldInfoArr set fieldInfoArr(minOccurs) 0 array set fieldInfoArr $fieldDef if {$fieldInfoArr(minOccurs) && ![info exists fieldInfoArr($field)]} { ## ## Fields was required but is missing ## | | | | 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 | array unset fieldInfoArr set fieldInfoArr(minOccurs) 0 array set fieldInfoArr $fieldDef if {$fieldInfoArr(minOccurs) && ![info exists fieldInfoArr($field)]} { ## ## Fields was required but is missing ## set ::errorCode [list WS CHECK MISSREQFLD [list $typeName $field]] set result 0 } elseif {$fieldInfoArr(minOccurs) && ($fieldInfoArr(minOccurs) > [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but not enough times ## set ::errorCode [list WS CHECK MINOCCUR [list $type $field]] set result 0 } elseif {[info exists fieldInfoArr(maxOccurs)] && [string is integer fieldInfoArr(maxOccurs)] && ($fieldInfoArr(maxOccurs) < [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but too many times ## set ::errorCode [list WS CHECK MAXOCCUR [list $typeName $field]] set result 0 } elseif {[info exists fieldInfoArr($field)]} { foreach node $fieldInfoArr($field) { set result [checkTags $mode $serviceName $node $fieldInfoArr(type)] if {!$result} { break } |
︙ | ︙ | |||
2939 2940 2941 2942 2943 2944 2945 | set value [$currNode asText] set result [checkValue $mode $serviceName $baseTypeName $value] } return $result } | | > | 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 | set value [$currNode asText] set result [checkValue $mode $serviceName $baseTypeName $value] } return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # |
︙ | ︙ | |||
2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 | set result 0 array set typeInfos { minLength 0 maxLength -1 fixed false } array set typeInfos [GetServiceTypeDef $mode $serviceName $type] foreach {var value} [array get typeInfos] { set $var $value } set result 1 if {$minLength >= 0 && [string length $value] < $minLength} { | > | | | | | | > | 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 | set result 0 array set typeInfos { minLength 0 maxLength -1 fixed false } # returns indexes type, xns, ... array set typeInfos [GetServiceTypeDef $mode $serviceName $type] foreach {var value} [array get typeInfos] { set $var $value } set result 1 if {$minLength >= 0 && [string length $value] < $minLength} { set ::errorCode [list WS CHECK VALUE_TO_SHORT [list $type $value $minLength $typeInfo]] set result 0 } elseif {$maxLength >= 0 && [string length $value] > $maxLength} { set ::errorCode [list WS CHECK VALUE_TO_LONG [list $type $value $maxLength $typeInfo]] set result 0 } elseif {[info exists enumeration] && ([lsearch -exact $enumeration $value] == -1)} { set errorCode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $type $value $enumeration $typeInfo]] set result 0 } elseif {[info exists pattern] && (![regexp -- $pattern $value])} { set errorCode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $type $value $pattern $typeInfo]] set result 0 } return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # |
︙ | ︙ | |||
3057 3058 3059 3060 3061 3062 3063 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to generate qualified XML # ########################################################################### proc ::WS::Utils::buildTags {mode serviceName typeName valueInfos doc currentNode} { | | | > | | | 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to generate qualified XML # ########################################################################### proc ::WS::Utils::buildTags {mode serviceName typeName valueInfos doc currentNode} { upvar 1 $valueInfos values ## ## Get the type information ## set baseTypeName [string trimright $typeName {()?}] set typeInfo [GetServiceTypeDef $mode $serviceName $baseTypeName] set typeName [string trimright $typeName {?}] set xns [dict get $typeInfo $mode $serviceName $typeName xns] foreach {field fieldDef} [dict get $typeInfo definition] { ## ## Get info about this field and its type ## array unset fieldInfoArr set fieldInfoArr(minOccurs) 0 array set fieldInfoArr $fieldDef set typeInfoList [TypeInfo $mode $serviceName $fieldInfoArr(type)] set fieldBaseType [string trimright $fieldInfoArr(type) {()?}] set isComplex [lindex $typeInfoList 0] set isArray [lindex $typeInfoList 1] if {[dict exists $valueInfos $field]} { if {$isArray} { set valueList [dict get $valueInfos $field] } else { set valueList [list [dict get $valueInfos $field]] |
︙ | ︙ | |||
3112 3113 3114 3115 3116 3117 3118 | [string is integer fieldInfoArr(maxOccurs)] && ($fieldInfoArr(maxOccurs) < $valueListLenght)} { ## ## Fields was required and present, but too many times ## set minOccurs $fieldInfoArr(maxOccurs) return \ | | | > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 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 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 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 | [string is integer fieldInfoArr(maxOccurs)] && ($fieldInfoArr(maxOccurs) < $valueListLenght)} { ## ## Fields was required and present, but too many times ## set minOccurs $fieldInfoArr(maxOccurs) return \ -errorcode [list WS CHECK MAXOCCUR [list $typeName $field]] \ "Field '$field' of type '$typeName' could only occur $minOccurs time(s) but occured $valueListLenght time(s)" } elseif {[dict exists $valueInfos $field]} { foreach value $valueList { $currentNode appendChild [$doc createElement $xns:$field retNode] if {$isComplex} { buildTags $mode $serviceName $fieldBaseType $value $doc $retNode } else { if {[info exists fieldInfoArr(enumeration)] && [info exists fieldInfoArr(fixed)] && $fieldInfoArr(fixed)} { set value [lindex $fieldInfoArr(enumeration) 0] } if {[checkValue $mode $serviceName $fieldBaseType $value]} { $retNode appendChild [$doc createTextNode $value] } else { set msg "Field '$field' of type '$typeName' " switch -exact -- [lindex $::errorCode 2] { VALUE_TO_SHORT { append msg "value required to be $fieldInfoArr(minLength) long but is only [string length $value] long" } VALUE_TO_LONG { append msg "value allowed to be only $fieldInfoArr(minLength) long but is [string length $value] long" } VALUE_NOT_IN_ENUMERATION { append msg "value '$value' not in ([join $fieldInfoArr(enumeration) {, }])" } VALUE_NOT_MATCHES_PATTERN { append msg "value '$value' does not match pattern: $fieldInfoArr(pattern)" } default { ## ## Placed here to shut up tclchecker ## } } return \ -errorcode $::errorCode \ $msg } } } } } } ########################################################################### # # 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 # # Pre-requisite Conditions : None # # Original Author : Gerald Lester # #>>END PRIVATE<< # # 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} { # No namespace prefix given - use current prefix 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: # <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"> # - plus ":ArrayOfSomething" if {$node ne {}} { set attr xmlns:$tmpTns if {[$node hasAttribute $attr]} { # There is a node-local attribute (Example: xmlns:x1) giving the node namespace set xmlns [$node getAttribute $attr] if {[dict exists $serviceInfo tnsList url $xmlns]} { set result [dict get $serviceInfo tnsList url $xmlns]:$tmpType ::log::logsubst debug {Got global qualified type '$result' from node-local qualified namespace '$xmlns'} return $result } else { # The node namespace (Ex: http://foo.org/bar) was not found as global prefix. # Thus, the type is refused. # HaO 2018-11-05 Opinion: # Continuing here is IMHO not an option, as the prefix (Ex: x1) might have a # different namespace on the global level which would lead to a misassignment. # # One day, we may support cascading namespace prefixes. Then, we may define # the namespace here set errMsg "Node local namespace URI '$xmlns' not found for type: '$type'" ::log::log error $errMsg return -code error $errMsg } # 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}} return -code error "Namespace prefix of type '$type' not found." } } return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::GenerateTemplateDict # # Description : Generate a template dictionary object for # a given type. # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # type - The name of the type # arraySize - Number of elements to generate in an array. Default is 2 # # Returns : A dictionary object for a given type. If any circular references # exist, they will have the value of <** Circular Reference **> # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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::Utils::GenerateTemplateDict {mode serviceName type {arraySize 2}} { variable generatedTypes ::log::logsubst debug {Entering [info level 0]} unset -nocomplain -- generatedTypes set result [_generateTemplateDict $mode $serviceName $type $arraySize] unset -nocomplain -- generatedTypes ::log::logsubst debug {Leaving [info level 0] with {$result}} return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::_generateTemplateDict # # Description : Private procedure to generate a template dictionary. This needs # setup work done by ::WS::Utils::GnerateTemplateDict # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # type - The name of the type # arraySize - Number of elements to generate in an array. # # Returns : A dictionary object for a given type. If any circular references # exist, they will have the value of <** Circular Reference **> # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PRIVATE<< # # 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::Utils::_generateTemplateDict {mode serviceName type arraySize {xns {}}} { variable typeInfo variable mutableTypeInfo variable options variable generatedTypes ::log::logsubst debug {Entering [info level 0]} set results {} ## ## Check for circular reference ## if {[info exists generatedTypes([list $mode $serviceName $type])]} { set results {<** Circular Reference **>} ::log::logsubst debug {Leaving [info level 0] with {$results}} return $results } else { set generatedTypes([list $mode $serviceName $type]) 1 } set type [string trimright $type {?}] # set typeDefInfo [dict get $typeInfo $mode $serviceName $type] set typeDefInfo [GetServiceTypeDef $mode $serviceName $type] if {![llength $typeDefInfo]} { ## We failed to locate the type. try with the last known xns... set typeDefInfo [GetServiceTypeDef $mode $serviceName ${xns}:$type] } ::log::logsubst debug {\t type def = {$typeDefInfo}} set xns [dict get $typeDefInfo xns] ## ## Check for mutable type ## if {[info exists mutableTypeInfo([list $mode $serviceName $type])]} { set results {<** Mutable Type **>} ::log::logsubst debug {Leaving [info level 0] with {$results}} return $results } if {![dict exists $typeDefInfo definition]} { ## This is a simple type, simulate a type definition... if {![dict exists $typeDefInfo type]} { if {[dict exists $typeDefInfo baseType]} { dict set typeDefInfo type [dict get $typeDefInfo baseType] } else { dict set typeDefInfo type xs:string } } set typeDefInfo [dict create definition [dict create $type $typeDefInfo]] } set partsList [dict keys [dict get $typeDefInfo definition]] ::log::logsubst debug {\t partsList is {$partsList}} foreach partName $partsList { set partType [string trimright [dict get $typeDefInfo definition $partName type] {?}] set partXns $xns catch {set partXns [dict get $typeInfo $mode $serviceName $partType xns]} set typeInfoList [TypeInfo $mode $serviceName $partType] set isArray [lindex $typeInfoList end] ::log::logsubst debug {\tpartName $partName partType $partType xns $xns typeInfoList $typeInfoList} switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## set msg {Simple non-array} ## Is there an enumenration? foreach attr {enumeration type comment} { if {[dict exists $typeDefInfo definition $partName $attr]} { set value [dict get $typeDefInfo definition $partName $attr] set value [string map {\{ ( \} ) \" '} $value] append msg ", $attr=\{$value\}" } } dict set results $partName $msg } {0 1} { ## ## Simple array ## set tmp {} for {set row 1} {$row <= $arraySize} {incr row} { lappend tmp [format {Simple array element #%d} $row] } dict set results $partName $tmp } {1 0} { ## ## Non-simple non-array ## dict set results $partName [_generateTemplateDict $mode $serviceName $partType $arraySize $xns] } {1 1} { ## ## Non-simple array ## set partType [string trimright $partType {()}] set tmp [list] set isRecursive [info exists generatedTypes([list $mode $serviceName $partType])] for {set row 1} {$row <= $arraySize} {incr row} { if {$isRecursive} { lappend tmp $partName {<** Circular Reference **>} } else { unset -nocomplain -- generatedTypes([list $mode $serviceName $partType]) lappend tmp [_generateTemplateDict $mode $serviceName $partType $arraySize $xns] } } dict set results $partName $tmp } default { ## ## Placed here to shut up tclchecker ## } } } ::log::logsubst debug {Leaving [info level 0] with {$results}} return $results } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::setAttr # # Description : Set attributes on a DOM node # # Arguments : # node - node to set attributes on # attrList - List of attribute name value pairs # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # |
︙ | ︙ | |||
3190 3191 3192 3193 3194 3195 3196 | # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 02/24/2011 G. Lester Initial version # ########################################################################### | < < < < | < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > | > > > > > > > > > > > > | 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 | # 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::setAttr {node attrList} { $node setAttribute {*}$attrList } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::geturl_followRedirects # # Description : fetch via http following redirects. # May not be used as asynchronous call with -command option. # # Arguments : # url - target document url # args - additional argument list to http::geturl call # # Returns : http package token of received data # # Side-Effects : Save final url in redirectArray to forward info to # procedure "processImport". # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald Lester # #>>END PRIVATE<< # # 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.3.10 11/09/2015 H. Oehlmann Allow only 5 redirects (loop protection) # 3.1.0 2020-11-06 H.Oehlmann Access namespace variable redirectArray # via variable command # ########################################################################### proc ::WS::Utils::geturl_followRedirects {url args} { variable redirectArray ::log::logsubst debug {[info level 0]} set initialUrl $url set finalUrl $url array set URI [::uri::split $url] ;# Need host info from here for {set loop 1} {$loop <=5} {incr loop} { ::log::logsubst info {[concat [list ::http::geturl $url] $args]} set token [http::geturl $url {*}$args] set ncode [::http::ncode $token] ::log::logsubst info {ncode = $ncode} if {![string match {30[12378]} $ncode]} { ::log::logsubst debug {initialUrl = $initialUrl, finalUrl = $finalUrl} if {![string equal $finalUrl {}]} { ::log::log debug "Getting initial URL directory" set lastPos [string last / $initialUrl] set initialUrlDir [string range $initialUrl 0 [expr {$lastPos - 1}]] set lastPos [string last / $finalUrl] set finalUrlDir [string range $finalUrl 0 [expr {$lastPos - 1}]] ::log::logsubst debug {initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir} set redirectArray($initialUrlDir) $finalUrlDir } return $token } elseif {![string match {20[1237]} $ncode]} { return $token } # http code announces redirect (3xx) array set meta [set ${token}(meta)] if {![info exist meta(Location)]} { ::log::log debug "Redirect http code without Location" return $token } array set uri [::uri::split $meta(Location)] unset meta array unset meta ::http::cleanup $token if { $uri(host) eq "" } { set uri(host) $URI(host) } # problem w/ relative versus absolute paths set url [eval ::uri::join [array get uri]] ::log::logsubst debug {url = $url} set finalUrl $url } # > 5 redirects reached -> exit with error return -errorcode [list WS CLIENT REDIRECTLIMIT $url] \ -code error "http redirect limit exceeded for $url" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::geturl_fetchbody # # Description : fetch via http following redirects and return data or error # # Arguments : # ?-codeok list? - list of acceptable http codes. # If not given, 200 is used # ?-codevar varname ? - Uplevel variable name to return current code # value. # ?-bodyalwaysok bool? - If a body is delivered any ncode is ok # url - target document url # args - additional argument list to http::geturl call # # Returns : fetched data # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # 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 11/08/2015 H.Oehlmann Initial version # 3.0.0 2020-10-26 H.Oehlmann Honor timeout and eof status # ########################################################################### proc ::WS::Utils::geturl_fetchbody {args} { set codeOkList {200} set codeVar "" set bodyAlwaysOk 0 ::log::logsubst info {Entering [info level 0]} if {[lindex $args 0] eq "-codeok"} { set codeOkList [lindex $args 1] set args [lrange $args 2 end] } if {[lindex $args 0] eq "-codevar"} { set codeVar [lindex $args 1] set args [lrange $args 2 end] } if {[lindex $args 0] eq "-bodyalwaysok"} { set bodyAlwaysOk [lindex $args 1] set args [lrange $args 2 end] } set token [eval ::WS::Utils::geturl_followRedirects $args] switch -exact -- [::http::status $token] { ok { if {[::http::size $token] == 0} { ::log::log debug "\tHTTP error: no data" ::http::cleanup $token return -errorcode [list WS CLIENT NODATA [lindex $args 0]]\ -code error "HTTP failure socket closed" } if {$codeVar ne ""} { upvar 1 $codeVar ncode } set ncode [::http::ncode $token] set body [::http::data $token] ::http::cleanup $token if {$bodyAlwaysOk && $body ne "" || $ncode in $codeOkList } { # >> Fetch ok ::log::logsubst debug {\tReceived: $body} return $body } ::log::logsubst debug {\tHTTP error: Wrong code $ncode or no data} return -code error -errorcode [list WS CLIENT HTTPERROR $ncode]\ "HTTP failure code $ncode" } eof { set error "socket closed by server" } error { set error [::http::error $token] } timeout { set error "timeout" } default { set error "unknown http::status: [::http::status $token]" } } ::log::logsubst debug {\tHTTP error [array get $token]} ::http::cleanup $token return -errorcode [list WS CLIENT HTTPERROR $error]\ -code error "HTTP error: $error" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::check_version # # Description : for a particular version code, check if the requested version # is allowd # # Arguments : # version - The specified version for the type, proc, etc # requestedVersion - The version being requested by the user # # Returns : boolean - true if allowed, false if not # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Jonathan Cone # #>>END PRIVATE<< # # 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 10/23/2018 J. Cone Initial version # ########################################################################### proc ::WS::Utils::check_version {version requestedVersion} { if {$version eq {} || $requestedVersion eq {}} { return 1 } if {[regexp {^(\d+)([+-])?(\d+)?$} $version _ start modifier end]} { if {$start ne {} && $end ne {}} { return [expr {$requestedVersion >= $start && $requestedVersion <= $end}] } elseif {$start ne {}} { switch -- $modifier { "+" { return [expr {$requestedVersion >= $start}] } "-" { return [expr {$requestedVersion <= $start}] } "" { return [expr {$requestedVersion == $start}] } } } } return 0 } |
Changes to Wub.tcl.
︙ | ︙ | |||
35 36 37 38 39 40 41 42 43 44 45 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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 uri package require base64 package require html | > > > > > | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## 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- # WS::Utils usable here for dict? if {![llength [info command dict]]} { package require dict } package require uri package require base64 package require html package provide WS::Wub 2.4.0 namespace eval ::WS::Wub { array set portInfo {} set portList [list] set forever {} |
︙ | ︙ | |||
64 65 66 67 68 69 70 | # Procedure Name : ::WS::Wub::AddHandler # # Description : Register a handler for a url on a port. # # Arguments : # port -- The port to register the callback on # url -- The URL to register the callback for | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | # Procedure Name : ::WS::Wub::AddHandler # # Description : Register a handler for a url on a port. # # Arguments : # port -- The port to register the callback on # url -- The URL to register the callback for # callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : # None # |
︙ | ︙ | |||
164 165 166 167 168 169 170 | # Description : Instruct the module to listen on a Port, security information. # # Arguments : # port -- Port number to listen on # certfile -- Name of the certificate file # keyfile -- Name of the key file # userpwds -- A list of username and passwords | | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | # Description : Instruct the module to listen on a Port, security information. # # Arguments : # port -- Port number to listen on # certfile -- Name of the certificate file # keyfile -- Name of the key file # userpwds -- A list of username and passwords # realm -- The security realm # logger -- A logging routines for errors # # Returns : Nothing # # Side-Effects : # None # |
︙ | ︙ | |||
200 201 202 203 204 205 206 | lappend portList $port foreach key {port certfile keyfile userpwds realm logger} { set portInfo($port,$key) [set $key] } set portInfo($port,$handlers) {} foreach up $userpwds { | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 | lappend portList $port foreach key {port certfile keyfile userpwds realm logger} { set portInfo($port,$key) [set $key] } set portInfo($port,$handlers) {} foreach up $userpwds { lappend portInfo($port,auths) [base64::encode $up] } if {$certfile ne ""} { package require tls ::tls::init \ -certfile $certfile \ |
︙ | ︙ | |||
637 638 639 640 641 642 643 | } if {[eof $sock]} { $portInfo($port,logger) "Connection closed from $ip" } foreach {method url version} $line { break } switch -exact $method { GET { | | | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 | } if {[eof $sock]} { $portInfo($port,logger) "Connection closed from $ip" } foreach {method url version} $line { break } switch -exact $method { GET { handler $port $sock $ip [uri::split $url] $auth } default { $portInfo($port,logger) "Unsupported method '$method' from $ip" } } } msg]} { $portInfo($port,logger) "Error: $msg" } catch {flush $sock} catch {close $sock} return; } |
Changes to WubServer.tcl.
1 2 3 4 5 6 7 8 | # WSWub - Wub interface to WebServices package require WS::Server package require OO package require Direct package require Debug Debug off wsdl 10 | > > > > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # WSWub - Wub interface to WebServices package require Tcl 8.4- # WS::Utils usable here for dict? if {![llength [info command dict]]} { package require dict } package require WS::Server package require OO package require Direct package require Debug Debug off wsdl 10 package provide WS::Wub 2.4.0 package provide Wsdl 2.4.0 class create Wsdl { method / {r args} { return [Http Ok $r [::WS::Server::generateInfo $service 0] text/html] } method /op {r args} { |
︙ | ︙ |
Deleted docs/Calling a Web Service.html.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added docs/Calling_a_Web_Service.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 | <HTML lang=en dir=ltr xml:lang="en" xmlns="http://www.w3.org/1999/xhtml"> <HEAD> <TITLE>Calling a Web Service from Tcl</TITLE> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1 class=firstHeading>Calling a Web Service from Tcl</H1> <HR> <TABLE class=toc id=toc> <TR> <TD> <H2>Contents</H2></DIV> <UL> <LI class=toclevel-1><A href="#Overview"><SPAN class=tocnumber>1</SPAN> <SPAN class=toctext>Overview</SPAN></A> <LI class=toclevel-1><A href="#Loading_the_Webservices_Client_Package"><SPAN class=tocnumber>2</SPAN> <SPAN class=toctext>Loading the Webservices Client Package</SPAN></A> <LI class=toclevel-1><A href="#Quering_a_remote_Web_Services_Server_for_its_WSDL_and_parsing_it"><SPAN class=tocnumber>3</SPAN> <SPAN class=toctext>Quering a remote Web Services Server for its WSDL and parsing it</SPAN></A> <LI class=toclevel-1><A href="#Parsing_a_saved_WSDL"><SPAN class=tocnumber>4</SPAN> <SPAN class=toctext>Parsing a saved WSDL</SPAN></A> <LI class=toclevel-1><A href="#Loading_a_pre-parsed_WSDL"><SPAN class=tocnumber>5</SPAN> <SPAN class=toctext>Loading a pre-parsed WSDL</SPAN></A> <LI class=toclevel-1><A href="#Defining_a_REST_service"><SPAN class=tocnumber>6</SPAN> <SPAN class=toctext>Defining a REST based service by hand</SPAN></A> <LI class=toclevel-1><A href="#Transforms"><SPAN class=tocnumber>7</SPAN> <SPAN class=toctext>Defining Transforms</SPAN></A> <LI class=toclevel-1><A href="#Synchronous_Call_returning_a_dictionary_object"><SPAN class=tocnumber>8</SPAN> <SPAN class=toctext>Synchronous Call returning a dictionary object</SPAN></A> <LI class=toclevel-1><A href="#Asynchronous_Call_with_separate_success_and_error_callbacks"><SPAN class=tocnumber>9</SPAN> <SPAN class=toctext>Asynchronous Call with separate success and error callbacks</SPAN></A> <LI class=toclevel-1><A href="#Creation_of_stub_Tcl_procedures_to_make_synchronous_calls"><SPAN class=tocnumber>10</SPAN> <SPAN class=toctext>Creation of stub Tcl procedures to make synchronous calls</SPAN></A> <LI class=toclevel-1><A href="#Synchronous_Call_returning_the_raw_XML"><SPAN class=tocnumber>11</SPAN> <SPAN class=toctext>Synchronous Call returning the raw XML</SPAN></A> </li> <li class="toclevel-1"><a href="#Config"><span class="tocnumber">12</span> <span class="toctext">Configuring Services</span></a> </LI> <li class="toclevel-1"><a href="#TypeCasting"><span class="tocnumber">13</span> <span class="toctext">Dealing With Casting Abstract Types to Concrete Types</span></a> </LI> </UL></TD></TR></TBODY></TABLE> <P> </P> <A name=Overview></A> <H2>Overview </H2> <P>The Webservices Client package provides a several ways to define what operations a remote Web Services Server provides and how to call those operations. It also includes several ways to call an operation. </P> <P>The following ways are provided to define remote operations: </P> <UL> <LI>Loading a pre-parsed WSDL </li><li>Quering a remote Web Services Server for its WSDL and parsing it </li><li>Parsing a saved WSDL </li></ul> <ul><li>Defining a REST based service by hand </li></ul> <P>The parsed format is much more compact than the XML of a WSDL. </P> <P>The following ways are provided to directly call an operation of a Web Service Server: </P> <UL> <LI>Synchronous Call returning a dictionary object <LI>Synchronous Call returning the raw XML <LI>Asynchronous Call with separate success and error callbacks <LI>Creation of stub Tcl procedures to make synchronous calls </LI></UL> <p>This package makes use of the <b>log</b> package from <b>TclLib</b>. In particular the following levels are used: </p><ul> <li>error/warning -- errors encountered when parsing a WSDL. Actual level depends on options that are set in the <b>::WS::Utils</b> package. </li><li>info -- HTTP calls, including the XML, made to invoke operations and the replies received. <i>Introduced in 2.2.8.</i> </li><li>debug -- detailed internal information. This should only be used if you want to code dive into the TclWs package internals. </li></ul> <A name=Loading_the_Webservices_Client_Package></A> <H2>Loading the Webservices Client Package </H2> <P>To load the webservices server package, do: </P><PRE> package require WS::Client </PRE> <P>This command will only load the utilities the first time it is used, so it causes no ill effects to put this in each file using the utilties. </P> <HR> <A name=Quering_a_remote_Web_Services_Server_for_its_WSDL_and_parsing_it></A> <H2>Quering a remote Web Services Server for its WSDL and parsing it </H2> <P><B>Procedure Name : <I>::WS::Client::GetAndParseWsdl</I></B> </P> <P><B>Description : Fetch the WSDL file from the given URL, aprse it and create the service.</B> </P> <P><B>Arguments :</B> </P><PRE> <I>url</I> - The url of the WSDL <I>headers</I> - Extra headers to add to the HTTP request. This <I></I> is a key value list argument. It must be a list with <I></I> an even number of elements that alternate between <I></I> keys and values. The keys become header field names. <I></I> Newlines are stripped from the values so the header <I></I> cannot be corrupted. <I></I> This is an optional argument and defaults to {}. <I>serviceAlias</I> - Alias (unique) name for service. <I></I> This is an optional argument and defaults to the name of the <I></I> service in serviceInfo. <I>serviceNumber</I> - Number of service within the WSDL to assign the <I></I> serviceAlias to. Only recognized with a serviceAlias. <I></I> First service (default) is addressed by value "1". </PRE> <p>The following example WSDL snipped defines two services:</p> <pre> >definitions ...< >service name="service1"< ... >/service< >service name="service1"< ... >/service< >/definitions< </pre> <p>Using an empty or no <I>serviceAlias</I> would result in the creation of the services "service1" and "service2".</p> <p>Using <i>serviceAlias</i>="SE" and <i>serviceNumber</i>=2 would result in the creation of the service "SE" containing the "service2" of the WSDL.</p> <P><B>Returns : The parsed service definition</B> </P> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions : None</B> </P> <P><B>Pre-requisite Conditions : None</B> </P> <HR> <A name=Parsing_a_saved_WSDL></A> <H2>Parsing a saved WSDL </H2> <P><B>Procedure Name : <I>::WS::Client::ParseWsdl</I></B> </P> <P><B>Description : Parse a WSDL and create the service. Create also the stubs if specified.</B> </P> <P><B>Arguments :</B> </P><PRE> <I>wsdlXML</I> - XML of the WSDL </PRE> <P><B>Optional Arguments:</B> </P> <PRE> <i>-createStubs</i> 0|1 - create stub routines for the service <i>-headers</i> - Extra headers to add to the HTTP request. This <i></i> is a key value list argument. It must be a list with <i></i> an even number of elements that alternate between <i></i> keys and values. The keys become header field names. <i></i> Newlines are stripped from the values so the header <i></i> cannot be corrupted. <i></i> This is an optional argument and defaults to {}. <i>-serviceAlias</i> - Alias (unique) name for service. <i></i> This is an optional argument and defaults to the name of the <i></i> service in serviceInfo. <I>serviceNumber</I> - Number of service within the WSDL to assign the <I></I> serviceAlias to. Only recognized with a serviceAlias. <I></I> First service (default) is addressed by value "1". </PRE> <p>The arguments are position independent.</p> <p>For an example use of <i>serviceAlias</i> and <i>serviceNumber</i>, see <a href="#Quering_a_remote_Web_Services_Server_for_its_WSDL_and_parsing_it">the chapter above</a>.</p> <P><B>Returns : The parsed service definition</B> </P> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions :None</B> </P> <P><B>Pre-requisite Conditions : None</B> </P> <HR> <A name=Loading_a_pre-parsed_WSDL></A> <H2>Loading a pre-parsed WSDL </H2> <P><B>Procedure Name : <I>::WS::Client::LoadParsedWsdl</I></B> </P> <P><B>Description : Load a saved service definition in</B> </P> <P><B>Arguments :</B> </P><PRE> <I>serviceInfo</I> - parsed service definition, as returned from <I>::WS::Client::ParseWsdl</I> or <I>::WS::Client::GetAndParseWsdl</I> <I>headers</I> - Extra headers to add to the HTTP request. This is a key value list argument. It must be a list with an even number of elements that alternate between keys and values. The keys become header field names. Newlines are stripped from the values so the header cannot be corrupted. This is an optional argument and defaults to {}. <I>serviceAlias</I> - Alias (unique) name for service. This is an optional argument and defaults to the name of the service in serviceInfo. </PRE> <P><B>Returns : The name of the service loaded</B> </P> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions : None</B> </P> <P><B>Pre-requisite Conditions : None</B> </P> <HR> <A name=Defining_a_REST_service></A> <H2>Defining a REST based service by hand </H2> <BR> <H3>Service Definition</H3> <P><B>Procedure Name : <I>::WS::Client::CreateService</I></B> </P> <P><B>Description : Define a REST service</B> </P> <P><B>Arguments :</B> </P><PRE> <I>serviceName</I> - Service name to add namespace to <I>type</I> - The type of service, currently only <B>REST</B> is supported. <I>url</I> - URL of namespace. <I>args</I> - Optional arguments: This is an optional argument and defaults to the name of the <I>-header</I> httpHeaderList. </PRE> <P><B>Returns : The local alias (tns)</B> </P> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions : None</B> </P> <P><B>Pre-requisite Conditions : None</B> </P> <H3>Method Definition</H3> <P><B>Procedure Name : <I>::WS::Client::DefineRestMethod</I></B> </P> <P><B>Description : Define a method on a REST service</B> </P> <P><B>Arguments :</B> </P><PRE> <I>serviceName</I> - Service name to add namespace to <I>methodName</I> - The name of the method to add. <I>returnType</I> - The type, if any returned by the procedure. Format is: xmlTag <I>typeInfo</I>. <i>inputArgs</i> - List of input argument definitions where each argument definition is of the format: name typeInfo. where, <I>typeInfo</I> is of the format <B>{</B>type typeName comment commentString<B>}</B> </PRE> <P><B>Returns : The current service definition </B> </P> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions : None</B> </P> <P><B>Pre-requisite Conditions : None</B> </P> <HR> <A name=Transforms></A> <H2>Defining Transforms </H2> <P><B>Procedure Name : <I>::WS::Client::SetServiceTransforms</I></B> </P> <P><B>Description : Define a service's transforms</B> <PRE> Transform signature is: cmd serviceName operationName <I>transformType</I> xml {url {}} {argList {}} where <I>transformType</I> is <B>REQUEST</B> or <B>REPLY</B> and url and argList will only be present for <I>transformType</I> == <B>REQUEST</B> </PRE> </P> <P><B>Arguments :</B> </P><PRE> <I>serviceName</I> - The name of the Webservice <I>inTransform</I> - Input transform <I>cmd</I>, defaults to {}. The inTransform is the proc which allows to transform the SOAP output message, which will be input in the server. <I>outTransform</I> - Output transform<I>cmd</I>, defaults to {}. The outTransform is the proc which allows to transform the SOAP input message, which is the answer of the server. </PRE> <P><B>Returns : None</B></P> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions : None</B> </P> <P><B>Pre-requisite Conditions : Service must have been defined.</B> </P> <HR> <A name=Synchronous_Call_returning_a_dictionary_object></A> <H2>Synchronous Call returning a dictionary object </H2> <P><B>Procedure Name : <I>::WS::Client::DoCall</I></B> </P> <P><B>Description : Call an operation of a web service</B> </P> <P><B>Arguments :</B> </P><PRE> <I>serviceName</I> - The name of the Webservice <I>operationName</I> - The name of the Operation to call <I>argList</I> - The arguements to the operation as a dictionary object This is for both the Soap Header and Body messages. <I>headers</I> - Extra headers to add to the HTTP request. This is a key value list argument. It must be a list with an even number of elements that alternate between keys and values. The keys become header field names. Newlines are stripped from the values so the header cannot be corrupted. This is an optional argument and defaults to {}. </PRE> <P><B>Returns :</B> </P> <PRE> The return value of the operation as a dictionary object. This includes both the return result and any return headers. </PRE> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions :</B> </P><PRE> <B>WSCLIENT HTTPERROR</B> - if an HTTP error occured others - as raised by called Operation </PRE> <P><B>Pre-requisite Conditions : Service must have been defined.</B> </P> <HR> <A name=Asynchronous_Call_with_separate_success_and_error_callbacks></A> <H2>Asynchronous Call with separate success and error callbacks </H2> <P><B>Procedure Name : <I>::WS::Client::DoAsyncCall</I></B> </P> <P><B>Description : Call an operation of a web service asynchronously</B> </P> <P><B>Arguments :</B> </P><PRE> <I>serviceName</I> - The name of the Webservice <I>operationName</I> - The name of the Operation to call <I>argList</I> - The arguements to the operation as a dictionary object This is for both the Soap Header and Body messages. <I>succesCmd</I> - A command prefix to be called if the operations does not raise an error. The results, as a dictionary object are concatinated to the prefix. This includes both the return result and any return headers. Leave empty to not call any function. <I>errorCmd</I> - A command prefix to be called if the operations raises an error. The error code, stack trace and error message are concatinated to the prefix. Leave empty to not call any function. <I>headers</I> - Extra headers to add to the HTTP request. This is a key value list argument. It must be a list with an even number of elements that alternate between keys and values. The keys become header field names. Newlines are stripped from the values so the header cannot be corrupted. This is an optional argument and defaults to {}. </PRE> <P><B>Returns : Nothing.</B> </P> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions :</B> </P><PRE> WSCLIENT HTTPERROR - if an HTTP error occured others - as raised by called Operation </PRE> <P><B>Pre-requisite Conditions : Service must have been defined.</B> </P> <HR> <A name=Creation_of_stub_Tcl_procedures_to_make_synchronous_calls></A> <H2>Creation of stub Tcl procedures to make synchronous calls </H2> <P><B>Procedure Name : <I>::WS::Client::CreateStubs</I></B> </P> <P><B>Description : Create stubs routines to make calls to Webservice Operations.</B> </P><PRE> All routines will be create in a namespace that is the same as the service name. The procedure name will be the same as the operation name. </PRE><PRE> <B>NOTE</B> -- Webservice arguments are position independent, thus the proc arguments will be defined in alphabetical order. </PRE> <P><B>Arguments :</B> </P><PRE> <I>serviceName</I> - The service to create stubs for </PRE> <P><B>Returns : A string describing the created procedures.</B> </P> <P><B>Side-Effects : Existing namespace is deleted.</B> </P> <P><B>Exception Conditions : None</B> </P> <P><B>Pre-requisite Conditions : Service must have been defined.</B> </P> <HR /> <A name=Synchronous_Call_returning_the_raw_XML></A> <H2>Synchronous Call returning the raw XML </H2> <P><B>Procedure Name : <I>::WS::Client::DoRawCall</I></B> </P> <P><B>Description : Call an operation of a web service</B> </P> <P><B>Arguments :</B> </P><PRE> <I>serviceName</I> - The name of the Webservice <I>operationName</I> - The name of the Operation to call <I>argList</I> - The arguements to the operation as a dictionary object This is for both the Soap Header and Body messages. <I>headers</I> - Extra headers to add to the HTTP request. This is a key value list argument. It must be a list with an even number of elements that alternate between keys and values. The keys become header field names. Newlines are stripped from the values so the header cannot be corrupted. This is an optional argument and defaults to {}. </PRE> <P><B>Returns :</B> </P><PRE> The XML of the operation. </PRE> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions :</B> </P><PRE> <B>WSCLIENT HTTPERROR</B> - if an HTTP error occured </PRE> <P><B>Pre-requisite Conditions : Service must have been defined.</B> </P> <HR /> <p><a name="Template"></a> </p><h2>Generating a Template Dictionary</h2> <p><b>Procedure Name : <i>::WS::Utils::GenerateTemplateDict</i></b> </p> <p><b>Description : Generate a template dictionary object for a given type.</b> </p> <p><b>Arguments :</b> </p> <pre> <i>mode</i> - The mode, <b>Client</b> or <b>Server</b> <i>serviceName</i> - The name of the Webservice <i>type</i> - The name of the type <i>arraySize</i> - Number of elements to generate in an array. Default is 2 <ul> </pre> <p><b>Returns :</b> </p><pre>A dictionary object for a given type. If any circular references exist, they will have the value of <** Circular Reference **> <p><b>Side-Effects : None</b> </p> <p><b>Exception Conditions : None</b> </p> <p><b>Pre-requisite Conditions : Service must have been defined.</b> </p></pre><p></p> <HR /> <p><a name="Config"></a> </p><h2>Configuring a Service </h2> There are two procedures to configure a service: <ul> <li>::WS::Client::SetOption</li> <li>::WS::Client::Config</li> </ul> <p>The first procedure contains the default options of the package. The default options are used on service creation and are then copied to the service.</p> <p>The second procedure contains the options of each service. They are copied on service creation from the default options.</p> <p>Most option items may be accessed by both functions. Some options are only used on service creation phase, which do not exist as service option. Other options do not exist as default option, as they are initialized from the WSDL file.</p> <p>In the following, first the two access routines are described. Then, a list of options for both functions are given, with remarks, if they are only valid for one of the two procedures.</p> <p><b>Procedure Name : <i>::WS::Client::SetOption</i></b> </p> <p><b>Description : Get or set the default options of the package</b> </p> <p><b>Arguments :</b> </p> <pre> <i>-globalonly</i> - Return a list of global-only options and their values. <i></i> Global-only options are not copied to the service. <i>-defaultonly</i> - Return a list of default-only options and their values. <i></i> default-only options are copied to the service. <i>--</i> - End of options <i>item</i> - The option item to get or configure. <i></i> Return a list of all item/value pairs if ommitted. <i>value</i> - The value to set the option item to. <i></i> Return current value if omitted. </pre> <p><b>Procedure Name : <i>::WS::Client::Config</i></b> </p> <p><b>Description : Get or set the options local to a service definition</b> </p> <p><b>Arguments :</b> </p> <pre> <i>serviceName</i> - The name of the Webservice. <i></i> Return a list of default items/values paires if not given. <i>item</i> - The option item to get or configure. <i></i> Return a list of all item/value pairs, if not given. <i>value</i> - The value to set the option item to. <i></i> Return current value if omitted. </pre> <p><b>Option List:</b> </p> <ul> <li><pre>allowOperOverloading</pre> <p>An overloaded operation is an operation with the same name but different may exist with different input parameter sets.</p> <p>This option throws an error, if a WSDL is parsed with an overloaded operation.</p> Default: 1</li> <li><pre>contentType</pre> The http content type of the http request sent to call the web service.<br /> Default: "text/xml;charset=utf-8"</li> <li><pre>errorOnRedefine</pre> <p>Throw an error, if a service is created (CreateService etc) for an already existing service.</p> <p>Default value: 0</p> <p>This item may not be used with <i>::WS::Client::Config</i>.</p> </li> <li><pre>genOutAttr</pre> generate attributes on outbound tags, see <A HREF="Using_Options.html#genOutAttr">here</A> for details</li> <li><pre>inlineElementNS</pre> <p>Namespace prefixes for types may be defined within the WSDL root element.</p> <p>This item may not be used with <i>::WS::Client::Config</i>.</p> <p>Activate this option, to also search namespace prefixes in the type definition. As those are seen as global prefixes, there might be a double-used prefix which will cause a processing error, if different URI's are assigned.</p> <p>The error would be caused by a WSDL as follows</p> <pre> <wsdl:definitions targetNamespace="http://www.webserviceX.NET/" xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/ xmlns:q1="myURI1" ...> ... <xs:element xmlns:q1="myURI2" type="q1:MessageQ1"/> </pre> </li> <li><pre>location</pre> <p>The URL of the service. This is initialized on the value in the WSDL file, when the WSDL file is parsed. The value may be overwritten setting this option.</p> <p>This item may not be used with <i>::WS::Client::SetOption</i>.</p> </li> <li><pre>noTargetNs</pre> The target namespace URI is normally included twice in the envelope of the webservice call:<br /> <pre> <SOAP-ENV:Envelope ... xmlns="http://targeturi.org/" xmlns:tns1="http://targeturi.org/" ...> </pre> Setting this option to 1 suppresses the line with "xmlns=". <br />This option was set to call a service published by SAP. <br />Default value: 0</li> <li><pre>nsOnChangeOnly</pre> only put namespace prefix when namespaces change</li> <li><pre>parseInAttr</pre> parse attributes on inbound tags, see <A HREF="Using_Options.html#parseInAttr">here</A> for details</li> <li><pre>queryTimeout</pre> Timeout to any network query in ms. Default value: 60000 (1 minuite). The <A HREF="Using_Options.html#queryTimeout">utility package</a> has an option with the same functionality, which is used, when there is no call option context. </li> <li><pre>skipHeaderLevel</pre> boolean indicating the first level of the XML in a request header <i><b>shall be</b></i> skipped. Derived from options. Default is 0 (do not skip). <i>(Introduced in 2.2.8)</i></li> <li><pre>skipLevelOnReply</pre> boolean indicating the first level of the XML in a reply <i><b>may be</b></i> skipped. Derived from options. Default is 0 (do not skip). <i>(Introduced in 2.2.8)</i></li> <li><pre>skipLevelWhenActionPresent</pre> boolean indicating if the first level of the XML is to be skipped. Derived from options. Default is 0 (do not skip).</li> <li><pre>suppressNS (default: empty string)</pre> do not put a particular namespace prefix</li> <li><pre>suppressTargetNS</pre> <p>Do not add the Target Namespace URI prefix "tns1" to all parameters in the webservice call XML.</p> <p>As an example, the XML is modified from (option not set): <pre> <SOAP-ENV:Envelope ... xmlns:tns1="http://targeturi.org/" ... > <SOAP-ENV:Body> <tns1:CalledMethod> <tns1:Parameter1>Value;/tns1:Parameter1> </tns1:CalledMethod> </SOAP-ENV:Body> </SOAP-ENV:Envelope> </pre> to (option set) <pre> <SOAP-ENV:Envelope ... xmlns:tns1="http://targeturi.org/" ... > <SOAP-ENV:Envelope ... <SOAP-ENV:Body> <tns1:CalledMethod> <Parameter1>Value;/Parameter1> </tns1:CalledMethod> </SOAP-ENV:Body> </SOAP-ENV:Envelope> </pre> </p> Derived from options. <br />Internally, this option sets the option "suppressNS" to "tns1". <br />This option was set to call a service published by SAP. <br />This option made a call to a certain MS Web Service fail with the error message: "Input parameter 'Parameter1' can not be NULL or Empty.". <br />Default is 0 (do not suppress). </li> <li><pre>targetNamespace (default: empty string)</pre> <p>the target namespace of the service, derived from the WSDL.</p> <p>This item may not be used with <i>::WS::Client::SetOption</i>.</p> </li> <li><pre>UseNS (default: empty string)</pre> See <A HREF="Using_Options.html#UseNS">here</A> </li> <li><pre>useTypeNS (default: empty string)</pre> use type's namespace prefix as prefix of elements</li> <li><pre>valueAttrCompatiblityMode (default: 1)</pre> If this and genOutAttr/parseInAttr are set, then values are specified in the dictionary as {}. Otherwise if genOutAttr/parseInAttr is set this is not set, then the values are specified in the dictionary as ::value.</li> </ul> <pre> <i>value</i> - Optional, the new value. </pre> <p><b>Returns :</b> </p><pre> The value of the item. <p><b>Side-Effects : None</b> </p> <p><b>Exception Conditions : None</b> </p> <p><b>Pre-requisite Conditions : Service must have been defined.</b> </p></pre><p></p> <p><a name="TypeCasting"></a> </p><h2>Dealing With Casting Abstract Types to Concrete Types </h2> <p> If you turn on <i>parseInAttr</i> and <i>genOutAttr</i>, the system will semi-automatically deal with casting of elements declared as a being of a type that is an abstract type to/from the concrete type actually to be used in a message. On an element that is decleared to be a type which is an abstract type, the value of the <b>::type</b> key in the dictionary will specify the concrete type to be actually used (or for a reply message the concrete type that was actually used). </p> <p> <B>NOTE:</B> While in the WSDL the concreate type must be an extention of the abstract type, the package does not enforce this restriction, so caution must be taken. </p> </div> </BODY> </HTML> |
Deleted docs/Creating a Tcl Web Service.html.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted docs/Creating a Web Service Type.html.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added docs/Creating_a_Tcl_Web_Service.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | <HTML lang=en dir=ltr xml:lang="en" xmlns="http://www.w3.org/1999/xhtml"> <HEAD> <TITLE>Creating a Tcl Web Service</TITLE> <META http-equiv=Content-Type content="text/html; charset=utf-8"> <META content="Creating a Tcl Web Service" name=KEYWORDS> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1>Creating a Tcl Web Service</H1> <TABLE class=toc id=toc> <TBODY> <TR> <TD> <DIV id=toctitle> <H2>Contents</H2></DIV> <UL> <LI class=toclevel-1><A href="#Loading_the_Webservices_Server_Package"><SPAN class=tocnumber>1</SPAN> <SPAN class=toctext>Loading the Webservices Server Package</SPAN></A> <LI class=toclevel-1><A href="#Defining_a_Service"><SPAN class=tocnumber>2</SPAN> <SPAN class=toctext>Defining a Service</SPAN></A> <LI class=toclevel-1><A href="#Defining_an_Operation_.28aka_a_Service_Procedure.29"><SPAN class=tocnumber>3</SPAN> <SPAN class=toctext>Defining an Operation (aka a Service Procedure)</SPAN></A> <LI class=toclevel-1><A href="#Declaring_Complex_Types"><SPAN class=tocnumber>4</SPAN> <SPAN class=toctext>Declaring Complex Types</SPAN></A> </LI> </UL> </TD> </TR> </TBODY> </TABLE> <A name=Loading_the_Webservices_Server_Package></A> <H2>Loading the Webservices Server Package </H2> <p>To load the webservices server package, do: </p> <PRE> package require WS::Server</PRE> <p>This command will only load the server the first time it is used, so it causes no ill effects to put this in each file declaring a service or service procedure. </p> <h3>Using as part of TclHttpd</h3> <p> The Web Services package, WS::Server, is not a standalone application, but rather is designed to be a "module" of TclHttpd. The following command is normally placed in httpdthread.tcl: </p> <h3>Embedding in a Standalone Application</h3> <p> To embed a Web Service into an application, the application needs to be event driven and you also need to use the <b>WS::Embeded</b> package. You also must define the service with the <i>-mode=embedded</i> option. </p> <p> See also <a href="Embedded_Web_Service.html">Embedding a Web Service into an application</A>. </p> <h3>Using with Apache Rivet</h3> <p> <a href="http://tcl.apache.org/rivet/">Apache Rivet</a> is a module (mod_rivet) that can be loaded by Apache httpd server to allow web pages to run embedded Tcl commands in a way similar to PHP. To create a Web Service in Rivet, use the example EchoRivetService.rvt as a starting point by simply copying it into any directory served by your Apache instance. You should be able to immediately access that new location at the following URLs: </p> <PRE> /path/to/EchoRivetService.rvt/doc Displays an HTML page describing the service /path/to/EchoRivetService.rvt/wsdl Returns a WSDL describing the service /path/to/EchoRivetService.rvt/op Invoke an operation </PRE> <p> If you would prefer to expose the published URLs of your service differently, you can use the standard Apache mod_rewrite or mod_alias modules to transparently map any other URL to those locations. </p> <HR> <A name=Defining_a_Service></A> <H2>Defining a Service </H2> <p> The code that defines a service is normally placed in one or more files in the custom directory. </p> <p><b>Procedure Name : <i>::WS::Server::Service</i></b> </p> <p><b>Description</b> : Declare a Web Service, the following URLs will exist </p><PRE> /service/<ServiceName> Displays an HTML page describing the service /service/<ServiceName>/wsdl Returns a WSDL describing the service /service/<ServiceName>/op Invoke an operation </PRE> <p><b>Arguments</b> : this procedure uses position independent arguments, they are: </p><pre> -hostcompatibility32 bool - Activate version 3.2.0 compatibility mode for -host parameter. Defaults to true. -host - The host specification within XML namespaces of the transmitted XML files. This should be unique. Defaults to localhost. If 3.2 compatibility is activated, the default value is changed to ip:port in embedded mode. -hostlocation - The host name, which is promoted within the generated WSDL file. Defaults to localhost. If 3.2 compatibility is activated, the default value is equal to the -host parameter. -hostlocationserver bool - If true, the host location is set by the current server settings. In case of httpd server, this value is imported. For other servers or if this fails, the value is the current ip:port. The default value is true. In case of 3.2 compatibility, the default value is true for tclhttpd, false otherwise. -hostProtocol - Define the host protocol (http, https) for the WSDL location URL. The special value "server" (default) follows the TCP/IP server specification. This is implemented for Embedded server and tclhttpd. Remark that the protocol for XML namespaces is always "http". -description - The HTML description for this service -htmlhead - The title string of the service description -author - The author property in the service description -xmlnamespace - Extra XML namespaces used by the service -service - The service name (this will also be used for the Tcl namespace of the procedures that implement the operations. -premonitor - This is a command prefix to be called before an operation is called. The following arguments are added to the command prefix: PRE serviceName operationName operArgList -postmonitor - This is a command prefix to be called after an operation is called. The following arguments are added to the command prefix: POST serviceName operationName OK|ERROR results -inheaders - List of input header types. -outheaders - List of output header types. -intransform - Inbound (request) transform procedure (2.0.3 and later). The signature of the command must be: cmd \ mode (REQUEST) \ xml \ notUsed_1 \ notUsed_2 -outtransform - Outbound (reply) transform procedure (2.0.3 and later). The signature of the command must be: cmd \ mode (REPLY) \ xml \ operation \ resultDict -checkheader - Command prefix to check headers. If the call is not to be allowed, this command should raise an error. The signature of the command must be: cmd \ service \ operation \ caller_ipaddr \ http_header_list \ soap_header_list -mode - Mode that service is running in. Must be one of: tclhttpd -- running inside of tclhttpd or an environment that supplies a compatible Url_PrefixInstall and Httpd_ReturnData commands embedded -- using the ::WS::Embedded package aolserver -- using the ::WS::AolServer package wub -- using the ::WS::Wub package wibble -- running inside wibble rivet -- running inside Apache Rivet (mod_rivet) -ports - List of ports for embedded mode. Default: 80 NOTE -- a call should be to ::WS::Embedded::Listen for each port in this list prior to calling ::WS::Embeded::Start -prefix - Path prefix used for the namespace and endpoint Defaults to "/service/" plus the service name -traceEnabled - Boolean to enable/disable trace being passed back in exception Defaults to "Y" -docFormat - Format of the documentation for operations ("text" or "html"). Defaults to "text" -stylesheet - The CSS stylesheet URL used in the HTML documentation -errorCallback - Callback to be invoked in the event of an error being produced -verifyUserArgs - Boolean to enable/disable validating user supplied arguments Defaults to "N" -enforceRequired - Throw an error if a required field is not included in the response. Defaults to "N" </PRE> <p><b>Returns</b> : Nothing </p> <p><b>Side-Effects</b> : None </p> <p><b>Exception Conditions</b> : </p><PRE> <i>MISSREQARG</i> -- Missing required arguments </PRE> <p><b>Pre-requisite Conditions</b> : None </p> <HR> <A name=Defining_an_Operation_.28aka_a_Service_Procedure.29></A> <H2>Defining an Operation (aka a Service Procedure) </H2> <p><b>Procedure Name : <i>::WS::Server::ServiceProc</i></b> </p> <p><b>Description</b> : Register an operation for a service and declare the procedure to handle the operations. </p> <p><b>Arguments</b> : </p><PRE> <i>ServiceName </i> -- Name of the service this operation is for <i>NameInfo </i> -- List of two elements: 1) OperationName -- the name of the operation 2) ReturnType -- the type of the procedure return, this can be a simple or complex type <i>Arglist </i> -- List of argument definitions, each list element must be of the form: 1) ArgumentName -- the name of the argument 2) ArgumentTypeInfo -- -- A list of: {type typeName comment commentString} typeName can be any simple or defined type. commentString is a quoted string describing the field <i>Documentation</i> -- HTML describing what this operation does <i>Body </i> -- The tcl code to be called when the operation is invoked. This code should return a dictionary with <OperationName>Result as a key and the operation's result as the value. </PRE> Available simple types are: <UL><LI>anyType, string, boolean, decimal, float, double, duration, dateTime, time, date, gYearMonth, gYear, gMonthDay, gDay, gMonth, hexBinary, base64Binary, anyURI, QName, NOTATION, normalizedString, token, language, NMTOKEN, NMTOKENS, Name, NCName, ID, IDREF, IDREFS, ENTITY, ENTITIES, integer, nonPositiveInteger, negativeInteger, long, int, short, byte, nonNegativeInteger, unsignedLong, unsignedInt, unsignedShort, unsignedByte, positiveInteger</LI></UL> The <em>typeName</em> may contain the following suffixes: <UL> <LI><em>()</em> : type is an array</LI> <LI><em>?</em> : type is an optional parameter</LI> </UL> <p><b>Returns</b> : Nothing </p> <p><i>Side-Effects</i> : </p><PRE> A procedure named "<ServiceName>::<OperationName>" defined A type name with the name <OperationName>Result is defined. </PRE> <p><i>Exception Conditions</i> : None </p> <p><i>Pre-requisite Conditions</i> : ::WS::Server::Server must have been called for the ServiceName </p> <HR> <A name=Declaring_Complex_Types></A> <H2>Declaring Complex Types </H2> <p>See: <A title="Creating a Web Service Type from Tcl" href="Creating_a_Web_Service_Type.html">Creating a Web Service Type from Tcl</A> </p> </BODY> </HTML> |
Added docs/Creating_a_Web_Service_Type.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | <HTML lang=en dir=ltr xml:lang="en" xmlns="http://www.w3.org/1999/xhtml"> <HEAD> <TITLE>Creating a Web Service Type from Tcl</TITLE> <META http-equiv=Content-Type content="text/html; charset=utf-8"> <META content="Creating a Web Service Type from Tcl" name=KEYWORDS> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1>Creating a Web Service Type from Tcl</H1> <TABLE class=toc id=toc> <TR> <TD> <DIV id=toctitle> <H2>Contents</H2></DIV> <UL> <LI class=toclevel-1><A href="#Overview"><SPAN class=tocnumber>1</SPAN> <SPAN class=toctext>Overview</SPAN></A> <LI class=toclevel-1><A href="#Loading_the_Webservices_Utility_Package"><SPAN class=tocnumber>2</SPAN> <SPAN class=toctext>Loading the Webservices Utility Package</SPAN></A> <LI class=toclevel-1><A href="#Defining_a_type"><SPAN class=tocnumber>3</SPAN> <SPAN class=toctext>Defining a type</SPAN></A> <LI class=toclevel-1><A href="#Deriving_a_type"><SPAN class=tocnumber>3</SPAN> <SPAN class=toctext>Defining a derived type</SPAN></A> <LI class=toclevel-1><A href="#Getting_a_type_definition"><SPAN class=tocnumber>4</SPAN> <SPAN class=toctext>Getting a type definition<li class="toclevel-1"><a href="#Template_dict_for_type_definition"><span class="tocnumber">5</span> <span class="toctext" type="">Generating a template dictionary for a type definition</SPAN></A> </LI></UL></TD></TR></TBODY></TABLE> <P> </P> <A name=Overview></A> <H2>Overview </H2> <P>Webservice Type declaration is part of the Webservices Utility package. </P> <P>When writing a web service it is often requried to write a complex type definition for an argument containing structured data. </P> <P>When calling an operation on a web service it is sometimes convient to define a complex type to return structured data as an XML fragment even though the sevice may state that it is only expecting a string. </P> <A name=Loading_the_Webservices_Utility_Package></A> <H2>Loading the Webservices Utility Package </H2> <P>To load the webservices server package, do: </P><PRE> package require WS::Utils </PRE> <P>This command will only load the utilities the first time it is used, so it causes no ill effects to put this in each file using the utilties. </P> <HR> <A name=Defining_a_type></A> <H2>Defining a type </H2> <P><B>Procedure Name</B> : <I>::WS::Utils::ServiceTypeDef</I> </P> <P><B>Description</B> : Define a type for a service. </P> <P><B>Arguments</B> : </P><PRE> <I>mode</I> - <B>Client</B> or <B>Server</B> <I>service</I> - The name of the service this type definition is for <I>type</I> - The type to be defined/redefined <I>definition</I> - The definition of the type's fields. This consist of one or more occurance of a field definition. Each field definition consist of: fieldName fieldInfo Where field info is: {<B>type</B> typeName <B>comment</B> commentString} <I>typeName</I> can be any simple or defined type. <I>commentString</I> is a quoted string describing the field. </PRE> <P><B>Returns</B> : Nothing </P> <P><B>Side-Effects</B> : None </P> <P><B>Exception Conditions</B> : None </P> <P><B>Pre-requisite Conditions</B> : None </P> <HR> <A name=Deriving_a_type></A> <H2>Defining a derived type </H2> <P><B>Procedure Name</B> : <I>::WS::Utils::ServiceSimpleTypeDef</I> </P> <P><B>Description</B> : Define a derived type for a service. </P> <P><B>Arguments</B> : </P><PRE> <I>mode</I> - <B>Client</B> or <B>Server</B> <I>service</I> - The name of the service this type definition is for <I>type</I> - The type to be defined/redefined <I>definition</I> - The definition of the type's fields. This consist of one or more occurance of a field definition. Each field definition consist of: fieldName fieldInfo Where: {<B>type</B> typeName <B>comment</B> commentString} <B>baseType</B> <I>typeName</I> - any simple or defined type. <B>comment</B> <I>commentString</I> - a quoted string describing the field. <B>pattern</B> <I>value</I> <B>length</B> <I>value</I> <B>fixed</B> <I>"true"|"false"</I> <B>maxLength</B> <I>value</I> <B>minLength</B> <I>value</I> <B>minInclusive</B> <I>value</I> <B>maxInclusive</B> <I>value</I> <B>enumeration</B> <I>value</I> </PRE> <P><B>Returns</B> : Nothing </P> <P><B>Side-Effects</B> : None </P> <P><B>Exception Conditions</B> : None </P> <P><B>Pre-requisite Conditions</B> : None </P> <HR> <A name=Getting_a_type_definition></A> <H2>Getting a type definition </H2> <P><B>Procedure Name</B> : <I>::WS::Utils::GetServiceTypeDef</I> </P> <P><B>Description</B> : Query for type definitions. </P> <P><B>Arguments</B> : </P><PRE> <I>mode</I> - <B>Client</B> or <B>Server</B> <I>service</I> - The name of the service this query is for <I>type</I> - The type to be retrieved (optional) </PRE> <P><B>Returns</B> : </P><PRE> If type not provided, a dictionary object describing all of the types for the service. If type provided, a dictionary object describing the type. A definition consist of a dictionary object with the following key/values: <B>xns</B> - The namespace for this type. <B>definition</B> - The definition of the type's fields. This consist of one or more occurance of a field definition. Each field definition consist of: fieldName fieldInfo Where field info is: {<B>type</B> <I>typeName</I> <B>comment</B> <B>commentString</B>} <I>typeName</I> can be any simple or defined type. <I>commentString</I> is a quoted string describing the field. </PRE> <P><B>Side-Effects</B> : None </P> <P><B>Exception Conditions</B> : None </P> <P><B>Pre-requisite Conditions</B> : The service must be defined. </P> <hr /> <a name="Template_dict_for_type_definition"></a> </p><h2>Generating a template dictionary for a type definition </h2> <p><b>Procedure Name</b> : <i>::WS::Utils::GenerateTemplateDict</i> </p> <p><b>Description</b> : Generate a template dictionary object for a given type.</p> <p><b>Arguments</b> : </p><pre> <i>mode</i> - <b>Client</b> or <b>Server</b> <i>serviceName</i> - The service name the type is defined in <i>type</i> - The name of the type <i>arraySize</i> - Number of elements to generate in an array. Default is 2. </pre> <p><b>Returns</b> : </p><pre> A dictionary object for a given type. If any circular references exist, they will have the value of <** Circular Reference **> </pre> <p><b>Side-Effects</b> : None </p> <p><b>Exception Conditions</b> : None </p> <p><b>Pre-requisite Conditions</b> : The type and service must be defined. </p> </div> </body></html> |
Added docs/Defining_Types.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | <!DOCTYPE html> <html><head> <meta http-equiv="content-type" content="text/html; charset=UTF-8"> <title>Web Services for Tcl (aka tclws): Defining Types</title> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </head> <body> <table class="toc" id="toc"> <tbody><tr> <td> <h2>Contents</h2> <ul> <li class="toclevel-1"><a href="#Overview"><span class="tocnumber">1</span> <span class="toctext">Overview</span></a> </li><li class="toclevel-1"><a href="#Loading_the_Webservices_Utility_Package"><span class="tocnumber">2</span> <span class="toctext">Loading the Webservices Utility Package</span></a> </li><li class="toclevel-1"><a href="#Defining_a_type"><span class="tocnumber">3</span> <span class="toctext" type="">Defining a type</span></a> </li><li class="toclevel-1"><a href="#Deriving_a_type"><span class="tocnumber">3</span> <span class="toctext" type="">Defining a derived type</span></a> </li><li class="toclevel-1"><a href="#Getting_a_type_definition"><span class="tocnumber">4</span> <span class="toctext" type="">Getting a type definition</span></a> </li> <li class="toclevel-1"><a href="#Template_dict_for_type_definition"><span class="tocnumber">5</span> <span class="toctext" type="">Generating a template dictionary for a type definition</span></a> </li></ul></td></tr></tbody></table> <p> </p> <p><a name="Overview"></a> </p><h2>Overview </h2> <p>Webservice Type declaration is part of the Webservices Utility package. </p> <p>When writing a web service it is often requried to write a complex type definition for an argument containing structured data. </p> <p>When calling an operation on a web service it is sometimes convient to define a complex type to return structured data as an XML fragment even though the sevice may state that it is only expecting a string. </p> <p><a name="Loading_the_Webservices_Utility_Package"></a> </p><h2>Loading the Webservices Utility Package </h2> <p>To load the webservices server package, do: </p><pre> package require WS::Utils </pre> <p>This command will only load the utilities the first time it is used, so it causes no ill effects to put this in each file using the utilties. </p> <hr> <p><a name="Defining_a_type"></a> </p><h2>Defining a type </h2> <p><b>Procedure Name</b> : <i>::WS::Utils::ServiceTypeDef</i> </p> <p><b>Description</b> : Define a type for a service. </p> <p><b>Arguments</b> : </p><pre> <i>mode</i> - <b>Client</b> or <b>Server</b> <i>service</i> - The name of the service this type definition is for <i>type</i> - The type to be defined/redefined <i>definition</i> - The definition of the type's fields. This consist of one or more occurance of a field definition. Each field definition consist of: fieldName fieldInfo Where field info is: {<b>type</b> typeName <b>comment</b> commentString} <i>typeName</i> can be any simple or defined type. <i>commentString</i> is a quoted string describing the field. </pre> <p><b>Returns</b> : Nothing </p> <p><b>Side-Effects</b> : None </p> <p><b>Exception Conditions</b> : None </p> <p><b>Pre-requisite Conditions</b> : None </p> <hr> <p><a name="Deriving_a_type"></a> </p><h2>Defining a derived type </h2> <p><b>Procedure Name</b> : <i>::WS::Utils::ServiceSimpleTypeDef</i> </p> <p><b>Description</b> : Define a derived type for a service. </p> <p><b>Arguments</b> : </p><pre> <i>mode</i> - <b>Client</b> or <b>Server</b> <i>service</i> - The name of the service this type definition is for <i>type</i> - The type to be defined/redefined <i>definition</i> - The definition of the type's fields. This consist of one or more occurance of a field definition. Each field definition consist of: fieldName fieldInfo Where: {<b>type</b> typeName <b>comment</b> commentString} <b>baseType</b> <i>typeName</i> - any simple or defined type. <b>comment</b> <i>commentString</i> - a quoted string describing the field. <b>pattern</b> <i>value</i> <b>length</b> <i>value</i> <b>fixed</b> <i>"true"|"false"</i> <b>maxLength</b> <i>value</i> <b>minLength</b> <i>value</i> <b>minInclusive</b> <i>value</i> <b>maxInclusive</b> <i>value</i> <b>enumeration</b> <i>value</i> </pre> <p><b>Returns</b> : Nothing </p> <p><b>Side-Effects</b> : None </p> <p><b>Exception Conditions</b> : None </p> <p><b>Pre-requisite Conditions</b> : None </p> <hr> <p><a name="Getting_a_type_definition"></a> </p><h2>Getting a type definition </h2> <p><b>Procedure Name</b> : <i>::WS::Utils::GetServiceTypeDef</i> </p> <p><b>Description</b> : Query for type definitions. </p> <p><b>Arguments</b> : </p><pre> <i>mode</i> - <b>Client</b> or <b>Server</b> <i>service</i> - The name of the service this query is for <i>type</i> - The type to be retrieved (optional) </pre> <p><b>Returns</b> : </p><pre> If type not provided, a dictionary object describing all of the types for the service. If type provided, a dictionary object describing the type. A definition consist of a dictionary object with the following key/values: <b>xns</b> - The namespace for this type. <b>definition</b> - The definition of the type's fields. This consist of one or more occurance of a field definition. Each field definition consist of: fieldName fieldInfo Where field info is: {<b>type</b> <i>typeName</i> <b>comment</b> <b>commentString</b>} <i>typeName</i> can be any simple or defined type. <i>commentString</i> is a quoted string describing the field. </pre> <p><b>Side-Effects</b> : None </p> <p><b>Exception Conditions</b> : None </p> <p><b>Pre-requisite Conditions</b> : The service must be defined. </p> <hr /> <a name="Template_dict_for_type_definition"></a> </p><h2>Generating a template dictionary for a type definition </h2> <p><b>Procedure Name</b> : <i>::WS::Utils::GenerateTemplateDict</i> </p> <p><b>Description</b> : Generate a template dictionary object for a given type.</p> <p><b>Arguments</b> : </p><pre> <i>mode</i> - <b>Client</b> or <b>Server</b> <i>serviceName</i> - The service name the type is defined in <i>type</i> - The name of the type <i>arraySize</i> - Number of elements to generate in an array. Default is 2. </pre> <p><b>Returns</b> : </p><pre> A dictionary object for a given type. If any circular references exist, they will have the value of <** Circular Reference **> </pre> <p><b>Side-Effects</b> : None </p> <p><b>Exception Conditions</b> : None </p> <p><b>Pre-requisite Conditions</b> : The type and service must be defined. </p> </div> </body></html> |
Added docs/Dictionary_Representation_of_XML_Arrays.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 | <!DOCTYPE html> <html><head> <meta http-equiv="content-type" content="text/html; charset=UTF-8"> <title>Web Services for Tcl (aka tclws): Dictionary Representation of XML Arrays</title> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </head> <body> <p> XML arrays are represented in dictionary format as a list of values. Lets consider what this looks like for a <a href="#SimpleTypeArray">simple type</a> and for a <a href="#ComplexTypeArray">complex type</a>;. </p> <p><a name="SimpleTypeArray"></a> </p><h3>Array of Simple Type</h3> <p> Lets assume we have an element with the following definition: </p><pre class="verbatim"> <xs:element minOccurs="0" maxOccurs="unbounded" name="Primes" type="xs:integer" /> </pre> Lets also assume that we will have that element in our dictionary with the first four prime numbers, thus the dictionary representation for that element would look like: <pre class="verbatim"> Primes {2 3 5 7} </pre> Or, if we have are using attributes (i.e. parseInAttr and/or genOutAttr are set), it would look like: <pre class="verbatim"> Primes {{} {2 3 5 7}} </pre> <p></p> <p><a name="ComplexTypeArray"></a> </p><h3>Array of Complex Type</h3> <p> Lets assume we have the type definition: </p><pre class="verbatim"><xs:element name="Person"> <xs:complexType> <xs:sequence> <xs:element name="FristName" type="xs:string"/> <xs:element name="LastName" type="xs:integer"/> </xs:sequence> </xs:complexType> </xs:element> </pre> Lets assume we have the following definition: <pre class="verbatim"> <xs:element minOccurs="0" maxOccurs="unbounded" name="Attendees" type="Person" /> </pre> Now lets assume the following people are are attending: <ul> <li> John Doe </li> <li> Jane Doe </li> </ul> Thus the dictionary representation for that element would look like: <pre class="verbatim"> Attendees { {FirstName {John} LastName {Doe}} {FirstName {Jane} LastName {Doe}} } </pre> Or, if we have are using attributes (i.e. parseInAttr and/or genOutAttr are set), it would look like: <pre class="verbatim"> Attendees { {{} {FirstName {{} {John}} LastName {{} {Doe}}}} {{} {FirstName {{} {Jane}} LastName {{} {Doe}}}} } </pre> <p></p> </div> </body></html> |
Deleted docs/Embedded Web Service.html.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added docs/Embedded_Web_Service.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | <HTML lang=en dir=ltr xml:lang="en" xmlns="http://www.w3.org/1999/xhtml"> <HEAD> <TITLE>Embeding a Web Service</TITLE> <META http-equiv=Content-Type content="text/html; charset=utf-8"> <META content="Embeding a Web Service" name=KEYWORDS> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1>Embeding a Web Service</H1> <TABLE class=toc id=toc> <TR> <TD> <DIV id=toctitle> <H2>Contents</H2></DIV> <UL> <LI class=toclevel-1><A href="#Loading_the_Webservices_Embeded_Package"><SPAN class=tocnumber>1</SPAN> <SPAN class=toctext>Loading the Webservices Embeded Package</SPAN></A> <LI class=toclevel-1><A href="#Listen"><SPAN class=tocnumber>2</SPAN> <SPAN class=toctext>Specify a Port to Receive Request on</SPAN></A> <LI class=toclevel-1><A href="#EventQueue"><SPAN class=tocnumber>3</SPAN> <SPAN class=toctext>Run the event queue</SPAN></A> <LI class=toclevel-1><A href="#Close"><SPAN class=tocnumber>4</SPAN> <SPAN class=toctext>Close a port</SPAN></A> <LI class=toclevel-1><A href="#CloseAll"><SPAN class=tocnumber>4</SPAN> <SPAN class=toctext>Close all ports</SPAN></A> </UL> </TD> </TR> </TABLE> <A name=Loading_the_Webservices_Embeded_Package></A> <H2>Loading the Webservices Server Package </H2> <P>To load the webservices server package, do: </P><PRE> package require WS::Embeded </PRE> <P>This command will only load the server the first time it is used, so it causes no ill effects to put this in each file declaring a service or service procedure. </P> <HR /> <A name=Listen></A> <H2>Specify a Port to Receive Request on</H2> <P>The following command opens a listener socket in the specified port. The webservice functionality may be added by a call to <I>::WS::Server::Service</I> with the <I>-mode</I> parameter set to <I>embedded</I>. <P><B>Procedure Name : <I>::WS::Embeded::Listen</I></B> </P> <P><B>Description</B> : Instruct the module to listen on a Port, security information. <P><B>Arguments</B> : this procedure uses position dependent arguments, they are: </P> <PRE> <I>port </I> -- Port number to listen on. <I>certfile</I> -- Name of the certificate file or a pfx archive for twapi. Defaults to {}. <I>keyfile </I> -- Name of the key file. Defaults to {}. To use twapi TLS, specify a list with the following elements: -- "-twapi": Flag, that TWAPI TLS should be used -- password: password of PFX file passed by [::twapi::conceal]. The concealing makes sure that the password is not readable in the error stack trace -- ?subject?: optional search string in pfx file, if multiple certificates are included. <I>userpwds</I> -- A list of username:password. Defaults to {}. <I>realm </I> -- The seucrity realm. Defaults to {}. <I>timeout </I> -- A time in ms the sender may use to send the request. If a sender sends wrong data (Example: TLS if no TLS is used), the process will just stand and a timeout is required to clear the connection. Set to 0 to not use a timeout. Default: 60000 (1 Minuit). </PRE> <P><B>Returns</B> : Handle of socket </P> <P><B>Side-Effects</B> : None </P> <P><B>Exception Conditions</B> : : None </P> <P><B>Pre-requisite Conditions</B> : None </P> <HR /> <A name=EventQueue></A> <H2>Run the event queue</H2> <P>To serve any requests, the interpreter must run the event queue using. If this is not anyway the case (Tk present etc.), one may call:</P> <PRE> vwait waitVariable </PRE> <P>To stop the event queue after server shutdown, one may execute:</P> <PRE> set waitVariable 1 </PRE> <HR /> <A name=Close></A> <H2>Close a port</H2> <P><B>Procedure Name : <I>::WS::Embeded::Close</I></B> </P> <P><B>Description</B> : Close a formerly opened listener port and stop all running requests on this port. <P><B>Arguments</B> : this procedure uses position dependent arguments, they are: </P> <PRE> <I>port </I> -- Port number to close. </PRE> <P><B>Returns</B> : None </P> <P><B>Side-Effects</B> : None </P> <P><B>Exception Conditions</B> : : None </P> <P><B>Pre-requisite Conditions</B> : None </P> <HR /> <A name=CloseAll></A> <H2>Close all ports</H2> <P><B>Procedure Name : <I>::WS::Embeded::CloseAll</I></B> </P> <P><B>Description</B> : Close all formerly opened listener port and stop all running requests. <P><B>Arguments</B> : this procedure uses no arguments</P> <P><B>Returns</B> : None </P> <P><B>Side-Effects</B> : None </P> <P><B>Exception Conditions</B> : : None </P> <P><B>Pre-requisite Conditions</B> : None </P> </BODY> </HTML> |
Added docs/Rest_flavor_service_response.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | <HTML lang=en dir=ltr xml:lang="en" xmlns="http://www.w3.org/1999/xhtml"> <HEAD> <TITLE>Rest-flavor service reply</TITLE> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1 class=firstHeading>Rest-flavor service reply</H1> <HR> <TABLE class=toc id=toc> <TR> <TD> <H2>Contents</H2></DIV> <UL> <LI class=toclevel-1><A href="#Overview"><SPAN class=tocnumber>1</SPAN> <SPAN class=toctext>Overview</SPAN></A> <LI class=toclevel-1><A href="#Rivet_Example"><SPAN class=tocnumber>2</SPAN> <SPAN class=toctext>Rivet example</SPAN></A> </UL></TD></TR></TBODY></TABLE> <P> </P> <A name=Overview></A> <H2>Overview </H2> <P>Since TCLWS 2.4, it is possible to return a response in <em>REST style</em>. This means, that a JSON reply is returned instead of an XML document.</P> <P>Our use case has only required us to accept FORM arguments and return JSON responses for everything, so we haven't implemented logic to parse any input arguments that are passed in as JSON serialized data, but this might be an area of future exploration for someone.</P> <A name=Rivet_Example></A> <H2>Rivet Example</H2> <P>Here's a bit of code showing how we initially start up this mode in Apache Rivet, which is actually pretty similar to how you'd use tclws in SOAP mode from Apache Rivet:</P> <PRE> # Capture the info from the request into an array. load_headers hdrArray set sock [pid]; # an arbitrary value array unset ::Httpd$sock # Prepare the CGI style arguments into a list load_response formArray set opname $formArray(call) unset formArray(call) set queryarg [list $opname [array get formArray]] # Invoke the the method array set ::Httpd$sock [list query $queryarg ipaddr [env REMOTE_ADDR] headerlist [array get hdrArray]] # Invoke the method in REST mode. set result [catch {::WS::Server::callOperation $svcname $sock -rest} error] array unset ::Httpd$sock if {$result} { headers numeric 500 puts "Operation failed: $error" abort_page } </PRE> </BODY> </HTML> |
Deleted docs/Tcl Web Service Example.html.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted docs/Tcl Web Service Math Example.html.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added docs/Tcl_Web_Service_Example.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | <HTML lang=en dir=ltr xml:lang="en" xmlns="http://www.w3.org/1999/xhtml"> <HEAD> <TITLE>Tcl Web Service Example</TITLE> <META http-equiv=Content-Type content="text/html; charset=utf-8"> <META content="Tcl Web Service Example" name=KEYWORDS> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1>Tcl Web Service Example</H1> <A name=Server_Side></A> <H2>Server Side </H2> <P> The following is placed in the httpdthread.tcl: </P> <PRE> package require WS::Server package require WS::Utils </PRE> <P> The following is placed in the a file in the custom directory: </P> <PRE> ## ## Define the service ## ::WS::Server::Service \ -service wsExamples \ -description {Tcl Example Web Services} \ -host $::Config(host):$::Config(port) </PRE><PRE> ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsExamples echoReply { echoBack {type string} echoTS {type dateTime} } </PRE><PRE> ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsExamples \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { </PRE><PRE> return [list SimpleEchoResult $TestString] } </PRE> <P><BR></P><PRE> ::WS::Server::ServiceProc \ wsExamples \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { </PRE><PRE> set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } </PRE> <P><BR></P> <A name=Client_Side></A> <H2>Client Side </H2><PRE> package require WS::Client </PRE><PRE> ## ## Get Definition of the offered services ## ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsExamples/wsdl </PRE><PRE> set testString "This is a test" set inputs [list TestString $testString] </PRE><PRE> ## ## Call synchronously ## puts stdout "Calling SimpleEcho via DoCalls!" set results [::WS::Client::DoCall wsExamples SimpleEcho $inputs] puts stdout "\t Received: {$results}" </PRE><PRE> puts stdout "Calling ComplexEcho via DoCalls!" set results [::WS::Client::DoCall wsExamples ComplexEcho $inputs] puts stdout "\t Received: {$results}" </PRE> <P><BR></P><PRE> ## ## Generate stubs and use them for the calls ## ::WS::Client::CreateStubs wsExamples puts stdout "Calling SimpleEcho via Stubs!" set results [::wsExamples::SimpleEcho $testString] puts stdout "\t Received: {$results}" </PRE><PRE> puts stdout "Calling ComplexEcho via Stubs!" set results [::wsExamples::ComplexEcho $testString] puts stdout "\t Received: {$results}" </PRE><PRE> ## ## Call asynchronously ## proc success {service operation result} { global waitVar </PRE><PRE> puts stdout "A call to $operation of $service was successful and returned $result" set waitVar 1 } </PRE><PRE> proc hadError {service operation errorCode errorInfo} { global waitVar </PRE><PRE> puts stdout "A call to $operation of $service was failed with {$errorCode} {$errorInfo}" set waitVar 1 } </PRE><PRE> set waitVar 0 puts stdout "Calling SimpleEcho via DoAsyncCall!" ::WS::Client::DoAsyncCall wsExamples SimpleEcho $inputs \ [list success wsExamples SimpleEcho] \ [list hadError wsExamples SimpleEcho] vwait waitVar </PRE><PRE> puts stdout "Calling ComplexEcho via DoAsyncCall!" ::WS::Client::DoAsyncCall wsExamples ComplexEcho $inputs \ [list success wsExamples SimpleEcho] \ [list hadError wsExamples SimpleEcho] vwait waitVar </PRE><PRE> exit </PRE> <P><BR></P> </BODY> </HTML> |
Added docs/Tcl_Web_Service_Math_Example.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | <HTML lang=en dir=ltr xml:lang="en" xmlns="http://www.w3.org/1999/xhtml"> <HEAD> <TITLE>Tcl Web Service Math Example</TITLE> <META http-equiv=Content-Type content="text/html; charset=utf-8"> <META content="Tcl Web Service Math Example" name=KEYWORDS> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1>Tcl Web Service Math Example</H1> <A name=Server_Side></A> <H2>Server Side </H2> <P> The following is placed in the httpdthread.tcl: </P> <PRE> package require WS::Server package require WS::Utils </PRE> <P> The following is placed in the a file in the custom directory: </P> <PRE> ## ## Define the service ## ::WS::Server::Service \ -service wsMathExample \ -description {Tcl Web Services Math Example} \ -host $::Config(host):$::Config(port) ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsMathExample Term { `coef {type float} powerTerms {type PowerTerm()} } ::WS::Utils::ServiceTypeDef Server wsMathExample PowerTerm { var {type string} exponet {type float} } ::WS::Utils::ServiceTypeDef Server wsMathExample Variables { var {type string} value {type float} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsMathExample \ {EvaluatePolynomial {type float comment {Result of evaluating a polynomial}}} \ { varList {type Variables() comment {The variables to be substitued into the polynomial}} polynomial {type Term() comment {The polynomial}} } \ {Evaluate a polynomial} { set equation {0 } foreach varDict $varList { set var [dict get $varDict var] set val [dict get $varDict value] set vars($var) $val } foreach term $polynomial { if {[dict exists $term coef]} { set coef [dict get $term coef] } else { set coef 1 } append equation "+ ($coef" foreach pow [dict get $term powerTerms] { if {[dict exists $pow exponet]} { set exp [dict get $pow exponet] } else { set exp 1 } append equation [format { * pow($vars(%s),%s} [dict get $pow var] $exp] } append equation ")" } set result [expr $equation] return [list SimpleEchoResult $result] } </PRE> <P><BR></P> <A name=Client_Side></A> <H2>Client Side </H2> <PRE> package require WS::Client ## ## Get Definition of the offered services ## ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsMathExamples/wsdl dict set term var X dict set term value 2.0 dict lappend varList $term dict set term var Y dict set term value 3.0 dict lappend varList $term set term {} set powerTerm {} dict set powerTerm coef 2.0 dict set term var X dict set term pow 2.0 dict lappend terms $term dict set term var Y dict set term pow 3.0 dict lappend terms $term dict set powerTerm powerTerms $terms dict set powerTerm coef -2.0 dict set term var X dict set term pow 3.0 dict lappend terms $term dict set term var Y dict set term pow 2.0 dict lappend terms $term dict set powerTerm powerTerms $terms dict lappend polynomial powerTerms $powerTerm dict set input [list varList $varList polynomial $polynomial] ## ## Call service ## puts stdout "Calling EvaluatePolynomial wiht {$input}" set resultsDict [::WS::Client::DoCall wsMathExample EvaluatePolynomial $input] puts stdout "Results are {$resultsDict}" </PRE> <P><BR></P> </BODY> </HTML> |
Deleted docs/Using Options.html.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added docs/Using_Options.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | <HTML lang=en dir=ltr xml:lang="en" xmlns="http://www.w3.org/1999/xhtml"> <HEAD> <TITLE>Using Web Service Options</TITLE> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1 class=firstHeading>Using Web Service Options</H1> <TABLE class=toc id=toc> <TR> <TD> <H2>Contents</H2></DIV> <UL> <li class="toclevel-1"><a href="#Overview"><span class="toctext">Overview</span></a> </li><li class="toclevel-1"><a href="#Loading_the_Webservices_Utilities_Package"><span class="toctext">Loading the Webservices Utilities Package</span></a> </li><li class="toclevel-1"><a href="#SetOption"> <span class="toctext">Access Routine</span></a> </li><li class="toclevel-1"><a href="#Options"> <span class="toctext">Options</span></a> <ul> </li><li class="toclevel-2"><a href="#genOutAttr"> <span class="toctext">genOutAttr - generate attributes on outbound tags</span></a> </li><li class="toclevel-2"><a href="#includeDirectory"> <span class="toctext">includeDirectory - disk directory to use for XSD includes when they can not be accessed via the Web.</span></a> </li><li class="toclevel-2"><a href="#nsOnChangeOnly"> <span class="toctext">nsOnChangeOnly - only put namespace prefix when namespaces change</span></a> </li><li class="toclevel-2"><a href="#parseInAttr"><span class="toctext">parseInAttr - parse attributes on inbound tags</span></a> </li><li class="toclevel-2"><a href="#queryTimeout"> <span class="toctext">queryTimeout - set http(s) fetch timeout.</span></a> </li><li class="toclevel-2"><a href="#StrictMode"> <span class="toctext">StrictMode - WSDL processing mode</span></a> <li class="toclevel-2"><a href="#UseNS"> <span class="toctext">UseNS - put namespaces on field tags</span></a> </li><li class="toclevel-2"><a href="#useTypeNs"> <span class="toctext">useTypeNs - use type's namespace prefix as prefix of elements</span></a> </li><li class="toclevel-2"><a href="#suppressNS"> <span class="toctext">suppressNS - do not put a particular namespace prefix</span></a> </li></ul> </li></ul> <P> </P> <A name=Overview></A> <H2>Overview</H2> </P> <P>The Webservices Client and Server packages make use of the following options: </p><ul> <li><a href="#UseNS">UseNS</a>, when set the following options become relevant: <ul> <li><a href="#useTypeNs">useTypeNs</a> </li><li><a href="#nsOnChangeOnly">nsOnChangeOnly</a> </li><li><a href="#suppressNS">suppressNS</a> </li></ul> </li><li><a href="#StrictMode">StrictMode</a> </li><li><a href="#parseInAttr">parseInAttr</a> </li><li><a href="#genOutAttr">genOutAttr</a> </li><li><a href="#includeDirectory">includeDirectory</a> </li></ul> <p></p> <P>The attributes can be retrieved and set using <A href="#SetOption">::WS::Utils::SetOption</A>.</P> <p>If called by the client side, the following options are overwritten and restored on any call: <ul> <li>genOutAttr</li> <li>nsOnChangeOnly</li> <li>parseInAttr</li> <li>suppressNS</li> <li>UseNS</li> <li>useTypeNs</li> <li>valueAttrCompatiblityMode</li> </ul> </p> <HR> <A name=Loading_the_Webservices_Utilities_Package></A> <H2>Loading the Webservices Utilities Package </H2> <P>To load the webservices server package, do: </P><PRE> package require WS::Utils </PRE> <P>This command will only load the utilities the first time it is used, so it causes no ill effects to put this in each file using the utilties. </P> <HR> <A name=SetOption></A> <H2>Access Routine </H2> <P><B>Procedure Name : <I>::WS::Utils::SetOption</I></B> </P> <P><B>Description : </B> Retrieve or set an option </P> <P><B>Arguments :</B> </P> <PRE> <I>option</I> - name of the option <I>value</I> - value of the option (optional) </PRE> <P><B>Returns : The value of the option</B> </P> <P><B>Side-Effects : None</B> </P> <P><B>Exception Conditions :None</B> </P> <P><B>Pre-requisite Conditions : None</B> </P> <HR> <A name=genOutAttr></A> <H2>genOutAttr - generate attributes on outbound tags </H2> <P> The <I>genOutAttr</I> option, if set to a "true" value, will convert all dictionary keys of the entry for a given field tag to attribute value pairs of the tag in the outbound XML. For attributes in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name prepended with two colons (e.g. <B>::type</B>) and the value will be the value of the attribute. For attributes other than those in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name and the value will be the value of the attribute. The value of the tag will have a key determined by the <a href="#valueAttrCompatiblityMode"><I>valueAttrCompatiblityMode</I></a>. </P> <P> The default value, "0", is for this option to be turned off. </P> <HR> <p><a name="includeDirectory"></a> </p><h2>includeDirectory - disk directory to use for XSD includes when they can not be accessed via the Web. </h2> <p> The <i>includeDirectory</i> option, if set, instructs TclWs to look in the specified directory for any XSD includes that can not be found via the web. </p> <p> The default value, "{}", is for this option to be turned off. </p> <hr /> <p><a name="nsOnChangeOnly"></a> </p><h2>nsOnChangeOnly - only put namespace prefix when namespaces change </h2> <p> The <i>nsOnChangeOnly</i> option, if set to a "true" value, will only place namespace prefixes when the namespaces change. </p> <p> This option is only relevant, if the option <a href="#UseNS">UseNS</a> is set. </p> <p> The default value, "0", is for this option to be turned off. </p> <hr /> <A name=parseInAttr></A> <H2>parseInAttr - parse attributes on inbound tags </H2> <P> The <I>parseInAttr</I> option, if set to a "true" value, will convert all attributes of inbound field tags to dictionary entries for that tag. For attributes in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name prepended with two colons (e.g. <B>::type</B>) and the value will be the value of the attribute. For attributes other than those in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name and the value will be the value of the attribute. The value of the tag will have a key determined by the <a href="#valueAttrCompatiblityMode"><I>valueAttrCompatiblityMode</I></a>. </P> <P> The default value, "0", is for this option to be turned off. </P> <HR /> <p><a name="queryTimeout"></a></p> <h2>queryTimeout - set http(s) query timeout</h2> <p> Timeout to any network query in ms. The <A HREF="Calling_a_Web_Service.html#Config">client side package</a> has an option with the same functionality, which is used, when there is a call option context. </p> <p>Default value: 60000 (1 minuite).</p> <HR /> <A name=StrictMode></A> <H2>StrictMode - WSDL processing mode </H2> <P> The <I>StrictMode</I> option determines what happens when an error is detected in parsing a WSDL. The legal values are: <UL> <LI><B>debug</B></LI> <LI><B>warning</B></LI> <LI><B>error</B></LI> </UL> </P> <P> If the <I>StrictMode</I> is set to <B>debug</B> or <B>warning</B>, a message is logged using the ::log package at that level and the error is then ignored. </P> <P> If the <I>StrictMode</I> is set to any value other than <B>debug</B> or <B>warning</B>, a message is logged using the ::log package at the <B>error</B> level and exception is generated. </P> <P> The default value is <B>error</B>. </P> <P> A major use of this is to ignore namespace imports in a WDSL that do not actually import any definitions. </P> <HR /> <A name=UseNS></A> <H2>UseNS - put namespaces on field tags </H2> <P> The <I>UseNS</I> option, if set to a "true" value, will put a namespace alias on all field tags. </P> <P> The default value, "1", is for this option to be turned on. </P> <HR> <p><a name="useTypeNs"></a> </p><h2>useTypeNs - use type's namespace prefix as prefix of elements </h2> <p> The <i>useTypeNs</i> option, if set to a "true" value, will use the prefix of the type's namespace instead of the prefix of the element's namespace. </p> <p> This option is only relevant, if the option <a href="#UseNS">UseNS</a> is set. </p> <p> The default value, "0", is for this option to be turned off. </p> <hr /> <p><a name="suppressNS"></a> </p><h2>suppressNS - do not put a given namespace prefix. </h2> <p> The <i>suppressNS</i> option, if set, will cause the given namespace to never be used as a prefix (i.e. tags that would normally have had the given prefix will not have any prefix). </p> <p> This option is only relevant, if the option <a href="#UseNS">UseNS</a> is set. </p> <p> The default value, "{}", is for this option to be turned off. </p> <hr /> <A name=valueAttrCompatiblityMode></A> <H2>valueAttrCompatiblityMode - specify dictionary key for value when attributes are in use</H2> <P> This option is only meaningful when the <i>parseInAttr</i> or <I>genOutAttr</I> option is set to a "true" value. When set to a "true" value, the value of the tag will have a key of the null string (i.e. <B>{}</B>). When set to a "false" value, the value of the tag will have a key of <B>::value</B>. </P> <P> The default value, "0", is for this option to be turned off. </P> <HR> </BODY> </HTML> |
Changes to docs/index.html.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN"> <HTML> <HEAD> <TITLE>Tcl Web Services</TITLE> <META NAME="Generator" CONTENT="TextPad 4.6"> <META NAME="Author" CONTENT="Gerald W. Lester"> </HEAD> <BODY> <H1>Tcl Web Services</H1> <h2>Summary</h2> <p> The distribution provides both client side access to Web Services and server side creation of Web Services. Currently only document/literal and rpc/encoded with HTTP Soap transport are supported on the client side. The server side currently works only with TclHttpd or embedded into an application. The server side provides all services as document/literal over HTTP Soap transport. Documentation for the package, including examples can be found here. </p> <UL> | > | | | > > | | | > > > > > > > > > > > > > | | | | | > | > > | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN"> <HTML> <HEAD> <TITLE>Tcl Web Services</TITLE> <META NAME="Generator" CONTENT="TextPad 4.6"> <META NAME="Author" CONTENT="Gerald W. Lester"> <link rel="stylesheet" href="style.css" type="text/css" media="screen"> </HEAD> <BODY> <H1>Tcl Web Services</H1> <h2>Summary</h2> <p> The distribution provides both client side access to Web Services and server side creation of Web Services. Currently only document/literal and rpc/encoded with HTTP Soap transport are supported on the client side. The server side currently works only with TclHttpd or embedded into an application. The server side provides all services as document/literal over HTTP Soap transport. Documentation for the package, including examples can be found here. </p> <UL> <LI> <A HREF="Calling_a_Web_Service.html">Calling a Web Service from Tcl</A></LI> <LI> <A HREF="Creating_a_Tcl_Web_Service.html">Creating a Tcl Web Service</A></LI> <LI> <A HREF="Creating_a_Web_Service_Type.html">Creating a Web Service Type</A></LI> <LI> <A HREF="Rest_flavor_service_response.html">REST flavor service response</A></LI> <LI> <A HREF="Dictionary_Representation_of_XML_Arrays.html">Dictionary Representation of XML Arrays</A></LI> <LI> <A HREF="Using_Options.html">Using Web Service Options</A></LI> <LI> <A HREF="Embedded_Web_Service.html">Embeding a Web Service into an application</A></LI> <LI> <A HREF="Tcl_Web_Service_Example.html">Tcl Web Service Example</A></LI> <LI> <A HREF="Tcl_Web_Service_Math_Example.html">Tcl Web Service Math Example</A></LI> </UL> <p> The client is known to work with #C and Java based Web Services (your mileage may very). </p> <h2>License</h2> <p> Standard BSD. <h1>Web Servers</h1> <p> The server side works with the following web servers: </p><ul> <li> <a href="https://core.tcl-lang.org/tclhttpd">TclHttpd</a> </li><li> <a href="http://tcl.apache.org/rivet">Rivet</a> </li><li> <a href="http://www.aolserver.com/">AOLserver</a> </li><li> <a href="http://code.google.com/p/wub/">WUB</a> </li><li> <a href="http://wiki.tcl-lang.org/23626">wibble</a> </li><li> Embedded mode (see <a href="Embedded_Web_Service.html">Embedding</a>) </li></ul> </p> <h2>Packages Required</h2> <p> The following packages are used: </p> <UL> <li> <a href="http://www.tcl-lang.org/">Tcl 8.6</a> </li><li> <a href="http://www.tdom.org/">tdom 0.8.1</a> </li><li> <a href="http://core.tcl-lang.org/tcltls/">tcltls</a> or <a href="https://www.magicsplat.com/tcl-docs/doctoc_twapi.html">TWAPI 4.4.0</a> for client and embedded server TLS support </li><li> log from <a href="https://core.tcl-lang.org/tcllib">TclLib</a> </li><li> uri from <a href="https://core.tcl-lang.org/tcllib">TclLib</a> </li><li> struct::set from <a href="https://core.tcl-lang.org/tcllib">TclLib</a> </li><li> http from <a href="http://www.tcl-lang.org/">Tcl</a> itself </li><li> yajl-tcl from <a href="https://github.com/flightaware/yajl-tcl">flightaware github</a> (only for rest-flavour requests) </li></ul> <p> If you are running the TclHttpd on Windows, it is highly recommended that you use the iocpsock extension. </p> <p> The following packages are additionally used in Embedded Server mode: </p><ul> <li> base64 from <a href="https://core.tcl-lang.org/tcllib">TclLib</a> (also channel server) </li><li> html from <a href="https://core.tcl-lang.org/tcllib">TclLib</a> (also channel server) </li><li> ncgi from <a href="https://core.tcl-lang.org/tcllib">TclLib</a> </li><li> fileutil from <a href="https://core.tcl-lang.org/tcllib">TclLib</a> </li></ul> </BODY> </HTML> |
Added docs/style.css.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 | /* General settings for the entire page */ body { margin: 0ex 0ex; padding: 0px; background-color: #fef3bc; font-family: sans-serif; } /* The project logo in the upper left-hand corner of each page */ div.logo { display: inline; text-align: center; vertical-align: bottom; font-weight: bold; font-size: 2.5em; color: #a09048; } /* The page title centered at the top of each page */ div.title { display: table-cell; font-size: 2em; font-weight: bold; text-align: left; padding: 0 0 0 5px; color: #a09048; vertical-align: bottom; width: 100%; } /* The login status message in the top right-hand corner */ div.status { display: table-cell; text-align: right; vertical-align: bottom; color: #a09048; padding: 5px 5px 0 0; font-size: 0.8em; font-weight: bold; } /* The header across the top of the page */ div.header { display: table; width: 100%; } /* The main menu bar that appears at the top of the page beneath ** the header */ div.mainmenu { padding: 5px 10px 5px 10px; font-size: 0.9em; font-weight: bold; text-align: center; letter-spacing: 1px; background-color: #a09048; color: black; } /* The submenu bar that *sometimes* appears below the main menu */ div.submenu, div.sectionmenu { padding: 3px 10px 3px 0px; font-size: 0.9em; text-align: center; background-color: #c0af58; color: white; } div.mainmenu a, div.mainmenu a:visited, div.submenu a, div.submenu a:visited, div.sectionmenu>a.button:link, div.sectionmenu>a.button:visited { padding: 3px 10px 3px 10px; color: white; text-decoration: none; } div.mainmenu a:hover, div.submenu a:hover, div.sectionmenu>a.button:hover { color: #a09048; background-color: white; } /* All page content from the bottom of the menu or submenu down to ** the footer */ div.content { padding: 1ex 5px; } div.content a { color: #706532; } div.content a:link { color: #706532; } div.content a:visited { color: #704032; } div.content a:hover { background-color: white; color: #706532; } /* Some pages have section dividers */ div.section { margin-bottom: 0px; margin-top: 1em; padding: 3px 3px 0 3px; font-size: 1.2em; font-weight: bold; background-color: #a09048; color: white; } /* The "Date" that occurs on the left hand side of timelines */ div.divider { background: #e1d498; border: 2px #a09048 solid; font-size: 1em; font-weight: normal; padding: .25em; margin: .2em 0 .2em 0; float: left; clear: left; } /* The footer at the very bottom of the page */ div.footer { font-size: 0.8em; margin-top: 12px; padding: 5px 10px 5px 10px; text-align: right; background-color: #a09048; color: white; } /* Hyperlink colors */ div.footer a { color: white; } div.footer a:link { color: white; } div.footer a:visited { color: white; } div.footer a:hover { background-color: white; color: #558195; } /* <verbatim> blocks */ pre.verbatim { background-color: #f5f5f5; padding: 0.5em; } /* The label/value pairs on (for example) the ci page */ table.label-value th { vertical-align: top; text-align: right; padding: 0.2ex 2ex; } /* Side-by-side diff */ table.sbsdiff { background-color: #ffffc5; font-family: fixed, Dejavu Sans Mono, Monaco, Lucida Console, monospace; font-size: 8pt; border-collapse:collapse; white-space: pre; width: 98%; border: 1px #000 dashed; } table.sbsdiff th.diffhdr { border-bottom: dotted; border-width: 1px; } table.sbsdiff tr td { white-space: pre; padding-left: 3px; padding-right: 3px; margin: 0px; } table.sbsdiff tr td.lineno { text-align: right; } table.sbsdiff tr td.meta { background-color: #a09048; text-align: center; } table.sbsdiff tr td.added { background-color: rgb(210, 210, 100); } table.sbsdiff tr td.removed { background-color: rgb(190, 200, 110); } table.sbsdiff tr td.changed { background-color: rgb(200, 210, 120); }/* The nomenclature sidebox for branches,.. */ div.sidebox { float: right; background-color: white; border-width: medium; border-style: double; margin: 10px; } /* The nomenclature title in sideboxes for branches,.. */ div.sideboxTitle { display: inline; font-weight: bold; } /* The defined element in sideboxes for branches,.. */ div.sideboxDescribed { display: inline; font-weight: bold; } /* The defined element in sideboxes for branches,.. */ span.disabled { color: red; } /* The suppressed duplicates lines in timeline, .. */ span.timelineDisabled { font-style: italic; font-size: small; } /* the format for the timeline data table */ table.timelineTable { border: 0; } /* the format for the timeline data cells */ td.timelineTableCell { vertical-align: top; text-align: left; } /* the format for the timeline leaf marks */ span.timelineLeaf { font-weight: bold; } /* the format for the timeline version links */ a.timelineHistLink { } /* the format for the timeline version display(no history permission!) */ span.timelineHistDsp { font-weight: bold; } /* the format for the timeline time display */ td.timelineTime { vertical-align: top; text-align: right; } /* the format for the grap placeholder cells in timelines */ td.timelineGraph { width: 20px; text-align: left; vertical-align: top; } /* the format for the tag links */ a.tagLink { } /* the format for the tag display(no history permission!) */ span.tagDsp { font-weight: bold; } /* the format for wiki errors */ span.wikiError { font-weight: bold; color: red; } /* the format for fixed/canceled tags,.. */ span.infoTagCancelled { font-weight: bold; text-decoration: line-through; } /* the format for fixed/cancelled tags,.. on wiki pages */ span.wikiTagCancelled { text-decoration: line-through; } /* format for the file display table */ table.browser { /* the format for wiki errors */ width: 100% ; border: 0; } /* format for cells in the file browser */ td.browser { width: 24% ; vertical-align: top; } /* format for the list in the file browser */ ul.browser { margin-left: 0.5em; padding-left: 0.5em; } /* table format for login/out label/input table */ table.login_out { text-align: left; margin-right: 10px; margin-left: 10px; margin-top: 10px; } /* captcha display options */ div.captcha { text-align: center; } /* format for the layout table, used for the captcha display */ table.captcha { margin: auto; padding: 10px; border-width: 4px; border-style: double; border-color: black; } /* format for the label cells in the login/out table */ td.login_out_label { text-align: center; } /* format for login error messages */ span.loginError { color: red; } /* format for leading text for notes */ span.note { font-weight: bold; } /* format for textarea labels */ span.textareaLabel { font-weight: bold; } /* format for the user setup layout table */ table.usetupLayoutTable { outline-style: none; padding: 0; margin: 25px; } /* format of the columns on the user setup list page */ td.usetupColumnLayout { vertical-align: top } /* format for the user list table on the user setup page */ table.usetupUserList { outline-style: double; outline-width: 1px; padding: 10px; } /* format for table header user in user list on user setup page */ th.usetupListUser { text-align: right; padding-right: 20px; } /* format for table header capabilities in user list on user setup page */ th.usetupListCap { text-align: center; padding-right: 15px; } /* format for table header contact info in user list on user setup page */ th.usetupListCon { text-align: left; } /* format for table cell user in user list on user setup page */ td.usetupListUser { text-align: right; padding-right: 20px; white-space:nowrap; } /* format for table cell capabilities in user list on user setup page */ td.usetupListCap { text-align: center; padding-right: 15px; } /* format for table cell contact info in user list on user setup page */ td.usetupListCon { text-align: left } /* layout definition for the capabilities box on the user edit detail page */ div.ueditCapBox { float: left; margin-right: 20px; margin-bottom: 20px; } /* format of the label cells in the detailed user edit page */ td.usetupEditLabel { text-align: right; vertical-align: top; white-space: nowrap; } /* color for capabilities, inherited by nobody */ span.ueditInheritNobody { color: green; } /* color for capabilities, inherited by developer */ span.ueditInheritDeveloper { color: red; } /* color for capabilities, inherited by reader */ span.ueditInheritReader { color: black; } /* color for capabilities, inherited by anonymous */ span.ueditInheritAnonymous { color: blue; } /* format for capabilities, mentioned on the user edit page */ span.capability { font-weight: bold; } /* format for different user types, mentioned on the user edit page */ span.usertype { font-weight: bold; } /* leading text for user types, mentioned on the user edit page */ span.usertype:before { content:"'"; } /* trailing text for user types, mentioned on the user edit page */ span.usertype:after { content:"'"; } /* selected lines of text within a linenumbered artifact display */ div.selectedText { font-weight: bold; color: blue; background-color: #d5d5ff; border: 1px blue solid; } /* format for missing privileges note on user setup page */ p.missingPriv { color: blue; } /* format for leading text in wikirules definitions */ span.wikiruleHead { font-weight: bold; } /* format for labels on ticket display page */ td.tktDspLabel { text-align: right; } /* format for values on ticket display page */ td.tktDspValue { text-align: left; vertical-align: top; background-color: #d0d0d0; } /* format for ticket error messages */ span.tktError { color: red; font-weight: bold; } /* format for example tables on the report edit page */ table.rpteditex { float: right; margin: 0; padding: 0; width: 125px; text-align: center; border-collapse: collapse; border-spacing: 0; } /* format for example table cells on the report edit page */ td.rpteditex { border-width: thin; border-color: #000000; border-style: solid; } /* format for user color input on checkin edit page */ input.checkinUserColor { /* no special definitions, class defined, to enable color pickers, f.e.: ** add the color picker found at http:jscolor.com as java script include ** to the header and configure the java script file with ** 1. use as bindClass :checkinUserColor ** 2. change the default hash adding behaviour to ON ** or change the class defition of element identified by id="clrcust" ** to a standard jscolor definition with java script in the footer. */ } /* format for end of content area, to be used to clear page flow(sidebox on branch,.. */ div.endContent { clear: both; } /* format for general errors */ p.generalError { color: red; } /* format for tktsetup errors */ p.tktsetupError { color: red; font-weight: bold; } /* format for xfersetup errors */ p.xfersetupError { color: red; font-weight: bold; } /* format for th script errors */ p.thmainError { color: red; font-weight: bold; } /* format for th script trace messages */ span.thTrace { color: red; } /* format for report configuration errors */ p.reportError { color: red; font-weight: bold; } /* format for report configuration errors */ blockquote.reportError { color: red; font-weight: bold; } /* format for artifact lines, no longer shunned */ p.noMoreShun { color: blue; } /* format for artifact lines beeing shunned */ p.shunned { color: blue; } /* a broken hyperlink */ span.brokenlink { color: red; } /* List of files in a timeline */ ul.filelist { margin-top: 3px; line-height: 100%; } /* side-by-side diff display */ div.sbsdiff { font-family: monospace; font-size: smaller; white-space: pre; } /* context diff display */ div.udiff { font-family: monospace; white-space: pre; } /* changes in a diff */ span.diffchng { background-color: #c0c0ff; } /* added code in a diff */ span.diffadd { background-color: #c0ffc0; } /* deleted in a diff */ span.diffrm { background-color: #ffc8c8; } /* suppressed lines in a diff */ span.diffhr { color: #0000ff; } /* line numbers in a diff */ span.diffln { color: #a0a0a0; } /* Moderation Pending message on timeline */ span.modpending { color: #b03800; font-style: italic; } |
Added license.terms.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | This software is copyrighted by the Gerald W. Leser and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license. |
Changes to pkgIndex.tcl.
|
| < < < < < < < < < | | < | | | | | < | | 1 2 3 4 5 6 7 8 | 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 3.0.1 [list source [file join $dir ClientSide.tcl]] package ifneeded WS::Embeded 3.3.1 [list source [file join $dir Embedded.tcl]] package ifneeded WS::Server 3.4.0 [list source [file join $dir ServerSide.tcl]] package ifneeded WS::Utils 3.1.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]] |