diff options
Diffstat (limited to 'ds9/library/sia.tcl')
-rw-r--r-- | ds9/library/sia.tcl | 499 |
1 files changed, 499 insertions, 0 deletions
diff --git a/ds9/library/sia.tcl b/ds9/library/sia.tcl new file mode 100644 index 0000000..d992ccb --- /dev/null +++ b/ds9/library/sia.tcl @@ -0,0 +1,499 @@ +# Copyright (C) 1999-2016 +# Smithsonian Astrophysical Observatory, Cambridge, MA, USA +# For conditions of distribution and use, see copyright notice in "copyright" + +package provide DS9 1.0 + +proc SIADef {} { + global sia + global isia + global psia + global wcs + + set isia(sias) {} + + set isia(rformat) arcmin + set isia(width) 15 + set isia(height) 15 + + set isia(minrows) 20 + set isia(mincols) 10 + + set isia(mode) new + set isia(save) 0 + + set isia(def) { \ + {{2MASS (NASA/IPAC)} \ + sia2mass \ + {http://irsa.ipac.caltech.edu/cgi-bin/2MASS/IM/nph-im_sia}\ + {} \ + post \ + } \ + {{AKARI (ISAS/JAXA)} \ + siaakari \ + {http://jvo.nao.ac.jp/skynode/do/siap/akari/fis_image_v1/1.0}\ + {} \ + post \ + } \ + {{Astro-Wise} \ + siaastrowise \ + {http://vo.astro-wise.org/SIAP}\ + {VERB=2&FORM=VOTable&PROJECT=ALL&INSTRUMENT=ALL&} \ + post \ + } \ + {{CADC} \ + siacadc \ + {http://www1.cadc-ccda.hia-iha.nrc-cnrc.gc.ca/sia/query}\ + {} \ + post \ + } \ + {{Chandra (NASA/CXC)} \ + siacxc \ + {http://cda.harvard.edu/cxcsiap/queryImages}\ + {} \ + post \ + } \ + {{MAST (STSCI)} siamast \ + {http://archive.stsci.edu/siap/search.php}\ + {} \ + post \ + } \ + {{SDSS DR12} \ + siasdss \ + {http://skyserver.sdss.org/SkyserverWS/dr12/SIAP/getSIAP}\ + {} \ + get \ + } \ + {{SkyView (NASA/HEASARC)} \ + siaskyview \ + {http://skyview.gsfc.nasa.gov/cgi-bin/vo/sia.pl}\ + {} \ + post \ + } \ + {{TGSSADR (GMRT)} \ + siatgssadr \ + {http://vo.astron.nl/tgssadr/q_fits/imgs/siap.xml}\ + {} \ + post \ + } \ + } + +# {{NASA/CXC Chandra} \ +# siacxc \ +# {http://cda.harvard.edu/cxcsiap/queryImages}\ +# {} \ +# post \ +# } \ +# {{MPE/MPG ROSAT} siarosat \ +# {http://gavo.mpe.mpg.de/rosat/SIAP} \ +# {action=queryImage&siap=siap.service.rosat&} \ +# get \ +# } \ +} + +proc SIAAnalysisMenu {mb} { + global isia + global ds9 + + foreach ff $isia(def) { + set title [lindex $ff 0] + set vars [lindex $ff 1] + set url [lindex $ff 2] + set opts [lindex $ff 3] + set method [lindex $ff 4] + + $mb add command -label $title \ + -command [list SIADialog $vars $title $url $opts $method apply] + } +} + +proc SIAGetURL {varname url2} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,sia)} { + puts stderr "SIAGetURL $varname $var(method) $url2?$var(query2)" + } + + ARStatus $varname [msgcat::mc {Loading}] + + # geturl --method does not work + switch $var(method) { + get { + set url $url2?$var(query2) + set query {} + } + default { + set url $url2 + set query $var(query2) + } + } + + global ihttp + if {$var(sync)} { + if {![catch {set var(token) [http::geturl $url \ + -query $query \ + -timeout $ihttp(timeout) \ + -headers "[ProxyHTTP]"] + + + }]} { + # reset errorInfo (may be set in http::geturl) + global errorInfo + set errorInfo {} + + set var(active) 1 + SIAGetURLFinish $varname $var(token) + } else { + SIAError $varname "[msgcat::mc {Unable to locate URL}] $url2" + } + } else { + if {![catch {set var(token) [http::geturl $url \ + -query $query \ + -timeout $ihttp(timeout) \ + -command \ + [list SIAGetURLFinish $varname] \ + -headers "[ProxyHTTP]"] + }]} { + # reset errorInfo (may be set in http::geturl) + global errorInfo + set errorInfo {} + + set var(active) 1 + } else { + SIAError $varname "[msgcat::mc {Unable to locate URL}] $url2" + } + } +} + +proc SIAGetURLFinish {varname token} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,sia)} { + puts stderr "SIAGetURLFinish $varname" + } + + if {!($var(active))} { + SIACancelled $varname + return + } + + upvar #0 $token t + + # Code + set code [http::ncode $token] + + # Meta + set meta $t(meta) + + # Log it + HTTPLog $token + + # Result? + switch -- $code { + {} - + 200 - + 203 - + 404 - + 503 { + VOTParse $var(tbldb) $token + SIADone $varname + SIALoadDone $varname + } + + 201 - + 300 - + 301 - + 302 - + 303 - + 305 - + 307 { + foreach {name value} $meta { + if {[regexp -nocase ^location$ $name]} { + global debug + if {$debug(tcl,sia)} { + puts stderr "SIAGetURLFinish redirect $code to $value" + } + # clean up and resubmit + http::cleanup $token + unset var(token) + + SIAGetURL $varname $value + } + } + } + + default { + SIAError $varname "[msgcat::mc {Error code was returned}] $code" + } + } +} + +proc SIALoad {varname} { + upvar #0 $varname var + global $varname + + # clear previous db + global $var(tbldb) + if {[info exists $var(tbldb)]} { + unset $var(tbldb) + } + + global debug + if {$debug(tcl,sia)} { + puts stderr "SIALoad $varname $var(url2)?$var(query2)" + } + + SIAGetURL $varname $var(url2) + return +} + +proc SIALoadDone {varname} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,sia)} { + puts stderr "SIALoadDone $varname" + } + + SIATable $varname + + SIADialogUpdate $varname +} + +proc SIAOff {varname} { + upvar #0 $varname var + global $varname + + global $var(tbldb) + if {[info exists $var(tbldb)]} { + unset $var(tbldb) + } + set db $var(tbldb) + set ${db}(Nrows) {} + + $var(tbl) selection clear all + + SIADialogUpdate $varname +} + +proc SIATable {varname} { + upvar #0 $varname var + global $varname + global $var(tbldb) + global isia + + global debug + if {$debug(tcl,sia)} { + puts stderr "SIATable $varname" + } + + if {![CATValidDB $var(tbldb)]} { + return + } + + # clear the selection + $var(tbl) selection clear all + + global $var(tbldb) + $var(found) configure -textvariable ${var(tbldb)}(Nrows) + +# starbase_writefp $var(tbldb) stdout + + if {[starbase_nrows $var(tbldb)] == 0} { + ARStatus $varname [msgcat::mc {No Items Found}] + return + } + + set nc [starbase_ncols $var(tbldb)] + if { $nc > $isia(mincols)} { + $var(tbl) configure -cols $nc + } else { + $var(tbl) configure -cols $isia(mincols) + } + + # add header + set nr [expr [starbase_nrows $var(tbldb)]+1] + if {$nr > $isia(minrows)} { + $var(tbl) configure -rows $nr + } else { + $var(tbl) configure -rows $isia(minrows) + } +} + +# Process Cmds + +proc ProcessSIACmd {varname iname} { + upvar $varname var + upvar $iname i + + global isia + + # we need to be realized + ProcessRealizeDS9 + + set item [string tolower [lindex $var $i]] + switch -- $item { + cancel - + clear - + close - + coordinate - + crosshair - + export - + name - + print - + retreive - + retrieve - + save - + size - + sky - + skyformat - + system - + update {ProcessSIA $varname $iname [lindex $isia(sias) end]} + + default { + # existing sia or load new one? + set ref $item + + incr i + set item [string tolower [lindex $var $i]] + switch -- $item { + cancel - + clear - + close - + coordinate - + crosshair - + export - + name - + print - + retreive - + retrieve - + save - + size - + sky - + skyformat - + system - + update {ProcessSIA $varname $iname sia${ref}} + + default { + # ok, new sia + incr i -1 + set item [string tolower [lindex $var $i]] + + # see if its from our list of sias + foreach mm $isia(def) { + set title [lindex $mm 0] + set vars [lindex $mm 1] + set url [lindex $mm 2] + set opts [lindex $mm 3] + set method [lindex $mm 4] + + if {$title != {-} && "sia${item}" == $vars} { + SIADialog $vars $title $url $opts $method sync + return + } + } + } + } + } + } +} + +proc ProcessSIA {varname iname cvarname} { + upvar 2 $varname var + upvar 2 $iname i + + global isia + global psia + global current + + # we should have a sia now + global $cvarname + upvar #0 $cvarname cvar + + if {![info exists cvar(top)]} { + Error "[msgcat::mc {Unable to find SIAP window}] $cvarname" + return + } + if {![winfo exists $cvar(top)]} { + Error "[msgcat:: mc {Unable to find SIAP window}] $cvarname" + return + } + + # now, process it + set item [string tolower [lindex $var $i]] + switch -- $item { + cancel {ARCancel $cvarname} + clear {SIAOff $cvarname} + close {SIADestroy $cvarname} + coordinate { + incr i + set cvar(x) [lindex $var $i] + incr i + set cvar(y) [lindex $var $i] + incr i + set cvar(sky) [lindex $var $i] + } + crosshair {IMGSVRCrosshair $cvarname} + export - + save { + incr i + set writer VOTWrite + switch -- [lindex $var $i] { + xml - + vot {incr i; set writer VOTWrite} + sb - + starbase {incr i; set writer starbase_write} + csv - + tsv {incr i; set writer TSVWrite} + } + + set fn [lindex $var $i] + CATSaveFn $cvarname $fn $writer + FileLast catfbox $fn + } + name { + incr i + set cvar(name) [lindex $var $i] + } + print {CATPrint $cvarname} + retrieve - + retreive {SIAApply $cvarname 1} + size { + incr i + set cvar(width) [lindex $var $i] + incr i + set cvar(height) [lindex $var $i] + incr i + set cvar(rformat) [lindex $var $i] + set cvar(rformat,msg) $cvar(rformat) + } + sky { + incr i + set cvar(sky) [lindex $var $i] + CoordMenuButtonCmd $cvarname system sky \ + [list SIAWCSMenuUpdate $cvarname] + } + skyformat { + incr i + set cvar(skyformat) [lindex $var $i] + } + system { + incr i + set cvar(system) [lindex $var $i] + CoordMenuButtonCmd $cvarname system sky \ + [list SIAWCSMenuUpdate $cvarname] + } + update {IMGSVRUpdate $cvarname} + } +} + +proc ProcessSendSIACmd {proc id param sock fn} { + global isia + + $proc $id "$isia(sias)\n" +} |