Posted to tcl by patthoyts at Tue Jan 26 00:28:39 GMT 2010view raw
- proc match_old {url} {
- set exp {^(([^:]*)://)?([^@]+@)?([^/:]+)(:([0-9]+))?(/.*)?$}
- if {![regexp -nocase $exp $url x prefix proto user host y port srvurl]} {
- return -code error "Unsupported URL: $url"
- }
- return [list $proto $user $host $port $srvurl]
- }
- proc match_now {url} {
- set URLmatcher {(?x) # this is _expanded_ syntax
- ^
- (?: (\w+) : ) ? # <protocol scheme>
- (?: //
- (?:
- (
- [^@/\#?]+ # <userinfo part of authority>
- ) @
- )?
- ( [^/:\#?]+ ) # <host part of authority>
- (?: : (\d+) )? # <port part of authority>
- )?
- ( / [^\#]*)? # <path> (including query)
- (?: \# (.*) )? # <fragment>
- $
- }
- if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
- return -code error "Unsupported URL: $url"
- }
- return [list $proto $user $host $port $srvurl]
- }
- foreach url {
- http://www.example.com/?iq=1
- http://user:pass@www.example.com/?a=1&b-2
- http://www.example.com/?q=1/2/3/@xyz
- http://user:pass@www.example.com/?q=1/2/3/@xyz
- } {
- puts "old: [lindex [match_old $url] 1]"
- puts "new: [lindex [match_now $url] 1]"
- }
- ## results:
- pat@frog:/opt/src/tcl.git$ tclsh ../http_check.tcl
- old:
- new:
- old: user:pass@
- new: user:pass
- old: www.example.com/?q=1/2/3/@
- new:
- old: user:pass@
- new: user:pass
- pat@frog:/opt/src/tcl.git$