#### ### 010305 - Fixed for AOL's new weather format again ### 010306 - added blowingsnow ### 010618 - added dust ### 020326 - added freezingrain ### 020401 - fixed aol's new format for time #### ### # Checked in $Date: 1999/11/22 23:28:10 $ # $Revision: 2.13 $ ### # $Log: weather.tcl,v $ # Revision 2.13 1999/11/22 23:28:10 blalor # * weather.tcl (Repository): Revamped handling of AOL sourced data # to work with changes they made. # # Revision 2.12 1999/09/08 17:49:09 blalor # Fixed logic that caused error to be caught when bad data is retrieved from the # NOAA FTP server; a bug still exists with otherString... # # Revision 2.11 1999/03/26 15:10:18 blalor # Potential fix for error raised when changing popupText whilst updating. # Dunno if its quite right yet... # # Revision 2.10 1999/03/22 20:23:45 blalor # Patched Pressure parsing for hPa 1999/03/19 20:13:45 mwolf@tkc.de # # Revision 2.9 1999/03/19 11:45:19 blalor # fix for missing sky info and resulting bad image # # Revision 2.8 1999/03/04 17:01:47 blalor # Now properly unsets old variables and handles missing humidity reports properly # # Revision 2.7 1999/03/03 20:06:42 blalor # *** empty log message *** # # Revision 2.6 1999/03/02 13:59:11 blalor # Added icon for PalmStation Palm:Question category and updated slashmeat.tcl to # use it. # Cleanup of weather package for better handling of FTP errors and getting # status to user. # # Revision 2.5 1999/02/24 02:03:39 blalor # o Couple of cosmetic changes to display when doing update. # o Added debugging info for trying to figure out these ftp_lib problems # o Made display of data an "after idle" event to help speed some things up # o Removed FTP::Abort calls which Steffen says don't apply afterall :) # o Added code to not step on updates in progress # # Revision 2.4 1999/02/19 17:48:54 blalor # o Cosmetic tweaks to apwire # o /tmp file support for weather # o Added support for PalmStation data to slashmeat package and imported icons # for PalmStation categories # # Revision 2.3 1999/02/18 23:33:23 blalor # Added hierarchy and sshproxy packages and tweaked tik.tcl and weather.tcl # # Revision 2.2 1999/02/18 22:51:56 blalor # stupid bug # # Revision 2.1 1999/02/18 22:41:45 blalor # Added support for data files to be put in /tmp # # Revision 2.0 1999/02/17 20:48:11 blalor # Uhm, just bringing everything up to v2.0... # # Revision 1.11 1999/02/17 20:38:54 blalor # Kludged FTP transfer workings to do passive transfer (and to transfer in # ASCII, but that's kinda immaterial). For some reason, doing an active # transfer fails with # # too many nested calls to Tcl_EvalObj (infinite loop?) # # when setting the port. Setting the transfer mode to passive allows it to work # properly. Hopefully, this doesn't cause any further problems. The author of # the ftp_lib package has been notified of this problem (which only shows up in # TiK v0.58). # # Revision 1.10 1999/02/16 14:39:37 blalor # changed name of icons to better differentiate between diff't packages. # # Revision 1.9 1999/02/09 12:54:46 blalor # regexp tweaks, versioning, better error handling # # Revision 1.8 1999/01/14 22:07:56 blalor # Just another URL reference for places to find current conditions... # # Revision 1.7 1999/01/14 13:59:48 blalor # Properly handle unsetting of variables # # Revision 1.6 1999/01/14 04:28:18 blalor # Forgot to turn off debugging # # Revision 1.5 1999/01/14 04:27:09 blalor # Various changes; thanks to Marc Aurel <4-tea-2@bong.saar.de> (Autonom 42) for # help pointing out problems and betatesting. # # Revision 1.4 1999/01/13 16:36:53 blalor # added modsnow->snow image # # Revision 1.3 1998/12/18 23:08:44 blalor # Mondo changes # # Revision 1.2 1998/12/12 05:04:19 blalor # New routine to grab decoded METARs from weather.noaa.gov # Slightly modularized display code. # # Revision 1.1 1998/12/12 00:44:44 blalor # Initial revision # # Revision 1.6 1998/12/11 14:22:41 blalor # Deleted proxy returns, tweaked some of the URL composition code, added rain # icon (modrain.gif), added "Pragma no-cache" to headers of geturl # # Revision 1.5 1998/12/10 04:34:09 blalor # A few more changes: # o more format tweaks (degree sign not in regexp any more) # o better handling of rogue wind readings # o new tickerString to be used in Buddy Ticker; requires patch to ticker.tcl # ### namespace eval weather { regexp -- {[0-9]+\.[0-9]+} {@(#)TiK Weather package $Revision: 2.13 $} \ ::weather::VERSION regexp -- { .* } {:$Date: 1999/11/22 23:28:10 $} \ ::weather::VERSDATE set ::weather::URL {http://hcirisc.cs.binghamton.edu/~blalor/tik/} } tik_default_set options,Weather,update 1800000 tik_default_set options,Weather,units "F" tik_default_set options,Weather,source "AOL" tik_default_set options,Weather,passive 1 # import packages if {[lsearch $::auto_path "."] == "-1"} { lappend ::auto_path "." } package require http 2.0 package require FTP # overwrite default ftp_lib display message procedure namespace eval FTP { proc DisplayMsg {msg {state ""}} { if {$::FTP::VERBOSE} { .ftp.f.text configure -state normal switch $state { data {.ftp.f.text insert end "$msg\n" data} control {.ftp.f.text insert end "$msg\n" control} error {.ftp.f.text insert end "$msg\n" error} header {.ftp.f.text insert end "$msg\n" header} default {.ftp.f.text insert end "$msg\n"} } .ftp.f.text configure -state disabled .ftp.f.text see end } else { return } } } namespace eval weather { variable info variable conditions variable obs variable nextUpdate variable baseurl "http://my.aol.com/weather/?" variable noaasite "weather.noaa.gov" variable noaapath "/data/observations/metar/decoded" variable Revision [lindex "\$Revision: 2.13 $" 1] # Must export at least: load, unload, goOnline, goOffline namespace export load unload goOnline goOffline add # All packages must have a load routine. This should do most # of the setup for the package. Called only once. proc load {} { set ::FTP::DEBUG 0 set ::FTP::VERBOSE 0 # We use TIK variable to store information, so it isn't # lost during reloads. if {![info exists ::TIK(Weather,list)]} { set ::TIK(Weather,list) "" } if {$::TIK(options,Weather,update) < 180000} { set ::TIK(options,Weather,update) 180000 } # set weather::conditions [list clear fog haze \ # heavyrain heavysnow lightrain \ # lightsnow modrain modsnow \ # mostlyclear mostlycloudy \ # overcast partlycloudy sand thunder \ # fair rain cloudy snowshowers ] set weather::conditions [list clear cloudy fair \ fog haze heavyrain heavysnow ice lightrain \ lightsnow modrain modsnow mostlyclear mostlycloudy \ overcast partlycloudy partlycloudyam rain \ rainandsnow sand scatteredshowers sctsnowshwrs \ showers snow snowshowers sunny thunder \ partlycloudypm mostlycloudypm clearpm mostlysunny \ windy nr rainsnow sctshowers drizzle flurries \ thunderstorms sctt-storms iceandsnow scttstorms \ isot-storms isotstorms freezingdrzl blowingsnow \ dust freezingrain] foreach cond $weather::conditions { image create photo $cond -file media/wx_${cond}.gif } # lappend weather::conditions cloudy rain snow # lappend weather::conditions snow # image create photo cloudy -file media/wx_partlycloudy.gif # image create photo rain -file media/wx_modrain.gif # image create photo snow -file media/wx_modsnow.gif set weather::info(timer) "" set weather::info(update_active) 0 menu .weatherMenu -tearoff 0 .toolsMenu add cascade -label "Weather Monitor" -menu .weatherMenu .weatherMenu add command -label "Update Now" -command weather::doUpdate .weatherMenu add command -label "New City" -command weather::newCity menu .weatherIMenu -tearoff 0 .weatherMenu add cascade -label "Update Interval" -menu .weatherIMenu .weatherIMenu add radiobutton -label "30 Minutes" -value 1800000 \ -variable ::TIK(options,Weather,update) -command weather::doUpdate .weatherIMenu add radiobutton -label "45 Minutes" -value 2700000 \ -variable ::TIK(options,Weather,update) -command weather::doUpdate .weatherIMenu add radiobutton -label "60 Minutes" -value 3600000 \ -variable ::TIK(options,Weather,update) -command weather::doUpdate menu .weatherUMenu -tearoff 0 .weatherMenu add cascade -label "Temp. Units" -menu .weatherUMenu .weatherUMenu add radiobutton -label "English" -value "F" \ -variable ::TIK(options,Weather,units) -command weather::doUpdate .weatherUMenu add radiobutton -label "Metric" -value "C" \ -variable ::TIK(options,Weather,units) -command weather::doUpdate menu .weatherSMenu -tearoff 0 .weatherMenu add cascade -label "Select Source" -menu .weatherSMenu .weatherSMenu add radiobutton -label "NOAA" -value "NOAA"\ -variable ::TIK(options,Weather,source) -command weather::doUpdate .weatherSMenu add radiobutton -label "AOL" -value "AOL"\ -variable ::TIK(options,Weather,source) -command weather::doUpdate menu .weatherFMenu -tearoff 0 .weatherMenu add cascade -label "FTP Debug" -menu .weatherFMenu .weatherFMenu add checkbutton -label "DEBUG" \ -variable ::FTP::DEBUG .weatherFMenu add checkbutton -label "VERBOSE" \ -variable ::FTP::VERBOSE .weatherMenu add command -label "Next Update..." -command { tk_messageBox -type ok -icon info -message "Next update at $weather::nextUpdate" } tik_register_buddy_button_func "City" "Weather Box" weather::weather_box # Save index so we can delete later set weather::info(menuindex) [.toolsMenu index end] # FTP output window toplevel .ftp -class Tik wm withdraw .ftp frame .ftp.b pack .ftp.b -side bottom -fill x -pady 2m button .ftp.b.close -text "Close" -state disabled \ -command "wm withdraw .ftp" ;# catch {FTP::Close} .ftp.b.close configure -default active -state normal pack .ftp.b.close -side left -expand 1 frame .ftp.f pack .ftp.f -side top -expand 1 -fill both label .ftp.f.label -text "Messages:" -anchor w pack .ftp.f.label -in .ftp.f -side top -fill x scrollbar .ftp.f.yscroll -command ".ftp.f.text yview" pack .ftp.f.yscroll -in .ftp.f -side right -fill y scrollbar .ftp.f.xscroll -relief sunken -orient horizontal -command ".ftp.f.text xview" pack .ftp.f.xscroll -in .ftp.f -side bottom -fill x text .ftp.f.text -relief sunken -setgrid 1 -wrap none -height 20 -width 80 -bg white -fg black\ -state disabled -xscrollcommand ".ftp.f.xscroll set" \ -yscrollcommand ".ftp.f.yscroll set" pack .ftp.f.text -in .ftp.f -side left -expand 1 -fill both .ftp.f.text tag configure error -foreground red .ftp.f.text tag configure data -foreground brown .ftp.f.text tag configure control -foreground blue .ftp.f.text tag configure header -foreground white -background black } proc addCity {city name symbol} { lappend ::GROUPS(Weather,people) $city set ::BUDDIES($city,type) City set ::BUDDIES($city,online) T set ::BUDDIES($city,name) $name set ::BUDDIES($city,symbol) $symbol set ::BUDDIES($city,otherString) "*NOT UPDATED*" set ::BUDDIES($city,tickerString) "*NOT UPDATED*" set ::BUDDIES($city,indexs) "" set ::BUDDIES($city,popupText) [list] set ::BUDDIES($city,doubleClick) "weather::doubleClick" set ::BUDDIES($city,icon) "" incr ::GROUPS(Weather,online) incr ::GROUPS(Weather,total) } proc doubleClick {name city} { set symbol $::BUDDIES([normalize $city],symbol) switch $::TIK(options,Weather,units) { "F" { set units "english" } "C" { set units "metric" } } append url ${weather::baseurl} [http::formatQuery units $units city $symbol] tik_show_url WeatherWin "$url" } # All pacakges must have goOnline routine. Called when the user signs # on, or if the user is already online when packages loaded. proc goOnline {} { lappend ::BUDDYLIST Weather set ::GROUPS(Weather,people) "" set ::GROUPS(Weather,type) Wx set ::GROUPS(Weather,online) 0 set ::GROUPS(Weather,total) 0 set ::GROUPS(Weather,collapsed) F foreach city $::TIK(Weather,list) { set name $::TIK(Weather,$city,name) set symbol $::TIK(Weather,$city,symbol) addCity $city $name $symbol } tik_draw_list T catch {after cancel $weather::info(timer)} # wait 5 seconds for things like the buddy list to pop up and # then run the update. set weather::info(timer) [after 5000 weather::doUpdate] } # All pacakges must have goOffline routine. Called when the user signs # off. NOT called when the package is unloaded. proc goOffline {} { catch {after cancel $weather::info(timer)} } # All packages must have a unload routine. This should remove everything # the package set up. This is called before load is called when reloading. proc unload {} { tik_unregister_buddy_button_func "City" "Weather Box" catch {after cancel $weather::info(timer)} .toolsMenu delete $weather::info(menuindex) destroy .weatherIMenu destroy .weatherUMenu destroy .weatherFMenu destroy .weatherSMenu destroy .weatherMenu catch {destroy .newCity} catch {destroy .ftp} set i [lsearch -exact $::BUDDYLIST Weather] if {$i != -1} { set ::BUDDYLIST [lreplace $::BUDDYLIST $i $i] } tik_draw_list T } proc add {name symbol} { set city [normalize $name] if {[lsearch $::TIK(Weather,list) $city] != -1} { return } set symbol [string toupper $symbol] if {[string length $symbol] != 8} { return } lappend ::TIK(Weather,list) $city set ::TIK(Weather,$city,symbol) $symbol set ::TIK(Weather,$city,name) $name } proc doUpdate {} { set weather::nextUpdate [clock format [expr [clock seconds] + ($::TIK(options,Weather,update)/1000)] -format "%H:%M"] catch {after cancel $weather::info(timer)} set weather::info(timer) [after $::TIK(options,Weather,update) weather::doUpdate] # if there's still an FTP session active somewhere, just return; don't # wanna muck things up... if {$weather::info(update_active)} { return } foreach citybud $::TIK(Weather,list) { set ::BUDDIES($citybud,otherString) "(Updating...)" set ::BUDDIES($citybud,icon) "" set start 0 if {[llength $::BUDDIES($citybud,popupText)] > 2} { set start 2 } set ::BUDDIES($citybud,popupText) [lreplace $::BUDDIES($citybud,popupText) $start end Updating] lappend ::BUDDIES($citybud,popupText) @[clock format [clock seconds] -format "%H:%M"] } tik_draw_list T wxDoUpdate_$::TIK(options,Weather,source) } proc wxDoUpdate_NOAA {} { set scale $::TIK(options,Weather,units) if {[llength $::TIK(Weather,list)] == 0} { return } append ftppass [normalize ${::SCREENNAME}] TiK_wx${weather::Revision}@[info hostname] if {$::FTP::VERBOSE} { wm deiconify .ftp } if {$::TIK(options,Weather,passive)} { set mode "passive" } else { set mode "active" } FTP::DisplayMsg "Calling FTP::Open $weather::noaasite anonymous $ftppass -mode $mode" if {! [FTP::Open $weather::noaasite anonymous $ftppass -mode $mode] } { # error opening FTP site catch { FTP::Close } set weather::nextUpdate [clock format [expr [clock seconds] + 600] -format "%H:%M"] catch {after cancel $weather::info(timer)} set weather::info(timer) [after 600000 weather::doUpdate] foreach citybud $::TIK(Weather,list) { set ::BUDDIES($citybud,otherString) "*NOT UPDATED*" set ::BUDDIES($citybud,icon) "" set start 0 if {[llength $::BUDDIES($citybud,popupText)] > 2} { set start 2 } set ::BUDDIES($citybud,popupText) [lreplace $::BUDDIES($citybud,popupText) $start end "Update failed"] lappend ::BUDDIES($citybud,popupText) @[clock format [clock seconds] -format "%H:%M"] lappend ::BUDDIES($citybud,popupText) {Couldn't} contact FTP {site;} Will try again at $weather::nextUpdate } tik_draw_list T return } else { set weather::info(update_active) 1 } FTP::DisplayMsg "FTP::Open completed" FTP::DisplayMsg "Calling FTP::Type ascii" FTP::Type ascii FTP::DisplayMsg "FTP::Type completed" FTP::DisplayMsg "Calling FTP::Cd $weather::noaapath" FTP::Cd $weather::noaapath FTP::DisplayMsg "FTP::Cd completed" foreach citybud $::TIK(Weather,list) { set symbol $::TIK(Weather,$citybud,symbol) set tempdir /tmp set localname "" if {([file isdirectory $tempdir]) && ([file writable $tempdir])} { append localname [file join $tempdir $::NSCREENNAME] _ $symbol.TXT } else { append localname $::NSCREENNAME _ $symbol.TXT } FTP::DisplayMsg "Calling FTP::Get $symbol.TXT $localname" if {(![FTP::Get $symbol.TXT $localname]) || ([file exists $localname] && ([file size $localname] == 0))} { # retrieve failed set ::BUDDIES($citybud,otherString) "*NOT UPDATED*" set ::BUDDIES($citybud,icon) "" set start 0 if {[llength $::BUDDIES($citybud,popupText)] > 2} { set start 2 } set ::BUDDIES($citybud,popupText) [lreplace $::BUDDIES($citybud,popupText) $start end "Update failed"] lappend ::BUDDIES($citybud,popupText) @[clock format [clock seconds] -format "%H:%M"] lappend ::BUDDIES($citybud,popupText) {Couldn't} retrieve $symbol.TXT tik_draw_list T file delete -force $localname continue } else { # retrieve successful if {[catch {open $localname r} inMetar]} { file delete -force $localname continue } set metar [read -nonewline $inMetar] close $inMetar file delete -force $localname } FTP::DisplayMsg "FTP::Get completed" # regexp "((Elmira), )?((Elmira / Corning Regional Airport)(, )(NY)(, ))?(United States) \\(KELM\\)" $metar match junk1 city junk2 station junk3 state junk4 country if {![regexp "((\[A-Za-z /]+), )?((\[A-Za-z /-]+)(, )(\[A-Za-z ]+)(, ))?(\[A-Za-z ]+) \\($symbol\\)" \ $metar match junk1 city junk2 station junk3 state junk4 country]} { # regexp failed set ::BUDDIES($citybud,otherString) "*NOT UPDATED*" set ::BUDDIES($citybud,icon) "" set start 0 if {[llength $::BUDDIES($citybud,popupText)] > 2} { set start 2 } set ::BUDDIES($citybud,popupText) [lreplace $::BUDDIES($citybud,popupText) $start end "Update failed"] lappend ::BUDDIES($citybud,popupText) @[clock format [clock seconds] -format "%H:%M"] lappend ::BUDDIES($citybud,popupText) Bad data for $symbol continue } if {[string length $city] == 0} { set city [lindex [split $station "/,"] 0] } if {[info exists country] && ("$country" != "United States")} { set weather::obs($symbol,location) [list $city $country] } else { set weather::obs($symbol,location) [list $city $state] } # regexp "(\[0-9]+-\[0-9]+(-\[0-9]+)?\[NS]) (\[0-9]+-\[0-9]+(-\[0-9]+)?\[EW]) (\[0-9]+.)" \ # $metar match lat junk1 lon junk2 elev regexp "Windchill: (-?\[0-9]+) \[FC] \\((-?\[0-9]+) \[FC]\\)" \ $metar match weather::obs($symbol,windchill,F) weather::obs($symbol,windchill,C) regexp "Dew Point: (\[0-9-]+)(\..)? . \\((\[0-9-]+)(\..)? .\\)" \ $metar match weather::obs($symbol,dew,F) junk1 weather::obs($symbol,dew,C) regexp "(\[A-Za-z]+) (\[0-9]+), (\[0-9]+) - (\[0-9]+:\[0-9]+ \[AP]M) (\[A-Z]+) / (\[0-9]+).(\[0-9]+).(\[0-9]+) (\[0-9]+) UTC" \ $metar match Lmon Lday Lyr Ltm Ltz Uyr Umon Uday Utm set weather::obs($symbol,time) [clock format [clock scan "$Utm $Umon/$Uday/$Uyr" -gmt 1] -format "%m/%d %H:%M"] if {[regexp "Wind: from the (\[A-Z]+) \\((\[0-9]+) degrees\\) at (\[0-9]+) MPH \\(\(\[0-9]+) KT\\)( gusting to (\[0-9]+) MPH \\((\[0-9]+) KT\\))?:0" \ $metar match compass dir mph kts junk1 Gmph Gkts]} { set weather::obs($symbol,wind,F) "$compass $mph mph" set weather::obs($symbol,newwind,F) "$dir@$mph" if {[string length $Gmph] != 0} { append weather::obs($symbol,wind,F) "\ngusts $Gmph" append weather::obs($symbol,newwind,F) "G$Gmph" } set weather::obs($symbol,wind,C) "$compass $kts kts" set weather::obs($symbol,newwind,C) "$dir@$kts" if {[string length $Gkts] != 0} { append weather::obs($symbol,wind,C) "\ngusts $Gkts" append weather::obs($symbol,newwind,C) "G$Gkts" } } else { # Calm set weather::obs($symbol,wind,F) "Calm" set weather::obs($symbol,newwind,F) "Calm" set weather::obs($symbol,wind,C) "Calm" set weather::obs($symbol,newwind,C) "Calm" } regexp "Visibility: (\[A-Za-z ]+)?(\[0-9]+ \[A-Za-z\\(\\)]+)" $metar match junk weather::obs($symbol,vis) regexp "Sky conditions: (\[A-Za-z ]+)" $metar match weather::obs($symbol,sky) regexp "Weather: (\[A-Za-z ;/]+)" $metar match weather::obs($symbol,weather) if {[info exists weather::obs($symbol,weather)]} { set weather::obs($symbol,currcond) \ [lindex [split $weather::obs($symbol,weather) ";"] 0] } elseif {[info exists weather::obs($symbol,sky)]} { set weather::obs($symbol,currcond) $weather::obs($symbol,sky) } else { set weather::obs($symbol,currcond) "N/A" } regexp "Temperature: (\[0-9-]+)(\..)? F \\((\[0-9-]+)(\..)? C\\)" $metar match degF junk1 degC regexp "Pressure \\(altimeter\\): (\[0-9]+\.\[0-9]+ in\. Hg) \\((\[0-9]+ hPa)\\)" \ $metar match presF presC regexp "Relative Humidity: (\[0-9]+)%" $metar match humid if {![info exist degF]} { set degF "N/A" } if {![info exist degC]} { set degC "N/A" } if {![info exist presF]} { set presF "N/A" } if {![info exist presC]} { set presC "N/A" } if {![info exist humid]} { set humid "N/A" } set weather::obs($symbol,currtemp,F) $degF set weather::obs($symbol,currtemp,C) $degC set weather::obs($symbol,press,F) $presF set weather::obs($symbol,press,C) $presC set weather::obs($symbol,humid) $humid after idle weather::display $citybud foreach var { match junk junk1 junk2 junk3 junk4 station city \ state country Lmon Lday Lyr Ltm Ltz Uyr Umon Uday Utm \ compass dir mph kts Gmph Gkts degF degC presF presC humid } { if {[info exists $var]} { unset $var } } } FTP::DisplayMsg "Calling FTP::Close" catch { FTP::Close } FTP::DisplayMsg "FTP::Close completed" set weather::info(update_active) 0 } proc wxDoUpdate_AOL {} { if {[llength $::TIK(Weather,list)] == 0} { return } switch $::TIK(options,Weather,units) { "F" { set units "english" } "C" { set units "metric" } } foreach c $::TIK(Weather,list) { set url "${weather::baseurl}[http::formatQuery city $::TIK(Weather,$c,symbol) units $units]" #puts $url catch {http::geturl $url -headers "Pragma no-cache" -command weather::wxDataAvailable_AOL} result } } proc display {city} { set symbol $::TIK(Weather,$city,symbol) set units $::TIK(options,Weather,units) set iconlist "" set icon "" set popupText [list \ "[lindex $weather::obs($symbol,location) 0]," "[lindex $weather::obs($symbol,location) 1]" \ Time: "$weather::obs($symbol,time)" \ Temp: "$weather::obs($symbol,currtemp,$units)° $units"\ Wind: "$weather::obs($symbol,wind,$units)" ] if {! ([info exists weather::obs($symbol,weather)] || [info exists weather::obs($symbol,sky)])} { lappend popupText Conditons: "$weather::obs($symbol,currcond)" if {[lsearch -exact $weather::conditions \ [normalize "$weather::obs($symbol,currcond)"]] != -1} { set icon [normalize "$weather::obs($symbol,currcond)"] } } else { if {[info exists weather::obs($symbol,sky)]} { lappend popupText Sky: "$weather::obs($symbol,sky)" if {[lsearch -exact $weather::conditions \ [normalize "$weather::obs($symbol,sky)"]] != -1} { set icon [normalize "$weather::obs($symbol,sky)"] } } if {[info exists weather::obs($symbol,weather)]} { lappend popupText Weather: "$weather::obs($symbol,weather)" set newicon [normalize [lindex [split "$weather::obs($symbol,weather)" ";"] 0]] if {[lsearch -exact $weather::conditions $newicon] != -1} { set icon $newicon } } } # remaining data foreach label {Visibility Humidity Barometer Dewpoint Windchill Sunrise Sunset "Forecast hi" "Forecast low"} \ var {vis humid press,$units dew,$units windchill,$units sunrise sunset fHi,$units fLo,$units} \ special {"" "%" "" "°" "°" "" "" "°" "°"} { eval set index $symbol,$var if {[info exists weather::obs($index)]} { lappend popupText "$label:" "$weather::obs($index)$special" } } set ::BUDDIES($city,popupText) $popupText set ::BUDDIES($city,tickerString) "$weather::obs($symbol,currtemp,$units)° $weather::obs($symbol,wind,$units)" set ::BUDDIES($city,otherString) "$weather::obs($symbol,currtemp,$units)° $weather::obs($symbol,newwind,$units)" set rc [catch { sag::change_otherstring .buddy.list $::BUDDIES($city,indexs) \ "$::BUDDIES($city,otherString)" } result] if {$rc} { tk_messageBox -icon error -message "got \n$result\nwhen calling sag::change_otherstring .buddy.list $::BUDDIES($city,indexs) \"$::BUDDIES($city,otherString)\"" } # sometimes get the following while calling last function: ## can't read "sag::buddydata(.buddy.list,,other)": no such element in array ## while executing ## "set other $sag::buddydata($winName,$index,other)" ## (procedure "sag::change_otherstring" line 2) ## invoked from within ## "sag::change_otherstring .buddy.list $::BUDDIES($city,indexs) "$::BUDDIES($city,otherString)"" ## (procedure "weather::display" line 45) ## invoked from within ## "weather::display ith" ## ("after" script) set ::BUDDIES($city,icon) $icon sag::change_icon .buddy.list $::BUDDIES($city,indexs) $icon foreach elt [array names weather::obs $symbol,*] { unset weather::obs($elt) } } # Callback when there is data available from the url we have # requested. proc wxDataAvailable_AOL {token} { upvar #0 $token state regsub -all "°(;)?" $state(body) "°" body #puts $body if {![regexp "/weather/\\\?city=(\[A-Z0-9]+)" $body match symbol]} { puts stderr "couldn't find symbol in HTML" return } set symbolOk 0 foreach city $::TIK(Weather,list) { if {"$::TIK(Weather,$city,symbol)" == "$symbol"} { set symbolOk 1 break } } if {! $symbolOk} { puts stderr "couldn't match $symbol from HTML to symbol in cities list" return } set units $::TIK(options,Weather,units) regsub -all "( )+" $body " " body # regexp "Current Temperature: \n\n\n\n((N/R)|(\[0-9]+))" $body match weather::obs($symbol,currtemp,$units) regexp "Current Temperature: \n((N/R)|(\[0-9]+))" $body match weather::obs($symbol,currtemp,$units) #puts "currtemp=$weather::obs($symbol,currtemp,$units)" regexp "Humidity: (\[0-9]+)" $body match weather::obs($symbol,humid) #puts "humid=$weather::obs($symbol,humid)" regexp "Visibility: \n((N/R \[a-z]+)|(\[0-9.]+ \[a-z]+))" $body match weather::obs($symbol,vis) #puts "vis=$weather::obs($symbol,vis)" regexp "Barometer: \n((N/R)|(\[0-9]\[0-9]\.\[0-9]\[0-9]. .))" $body match weather::obs($symbol,press,$units) #puts "press=$weather::obs($symbol,press,$units)" regexp "Sunrise: (\[0-9]+:\[0-9]\[0-9] .m)" $body match weather::obs($symbol,sunrise) #puts "sunrise=$weather::obs($symbol,sunrise)" regexp "Sunset: (\[0-9]+:\[0-9]\[0-9] .m)" $body match weather::obs($symbol,sunset) #puts "sunset=$weather::obs($symbol,sunset)" # regexp "Moonrise: (\[0-9]\[0-9]:\[0-9]\[0-9].M)" $body match weather::obs($symbol,moonrise) #puts "moonrise=$weather::obs($symbol,moonrise)" # regexp "Moonset: (\[0-9]\[0-9]:\[0-9]\[0-9].M)" $body match weather::obs($symbol,moonset) #puts "moonset=$weather::obs($symbol,moonset)" # forecast conditions regexp "Hi (\[0-9]+)" $body match weather::obs($symbol,fHi,$units) #puts "hi=$weather::obs($symbol,fHi,$units)" regexp "Lo (\[0-9]+)" $body match weather::obs($symbol,fLo,$units) #puts "lo=$weather::obs($symbol,fLo,$units)" set items [splitHTML $body] set len [llength $items] for {set i 0} {$i < $len} {incr i} { set item [lindex $items $i] if { $item == "" } { break } } for {} {$i < $len} {incr i} { set item [lindex $items $i] if { $item == "" } { incr i # messy HTML; strip extra whitespace in location regsub "\n(\[^A-Za-z0-9])+" [string trim [lindex $items $i]] "" loc #puts "loc=$loc" # puts [set weather::obs($symbol,location) [split $loc ,] set weather::obs($symbol,location) [split $loc ,] break } } for {} {$i < $len} {incr i} { set item [lindex $items $i] if { $item == "Last updated:" } { incr i 2 ;# jump past "
" set time [string trim [lindex $items $i]] # String looks like: Nov 22 1999 4:44PM ET # tcl can't grok that; cvt to "Nov 22, 1999 4:44PM" # set time "[lindex $time 0] [lindex $time 1], [lindex $time 2] [lindex $time 3]" #puts "time=$time" # set time [clock scan $time] # set weather::obs($symbol,time) [clock format $time -format "%m/%d %H:%M"] set weather::obs($symbol,time) $time break } } for {} {$i < $len} {incr i} { set item [lindex $items $i] if { [regexp "Current Conditions: (.+)" $item match weather::obs($symbol,currcond)] } { break } } for {} {$i < $len} {incr i} { # messy HTML; strip extra whitespace in item regsub "\n(\[^A-Za-z0-9])+" [string trim [lindex $items $i]] "" item if { [regexp "Wind Speed: \n(.+)" $item match weather::obs($symbol,wind,$units)] } { if {[string compare [lindex $weather::obs($symbol,wind,$units) 0] "NR"] == 0} { # no wind information reported set weather::obs($symbol,wind,$units) "--" set weather::obs($symbol,newwind,$units) "--" } elseif {[string compare [lindex $weather::obs($symbol,wind,$units) 0] "Calm"] == 0} { # calm winds (Calm 0 mph) set weather::obs($symbol,newwind,$units) "Calm" } else { regsub "(\[A-Za-z]+) (\[0-9]+) (\[a-zA-Z/]+)$" $weather::obs($symbol,wind,$units) {\1@\2} weather::obs($symbol,newwind,$units) } break } } foreach var {currtemp humid vis press sunrise sunset moonrise \ moonset fHi,$units fLo,$units location wind,$units newwind,$units phase time} { # set unset variables to "" if {! [info exists weather::obs($symbol,$var)]} { set weather::obs($symbol,$var) "--" } } display $city foreach elt [array names weather::obs $symbol*] { unset weather::obs($elt) } } # CODE FOR ADDING A NEW CITY proc newCity_ok {} { set city [normalize $weather::info(NEW,name)] set symbol [string toupper $weather::info(NEW,symbol)] if {[string length $symbol] == 4} { # we're ok; just continue } elseif {[string length $symbol] == 3} { set symbol "K${symbol}" } else { #symbol not 3 or 4 characters return } set weather::info(NEW,symbol) $symbol add $weather::info(NEW,name) $weather::info(NEW,symbol) addCity $city $weather::info(NEW,name) $weather::info(NEW,symbol) tik_draw_list T doUpdate } proc newCity {} { set w .newCity if {[winfo exists $w]} { raise $w return } toplevel $w wm title $w "New City" set weather::info(NEW,name) "" set weather::info(NEW,symbol) "" # http://tgsv7.nws.noaa.gov/weather/curcond.html label $w.info -text "This will NOT change your $::TIK(rcfile)\n\ Use: weather::add \n\ See http://www.nws.noaa.gov/oso/siteloc.shtml\n\ to find the ICAO identifier for a city near you." frame $w.nameF label $w.nameL -text "Enter City Name: " -width 20 entry $w.name -textvariable weather::info(NEW,name) pack $w.nameL $w.name -in $w.nameF -side left bind $w.name "focus $w.symbol" frame $w.symbolF label $w.symbolL -text "Enter City Symbol: " -width 20 entry $w.symbol -textvariable weather::info(NEW,symbol) pack $w.symbolL $w.symbol -in $w.symbolF -side left bind $w.symbol "destroy $w; weather::newCity_ok" frame $w.buttons button $w.ok -text "Ok" -command "destroy $w; weather::newCity_ok" button $w.cancel -text "Cancel" -command [list destroy $w] pack $w.ok $w.cancel -in $w.buttons -side left -padx 2m pack $w.info $w.nameF $w.symbolF -side top pack $w.buttons -side bottom focus $w.name } proc weather_box {name city} { set spaces " " set text "" set popupText $::BUDDIES([normalize $city],popupText) set llen 0 set lvlen 0 foreach {label value} $popupText { set ll [string length $label] if {$ll>$llen} { set llen $ll } set lv [string length $value] if {$lv>$lvlen} { set lvlen $lv } } foreach {label value} $popupText { set ll [string length $label] set end [expr $llen - $ll] set text "$text [string range $spaces 0 $end]$label $value" } # puts $text set w .myWeatherBox toplevel $w wm title $w "[normalize $city]" text $w.message -font {Courier -10} -width [expr $llen + $lvlen + 3] -height [expr [llength [split $text \n]]+1] $w.message delete 0.0 end $w.message insert end $text button $w.ok -text "Ok" -command "destroy $w" pack $w.message $w.ok raise $w } }