Posted to tcl by patthoyts at Tue Jan 26 00:28:39 GMT 2010view raw

  1. proc match_old {url} {
  2. set exp {^(([^:]*)://)?([^@]+@)?([^/:]+)(:([0-9]+))?(/.*)?$}
  3. if {![regexp -nocase $exp $url x prefix proto user host y port srvurl]} {
  4. return -code error "Unsupported URL: $url"
  5. }
  6. return [list $proto $user $host $port $srvurl]
  7. }
  8.  
  9. proc match_now {url} {
  10. set URLmatcher {(?x) # this is _expanded_ syntax
  11. ^
  12. (?: (\w+) : ) ? # <protocol scheme>
  13. (?: //
  14. (?:
  15. (
  16. [^@/\#?]+ # <userinfo part of authority>
  17. ) @
  18. )?
  19. ( [^/:\#?]+ ) # <host part of authority>
  20. (?: : (\d+) )? # <port part of authority>
  21. )?
  22. ( / [^\#]*)? # <path> (including query)
  23. (?: \# (.*) )? # <fragment>
  24. $
  25. }
  26. if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
  27. return -code error "Unsupported URL: $url"
  28. }
  29. return [list $proto $user $host $port $srvurl]
  30. }
  31.  
  32. foreach url {
  33. http://www.example.com/?iq=1
  34. http://user:pass@www.example.com/?a=1&b-2
  35. http://www.example.com/?q=1/2/3/@xyz
  36. http://user:pass@www.example.com/?q=1/2/3/@xyz
  37. } {
  38. puts "old: [lindex [match_old $url] 1]"
  39. puts "new: [lindex [match_now $url] 1]"
  40. }
  41.  
  42. ## results:
  43. pat@frog:/opt/src/tcl.git$ tclsh ../http_check.tcl
  44. old:
  45. new:
  46. old: user:pass@
  47. new: user:pass
  48. old: www.example.com/?q=1/2/3/@
  49. new:
  50. old: user:pass@
  51. new: user:pass
  52. pat@frog:/opt/src/tcl.git$