1 2# JStrack: copyright 1997/2010 by Jim Graham, N5IAL, all rights reserved. 3 4source $libdir/imagery_links.tcl 5source $libdir/anigif.tcl 6# source $libdir/jpg_xy.tcl 7 8set s1 "Imagery provided by the National Oceanic and" ;# just to cut 9set s2 "Atmospheric Administration (NOAA)." ;# line lengths 10set noaacredits "$s1 $s2" 11 12# Handle https 13package require http 14package require tls 15 16proc debug {s} { 17 set e [open errlog a] 18 set ts [clock format [clock seconds]] 19 puts $e "$ts $s" 20 close $e 21} 22 23 24# proc get_remote {link filename} { 25# set f [open $filename w] 26# 27# http::register https 443 [list ::tls::socket -tls1 1] 28# 29# # debug "just ran http::register" 30# 31# if {[catch { set token [http::geturl $link -channel $f] }]} { return -1 } 32# 33# # debug "still here after catch set token" 34# 35# upvar #0 $token state 36# regexp {([234][0-9][0-9]) (.*)} $state(http) a code msg 37# if {$code != 200} { return -1 } 38# # debug "code was NOT 200, so returning normally after closing file" 39# close $f 40# return 0 41# } 42 43 44if {[catch { set img_version [package require Img] }]} { 45 set img_version -1 46} 47 48 49proc check_img {} { 50 global img_version 51 52 if {$img_version < 0} { 53 tk_messageBox -type ok -message \ 54 "The Img extension is 55REQUIRED for displaying 56satellite imagery. 57 58See the JStrack web page 59for more information 60about adding the Img extension." 61 return 0 62 } 63 return 1 64} 65 66proc download_img {link} { 67 global trackdir libdir 68 69 catch { file mkdir $trackdir/imagery } 70 set linkfn [string tolower [file tail $link]] 71 set filename $trackdir/imagery/$linkfn 72 catch { exec wget $link -O $filename } 73 # get_remote $link $filename 74 return $filename 75} 76 77 78proc goes_east_mktop {w title html_link} { 79 catch { destroy $w } 80 toplevel $w 81 wm withdraw $w 82 wm title $w "Satellite Imagery" 83 wm geometry $w +[winfo rootx .c]+[winfo rooty .c] 84 wm attributes $w -topmost true 85 86 label $w.l1 -text "GOES East Hurricane Sector" \ 87 -font {Helvetica 14 bold} 88 label $w.l2 -text "$title" -font {Helvetica 12 bold} 89 label $w.l3 -text "($html_link)" -font {Helvetica 12} 90 pack $w.l1 $w.l2 $w.l3 -side top -expand y -fill x 91 update 92} 93 94 95proc goes_east_hurrsec {title link {isgif 0}} { 96 global goeslinks noaacredits 97 98 if {![check_img]} { return } 99 set w .imagery 100 101 # Create the toplevel and top portion of the window 102 goes_east_mktop $w $title $link 103 wm attributes $w -topmost true 104 105 set fn [download_img $link] 106 if {$fn == ""} { 107 label $w.l4 -text "Imagery download failed!" 108 label $w.l5 -text \ 109 "Use a web browser and the link above to find the image...." 110 $w.l4 configure -font {Helvetica 12 bold} -foreground red 111 $w.l5 configure -font {Helvetica 12 bold} -foreground red 112 113 pack $w.l4 $w.l5 -side top -expand y -fill x 114 } else { 115 pack [canvas $w.c -width 900 -height 540] -side top \ 116 -anchor center 117 if {$isgif} { 118 animate_in_canvas $w.c $fn 119 } else { 120 image create photo statimage -file $fn 121 $w.c create image 0 0 -image statimage -anchor nw 122 } 123 } 124 125 label $w.endl1 -text $noaacredits 126 label $w.endl2 -text "($goeslinks(SSD_Home))" -font {Helvetica 12} 127 button $w.dismiss -text "Dismiss" -command { 128 catch { image delete statimage } 129 catch { file delete $fn } 130 debug "About to destroy .imagery" 131 destroy .imagery 132 debug "Just destroyed .imagery: [winfo exists .imagery]" 133 } 134 pack $w.endl1 $w.endl2 $w.dismiss -side top -expand y -fill x 135 wm deiconify $w 136} 137 138 139