Keith Vetter 2003-12-03 : All for the want of a thermometer. Because I lack a thermometer and now that it's getting cold around me, I finally decided to write a tiny app that will display the current temperature scraped off a web page. TclWeather seemed more than I wanted but it did steer me to the NOAA web page for the weather data [L1 ].
What I wanted was: 1) a small unadorned window showing the current temperature and the time is was recorded, and/or 2) the temp/time displayed in the task bar.
I've included a windows icon file to make the taskbar look nicer. Also, clicking on either display will toggle the visibility of the other (this may only work well on Windows). One last detail, you'll have to give it the NOAA weather station id for you location.
Stu 2008-10-25 Small q&d change to the time regexp: "EST" -> "E.T". I guess once the weather got nice you didn't bother checking the temperature anymore! :D
#
# fahrenheit.tcl -- scraps current temperature from the NOAA weather page
# by Keith Vetter, December 2003
package require Tk
package require http 2.0
# METAR weather info
# cooked: http://weather.noaa.gov/weather/current/KVTA.html
# raw: http://weather.noaa.gov/cgi-bin/mgetmetar.pl?cccc=KVTA
# format: http://weather.unisys.com/wxp/Appendices/Formats/METAR.html
array set G {temp " ??\xB0" time "??:?? " maxDelay 1800000}
set G(where) [lindex [concat $argv "KVTA"] 0]
proc GetMETAR {where} {
.t config -bg red
set url http://weather.noaa.gov/weather/current/$where.html
set n [catch {set token [::http::geturl $url]}]
.t config -bg [lindex [.t config -bg] 3]
if {$n || [http::ncode $token] != 200} { ;# Error downloading
catch {http::cleanup $token}
return [list "??:?? " " ??\xB0"]
}
set data [::http::data $token]
::http::cleanup $token
# Scrape the temperature
set n [regexp -nocase {Temperature (.*?)F \(} $data => temp]
regsub -all {<.*?>} $temp {} temp
set temp [expr {round($temp)}]
append temp \xB0
# Scrape the time of the last update
set n [regexp {(\d\d:\d\d) .M E.T} $data => tupdate]
regsub {^0} $tupdate { } tupdate
return [list "$tupdate " " $temp"]
}
proc UpdateTemperature {} {
global G
foreach id [after info] {after cancel $id} ;# Be safe
foreach {G(time) G(temp)} [GetMETAR $G(where)] break
wm title . "$G(temp) $G(time)"
set next [clock scan "$G(time) + 1 hour + 5 minutes"] ;# Next Metar update
set delay [expr {1000 * ($next - [clock seconds])}]
if {$delay < 0} { ;# Past report time
set delay [expr {1000 * 5 * 60}] ;# ...then every 5 minutes
} elseif {$delay > $G(maxDelay)} {
set delay $G(maxDelay)
}
after $delay UpdateTemperature
}
proc ToggleVisibility {how} {
if {$how == "map"} {
wm iconify .
wm [expr {[wm state .t] eq "normal" ? "withdraw" : "deiconify"}] .t
} else {
wm [expr {[wm state .] eq "iconic" ? "withdraw" : "iconify"}] .
}
}
wm iconify .
catch {wm iconbitmap . fahrenheit.ico} ;# Use this icon if possible
toplevel .t -bd 2 -relief raised
wm overrideredirect .t 1
wm geometry .t -176-64
pack [label .t.temp -textvariable G(temp)] -side left
.t.temp configure -font "[font actual [.t.temp cget -font]] -weight bold"
pack [label .t.time -textvariable G(time) -font [.t.temp cget -font]] -side left
bind all <Button-1> [list ToggleVisibility x]
bind all <Key-F2> {console show}
bind all <Key-q> exit
update
bind . <Map> [list ToggleVisibility map]
after 1 UpdateTemperature
returnHere is a Windows icon and code to copy it to a file called fahrenheit.ico.
# A Windows icon you can use--it will create a file called fahrenheit.ico
if {[catch {package require base64}]} return
set icodata {
AAABAAEAEBAAAAEAGABoAwAAFgAAACgAAAAQAAAAIAAAAAEAGAAAAAAAAAAAAEgAAABIAAAAAAAA
AAAAAADz8/Pz8/Pz8/P08vLa4eK9u7idoqCkpKOnpaKenpzU1dby9e3z8fLz8/Pz8/Pz8/Pz8/Py
8vLz8/O/v72Mjo7Mz8unqu2GkvClr+va4N2SlY+trbPt9fHz8/Pz8/Pz8/Py8vL19fXk5ORwbnHy
9fOWmekECfABA/oCA/hAQOjn7O5pZWbt8e7z8/Pz8/Pz8/Pz8/Pz8/Px8fGDg4PR0c20ufQjIfIC
A/URFvCMje3c3t9ubWzz8/Pz8/Pz8/Pz8/Pz8/Pz8/Pz8/Pr7umknaeYn5PI0dsmJPBbYeGysLKN
jY3Y2Njy8vLz8/Pz8/Pz8/Pz8/Pz8/Pz8/Py8PXy9Om6triYjppMTPWVnMpzcGzr6+vz8/Px8fHz
8/Pz8/Pz8/Pz8/Pz8/Pz8/Pz8/Hl5ea7u71ydnBhY+qFhMaDhoX19fXx8fHy8vLz8/Pz8/Pz8/Pz
8/Pz8/Pz8/Pw8PDa2tq4uLh1dHBbW+6AjcSAfIDy8vL29vby8vLz8/Pz8/Pz8/Pz8/Pz8/Pz8/Pz
8/PX19ednZ1ucWdfXOiGhtZ0dG7z8/Py8vLx8fHz8/Pz8/Pz8/Pz8/Pz8/Pz8/Py8vLZ2dmenp5o
aW7Ey+vV1O5tbm7m5ub09PTz8/Pz8/Pz8/Pz8/Pz8/Pz8/Pz8/Px8fHs7OzFxcVtbW309PT6+vpy
cnLi4uLy8vLy8vLz8/Pz8/Pz8/Pz8/Pz8/Pz8/Px8fHn5+fGxsZ5eXnu7u77+/t2dnbi4uLy8vLx
8fHz8/Pz8/Pz8/Pz8/Pz8/Pz8/Pz8/Pi4uKhoaFxcXHk5OT8/Px6enrh4eHz8/Pz8/Pz8/Pz8/Pz
8/Pz8/Pz8/Pz8/Pz8/PZ2dmdnZ17e3vX19f8/PyFhYXR0dHx8fH09PTz8/Pz8/Pz8/Pz8/Pz8/Pz
8/Px8fHz8/Pz8/O5ubmVlZXg4OCAgIDb29vz8/Py8vLz8/Pz8/Pz8/Pz8/Pz8/Pz8/Px8fHz8/Pz
8/Pt7e21tbWhoaHIyMjy8vLw8PDz8/Pz8/Pz8/Pz8/MAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA}
regsub -all {\s} $icodata {} icodata ;# Bug in base64 package
if {[catch {set fout [open fahrenheit.ico w]}]} return
puts $fout [::base64::decode $icodata]
close $fout