NEM 19Dec2003 - I just made a simple widget package for handling downloads (like the progress meters you get in web browsers). It's quite a simple little thing, but it works ok. It has some flaws (particularly that it always saves files as binary, and it only supports http), but I thought it might make a useful starting point if anyone is in need of such a widget. As always with my contributions to this wiki, you can consider this in the public domain.
#!/bin/sh
# -*- tcl -*-
# vim: ft=tcl
package require Tk
package require http
package provide dlprogress 1.0
# Download progress dialog box
namespace eval dlprogress {
variable uniqueId 0
variable data
variable closeWhenComplete 0
namespace export dlprogress
}
proc dlprogress::dlprogress {url} {
variable uniqueId
variable closeWhenComplete
variable data
set file ""
regexp {http://.*/([^/]+)$} $url -> file
# Pick a file to save to
set file [tk_getSaveFile -initialfile $file]
if {[string length $file]} {
set data($uniqueId,url) $url
set data($uniqueId,file) $file
set data($uniqueId,done) 0
set data($uniqueId,ts) [clock seconds]
set data($uniqueId,close) $closeWhenComplete
# Create the progress dialog
CreateProgressDialog $uniqueId
# Start the download
GetUrl $uniqueId
set id $uniqueId
incr uniqueId
}
return
}
proc dlprogress::CreateProgressDialog {id} {
variable data
set t [toplevel .progress$id]
label $t.src -text "Source: $data($id,url)" -width 40 -anchor w
label $t.dst -text "Destination: $data($id,file)" -width 40 -anchor w
set data($id,progress) [list 0 ??]
# Create the progressbar
canvas $t.prg -bg white -height 15 -width 100 -relief sunken -bd 2
set data($id,prg) [$t.prg create rect 0 0 0 20 -fill navy]
label $t.done -text "0/?? bytes (0%)"
label $t.speed -text "0KB/Sec"
checkbutton $t.close \
-variable [namespace current]::data($id,close) \
-text "Close dialog when complete"
# Pack everything
pack $t.src $t.dst -anchor w
pack $t.prg -fill x
pack $t.done $t.speed $t.close -anchor w
pack [button $t.cancel -command [list [namespace code Cancel] $id] \
-text "Cancel"] -anchor e
wm title $t "Download Progress"
wm resizable $t 0 0
}
proc dlprogress::GetUrl {id} {
variable data
# Fetch the URL to the file
set data($id,token) [http::geturl $data($id,url) \
-progress [list [namespace code Progress] $id] \
-command [list [namespace code Cleanup] $id]]
}
proc dlprogress::Cancel {id} {
variable data
http::reset $data($id,token) "Cancelled"
}
proc dlprogress::FormatUnits {size} {
# Return the item formatted to 2d.p. with appropriate units
foreach {div unit } {
1073741824.0 GBytes
1048576.0 MBytes
1024.0 KBytes
1 bytes
} {
if {($size / $div) > 1} {
return "[format %.2f [expr {double($size)/$div}]] $unit"
}
}
# Should never be reached (any numbers which don't divide by 1?!)
return "$size ??"
}
proc dlprogress::Progress {id token expected received} {
variable data
if {$expected == 0} { return }
set t .progress$id
foreach {got total} $data($id,progress) {break}
# Work out percent download, and speed
set ts [clock seconds]
set percent [expr {int(100.0 * (double($received)/double($expected)))}]
set byteDiff [expr {$received - $got}]
set tsDiff [expr {$ts - $data($id,ts)}]
if {$tsDiff > 0} {
set speed [expr {$byteDiff/$tsDiff}]
$t.speed configure -text "[FormatUnits $speed]/Sec"
set data($id,progress) [list $received $expected]
}
# Update labels
set pwidth [expr {([winfo width $t.prg] / 100.0) * $percent}]
$t.prg coords $data($id,prg) 0 0 [expr {int($pwidth)}] 20
set txt "[FormatUnits $received]/[FormatUnits $expected] (${percent}%)"
$t.done configure -text $txt
# Update state
set data($id,ts) $ts
}
proc dlprogress::Cleanup {id token} {
variable data
variable closeWhenComplete
# Check the status
set t .progress$id
if {[http::status $token] eq "Cancelled"} {
$t.cancel configure -text "OK" -command \
[list [namespace code Destroy] $id]
$t.done configure -text "Cancelled"
$t.prg coords $data($id,prg) 0 0 [winfo width $t.prg] 20
} else {
if {[http::ncode $token] == 301 || [http::ncode $token] == 302} {
# Redirect
upvar #0 $token state
array set meta $state(meta)
set data($id,url) $meta(Location)
http::cleanup $token
GetUrl $id
return
} elseif {[string match 2?? [http::ncode $token]]} {
$t.cancel configure -text "OK" -command \
[list [namespace code Destroy] $id]
$t.done configure -text "Done"
# Save the file
set fid [open $data($id,file) w]
fconfigure $fid -translation binary -encoding binary
puts -nonewline $fid [http::data $token]
close $fid
http::cleanup $token
if {$data($id,close)} {
set closeWhenComplete 1
Destroy $id
}
} else {
# Bad status code from HTTP... what to do here?
$t.cancel configure -text "OK" -command \
[list [namespace code Destroy] $id]
$t.done configure -text "ERROR: [http::status $token]"
}
}
$t.close configure -state disabled
# Cleanup state
foreach item [array names data $id,*] {
catch {unset data($item)}
}
}
proc dlprogress::Destroy {id} {
catch {destroy .progress$id}
}And a little example of usage (download the Tcl sources):
package require dlprogress set url http://heanet.dl.sourceforge.net/sourceforge/tcl/tcl845-src.zip dlprogress::dlprogress $url
Hope you like it!