summaryrefslogtreecommitdiffstats
path: root/ds9/library/samp.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'ds9/library/samp.tcl')
-rw-r--r--ds9/library/samp.tcl1730
1 files changed, 1730 insertions, 0 deletions
diff --git a/ds9/library/samp.tcl b/ds9/library/samp.tcl
new file mode 100644
index 0000000..6971008
--- /dev/null
+++ b/ds9/library/samp.tcl
@@ -0,0 +1,1730 @@
+# 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 SAMPDef {} {
+ global isamp
+
+ set isamp(timeout) 1000
+}
+
+proc InitSAMP {} {
+ global pds9
+
+ if {$pds9(samp)} {
+ catch {SAMPConnect 0}
+ }
+}
+
+# Cmds
+
+proc SAMPConnect {{verbose 1}} {
+ global ds9
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ # connected?
+ if {[info exists samp]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: already connected}]
+ }
+ return
+ }
+
+ # reset samp array
+ catch {unset samp}
+ set samp(apps,image) {}
+ set samp(apps,table) {}
+ set samp(apps,votable) {}
+
+ # these are to try to prevent feedback problems with
+ # other probgrams
+ set samp(rcvd,lock) 0
+ set samp(send,lock) 0
+
+ # delete any old tmp files
+ SAMPDelTmpFiles
+
+ # can we find a hub?
+ if {![SAMPParseHub]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: unable to locate HUB}]
+ }
+ catch {unset samp}
+ return
+ }
+
+ # register
+ set params [list "string $samp(secret)"]
+ if {![SAMPSend {samp.hub.register} $params rr]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: internal error}]
+ }
+ catch {unset samp}
+ return
+ }
+ set rr [lindex $rr 1]
+ foreach ff $rr {
+ foreach {key val} $ff {
+ switch -- $key {
+ samp.hub-id {set samp(hub) $val}
+ samp.self-id {set samp(self) $val}
+ samp.private-key {set samp(private) $val}
+ }
+ }
+ }
+
+ # declare metadata
+ catch {unset sampmap}
+ set sampmap(samp.name) {string "SAOImage DS9"}
+ set sampmap(samp.description.text) {string "SAOImage DS9 is an astronomical visualization application"}
+ set sampmap(samp.icon.url) {string "http://ds9.si.edu/doc/sun.gif"}
+ set sampmap(samp.documentation.url) {string "http://ds9.si.edu/doc/ref/index.html"}
+
+ set sampmap(home.page) {string "http://ds9.si.edu/"}
+ set sampmap(author.name) {string "William Joye"}
+ set sampmap(author.email) {string "saord@cfa.harvard.edu"}
+ set sampmap(author.affiliation) {string "Smithsonian Astrophysical Observatory"}
+ set sampmap(ds9.version) "string [lindex $ds9(version) 0]"
+
+ set param1 [list "string $samp(private)"]
+ set param2 [list "struct sampmap"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.declareMetadata} $params rr]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: internal error}]
+ }
+ catch {unset samp}
+ return
+ }
+
+ # who are we
+ set samp(port) [lindex [fconfigure [xmlrpc::serve 0] -sockname] 2]
+ set samp(home) "[info hostname]:$samp(port)"
+
+ # callback
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string http://$samp(home)"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.setXmlrpcCallback} $params rr]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: internal error}]
+ }
+ catch {unset samp}
+ return
+ }
+
+ # declare subscriptions
+ catch {unset sampmap}
+ catch {unset sampmap2}
+ set sampmap(samp.app.ping) {struct mapPing}
+
+ set sampmap(samp.hub.event.shutdown) {struct mapShutdown}
+ set sampmap(samp.hub.event.register) {struct mapRegister}
+ set sampmap(samp.hub.event.unregister) {struct mapUnregister}
+ set sampmap(samp.hub.disconnect) {struct mapDisconnect}
+
+ set sampmap(image.load.fits) {struct mapImageLoadFits}
+ set sampmap(table.load.fits) {struct mapTableLoadFits}
+ set sampmap(table.load.votable) {struct mapTableLoadVotable}
+ set sampmap(table.highlight.row) {struct mapTableHighlightRow}
+ set sampmap(table.select.rowList) {struct mapTableSelectRowList}
+ set sampmap(coord.pointAt.sky) {struct mapCoordPointAtSky}
+ set sampmap(client.env.get) {struct mapClientEnvGet}
+
+ set sampmap(x-samp.affiliation.name) {struct mapAffiliationName}
+ set sampmap(x-samp.affiliation.url) {struct mapAffiliationURL}
+ set sampmap(x-samp.homepage.url) {struct mapHomepageURL}
+ set sampmap(x-samp.releasenotes.url) {struct mapReleasenotesURL}
+ set sampmap(x-samp.faq.url) {struct mapFAQURL}
+ set sampmap(x-samp.authors) {struct mapAuthors}
+ set sampmap(x-samp.release.version) {struct mapReleaseVersion}
+
+ set sampmap(ds9.get) {struct mapDS9Get}
+ set sampmap(ds9.set) {struct mapDS9Set}
+ set sampmap(ds9.restricted-get) {struct sampmap2}
+ set sampmap(ds9.restricted-set) {struct sampmap2}
+
+ set sampmap2(x-samp.mostly-harmless) {string "1"}
+
+ set param1 [list "string $samp(private)"]
+ set param2 [list "struct sampmap"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.declareSubscriptions} $params rr]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: internal error}]
+ }
+ catch {unset samp}
+ return
+ }
+
+ after $isamp(timeout) SAMPUpdate
+}
+
+proc SAMPDisconnect {} {
+ global ds9
+ global samp
+
+ # connected?
+ if {![info exists samp]} {
+ Error [msgcat::mc {SAMP: not connected}]
+ return
+ }
+
+ # disconnect
+ if {[info exists samp(private)]} {
+ set params [list "string $samp(private)"]
+ set rr {}
+ SAMPSend {samp.hub.unregister} $params rr
+ SAMPShutdown
+ }
+
+ UpdateFileMenu
+ UpdateCATDialog
+}
+
+proc SAMPSendImageLoadFits {id} {
+ global ds9
+ global current
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendImageLoadFits"
+ }
+
+ # connected?
+ if {![info exists samp]} {
+ Error [msgcat::mc {SAMP: not connected}]
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ # got something to send?
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ # save current frame
+ set fn [tmpnam {.samp}]
+ catch {$current(frame) save fits image file "\{$fn\}"}
+
+ # name to use
+ set fnb [$current(frame) get fits file name root base]
+ if {[regexp {(.*)\[.*\]} $fnb aa bb]} {
+ set fnb $bb
+ }
+
+ # cmd
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "image.load.fits"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(url) "string \"[XMLQuote file://localhost/$fn]\""
+ set sampmap2(name) "string \"[XMLQuote $fnb]\""
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableLoadFits {id} {
+ global ds9
+ global current
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendTableLoadFits"
+ }
+
+ # connected?
+ if {![info exists samp]} {
+ Error [msgcat::mc {SAMP: not connected}]
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ # got something to send?
+ if {![$current(frame) has fits] && [$current(frame) has fits bin]} {
+ return
+ }
+
+ # save current frame
+ set fn [tmpnam {.samp}]
+ catch {$current(frame) save fits table file "\{$fn\}"}
+
+ # name to use
+ set fnb [$current(frame) get fits file name root base]
+ if {[regexp {(.*)\[.*\]} $fnb aa bb]} {
+ set fnb $bb
+ }
+
+ # cmd
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "table.load.fits"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(url) "string \"[XMLQuote file://localhost/$fn]\""
+ set sampmap2(name) "string \"[XMLQuote $fnb]\""
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableLoadVotable {id varname} {
+ global ds9
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendTableLoadVotable $id $varname"
+ }
+
+ # connected?
+ if {![info exists samp]} {
+ Error [msgcat::mc {SAMP: not connected}]
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ # remember
+ set samp(icat,$varname$samp(port)) $varname
+ set samp(ocat,$varname) $varname$samp(port)
+
+ # save votable
+ set fn [tmpnam {.samp}]
+ CATSaveFn $varname $fn VOTWrite
+
+ # cmd
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "table.load.votable"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(url) "string \"[XMLQuote file://localhost/$fn]\""
+ set sampmap2(table-id) "string [XMLQuote $varname$samp(port)]"
+ set sampmap2(name) "string \"[XMLQuote $var(title)]\""
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableHighlightRow {id varname row} {
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ # row starts at 1
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendTableHighlightRow $samp(ocat,$varname) $row"
+ }
+
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "table.highlight.row"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(table-id) "string [XMLQuote $samp(ocat,$varname)]"
+ set sampmap2(row) "string [XMLQuote [expr $row-1]]"
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableSelectRowList {id varname rows} {
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ # rows start at 1
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendTableSelectRowList $samp(ocat,$varname) $rows"
+ }
+
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "table.select.rowList"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(table-id) "string [XMLQuote $samp(ocat,$varname)]"
+ set ss {}
+ foreach rr $rows {
+ lappend ss "string [expr $rr-1]"
+ }
+ set sampmap2(row-list) [list array $ss]
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableRowListCmd {varname rowlist} {
+ global ds9
+ global samp
+
+ # connected?
+ if {![info exists samp]} {
+ return
+ }
+
+ if {$samp(apps,votable) == {}} {
+ return
+ }
+
+ # are we good?
+ if {![info exists samp(ocat,$varname)]} {
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ switch -- [llength $rowlist] {
+ 0 {}
+ 1 {SAMPSendTableHighlightRow {} $varname $rowlist}
+ default {SAMPSendTableSelectRowList {} $varname $rowlist}
+ }
+}
+
+proc SAMPSendCoordPointAtSky {id coord} {
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendCoordPointAtSky $id $coord"
+ }
+
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "coord.pointAt.sky"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(ra) "string [XMLQuote [lindex $coord 0]]"
+ set sampmap2(dec) "string [XMLQuote [lindex $coord 1]]"
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendCoordPointAtSkyCmd {which} {
+ global ds9
+ global samp
+
+ # connected?
+ if {![info exists samp]} {
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ if {$samp(apps,image) == {} || $samp(apps,table) == {}} {
+ return
+ }
+
+ if {[$which has wcs equatorial wcs]} {
+ set coord [$which get coordinates [$which get cursor canvas] wcs fk5 degrees]
+ if {$coord != {}} {
+ SAMPSendCoordPointAtSky {} "$coord"
+ }
+ }
+}
+
+# Support
+
+proc SAMPShutdown {} {
+ global ds9
+ global samp
+
+ # delete any files
+ SAMPDelTmpFiles
+
+ # close the server socket if still up
+ catch {close $xmlrpc::acceptfd}
+
+ # update the menus
+ set samp(apps,image) {}
+ set samp(apps,table) {}
+ set samp(apps,votable) {}
+ UpdateFileMenu
+ UpdateCATDialog
+
+ # unset samp array
+ catch {unset samp}
+}
+
+proc SAMPUpdate {} {
+ # this routine is run after a delay since it needs to
+ # call the hub for metadata
+
+ # connected? we might have already disconnected.
+ global samp
+ if {![info exists samp]} {
+ return
+ }
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPUpdate"
+ }
+
+ # image fits
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string image.load.fits"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.getSubscribedClients} $params rr]} {
+ return
+ }
+
+ set samp(apps,image) {}
+ foreach arg [lindex $rr 1] {
+ foreach {key val} $arg {
+ if {$key != {}} {
+ lappend samp(apps,image) [list $key [SAMPGetAppName $key]]
+ }
+ }
+ }
+
+ # table fits
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string table.load.fits"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.getSubscribedClients} $params rr]} {
+ return
+ }
+
+ set samp(apps,table) {}
+ foreach arg [lindex $rr 1] {
+ foreach {key val} $arg {
+ if {$key != {}} {
+ lappend samp(apps,table) [list $key [SAMPGetAppName $key]]
+ }
+ }
+ }
+
+ # votable
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string table.load.votable"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.getSubscribedClients} $params rr]} {
+ return
+ }
+
+ set samp(apps,votable) {}
+ foreach arg [lindex $rr 1] {
+ foreach {key val} $arg {
+ if {$key != {}} {
+ lappend samp(apps,votable) [list $key [SAMPGetAppName $key]]
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPUpdate: image apps: $samp(apps,image)"
+ puts stderr "SAMPUpdate: table apps: $samp(apps,table)"
+ puts stderr "SAMPUpdate: votable apps: $samp(apps,votable)"
+ }
+
+ UpdateFileMenu
+ UpdateCATDialog
+}
+
+proc SAMPSend {method params resultVar} {
+ upvar $resultVar result
+
+ global samp
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSend: $method $params"
+ }
+
+ if {[catch {set result [xmlrpc::call $samp(url) $samp(method) $method $params]}]} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSend Error: $result"
+ }
+ return 0
+ }
+
+ # reset error if needed
+ # xmlrpc leaves error msgs
+ InitError samp
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSend Result: $result"
+ }
+ return 1
+}
+
+proc SAMPReply {msgid status {result {}} {url {}} {error {}}} {
+ global samp
+ global sampmap
+ global sampmap2
+ global sampmap3
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReply:$msgid:$status:$result:$url:$error:"
+ }
+
+ catch {unset sampmap}
+ catch {unset sampmap2}
+ catch {unset sampmap3}
+ switch -- $status {
+ OK {
+ set sampmap(samp.status) {string "samp.ok"}
+ set sampmap(samp.result) {struct sampmap2}
+ if {$result != {}} {
+ set sampmap2(value) "string \"[XMLQuote $result]\""
+ }
+ if {$url != {}} {
+ set sampmap2(url) "string \"[XMLQuote $url]\""
+ }
+ }
+ WARNING {
+ set sampmap(samp.status) {string "samp.warning"}
+ set sampmap(samp.result) {struct sampmap2}
+ set sampmap(samp.error) {struct sampmap3}
+ if {$result != {}} {
+ set sampmap2(value) "string \"[XMLQuote $result]\""
+ }
+ if {$url != {}} {
+ set sampmap2(url) "string \"[XMLQuote $url]\""
+ }
+ set sampmap3(samp.errortxt) "string \"[XMLQuote $error]\""
+ }
+ ERROR {
+ set sampmap(samp.status) {string "samp.error"}
+ set sampmap(samp.error) {struct sampmap3}
+ set sampmap3(samp.errortxt) "string \"[XMLQuote $error]\""
+ }
+ }
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string $msgid"]
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+ if {![SAMPSend {samp.hub.reply} $params rr]} {
+ return
+ }
+}
+
+proc SAMPReplySimple {msgid str} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReplySimple: $str"
+ }
+
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ SAMPReply $msgid OK "$str"
+}
+
+proc SAMPClearSendLock {} {
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPClearSendLock"
+ }
+ set samp(send,lock) 0
+}
+
+# receiveNotification(string sender-id, map message)
+proc samp.client.receiveNotification {args} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReceivedNotification: $args"
+ }
+ set secret [lindex $args 0]
+ set id [lindex $args 1]
+ set map [lindex $args 2]
+
+ set mtype {}
+ set params {}
+ foreach mm $map {
+ foreach {key val} $mm {
+ switch -- $key {
+ samp.mtype {set mtype $val}
+ samp.params {set params $val}
+ }
+ }
+ }
+
+ switch -- $mtype {
+ samp.hub.event.shutdown {
+ SAMPRcvdEventShutdown params
+ }
+ samp.hub.event.register {
+ SAMPRcvdEventRegister params
+ }
+ samp.hub.event.unregister {
+ SAMPRcvdEventUnregister params
+ }
+ samp.hub.disconnect {
+ SAMPRcvdDisconnect params
+ }
+ image.load.fits {
+ SAMPRcvdImageLoadFits params
+ }
+ table.load.fits {
+ SAMPRcvdTableLoadFits params
+ }
+ table.load.votable {
+ SAMPRcvdTableLoadVotable params
+ }
+ table.highlight.row {
+ SAMPRcvdTableHighlightRow params
+ }
+ table.select.rowList {
+ SAMPRcvdTableSelectRowList params
+ }
+ coord.pointAt.sky {
+ SAMPRcvdCoordPointAtSky params
+ }
+ ds9.set {
+ SAMPRcvdDS9Set {} params 0
+ }
+ ds9.restricted-set {
+ SAMPRcvdDS9Set {} params 1
+ }
+ default {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP samp.client.receiveNotification: bad mtype $mtype"
+ }
+ }
+ }
+ return {string OK}
+}
+
+# receiveCall(string sender-id, string msg-id, map message)
+proc samp.client.receiveCall {args} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReceivedCall: $args"
+ }
+
+ set secret [lindex $args 0]
+ set id [lindex $args 1]
+ set msgid [lindex $args 2]
+ set map [lindex $args 3]
+
+ set mtype {}
+ set params {}
+ foreach mm $map {
+ foreach {key val} $mm {
+ switch -- $key {
+ samp.mtype {set mtype $val}
+ samp.params {set params $val}
+ }
+ }
+ }
+
+ switch -- $mtype {
+ samp.app.ping {
+ SAMPReply $msgid OK
+ }
+ image.load.fits {
+ SAMPRcvdImageLoadFits params
+ SAMPReply $msgid OK
+ }
+ table.load.fits {
+ SAMPRcvdTableLoadFits params
+ SAMPReply $msgid OK
+ }
+ table.load.votable {
+ SAMPRcvdTableLoadVotable params
+ SAMPReply $msgid OK
+ }
+ table.highlight.row {
+ SAMPRcvdTableHighlightRow params
+ SAMPReply $msgid OK
+ }
+ table.select.rowList {
+ SAMPRcvdTableSelectRowList params
+ SAMPReply $msgid OK
+ }
+ coord.pointAt.sky {
+ SAMPRcvdCoordPointAtSky params
+ SAMPReply $msgid OK
+ }
+ client.env.get {
+ SAMPRcvdClientEnvGet $msgid params
+ }
+ x-samp.affiliation.name {
+ SAMPReplySimple $msgid "SMITHSONIAN ASTROPHYSICAL OBSERVATORY"
+ }
+ x-samp.affiliation.url {
+ SAMPReplySimple $msgid "https://www.cfa.harvard.edu/sao"
+ }
+ x-samp.homepage.url {
+ SAMPReplySimple $msgid "http://ds9.si.edu"
+ }
+ x-samp.releasenotes.url {
+ SAMPReplySimple $msgid OK "http://ds9.si.edu/doc/release/r7.0.html"
+ }
+ x-samp.faq.url {
+ SAMPReplySimple $msgid OK "http://ds9.si.edu/doc/faq.html"
+ }
+ x-samp.authors {
+ global help
+ SAMPReplySimple $msgid OK "$help(authors)"
+ }
+ x-samp.release.version {
+ SAMPReplySimple $msgid OK "$ds9(version)"
+ }
+ ds9.get {
+ SAMPRcvdDS9Get $msgid params
+ }
+ ds9.set {
+ SAMPRcvdDS9Set $msgid params 0
+ }
+ ds9.restricted-get {
+ SAMPRcvdDS9Get $msgid params
+ }
+ ds9.restricted-set {
+ SAMPRcvdDS9Set $msgid params 1
+ }
+ default {
+ SAMPReply $msgid ERROR {} {} "[msgcat::mc {Unknown command}]: $mtype"
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP samp.client.receiveCall: bad mtype $mtype"
+ }
+ }
+ }
+ return {string OK}
+}
+
+# receiveResponse(string responder-id, string msg-tag, map response)
+proc samp.client.receiveResponse {args} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReceivedResponse: $args"
+ }
+
+ set msgtag [lindex $args 0]
+ set value [lindex $args 1]
+ set map [lindex $args 2]
+
+ return {string OK}
+}
+
+# Support
+
+proc SAMPParseHub {} {
+ global samp
+ global env
+
+ set fn {}
+
+ if {[info exists env(SAMP_HUB)]} {
+ if {$env(SAMP_HUB) != {}} {
+ set exp {std-lockurl:(.*)}
+ if {[regexp $exp $env(SAMP_HUB) dummy url]} {
+
+ ParseURL $url rr
+ switch -- $rr(scheme) {
+ ftp {
+ set fn [tmpnam {.samp}]
+ GetFileFTP $rr(authority) $rr(path) $fn
+ }
+ file {set fn $rr(path)}
+ http -
+ default {
+ set fn [tmpnam {.samp}]
+ GetFileHTTP $url $fn
+ }
+ }
+ }
+ }
+ }
+
+ if {$fn == {}} {
+ # look in home directory for .samp
+ global tcl_platform
+ switch $tcl_platform(platform) {
+ unix {
+ set fn [file join [GetEnvHome] {.samp}]
+ }
+ windows {
+ set fn [file join "$env(HOMEDRIVE)$env(HOMEPATH)" {.samp}]
+ }
+ }
+ }
+
+ # no hub to be found
+ if {![file exist $fn]} {
+ return 0
+ }
+
+ set samp(secret) {}
+ set samp(url) {}
+ set samp(metod) {}
+ set fp [open $fn r]
+ while {1} {
+ if {[gets $fp line] == -1} {
+ break
+ }
+
+ # skip any comments
+ if {[string range $line 0 0] == "#"} {
+ continue;
+ }
+
+ if {[regexp -nocase {samp.secret=(.*)} $line foo ss]} {
+ set samp(secret) $ss
+ }
+ if {[regexp -nocase {samp.hub.xmlrpc.url=(.*)} $line foo url]} {
+ if {[ParseURL $url r]} {
+ set samp(url) $r(scheme)://$r(authority)
+ set samp(method) [string range $r(path) 1 end]
+ }
+ }
+ }
+ catch {close $fp}
+
+ if {$samp(secret) == {} || $samp(url) == {}} {
+ SAMPDelTmpFiles
+ return 0
+ }
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPParseHub: $samp(secret) $samp(url) $samp(method)"
+ }
+ return 1
+}
+
+proc SAMPGetAppName {id} {
+ global samp
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPGetAppName: $id"
+ }
+
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string $id"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.getMetadata} $params rr]} {
+ return
+ }
+
+ set name {}
+ foreach arg [lindex $rr 1] {
+ foreach {key val} $arg {
+ switch -- $key {
+ samp.name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ return $name
+}
+
+# CallBacks
+# Hub
+
+proc SAMPRcvdEventShutdown {varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdEventShutdown: $args"
+ }
+
+ SAMPShutdown
+}
+
+proc SAMPRcvdEventRegister {varname} {
+ upvar $varname args
+
+ global isamp
+ global samp
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdEventRegister: $args"
+ }
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ id {
+ # check to see if its just us
+ if {$samp(self) == $val} {
+ return
+ }
+ }
+ }
+ }
+ }
+
+ # wait
+ after $isamp(timeout) SAMPUpdate
+}
+
+proc SAMPRcvdEventUnregister {varname} {
+ upvar $varname args
+
+ global isamp
+ global samp
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdEventUnregister: $args"
+ }
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ id {
+ # check to see if its just us
+ if {$samp(self) == $val} {
+ return
+ }
+ }
+ }
+ }
+ }
+
+ # wait
+ after $isamp(timeout) SAMPUpdate
+}
+
+proc SAMPRcvdDisconnect {varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDisconnect: $args"
+ }
+
+ set msg {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ reason {set msg [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ SAMPShutdown
+}
+
+# HTTPClient
+
+proc SAMPRcvdImageLoadFits {varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdImageLoadFits: $args"
+ }
+
+ global current
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set imageid {}
+ set name {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ image-id {set imageid [XMLUnQuote $val]}
+ name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdImageLoadFits: $url $imageid $name"
+ }
+
+ if {$url != {}} {
+ MultiLoad
+ LoadURLFits $url {} {}
+ }
+}
+
+proc SAMPRcvdTableLoadFits {varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableLoadFits: $args"
+ }
+
+ global current
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set imageid {}
+ set name {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ image-id {set imageid [XMLUnQuote $val]}
+ name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableLoadFits: $url $imageid $name"
+ }
+
+ if {$url != {}} {
+ MultiLoad
+ LoadURLFits $url {} {}
+ }
+}
+
+proc SAMPRcvdTableLoadVotable {varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableLoadVotable: $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set tabid {}
+ set name {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ table-id {set tabid [XMLUnQuote $val]}
+ name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableLoadVotable: $url $tabid $name"
+ }
+
+ global icat
+ if {$url != {}} {
+ CATVOTURL $url $name $tabid
+ if {$tabid != {}} {
+ set catid [lindex $icat(cats) end]
+ set samp(icat,$tabid) $catid
+ set samp(ocat,$catid) $tabid
+ }
+ }
+}
+
+proc SAMPRcvdTableHighlightRow {varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableHighlightRow: $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set tabid {}
+ set row {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ table-id {set tabid [XMLUnQuote $val]}
+ row {set row [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableHighlightRow: $url $tabid $row"
+ }
+
+ if {$tabid != {} && $row != {}} {
+ if {[info exists samp(icat,$tabid)]} {
+ CATSelectRows $samp(icat,$tabid) samp [expr $row+1]
+ }
+ }
+}
+
+proc SAMPRcvdTableSelectRowList {varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableSelectRowList: $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set tabid {}
+ set rowlist {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ table-id {set tabid [XMLUnQuote $val]}
+ row-list {
+ foreach rr [XMLUnQuote $val] {
+ lappend rowlist [expr $rr+1]
+ }
+ }
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableSelectRowList: $url $tabid $rowlist"
+ }
+
+ if {$tabid != {} && [llength $rowlist] != 0} {
+ if {[info exists samp(icat,$tabid)]} {
+ CATSelectRows $samp(icat,$tabid) samp $rowlist
+ }
+ }
+}
+
+proc SAMPRcvdCoordPointAtSky {varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdCoordPointAtSky: $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set ra {}
+ set dec {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ ra {set ra [XMLUnQuote $val]}
+ dec {set dec [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdCoordPointAtSky: $ra $dec"
+ }
+
+ global current
+ if {$ra != {} && $dec != {} && [$current(frame) has wcs equatorial wcs]} {
+ set samp(rcvd,lock) 1
+ PanTo $ra $dec wcs fk5
+ set samp(rcvd,lock) 0
+ }
+}
+
+proc SAMPRcvdClientEnvGet {msgid varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdClientEnvGet: $msgid $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set name {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdClientEnvGet: $name"
+ }
+
+ global env
+ if {[catch {set rr $env($name)}]} {
+ SAMPReply $msgid ERROR {} {} [lindex [split $errorInfo "\n"] 0]
+ global errorInfo
+ set errorInfo {}
+ } else {
+ SAMPReply $msgid OK $rr
+ }
+}
+
+proc SAMPRcvdDS9Set {msgid varname safemode} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDS9Set: $msgid $args $safemode"
+ }
+
+ global current
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set cmd {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ cmd {set cmd [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ set fn {}
+
+ InitError samp
+ if {$url != {}} {
+ set fn [tmpnam {.samp}]
+ GetFileURL $url fn
+ }
+ CommSet $fn $cmd $safemode
+ if {$msgid != {}} {
+ SAMPRcvdDS9SetReply $msgid
+ }
+}
+
+proc SAMPRcvdDS9SetReply {msgid} {
+ global ds9
+ global icursor
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDS9SetReply: $msgid"
+ }
+
+ global errorInfo
+ if {$errorInfo != {} || $ds9(msg) != {}} {
+ if {$ds9(msg) != {}} {
+ switch $ds9(msg,level) {
+ info -
+ warning {SAMPReply $msgid OK $ds9(msg)}
+ error -
+ fatal {SAMPReply $msgid ERROR {} {} $ds9(msg)}
+ }
+ } else {
+ SAMPReply $msgid ERROR {} {} [lindex [split $errorInfo "\n"] 0]
+ }
+ InitError samp
+ } else {
+ SAMPReply $msgid OK
+ }
+}
+
+proc SAMPRcvdDS9Get {msgid varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDS9Get: $args"
+ }
+
+ global current
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set cmd {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ cmd {set cmd [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ set fn [tmpnam {.samp}]
+ InitError samp
+ CommGet SAMPRcvdDS9GetReply $msgid $cmd $fn
+}
+
+proc SAMPRcvdDS9GetReply {msgid msg {fn {}}} {
+ global ds9
+ global icursor
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDS9GetReply: $msgid $msg $fn"
+ }
+
+ global errorInfo
+ if {$errorInfo != {} || $ds9(msg) != {}} {
+ if {$ds9(msg) != {}} {
+ switch $ds9(msg,level) {
+ info -
+ warning {SAMPReply $msgid OK $ds9(msg)}
+ error -
+ fatal {SAMPReply $msgid ERROR {} {} $ds9(msg)}
+ }
+ } else {
+ SAMPReply $msgid ERROR {} {} [lindex [split $errorInfo "\n"] 0]
+ }
+ InitError samp
+ } else {
+ # be sure to white space any newlines, backslashes, and trim
+ set value [string trim [string map {\n { } \\ {}} $msg]]
+
+ # create url
+ set url {}
+ if {$fn != {}} {
+ set url "file://localhost/$fn"
+ }
+
+ SAMPReply $msgid OK $value $url
+ }
+}
+
+proc SAMPDelTmpFiles {} {
+ global ds9
+
+ # delete any previous files
+ foreach fn [glob -directory $ds9(tmpdir) -nocomplain {ds9*samp*}] {
+ catch {file delete -force "$fn"}
+ }
+}
+
+# Cmds
+
+proc ProcessSAMPCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global samp
+ global ds9
+ global env
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ SAMPUpdate
+
+ switch -- [string tolower [lindex $var $i]] {
+ send {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ image {
+ incr i
+ set name [string tolower [lindex $var $i]]
+ if {[info exists samp]} {
+ foreach arg $samp(apps,image) {
+ foreach {key val} $arg {
+ if {[string tolower $val] == $name} {
+ SAMPSendImageLoadFits $key
+ break
+ }
+ }
+ }
+ } else {
+ Error [msgcat::mc {SAMP: not connected}]
+ }
+ }
+ table {
+ incr i
+ set name [string tolower [lindex $var $i]]
+ if {[info exists samp]} {
+ foreach arg $samp(apps,table) {
+ foreach {key val} $arg {
+ if {[string tolower $val] == $name} {
+ SAMPSendTableLoadFits $key
+ break
+ }
+ }
+ }
+ } else {
+ Error [msgcat::mc {SAMP: not connected}]
+ }
+ }
+ default {
+ set name [string tolower [lindex $var $i]]
+ if {[info exists samp]} {
+ foreach arg $samp(apps,image) {
+ foreach {key val} $arg {
+ if {[string tolower $val] == $name} {
+ SAMPSendImageLoadFits $key
+ break
+ }
+ }
+ }
+ } else {
+ Error [msgcat::mc {SAMP: not connected}]
+ }
+ }
+ }
+ }
+ broadcast {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ image {SAMPSendImageLoadFits {}}
+ table {SAMPSendTableLoadFits {}}
+ default {
+ incr i -1
+ SAMPSendImageLoadFits {}
+ }
+ }
+ }
+ connect {SAMPConnect}
+ disconnect {SAMPDisconnect}
+ default {
+ if {[FromYesNo [lindex $var $i]]} {
+ SAMPConnect
+ } else {
+ SAMPDisconnect
+ }
+ }
+ }
+}
generated by cgit v0.12 at 2024-08-29 00:20:02 (GMT)