diff options
Diffstat (limited to 'ds9/library/samp.tcl')
-rw-r--r-- | ds9/library/samp.tcl | 1730 |
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 + } + } + } +} |