saods9-data 7.2+dfsg-4 / usr / share / saods9 / src / imgsvr.tcl

#  Copyright (C) 1999-2012
#  Smithsonian Astrophysical Observatory, Cambridge, MA, USA
#  For conditions of distribution and use, see copyright notice in "copyright"

package provide DS9 1.0

proc IMGSVRInit {varname title exec ack} {
    upvar #0 $varname var
    global $varname

    global ds9
    global pds9

    # AR variables
    ARInit $varname IMGSVRServer

    # IMG variables

    set var(proc,exec) $exec
    set var(proc,ack) $ack

    set var(current) {}
    set var(frame) {}
    set var(rgb) {}

    # create the window
    set w $var(top)
    set mb $var(mb)

    Toplevel $w $mb 6 $title "ARDestroy $varname"

    $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
    menu $mb.file
    $mb.file add command -label [msgcat::mc {Retrieve}] \
	-command "IMGSVRApply $varname 0"
    $mb.file add command -label [msgcat::mc {Cancel}] \
	-command "ARCancel $varname"
    $mb.file add separator
    $mb.file add command -label [msgcat::mc {Update from Current Frame}] \
	-command "IMGSVRUpdate $varname 1"
    $mb.file add command \
	-label [msgcat::mc {Update from Current Crosshair}] \
	-command "IMGSVRCrosshair $varname"
    $mb.file add separator
    $mb.file add command -label [msgcat::mc {Acknowledgment}] \
	-command "IMGSVRAck $varname"
    $mb.file add separator
    $mb.file add command -label [msgcat::mc {Close}] \
	-command "ARDestroy $varname"

    AREditMenu $varname
    NSVRServerMenu $varname

    $mb add cascade -label [msgcat::mc {Preferences}] -menu $mb.prefs
    menu $mb.prefs
    $mb.prefs add checkbutton -label [msgcat::mc {Save Image on Download}] \
	-variable ${varname}(save)
    $mb.prefs add separator
    $mb.prefs add radiobutton -label [msgcat::mc {New Frame}] \
	-variable ${varname}(mode) -value new
    $mb.prefs add radiobutton -label [msgcat::mc {Current Frame}] \
	-variable ${varname}(mode) -value current

    # Param
    set f [ttk::frame $w.param]

    ttk::label $f.nametitle -text [msgcat::mc {Object}]
    ttk::entry $f.name -textvariable ${varname}(name) -width 50
    ttk::label $f.sky -textvariable ${varname}(sky) -anchor w
    set var(xname) [ttk::label $f.xtitle -text {} -width 1]
    ttk::entry $f.x -textvariable ${varname}(x) -width 14
    set var(yname) [ttk::label $f.ytitle -text {} -width 1]
    ttk::entry $f.y -textvariable ${varname}(y) -width 14
    ARSkyFormat $f.skyformat $varname
    ttk::label $f.wtitle -text [msgcat::mc {Width}]
    ttk::entry $f.w -textvariable ${varname}(width) -width 14
    ttk::label $f.htitle -text [msgcat::mc {Height}]
    ttk::entry $f.h -textvariable ${varname}(height) -width 14
    ARRFormat $f.format $varname

    grid $f.nametitle x $f.name - - - - -padx 2 -pady 2 -sticky ew
    grid $f.sky $f.xtitle $f.x $f.ytitle $f.y $f.skyformat \
	-padx 2 -pady 2 -sticky w
    grid $f.wtitle x $f.w $f.htitle $f.h $f.format -padx 2 -pady 2 -sticky w

    # Status
    set f [ttk::frame $w.status]
    ttk::label $f.title -text [msgcat::mc {Status}]
    ttk::label $f.item -textvariable ${varname}(status)
    grid $f.title $f.item -padx 2 -pady 2 -sticky w

    # Buttons
    set f [ttk::frame $w.buttons]
    set var(apply) [ttk::button $f.apply -text [msgcat::mc {Retrieve}] \
			-command "IMGSVRApply $varname 0"]
    set var(cancel) [ttk::button $f.cancel -text [msgcat::mc {Cancel}] \
			 -command "ARCancel $varname" -state disabled]
    ttk::button $f.close -text [msgcat::mc {Close}] \
	-command "ARDestroy $varname"
    pack $f.apply $f.cancel $f.close -side left -expand true -padx 2 -pady 4 

    # Fini
    ttk::separator $w.sep -orient horizontal
    ttk::separator $w.sep2 -orient horizontal
    pack $w.buttons $w.sep $w.status $w.sep2 -side bottom -fill x
    pack $w.param -side top -fill both -expand true

    ARCoord $varname
    ARStatus $varname {}
}

proc IMGSVRApply {varname sync} {
    upvar #0 $varname var
    global $varname

    global debug
    if {$debug(tcl,image)} {
	puts stderr "IMGSVRApply $varname $sync"
    }

    set var(sync) $sync

    ARApply $varname

    set var(frame) {}
    set var(rgb) {}

    if {($var(name) != {})} {
	set var(sky) fk5
	ARCoord $varname

	# remember where we are
	global current
	switch -- $var(mode) {
	    current {
		set var(frame) $current(frame)
		set var(rgb) $current(rgb)
	    }
	    new {}
	}

	NSVRServer $varname
    } else {
	IMGSVRServer $varname
    }
}

proc IMGSVRAck {varname} {
    upvar #0 $varname var
    global $varname

    global debug
    if {$debug(tcl,image)} {
	puts stderr "IMGSVRAck $varname"
    }

    eval "$var(proc,ack) $varname"
}

proc IMGSVRUpdate {varname force} {
    upvar #0 $varname var
    global $varname

    global current
    global wcs

    global debug
    if {$debug(tcl,image)} {
	puts stderr "IMGSVRUpdate $varname $force"
    }
    if {$debug(tcl,update)} {
	puts stderr "IMGSVRUpdate"
    }

    if {[winfo exists $var(top)]} {
	set var(name) {}
	if {$current(frame) != {} } {
	    set fn [$current(frame) get fits file name]
	    if {($fn != $var(current)) || $force} {
		set var(current) $fn

		if {[$current(frame) has wcs equatorial $wcs(system)]} {
		    set coord [$current(frame) get fits center \
				   $wcs(system) $var(sky) $var(skyformat)]
		    set var(x) [lindex $coord 0]
		    set var(y) [lindex $coord 1]

		    set size [$current(frame) get fits size \
				  $wcs(system) $var(sky) $var(rformat)]
		    set var(width) [lindex $size 0]
		    set var(height) [lindex $size 1]

		    return
		}
	    }
	} else {
	    set var(x) {}
	    set var(y) {}
	    set var(width) {}
	    set var(height) {}
	}
    }
}

proc IMGSVRCrosshair {varname} {
    upvar #0 $varname var
    global $varname

    global debug
    if {$debug(tcl,image)} {
	puts stderr "IMGSVRCrosshair $varname"
    }

    global current
    global wcs

    if {[winfo exists $var(top)]} {
	set var(name) {}
	if {$current(frame) != {} } {
	    if {[$current(frame) has wcs equatorial $wcs(system)]} {
		set coord [$current(frame) get crosshair \
			       $wcs(system) $var(sky) $var(skyformat)]
		set var(x) [lindex $coord 0]
		set var(y) [lindex $coord 1]

		return
	    }
	}
	set var(x) {}
	set var(y) {}
    }
}

proc IMGSVRServer {varname} {
    upvar #0 $varname var
    global $varname
    global current

    global debug
    if {$debug(tcl,image)} {
	puts stderr "IMGSVRServer $varname"
    }

    if {($var(x) != {}) && ($var(y) != {})} {
	switch -- $var(mode) {
	    new {MultiLoadBase}
	    current {}
	}

	# remember where we are
	if {$var(frame) == {}} {
	    set var(frame) $current(frame)
	}
	if {$var(rgb) == {}} {
	    set var(rgb) $current(rgb)
	}

	ARStatus $varname "Contacting Image Server"
	eval "$var(proc,exec) $varname"
    } else {
	ARStatus $varname "Please specify Coordinates"
	ARReset $varname
    }
}

proc IMGSVRLoad {varname} {
    upvar #0 $varname var
    global $varname

    global debug
    if {$debug(tcl,image)} {
	puts stderr "IMGSVRLoad $varname $var(url) $var(query)"
    }

    set var(ch) [open "$var(fn)" w]

    global ihttp
    if {$var(sync)} {
	if {![catch {set var(token) [http::geturl $var(url) \
					 -protocol 1.0 \
					 -timeout $ihttp(timeout) \
					 -channel $var(ch) \
					 -progress \
					 [list IMGSVRProgress $varname] \
					 -binary 1 \
					 -headers "[ProxyHTTP]" \
					 -query "$var(query)"]
	}]} {
	    # reset errorInfo (may be set in http::geturl)
	    global errorInfo
	    set errorInfo {}

	    set var(active) 1
	    IMGSVRLoadFinish $varname $var(token)
	} else {
	    catch {close $var(ch)}
	    ARError $varname "[msgcat::mc {Unable to locate URL}] $var(url)"
	}
    } else {
	if {![catch {set var(token) [http::geturl $var(url) \
					 -protocol 1.0 \
					 -timeout $ihttp(timeout) \
					 -channel $var(ch) \
					 -command \
					 [list IMGSVRLoadFinish $varname] \
					 -progress \
					 [list IMGSVRProgress $varname] \
					 -binary 1 \
					 -headers "[ProxyHTTP]" \
					 -query "$var(query)"]
	}]} {
	    # reset errorInfo (may be set in http::geturl)
	    global errorInfo
	    set errorInfo {}

	    set var(active) 1
	} else {
	    catch {close $var(ch)}
	    ARError $varname "[msgcat::mc {Unable to locate URL}] $var(url)"
	}
    }
}

proc IMGSVRLoadFinish {varname token} {
    upvar #0 $varname var
    global $varname

    global debug
    if {$debug(tcl,image)} {
	puts stderr "IMGSVRLoadFinish $varname"
    }

    global current
    global ds9
    global loadParam

    catch {close $var(ch)}

    if {!($var(active))} {
	ARCancelled $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 {IMGSVRParse $varname}

	201 -
	300 -
	301 -
	302 -
	303 -
	305 -
	307 {
	    foreach {name value} $meta {
		if {[regexp -nocase ^location$ $name]} {
		    global debug
		    if {$debug(tcl,hv)} {
			puts stderr "IMGSVRLoadFinish redirect $code to $value"
		    }
		    # clean up and resubmit
		    http::cleanup $token
		    unset var(token)

		    set var(url) $value
		    IMGSVRLoad $varname
		}
	    }
	}

	default {ARError $varname "[msgcat::mc {Error code was returned}] $code"}
    }
}

proc IMGSVRParse {varname} {
    upvar #0 $varname var
    global $varname

    global debug
    if {$debug(tcl,image)} {
	puts stderr "IMGSVRParse $varname"
    }

    global current
    global ds9
    global loadParam

    # do we check for valid FITS?
    if {$var(valid)} {
	if {![ValidFits $var(fn)]} {
	    ARError $varname "[msgcat::mc {No data available at }] $var(x) $var(y)"
	    return
	}
    }

    # goto to frame
    if {$var(frame) != {}} {
	if {$current(frame) != $var(frame)} {
	    set ds9(next) $var(frame)
	    GotoFrame
	}
    }

    # got to channel
    if {$var(rgb) != {}} {
	if {$current(rgb) != $var(rgb)} {
	    set current(rgb) $var(rgb)
	    RGBChannel
	}
    }

    StartLoad
    # alloc it because we are going to delete it after load
    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)
    ProcessLoad

    if {!$var(save)} {
	if {[file exists $var(fn)]} {
	    catch {file delete -force $var(fn)}
	}
    }
    FinishLoad

    ARDone $varname
}

proc IMGSVRProgress {varname token totalsize currentsize} {
    upvar #0 $varname var
    global $varname

    # sometimes we get nothing
    if {$totalsize == {} || $currentsize == {}} {
	ARStatus $varname {}
    } elseif {$totalsize != 0} {
	ARStatus $varname "$currentsize bytes of $totalsize bytes [expr int(double($currentsize)/$totalsize*100)]%"
    } else {
	ARStatus $varname "$currentsize bytes"
    }
}

proc IMGSVRProcessCmd {varname iname vvarname} {
    upvar 2 $varname var
    upvar 2 $iname i

    upvar #0 $vvarname vvar

    switch -- [string tolower [lindex $var $i]] {
	{} {
	    if {$vvar(name) != {} || ($vvar(x) != {} && $vvar(y) != {})} {
		IMGSVRApply $vvarname 1
	    }
	}
	open {}
	close {ARDestroy $vvarname}
	save {
	    incr i
	    set vvar(save) [FromYesNo [lindex $var $i]]
	}
	frame {
	    incr i
	    set vvar(mode) [string tolower [lindex $var $i]]
	}
	survey {
	    incr i
	    set vvar(survey) [lindex $var $i]
	}
	size {
	    incr i
	    set vvar(width) [lindex $var $i]
	    incr i
	    set vvar(height) [lindex $var $i]
	    incr i
	    if {[lindex $var $i] != {} && \
		    [string range [lindex $var $i] 0 0] != {-}} {
		set vvar(rformat) [lindex $var $i]
		set vvar(rformat,msg) $vvar(rformat)
	    } else {
		incr i -1
	    }
	}
	update {
	    incr i
	    switch [string tolower [lindex $var $i]] {
		frame {IMGSVRUpdate $vvarname 1}
		crosshair {IMGSVRCrosshair $vvarname}
	    }
	    IMGSVRApply $vvarname 1
	}
	coord {
	    incr i
	    set vvar(x) [lindex $var $i]
	    incr i
	    set vvar(y) [lindex $var $i]
	    incr i
	    if {[lindex $var $i] != {} && \
		    [string range [lindex $var $i] 0 0] != {-}} {
		set vvar(skyformat) [lindex $var $i]
		set vvar(skyformat,msg) $vvar(skyformat)
	    } else {
		incr i -1
	    }
	    IMGSVRApply $vvarname 1
	}
	name {
	    incr i
	    set vvar(name) [lindex $var $i]
	    if {$vvar(name) != {}} {
		IMGSVRApply $vvarname 1
	    }
	}
	default {
	    set vvar(name) [lindex $var $i]
	    if {$vvar(name) != {}} {
		IMGSVRApply $vvarname 1
	    }
	}
    }
}

proc IMGSVRProcessSendCmd {proc id param vvarname} {
    upvar #0 $vvarname vvar

    switch -- [string tolower [lindex $param 0]] {
	save {$proc $id [ToYesNo $vvar(save)]}
	frame {$proc $id "$vvar(mode)\n"}
	survey {$proc $id "$vvar(survey)\n"}
	size {$proc $id "$vvar(width) $vvar(height) $vvar(rformat)\n"}
	coord {$proc $id "$vvar(x) $vvar(y) $vvar(skyformat)\n"}
	name -
	default {$proc $id "$vvar(name)\n"}
    }
}