Posted to tcl by Emiliano at Fri Nov 09 22:40:05 GMT 2007view raw

  1. package require Tk
  2. package require http
  3.  
  4. #procedure callback to actualize the status of the downloads
  5. proc showProgress {part_id token total actual} {
  6. global w part
  7.  
  8. $w($part_id.progress) configure -value $actual
  9. $w($part_id.percent) configure -text \
  10. [format {%5.1f%%} [expr {double($actual)/$total*100}]]
  11. }
  12.  
  13. #procedure callback when each connection finalize
  14. proc finalize {tok} {
  15. global state part
  16.  
  17. incr state(active) -1
  18. http::cleanup $tok
  19. if {$state(active) == 0} {
  20. set fd [open $state(targetFile) w]
  21. fconfigure $fd -translation binary -encoding binary
  22. for {set i 1} {$i <= $state(pieces)} {incr i} {
  23. seek $part($i.fd) 0
  24. fcopy $part($i.fd) $fd
  25. close $part($i.fd)
  26. file delete $part($i.filename)
  27. }
  28. close $fd
  29. exit
  30. }
  31. }
  32.  
  33. #build the gui
  34. proc gui {} {
  35. global w state part
  36.  
  37. . configure -background \
  38. [ttk::style lookup $::ttk::currentTheme -background]
  39. for {set i 1} {$i <= $state(pieces)} {incr i} {
  40. set l [ttk::label .l_$i -text "Part $i:"]
  41. set w($i.progress) [ttk::progressbar .pbar_$i -maximum $part($i.size)]
  42. set w($i.percent) [ttk::label .p_$i -text " 0.0%"]
  43. grid $l $w($i.progress) $w($i.percent) -padx 3 -pady 3
  44. grid configure $w($i.progress) -sticky ew
  45. }
  46. set dest [ttk::label .dest -text "File downloaded in folder: [pwd]"]
  47. grid $dest - - -sticky ew
  48. grid columnconfigure . 1 -weight 1
  49. }
  50.  
  51. # get the size of the file to download
  52. proc getSize {} {
  53. global state
  54. set tok [http::geturl $state(url) -validate 1]
  55. set state(size) [set ${tok}(totalsize)]
  56. http::cleanup $tok
  57. }
  58.  
  59. #main procedure
  60. proc main {} {
  61. global state part
  62.  
  63. set state(targetFile) [lindex [split $state(url) /] end]
  64.  
  65. #the getSize proc may block the script, so first hide the main window
  66. wm state . withdrawn
  67. getSize
  68.  
  69. set pSize [expr {$state(size)/$state(pieces)}]
  70.  
  71. for {set i 1} {$i <= $state(pieces) } {incr i} {
  72. set from [expr { ($i-1) * $pSize }]
  73. set to [expr { $i * $pSize - 1 }]
  74. if {$i == $state(pieces)} {
  75. set to [expr {$state(size) - 1}]
  76. }
  77. set part($i.size) [expr {$to - $from + 1}]
  78.  
  79. set part($i.filename) $state(targetFile).part$i
  80. set part($i.fd) [open $part($i.filename) w+]
  81. fconfigure $part($i.fd) -translation binary -encoding binary
  82. set part($i.token) [http::geturl $state(url) \
  83. -binary 1 \
  84. -channel $part($i.fd) \
  85. -headers [list Range "bytes=$from-$to"] \
  86. -command finalize \
  87. -progress [list showProgress $i]]
  88. }
  89.  
  90. if [catch {ttk::setTheme xpnative}] {ttk::setTheme clam}
  91. gui
  92.  
  93. #now show the main window
  94. wm state . normal
  95.  
  96. set state(active) $state(pieces)
  97. }
  98.  
  99. #by default we split the file in 4 pieces
  100. set state(pieces) 4
  101.  
  102. if {$argc < 1 || $argc > 2} {
  103. puts "Usage: $argv0 url \[pieces\]"
  104. exit
  105. } else {
  106. set state(url) [lindex $argv 0]
  107. if {$argc == 2} {
  108. set state(pieces) [lindex $argv 1]
  109. }
  110. }
  111.  
  112. if 0 {
  113. set state(url) http://ftp.netbsd.org/pub/NetBSD/misc/hubertf/netbsd-4.0RC3-i386pkg.iso
  114. }
  115.  
  116. main