# Copyright (C) 1999-2017 # Smithsonian Astrophysical Observatory, Cambridge, MA, USA # For conditions of distribution and use, see copyright notice in "copyright" package provide DS9 1.0 proc HVCancel {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVCancel" } # set state to 0 so that we don't process the finish proc set var(active) 0 # stop any refresh if {$var(refresh,id)>0} { after cancel $var(refresh,id) set var(refresh,id) 0 } # analysis if {$var(analysis)} { AnalysisTaskEnd $var(analysis,which) $var(analysis,i) HVSetAnalysis $varname 0 {} 0 } # clean up HVClearTmpFile $varname if {[info exists var(token)]} { http::reset $var(token) } if {[info exists var(widget)]} { $var(widget) configure -cursor {} } } proc HVDestroy {varname} { upvar #0 $varname var global $varname global ihv global debug if {$debug(tcl,hv)} { puts stderr "HVDestroy" } HVCancel $varname # clear the widge and all images $var(widget) clear # clear image cache foreach x [array names $varname "images,*"] { image delete $var($x) unset ${varname}($x) } # clear cache HVClearCache $varname # destroy the window and menubar if {[winfo exists $var(top)]} { destroy $var(top) destroy $var(mb) } # delete it from the xpa list set ii [lsearch $ihv(windows) $varname] if {$ii>=0} { set ihv(windows) [lreplace $ihv(windows) $ii $ii] } # clear varname unset $varname } proc HVReset {varname} { upvar #0 $varname var global $varname set var(active) 0 if {[info exists var(token)]} { global debug if {$debug(tcl,hv)} { puts stderr "HVReset ***cleanup***" } http::cleanup $var(token) unset var(token) } } proc HVDone {varname} { upvar #0 $varname var global $varname HVStatus $varname {} HVReset $varname } proc HVCancelled {varname} { upvar #0 $varname var global $varname HVStatus $varname {} HVReset $varname } proc HVError {varname err} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVError $err" } HVReset $varname Error $err } proc HVStatus {varname message} { upvar #0 $varname var global $varname set var(status) $message } proc HVResolveURL {varname url} { upvar #0 $varname var global $varname global debug global pvo if {$debug(tcl,hv)} { puts stderr "HVResolveURL $varname $url" } set sync $var(sync) # sub xpa method set exp {%40%40XPA_METHOD%40%40|@@XPA_METHOD@@} if {[regexp $exp $url]} { regsub -all $exp $url [XPAMethod] url if {$debug(tcl,hv)} { puts stderr "HVResolveURL XPA_METHOD $url" } } # sub vo method set exp {%40%40VO_METHOD%40%40|@@VO_METHOD@@} if {[regexp $exp $url]} { regsub -all $exp $url $pvo(method) url if {$debug(tcl,hv)} { puts stderr "HVResolveURL VO_METHOD $url" } } # if pvo(method) is xpa, HV has to be async if {$pvo(method) == {xpa}} { set sync 0 } # some old sites have a problem with '?' in the query not encoded ParseURL $url rr if {$rr(query) != {}} { if {[regsub -all {\?} $rr(query) {%25} query]} { set newurl "$rr(scheme)://$rr(authority)$rr(path)?$query" if {$rr(fragment) != {}} { append newurl "#$rr(fragment)" } HVLoadURL $varname $newurl {} $sync } else { HVLoadURL $varname $url {} $sync } } else { HVLoadURL $varname $url {} $sync } } # this is the main entry point, everybody calls here proc HVLoadURL {varname url query {sync 0}} { upvar #0 $varname var global $varname # this assumes the url has been already resolved global debug if {$debug(tcl,hv)} { puts stderr "HVLoadURL :$varname:$url:$query:$sync:" } # do we have anything? if {$url == {}} { return } HVStatus $varname {} # parse url ParseURL $url r if {$debug(tcl,hv)} { puts stderr "HVLoadURL |$r(scheme)|$r(authority)|$r(path)|$r(query)|$r(fragment)|$query|" } switch -- $r(scheme) { file - {} {HVProcessURLFile $varname $url $query r} ftp {HVProcessURLFTP $varname $url $query r} http - https {HVProcessURLHTTP $varname $url $query r $sync} default {HVError $varname "[msgcat::mc {Sorry, DS9 does not support}] $r(scheme)"} } } proc HVProcessURLFile {varname url query rr} { upvar #0 $varname var global $varname upvar $rr r global ds9 global debug if {$debug(tcl,hv)} { puts stderr "HVProcessURLFile" } if {[file exists $r(path)]} { if {[file isdirectory $r(path)]} { HVSetURL $varname $url {} {} HVSetResult $varname 200 "text/html" HVSetData $varname \ [HVFileHtmlList $r(path) [HVDirList $r(path)]] {} set var(delete) 0 HVParse $varname } else { HVSetURL $varname $url {} $r(fragment) set var(delete) 0 HVLoadFile $varname $r(path) } } } proc HVProcessURLFTP {varname url query rr} { upvar #0 $varname var global $varname upvar $rr r global ds9 global debug if {$debug(tcl,hv)} { puts stderr "HVProcessURLFTP" DumpURL r } set fn [tmpnam [file extension $r(path)]] set ftp [ftp::Open $r(authority) "ftp" "-ds9@" -mode passive] if {$ftp > -1} { # first try to get as file set ftp::VERBOSE $debug(tcl,ftp) set "ftp::ftp${ftp}(Output)" FTPLog ftp::Type $ftp binary if {[ftp::Get $ftp $r(path) "$fn"]} { ftp::Close $ftp if {$debug(tcl,hv)} { puts stderr "HVProcessURLFTP get $fn" } HVSetURL $varname $url {} $r(fragment) set var(delete) 1 HVLoadFile $varname "$fn" HVClearTmpFile $varname } else { # from the prev attempt catch {file delete -force "$fn"} # is it a dir or file that could not be download? if {[file extension $r(path)] == {}} { if {$debug(tcl,hv)} { puts stderr "HVProcessURLFTP list" } # now as a directory set list [ftp::List $ftp $r(path)] ftp::Close $ftp HVSetURL $varname $url {} {} HVSetResult $varname 200 "text/html" HVSetData $varname [HVFTPHtmlList $r(authority) $r(path) $list] {} set var(delete) 0 HVParse $varname } else { HVError $varname "[msgcat::mc {Unable to open file}] $r(path)" return } } } } proc HVProcessURLHTTP {varname url query rr sync} { upvar #0 $varname var global $varname upvar $rr r global ds9 global debug if {$debug(tcl,hv)} { puts stderr "HVProcessURLHTTP" } # stop any refresh if {[info exists ${varname}(refresh,id)]} { if {$var(refresh,id)>0} { after cancel $var(refresh,id) } } # do we already have it in cache? if {[info exists ${varname}(cache,file,$url,$query)]} { # has it expired? if {($var(cache,expire,$url,$query) == 0) || ($var(cache,expire,$url,$query) > [clock seconds])} { # just in case if {[file exists $var(cache,file,$url,$query)]} { # ok, to it if {$debug(tcl,hv)} { puts stderr "HVProcessURLHTTP found $url at $var(cache,file,$url,$query)" } HVSetURL $varname $url $query $r(fragment) set var(delete) 0 HVSetResult $varname 200 $var(cache,mime,$url,$query) HVSetData $varname {} $var(cache,file,$url,$query) HVParse $varname return } } # expired or invalid, clean up if {$debug(tcl,hv)} { puts stderr "HVProcessURLHTTP expired or invalid $var(cache,file,$url,$query)" } catch {file delete $var(cache,file,$url,$query)} unset var(cache,file,$url,$query) unset var(cache,mime,$url,$query) unset var(cache,expire,$url,$query) } HVSetURL $varname $url $query $r(fragment) HVSetResult $varname {} {} HVSetData $varname {} {} set var(ch) {} # do we have html? if so, use a var ParseURL $url r # geturl as file set var(fn) [tmpnam {.http}] if {[catch {open "$var(fn)" w} ${varname}(ch)]} { HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)" return } # disable timeouts for analysis global ihttp set timeout $ihttp(timeout) if {$var(analysis)} { set timeout 0 } if {$sync} { if {![catch {set var(token) [http::geturl $url \ -query "$query" \ -timeout $timeout \ -headers "[HVHTTPHeader $varname]" \ -progress [list HVProgress $varname] \ -binary 1 \ -channel $var(ch)] }]} { # reset errorInfo (may be set in http::geturl) global errorInfo set errorInfo {} set var(active) 1 set var(delete) 1 HVProcessURLHTTPFinish $varname $var(token) } else { catch {close $var(ch)} HVError $varname "[msgcat::mc {Unable to locate URL}] $url" } } else { if {![catch {set var(token) [http::geturl $url \ -query "$query" \ -timeout $timeout \ -headers "[HVHTTPHeader $varname]" \ -progress [list HVProgress $varname] \ -binary 1 \ -channel $var(ch) \ -command [list HVProcessURLHTTPFinish $varname]] }]} { # reset errorInfo (may be set in http::geturl) global errorInfo set errorInfo {} set var(active) 1 set var(delete) 1 } else { catch {close $var(ch)} HVError $varname "[msgcat::mc {Unable to locate URL}] $url" } } } proc HVProcessURLHTTPFinish {varname token} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVProcessURLHTTPFinish" } catch {close $var(ch)} if {!($var(active))} { HVCancelled $varname return } upvar #0 $token t # Code set var(code) [http::ncode $token] # Meta set var(meta) $t(meta) # Cache defaults set var(cache) 1 set var(cache,images) 1 set var(expire) 0 HVParseMeta $varname # Log it HTTPLog $token # Result? switch -- $var(code) { 200 - 203 - 404 - 503 { if {$var(cache)} { if {$debug(tcl,hv)} { puts stderr "HVProcessURLHTTPFinish cacheing:$var(url),$var(query):$var(fn)" } set url $var(url) set query $var(query) set var(cache,file,$url,$query) $var(fn) set var(cache,mime,$url,$query) $var(mime) set var(cache,expire,$url,$query) $var(expire) set var(delete) 0 } HVParse $varname HVDone $varname } 201 - 300 - 301 - 302 - 303 - 305 - 307 { foreach {name value} $var(meta) { if {[regexp -nocase ^location$ $name]} { global debug if {$debug(tcl,hv)} { puts stderr "HVProcessURLHTTPFinish redirect $var(code) to $value" } # clean up and resubmit http::cleanup $token unset var(token) HVClearTmpFile $varname if {[info exists var(widget)]} { HVLoadURL $varname [$var(widget) resolve $value] {} $var(sync) } else { HVLoadURL $varname $value {} $var(sync) } } } } default {HVError $varname "HTTP [msgcat::mc {Error}] $var(code)"} } } proc HVHTTPHeader {varname} { upvar #0 $varname var global $varname set domain {} ParseURL $var(url) rr regexp {[^:]*} $rr(authority) domain set result "[ProxyHTTP]" foreach cc $var(cookies) { if {$domain == [lindex $cc 2]} { append result " Cookie [lindex $cc 0]=[lindex $cc 3]" } } global debug if {$debug(tcl,hv)} { puts stderr "HVHTTPHeader:$result" } return $result } proc HVParseMeta {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParseMeta: $var(meta)" } foreach {name value} $var(meta) { switch -- [string tolower $name] { content-type { regexp -nocase {([^;]*);?(.*)} $value foo \ ${varname}(mime) ${varname}(mime,param) set var(mime) [string tolower $var(mime)] } content-length {} content-encoding { switch -- [string tolower $value] { gzip - x-gzip {set var(encoding) gzip} bzip2 {set var(encoding) bzip2} compress - Z {set var(encoding) compress} pack - z {set var(encoding) pack} default {} } } content-transfer-encoding { switch -- [string tolower $value] { binary - base64 {set var(transfer) [string tolower $value]} default {} } } refresh { set f [split $value \;] set var(refresh,time) [lindex $f 0] set var(refresh,url) [string range [lindex $f 1] 4 end] if {$var(refresh,url) != {} & $var(refresh,time) != {}} { set var(refresh,id) [after [expr $var(refresh,time)*1000] "HVLoadURL $varname \{$var(refresh,url)\} {} $var(sync)"] } else { set var(refresh,id) 0 } } expires { if {[catch {set ss [clock scan $value]}]} { set var(cache) 0 } else { set var(cache) 1 set var(expire) $ss } } cache-control { foreach cc [split $value {,}] { foreach {nn vv} [split $cc {=}] { switch $nn { public {set var(cache) 1} private {set var(cache) 1} no-cache {set var(cache) 0} no-store {set var(cache) 1} s-maxage - min-fresh - max-age { set var(cache) 1 set var(expire) \ [expr [file mtime $var(fn)]+$vv] } max-stale {} no-transform {} only-if-cached {} cache-extension {} must-revalidate {} proxy-revalidate {} } } } } pragma { switch $value { no-cache {set var(cache) 0} } } last-modified { } if-none-match { } set-cookie { set cname {} set cpath {/} set cdomain {} set cvalue {} ParseURL $var(url) rr regexp {[^:]*} $rr(authority) cdomain foreach cc [split $value {;}] { foreach {nn vv} [split $cc {=}] { switch [string tolower [string trim $nn]] { httponly {} expires {} path {set cpath $vv} domain {set cdomain $vv} {} {append cvalue {=}} default { if {$nn != {}} { set cname $nn set cvalue $vv } } } } } if {$cname != {}} { lappend ${varname}(cookies) [list $cname $cpath $cdomain $cvalue] } } } } if {$debug(tcl,hv)} { puts stderr "HVParseMeta Content-Type:$var(mime):$var(mime,param):" puts stderr "HVParseMeta Content-Encoding:$var(encoding):" puts stderr "HVParseMeta Content-Transfer-Encoding:$var(transfer):" puts stderr "HVParseMeta Refresh:$var(refresh,time):$var(refresh,url):" puts stderr "HVParseMeta Cache:$var(cache)" puts stderr "HVParseMeta Expires:$var(expire)" puts stderr "HVParseMeta Cookies:$var(cookies)" } } proc HVLoadFile {varname path} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVLoadFile $path" } HVSetResult $varname 200 {} HVSetData $varname {} $path # content-encoding switch -- [string tolower [file extension $path]] { .gz { set path [file rootname $path] set var(encoding) gzip } .bz2 { set path [file rootname $path] set var(encoding) bzip2 } .Z { set path [file rootname $path] set var(encoding) compress } .z { set path [file rootname $path] set var(encoding) pack } } switch -- [string tolower [file extension $path]] { .html - .htm {set var(mime) "text/html"} .gif {set var(mime) "image/gif"} .jpeg - .jpg {set var(mime) "image/jpeg"} .tiff - .tif {set var(mime) "image/tiff"} .png {set var(mime) "image/png"} .fits - .fit - .fts {set var(mime) "image/fits"} .ftz - .fits.gz - .fgz { set var(mime) "image/fits" set var(encoding) "gzip" } .text - .txt {set var(mime) "text/plain"} .multi { set var(mime) "multipart/mixed" set var(xpa,target) "*:*" if {[file exists "$path"]} { set ch [open "$path" r] if {[gets $ch line] >= 0} { set var(mime,param) "Content-Type: multipart/mixed; Boundary=[string range $line 2 end]" } catch {close $ch} } } .sao {set var(mime) "text/x-cmap-sao"} default { switch -- $var(encoding) { gzip - bzip2 - compress - pack {set var(mime) "application/octet-stream"} default {set var(mime) "text/plain"} } } } HVParse $varname } proc HVParse {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParse" } switch -- $var(mime) { "multipart/alternative" - "multipart/parallel" - "multipart/digest" - "multipart/related" - "multipart/signed" - "multipart/encrypted" - "multipart/report" {} "multipart/x-mixed-replace" - "multipart/mixed" { HVParseMulti $varname HVClearCache $varname } default {HVParseSingle $varname} } if {$var(analysis)} { AnalysisTaskEnd $var(analysis,which) $var(analysis,i) HVSetAnalysis $varname 0 {} 0 } } proc HVParseMulti {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParseMulti" } # do it now, to be restored later if {[info exists var(index)]} { incr ${varname}(index) set var(index,$var(index)) [list $var(url) $var(query)] set index $var(index) } set fn $var(fn) set del $var(delete) if {[file exists "$var(fn)"]} { if {[catch {open "$var(fn)" r} ch]} { HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)" return } } set boundary [HVParseMimeParam $varname "boundary"] if {[string equal "$boundary" {}]} { HVError $varname [msgcat::mc {Invalid formated multipart/mixed mime type message}] return } set state 1 set var(ch) {} HVSetResult $varname 200 {} HVSetData $varname {} {} while {[gets $ch line] >= 0} { if {$debug(tcl,hv)} { puts stderr "HVParseMulti $state:$line" } switch -- $state { 1 { # boundary if {[string equal "--$boundary" $line]} { set state 2 } } 2 { # header if {[string length $line] == 0} { HVParseMeta $varname # save to a file set var(fn) [tmpnam {.http}] set var(delete) 1 if {[catch {open "$var(fn)" w} ${varname}(ch)]} { HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)" return } switch $var(transfer) { binary - base64 { fconfigure $var(ch) \ -translation binary -encoding binary } } set state 3 } else { if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { lappend var(meta) $key [string trim $value] } } } 3 { # body if {[string equal "--$boundary" $line]} { catch {close $var(ch)} HVParseSingle $varname HVClearTmpFile $varname set var(ch) {} HVSetResult $varname 200 {} # we want to preserve var(text) # HVSetData $varname {} {} set var(data) {} set var(fn) {} set state 2 } elseif {[string equal "--$boundary--" $line]} { catch {close $var(ch)} catch {close $ch} HVParseSingle $varname HVClearTmpFile $varname # reset file values set var(fn) $fn set var(delete) $del if {[info exists var(index)]} { # reset index set var(index) $index HVClearIndex $varname $index } return } else { switch $var(transfer) { binary {puts -nonewline $var(ch) $line} base64 { puts -nonewline $var(ch) [base64::decode $line] } default {puts $var(ch) $line} } } } } } # clean up catch {close $ch} set var(fn) $fn } proc HVParseSingle {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParseSingle $var(url)" } switch -- $var(mime) { "text/html" - "text/plain" - "application/octet-stream" { # its never fails, someone can't get there mime types correct. # Override the mime type based on path ParseURL $var(url) r set path [file tail $r(path)] # set content-encoding switch -- [file extension $path] { .gz { set path [file rootname $path] set var(encoding) gzip } .bz2 { set path [file rootname $path] set var(encoding) bzip2 } .Z { set path [file rootname $path] set var(encoding) compress } .z { set path [file rootname $path] set var(encoding) pack } } # set Content-Type switch -- [file extension $path] { .html - .htm {set var(mime) "text/html"} .gif {set var(mime) "image/gif"} .jpeg - .jpg {set var(mime) "image/jpeg"} .tiff - .tif {set var(mime) "image/tiff"} .png {set var(mime) "image/png"} .fits - .fit - .fts {set var(mime) "image/fits"} .ftz - .fgz { set var(mime) "image/fits" set var(encoding) "gzip" } .xml - .vot - .votable {set var(mime) "text/xml"} .text - .txt {set var(mime) "text/plain"} .sao {set var(mime) "text/x-cmap-sao"} } } } switch -- $var(mime) { "text/html" {HVParseHTML $varname} "text/plain" {HVParseText $varname} "application/octet-stream" {HVParseSave $varname} "image/gif" - "image/jpeg" - "image/tiff" - "image/png" {HVParseImg $varname} "image/fits" - "application/fits" {HVParseFITS $varname} "application/fits-image" - "application/fits-table" - "application/fits-group" {HVParseFITS $varname} "image/x-fits" - "binary/x-fits" - "application/x-fits" {HVParseFITS $varname} "image/fits-hcompress" - "image/x-fits-h" {HVParseFITS $varname} "image/x-gfits" - "binary/x-gfits" - "image/gz-fits" - "application/x-gzip" - "display/gz-fits" { set var(encoding) gzip HVParseFITS $varname } "image/bz2-fits" - "display/bz2-fits" { set var(encoding) bzip2 HVParseFITS $varname } "image/x-cfits" - "binary/x-cfits" { set var(encoding) compress HVParseFITS $varname } "image/x-zfits" - "binary/x-zfits" { set var(encoding) pack HVParseFITS $varname } "text/xml" - "application/xml" - "application/x-votable+xml" {HVParseVOT $varname} "x-xpa/xpaget" {} "x-xpa/xpaset" {HVParseXPASet $varname} "x-xpa/xpainfo" {} "x-xpa/xpaaccess" {} "text/x-cmap-sao" {HVParseColormap $varname} default {HVParseSave $varname} } } proc HVParseText {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParseText" } if {[string length $var(data)] == 0} { if {[file exists "$var(fn)"]} { if {[catch {open "$var(fn)" r} ch]} { HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)" return } set var(data) [read $ch] close $ch } } if {$var(analysis)} { if {$debug(tcl,hv)} { puts stderr "HVParseText Analysis" } AnalysisProcessGetURL $var(analysis,which) $var(analysis,i) $var(data) } else { append var(text) $var(data) set var(data) \ "\n\n$var(text)\n\n" HVSetResult $varname 200 "text/html" HVParseHTML $varname } HVClearCache $varname } proc HVParseHTML {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParseHTML" } if {[string length $var(data)] == 0} { if {[file exists "$var(fn)"]} { if {[catch {open "$var(fn)" r} ch]} { HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)" return } set var(data) [read $ch] close $ch } } # figure out the base # we don't want any query or fragments ParseURL $var(url) r set base {} # scheme switch $r(scheme) { http - https {append base "$r(scheme)://"} ftp {} file {} } # authority if {[string length $r(authority)] != 0} { append base "$r(authority)" } # path if {[string length $r(path)] != 0} { append base "$r(path)" } else { append base "/" } # query if {[string length $r(query)] != 0} { append base "?$r(query)" } # spaces? # regsub { } $base {\ } base $var(widget) config -base $base if {$debug(tcl,hv)} { DumpURL r puts stderr "HVParseHTML base [$var(widget) cget -base]" } # we have a valid html $var(widget) clear # fix forms with no action HVFixHTMLForm $varname # and now, parse it $var(widget) parse $var(data) HVGotoHTML $varname } proc HVParseImg {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParseImg $var(url)" } if {$var(save)} { switch -- $var(mime) { "image/gif" {set fn [SaveFileDialog giffbox]} "image/jpeg" {set fn [SaveFileDialog jpegfbox]} "image/tiff" {set fn [SaveFileDialog tifffbox]} "image/png" {set fn [SaveFileDialog pngfbox]} } if {[string length "$fn"] != 0} { if {![catch {file rename -force "$var(fn)" "$fn"}]} { set var(fn) "$fn" set var(delete) 0 } } } switch -- $var(frame) { new {MultiLoadBase} current {} } ImportPhotoFile $var(fn) {} HVClearTmpFile $varname HVClearAll $varname HVUpdateDialog $varname } proc HVParseFITS {varname} { upvar #0 $varname var global $varname global ds9 global debug if {$var(save)} { switch -- $var(encoding) { gzip {FileLast savefitsfbox "ds9.fits.gz"} bzip2 {FileLast savefitsfbox "ds9.fits.bz2"} compress {FileLast savefitsfbox "ds9.fits.Z"} pack {FileLast savefitsfbox "ds9.fits.z"} default {FileLast savefitsfbox "ds9.fits"} } set fn [SaveFileDialog savefitsfbox] if {[string length "$fn"] != 0} { if {![catch {file rename -force "$var(fn)" "$fn"}]} { set var(fn) "$fn" set var(delete) 0 } } } switch -- $var(frame) { new {MultiLoadBase} current {} } global loadParam set loadParam(load,type) allocgz set loadParam(load,layer) {} set loadParam(file,type) fits set loadParam(file,mode) {} set loadParam(file,name) "$var(fn)" set loadParam(file,fn) $loadParam(file,name) # may have to convert the file, based on content-encoding switch -- "$var(encoding)" { bzip2 { catch {set ch [open "| bunzip2 < $var(fn) " r]} set loadParam(load,type) channel set loadParam(channel,name) $ch } compress { catch {set ch [open "| uncompress < $var(fn) " r]} set loadParam(load,type) channel set loadParam(channel,name) $ch } pack { catch {set ch [open "| pcat $var(fn) " r]} set loadParam(load,type) channel set loadParam(channel,name) $ch } } ProcessLoad FinishLoad HVClearTmpFile $varname HVClearAll $varname HVUpdateDialog $varname } proc HVParseColormap {varname} { upvar #0 $varname var global $varname global ds9 global debug if {$debug(tcl,hv)} { puts stderr "HVParseColormap" } set fn [HVParseMimeParam $varname "name"] if {$fn == {}} { ParseURL $var(url) r set fn [file tail $r(path)] } if {![catch {file rename -force $var(fn) $ds9(tmpdir)/$fn}]} { LoadColormapFile $ds9(tmpdir)/$fn } HVClearAll $varname HVUpdateDialog $varname } proc HVParseVOT {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParseVOT" } if {[file exists "$var(fn)"]} { CATVOTFile "$var(fn)" } HVClearTmpFile $varname HVClearAll $varname HVUpdateDialog $varname } proc HVParseSave {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVParseSave" } set fn [HVParseMimeParam $varname "name"] if {$fn == {}} { ParseURL $var(url) r set fn [file tail $r(path)] } FileLast savefitsfbox $fn set fn [SaveFileDialog savefitsfbox] if {[string length "$fn"] != 0} { if {![catch {file rename -force "$var(fn)" "$fn"}]} { set var(delete) 0 } } HVClearAll $varname HVUpdateDialog $varname } proc HVParseXPASet {varname} { upvar #0 $varname var global $varname global ds9 global debug if {$debug(tcl,hv)} { puts stderr "HVParseXPASet: [HVParseMimeParam $varname paramlist]" } if {[info exists var(xpa,target)]} { set target $var(xpa,target) } else { set target [HVParseMimeParam $varname target] } if {$target == "$ds9(title)" || $target == "DS9:*" || $target == "DS9:$ds9(title)" || $target == "*:$ds9(title)" || $target == "*:*" || $target == [XPAMethod]} { InitError hv CommSet $var(fn) [HVParseMimeParam $varname paramlist] 1 } else { HVError $varname "[msgcat::mc {Unable to match target with XPA Mime request}] $var(url)" } } proc HVGotoHTML {varname} { upvar #0 $varname var global $varname incr ${varname}(index) set var(index,$var(index)) [list $var(url) $var(query)] global debug if {$debug(tcl,hv)} { puts stderr "HVGotoHTML $var(index) |$var(url)|$var(query)|$var(fragment)|" } if {[string length $var(fragment)] != 0} { if {$debug(tcl,idletasks)} { puts stderr "HVGotoHTML" } update idletasks $var(widget) yview $var(fragment) } else { $var(widget) yview moveto 0 } HVUpdateDialog $varname } proc HVClearCache {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVClearCache $varname" } foreach x [array names $varname "cache,file,*"] { catch {file delete $var($x)} } foreach x [array names $varname "cache,*"] { unset ${varname}($x) } } proc HVClearIndex {varname n} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVClearIndex $varname $n" } foreach x [array names $varname "index,*"] { set f [split $x ,] if {[lindex $f 1] > $n} { unset ${varname}($x) } } set var(index) $n } proc HVClearTmpFile {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVClearTmpFile" } if {$var(delete) && [string length "$var(fn)"] != 0} { if {[file exists "$var(fn)"]} { if {$debug(tcl,hv)} { puts stderr "HVClearTmpFile delete $var(fn)" } file delete "$var(fn)" } set var(fn) {} set var(delete) 0 } } proc HVUpdateDialog {varname} { upvar #0 $varname var global $varname # in case we've set the cursor $var(widget) configure -cursor {} global debug if {$debug(tcl,hv)} { puts stderr "HVUpdateDialog\n" } set id $var(index) set id [incr id -1] if {[info exists ${varname}(index,$id)]} { $var(mb).view entryconfig [msgcat::mc {Back}] -state normal } else { $var(mb).view entryconfig [msgcat::mc {Back}] -state disabled } set id $var(index) set id [incr id 1] if {[info exists ${varname}(index,$id)]} { $var(mb).view entryconfig [msgcat::mc {Forward}] -state normal } else { $var(mb).view entryconfig [msgcat::mc {Forward}] -state disabled } } proc HVRefresh {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVRefresh" } set var(delete) 0 HVParse $varname } proc HVProgress {varname token totalsize currentsize} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVProgress:$varname" } if {$totalsize != 0} { HVStatus $varname "$currentsize bytes of $totalsize bytes [expr int(double($currentsize)/$totalsize*100)]%" } else { HVStatus $varname "$currentsize bytes" } } proc HVFTPHtmlList {host path list} { global debug if {$debug(tcl,hv)} { puts stderr "HVFTPHtmlList $host $path" } if {[string range $path end end] != "/"} { append path {/} } set html {} append html "\n" append html "\n" append html "Index of $path on $host\n" append html "\n" append html "\n" append html "

Index on $path on $host

\n" append html "
\n" append html "
\n"
    foreach l $list {
	switch -- [llength $l] {
	    8 {set offset 4}
	    9 {set offset 5}
	    10 {set offset 4}
	    11 {set offset 5}
	    default {set offset 5}
	}

	set ii [lindex $l [expr $offset+3]]
	switch -- [string range $l 0 0] {
	    d {
		set new "$ii"
	    }
	    l {
		set new "$ii"
	    }
	    default {
		set new "$ii"
	    }
	}

	regsub $ii $l $new l
	append html "$l\n"
    }
    append html "
\n" append html "\n" append html "\n" return $html } proc HVFileHtmlList {path list} { global debug if {$debug(tcl,hv)} { puts stderr "HVFileHtmlList $path" } if {[string range $path end end] != "/"} { append path {/} } set html {} append html "\n" append html "\n" append html "Index of $path\n" append html "\n" append html "\n" append html "

Index on $path

\n" append html "
\n" append html "
\n"
    foreach l $list {
	switch -- [llength $l] {
	    8 {set offset 4}
	    9 {set offset 5}
	    10 {set offset 4}
	    11 {set offset 5}
	    default {set offset 5}
	}

	set ii [lindex $l [expr $offset+3]]
	switch -- [string range $l 0 0] {
	    d {
		set new "$ii"
	    }
	    l {
		set new "$ii"
	    }
	    default {
		set new "$ii"
	    }
	}

	regsub $ii $l $new l
	append html "$l\n"
    }
    append html "
\n" append html "\n" append html "\n" return $html } proc HVDirList {path} { global debug if {$debug(tcl,hv)} { puts stderr "HVDirList $path" } return [split [exec ls -l $path] \n] } proc HVSetURL {varname url query fragment} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVSetURL $url $query $fragment" } set var(url) $url set var(query) $query set var(fragment) $fragment } proc HVSetResult {varname code mime} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVSetResult $code $mime" } set var(code) $code set var(meta) {} set var(mime) $mime set var(mime,param) {} set var(cache) 0 set var(cache,images) 1 set var(expire) 0 set var(encoding) {} set var(transfer) {} set var(refresh,time) 0 set var(refresh,url) {} set var(refresh,id) 0 } proc HVSetData {varname data fn} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVSetData $fn" } set var(data) $data set var(text) {} set var(fn) "$fn" } proc HVSetAnalysis {varname aa which ii} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVSetAnalysis" } set var(analysis) $aa set var(analysis,which) $which set var(analysis,i) $ii } proc HVClearAll {varname} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVClearAll" } HVSetURL $varname {} {} {} HVSetResult $varname {} {} HVSetData $varname {} {} HVSetAnalysis $varname 0 {} 0 } # CallBacks proc HVImageCB {varname args} { upvar #0 $varname var global $varname global ds9 global debug if {$debug(tcl,hv)} { puts stderr "HVImageCB $varname args: $args" } set url [lindex $args 0] if {$debug(tcl,hv)} { puts stderr "HVImageCB url: $url" } # do we have anything? if {[string length $url] == 0} { return } # do we have a width/height? set aa [lindex $args 3] set width [HVattrs width $aa 0] set height [HVattrs height $aa 0] set src [HVattrs src $aa 0] # check for percent (100%) in width/height if {![string is integer $width]} { set width 0 } if {![string is integer $height]} { set height 0 } if {$debug(tcl,hv)} { puts stderr "HVImageCB src: $width $height $src" } # we have a problem in that htmlwidget will not properly resolve a windows # file name, there for we may have a bad file name url # double check with the src attribute global tcl_platform switch $tcl_platform(platform) { unix {} windows { ParseURL $url r switch -- $r(scheme) { {} - file { if {![file exists $url]} { # bad, try src if {[file exists $src]} { set url $src } } } } } } set img [HVImageURL $varname $url $width $height] if {[string length $img] != 0} { return $img } else { if {$debug(tcl,hv)} { puts stderr "HVImageCB FAIL $url" } return $var(images,gray) } } proc HVImageURL {varname url width height} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVImageURL $varname $url $width $height" } # do we already have the image? if {[info exists ${varname}(images,$url)]} { if {$debug(tcl,hv)} { puts stderr "HVImageURL found image a $url" } return $var(images,$url) } ParseURL $url r set fn {} switch -- $r(scheme) { {} - file { if {[file exists $r(path)]} { # can't use -file for zvfs # catch {image create photo -file $r(path)} img set ch [open $r(path) r] fconfigure $ch -translation binary -encoding binary set dd [read $ch] close $ch unset ch catch {image create photo -data "$dd"} img unset dd } } ftp { set fn [tmpnam [file extension $r(path)]] set ftp [ftp::Open $r(authority) "ftp" "-ds9@" -mode passive] if {$ftp > -1} { set ftp::VERBOSE $debug(tcl,ftp) set "ftp::ftp${ftp}(Output)" FTPLog ftp::Type $ftp binary if {[ftp::Get $ftp $r(path) "$fn"]} { ftp::Close $ftp if {[file size "$fn"] == 0} { catch {file delete -force "$fn"} return {} } if {[catch {image create photo -file "$fn"} img]} { catch {file delete -force "$fn"} return {} } } } } http - https { set ch {} set fn [tmpnam [file extension $r(path)]] for {set ii 5} {$ii>0} {incr ii -1} { if {[catch {open "$fn" w} ch]} { HVError $varname "[msgcat::mc {Unable to open file}] $fn" return {} } global ihttp if {[catch {set token \ [http::geturl $url \ -timeout $ihttp(timeout) \ -progress [list HVProgress $varname] \ -channel $ch \ -binary 1 \ -headers "[HVHTTPHeader $varname]" \ ]}]} { # if there is a problem, just bail set ii 0 continue } # reset errorInfo (may be set in http::geturl) global errorInfo set errorInfo {} catch {close $ch} upvar #0 $token t set code [http::ncode $token] set meta $t(meta) # result? switch -- $code { 200 - 203 - 503 {set ii 0} 201 - 300 - 301 - 302 - 303 - 305 - 307 { foreach {name value} $meta { if {[regexp -nocase ^location$ $name]} { global debug if {$debug(tcl,hv)} { puts stderr "HVImageURL redirect $code to $value" } # clean up and resubmit set url $value http::cleanup $token catch {file delete -force "$fn"} } } } default { # in general, we don't want to know about this if {$debug(tcl,hv)} { puts stderr "HVImageURL HTTP Error: $code" } set ii 0 } } } catch {http::cleanup $token} if {[file size "$fn"] == 0} { catch {file delete -force "$fn"} return {} } if {[catch {image create photo -file "$fn"} img]} { catch {file delete -force "$fn"} return {} } } } # do we have an img? if {![info exists img]} { return {} } if {$debug(tcl,hv)} { puts stderr "HVImageURL got image $img" } # adjust image size if needed if {$width != 0 || $height != 0} { set iw [image width $img] set ih [image height $img] set doit 1 # check for one dimension of 0. calculate to maintain aspect ratio if {$width == 0} { set width [expr $iw*$height/$ih] # see if we have a bad resample dimension set wf [expr double($iw)*$height/$ih] if {$width != $wf} { if {$debug(tcl,hv)} { puts stderr "HVImageURL abort resample image $img width $wf" } set doit 0 } } if {$height == 0} { set height [expr $ih*$width/$iw] # see if we have a bad resample dimension set hf [expr double($ih)*$width/$iw] if {$height != $hf} { if {$debug(tcl,hv)} { puts stderr \ "HVImageURL abort resample image $img height $hf" } set doit 0 } } # check to resample if {$doit && ($width != $iw || $height != $ih)} { if {$debug(tcl,hv)} { puts stderr "HVImageURL resample image $iw->$width $ih->$height" } set img2 \ [image create photo -width $width -height $height] if {[catch {blt::winop image resample $img $img2 box} ]} { # just use existing img if {$debug(tcl,hv)} { puts stderr "HVImageURL error resample image $img" } } else { set tmp $img set img $img2 catch {image delete $tmp} } } } # delete any tmp files if {"$fn" != {}} { catch {file delete -force "$fn"} } if {$var(cache,images)} { set var(images,$url) $img } return $img } proc HVFontCB {varname sz args} { upvar #0 $varname var global $varname global ds9 global debug if {$debug(tcl,hv)} { puts stderr "HVFontCB $varname $sz $args" } set family $var(font) set size $var(font,size) set weight $var(font,weight) set slant $var(font,slant) global ds9 foreach ff [concat [lindex $args 0]] { switch -- $ff { fixed { set family $ds9(courier) set sz [expr $sz-1] } bold {set weight bold} italic {set slant italic} } } switch -- $sz { 0 {incr size -3} 1 {incr size -2} 2 {incr size -1} 3 {} 4 {incr size 6} 5 {incr size 12} 6 {incr size 24} 7 {incr size 36} } if {$debug(tcl,hv)} { puts stderr "HVFontCB \{$family\} $size $weight $slant" } return "\{$family\} $size $weight $slant" } proc HVNoScriptCB {varname n tag args} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { # puts stderr "HVNoScriptCB $varname $n $tag $args" } } proc HVScriptCB {varname args} { upvar #0 $varname var global debug if {$debug(tcl,hv)} { # puts stderr "HVScriptCB $varname $args" } } proc HVFrameCB {varname args} { upvar #0 $varname var global $varname if {$debug(tcl,hv)} { puts stderr "HVFrameCB $varname $args" } } proc HVAppletCB {varname w args} { upvar #0 $varname var global $varname global debug if {$debug(tcl,hv)} { puts stderr "HVAppletCB $varname $w $args" } } proc HVParseMimeParam {varname key} { upvar #0 $varname var global $varname foreach {pp} [split $var(mime,param) {;}] { set id [string first {=} $pp] set name [string trim [string range $pp 0 [expr $id-1]]] set value [string trim [string range $pp [expr $id+1] end]] if {[string equal -nocase $name $key]} { return [string trim $value {"'}] } } return {} }