Posted to tcl by patthoyts at Tue Feb 26 22:48:20 GMT 2008view raw

  1. package require Tk
  2. if {![package vsatisfies [package provide Tk] 8.5]} {
  3. set auto_path [concat /opt/tcl/site-lib/tile0.8.2 $auto_path]
  4. package require tile
  5. }
  6. source [file join [file dirname [info script]] http.tcl]
  7. set auto_path [concat /opt/tcl/site-lib/tls1.5.1 $auto_path]
  8. package require tls
  9.  
  10. http::register https 443 ::tls::socket
  11.  
  12. proc Progress {tok total count} {
  13. .status.progress configure -value [expr {($count * 100) / $total}]
  14. }
  15.  
  16. proc Command {tok} {
  17. .t insert end "$tok [http::status $tok]\n" {}
  18. catch {
  19. for {set level 0} {1} {incr level -1} {
  20. .t insert end "\t[info level $level]\n" {}
  21. }
  22. }
  23. if {[http::status $tok] eq "error"} {
  24. .t insert end "error: [http::error $tok]\n" {}
  25. }
  26. .t insert end "\n[http::meta $tok]\n" {}
  27.  
  28. ::http::cleanup $tok
  29. }
  30.  
  31. proc Fetch {url} {
  32. if {[catch {http::geturl $url \
  33. -timeout 10000 \
  34. -progress Progress \
  35. -command Command} err]} {
  36.  
  37. .t insert end "Caught error: $err\n" {} $::errorInfo\n {}
  38. catch {
  39. for {set level 0} {1} {incr level -1} {
  40. .t insert end "\t[info level $level]\n" {}
  41. }
  42. }
  43. }
  44. }
  45.  
  46. proc Main {url} {
  47. text .t -yscrollcommand {.vs set}
  48. scrollbar .vs -command {.t yview}
  49. ttk::frame .status
  50. ttk::label .status.pane0
  51. ttk::progressbar .status.progress
  52. ttk::sizegrip .status.sizegrip
  53.  
  54. grid .status.pane0 .status.progress .status.sizegrip -sticky news
  55. grid rowconfigure .status 0 -weight 1
  56. grid columnconfigure .status 0 -weight 1
  57.  
  58. grid .t .vs -sticky news
  59. grid .status - -sticky ew
  60. grid rowconfigure . 0 -weight 1
  61. grid columnconfigure . 0 -weight 1
  62.  
  63. bind . <Control-F2> {console show}
  64.  
  65. after 250 [list Fetch $url]
  66. tkwait window .
  67. }
  68.  
  69. if {!$tcl_interactive} {
  70. set r [catch [linsert $argv 0 Main] err]
  71. if {$r} {
  72. tk_messageBox -icon error -title [info script] -message $::errorInfo
  73. } elseif {[string length $err]>0} {
  74. tk_messageBox -icon info -title [info script] -message $err
  75. }
  76. exit $r
  77. }