Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | ::WS::Utils::geturl_followRedirects : limit to 5 redirects, plug http package memory leak, add redirect test scripts |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
a18130bfafb49e71935e82e0ffc9ddeb |
User & Date: | oehhar 2015-11-09 16:17:13.207 |
Context
2015-11-09 16:19 | Removed own debugging message, sorry check-in: 0cda2c9b1d user: oehhar tags: trunk | |
2015-11-09 16:17 | ::WS::Utils::geturl_followRedirects : limit to 5 redirects, plug http package memory leak, add redirect test scripts check-in: a18130bfaf user: oehhar tags: trunk | |
2015-11-03 17:42 | Fixed outdated example EchoEmbeddedService. Ticket [0e2728fadd] check-in: 1610455cee user: oehhar tags: trunk | |
Changes
Changes to Examples/Echo/CallEchoWebService.tcl.
︙ | ︙ | |||
29 30 31 32 33 34 35 | ## 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. ## ## ## ############################################################################### | > | | | 29 30 31 32 33 34 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. ## ## ## ############################################################################### 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 set testString "This is a test" |
︙ | ︙ |
Changes to Examples/Echo/EchoEmbeddedService.tcl.
︙ | ︙ | |||
29 30 31 32 33 34 35 | ## 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. ## ## ## ############################################################################### | | > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | ## 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} \ |
︙ | ︙ | |||
83 84 85 86 87 88 89 | return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } set ::errorInfo {} set SocketHandle [::WS::Embeded::Listen 8015] set ::errorInfo {} | > > > > > | < < < | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | 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/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 Utilities.tcl.
︙ | ︙ | |||
55 56 57 58 59 60 61 | } } package require log package require tdom 0.8 package require struct::set | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | } } package require log package require tdom 0.8 package require struct::set package provide WS::Utils 2.3.10 namespace eval ::WS {} namespace eval ::WS::Utils { set ::WS::Utils::typeInfo {} set ::WS::Utils::currentSchema {} array set ::WS::Utils::importedXref {} |
︙ | ︙ | |||
4528 4529 4530 4531 4532 4533 4534 | ## 8.5 or later, so use {*} expansion ## proc ::WS::Utils::setAttr {node attrList} { $node setAttribute {*}$attrList } } | > | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | > > > > > | 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 | ## 8.5 or later, so use {*} expansion ## 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 : nothing # # 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) # ########################################################################### proc ::WS::Utils::geturl_followRedirects {url args} { ::log::log 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} { if {[llength $args]} { ::log::log info [concat [list ::http::geturl $url] $args] set token [eval [list http::geturl $url] $args] } else { ::log::log info [list ::http::geturl $url] set token [::http::geturl $url] } set ncode [::http::ncode $token] puts **$ncode if {![string match {30[12378]} $ncode]} { ::log::log 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::log debug "initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir" set ::WS::Utils::redirectArray($initialUrlDir) $finalUrlDir } 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 {[string equal $uri(host) {}]} { set uri(host) $URI(host) } # problem w/ relative versus absolute paths set url [eval ::uri::join [array get uri]] ::log::log debug "url = $url" set finalUrl $url } # > 5 redirects reached -> exit with error return -code error "http redirect limit exceeded" } |
Changes to pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded WS::Client 2.3.8 [list source [file join $dir ClientSide.tcl]] package ifneeded WS::Server 2.3.7 [list source [file join $dir ServerSide.tcl]] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded WS::Client 2.3.8 [list source [file join $dir ClientSide.tcl]] package ifneeded WS::Server 2.3.7 [list source [file join $dir ServerSide.tcl]] package ifneeded WS::Utils 2.3.10 [list source [file join $dir Utilities.tcl]] package ifneeded WS::Embeded 2.3.0 [list source [file join $dir Embedded.tcl]] package ifneeded WS::AOLserver 2.0.0 [list source [file join $dir AOLserver.tcl]] package ifneeded WS::Channel 2.0.0 [list source [file join $dir ChannelServer.tcl]] package ifneeded WS::Wub 2.2.1 [list source [file join $dir WubServer.tcl]] package ifneeded Wsdl 2.0.0 [list source [file join $dir WubServer.tcl]] |
︙ | ︙ |