diff options
Diffstat (limited to 'ds9/library/header.tcl')
| -rw-r--r-- | ds9/library/header.tcl | 195 |
1 files changed, 195 insertions, 0 deletions
diff --git a/ds9/library/header.tcl b/ds9/library/header.tcl new file mode 100644 index 0000000..e07b3d8 --- /dev/null +++ b/ds9/library/header.tcl @@ -0,0 +1,195 @@ +# 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 DisplayHeaderMenu {} { + global current + + # possible cases + # image primary + # image xtension + # compressed primary + # compressed xtension + # bin table xtension + # hpx xtension + # cube primary + # cube xtension + # multiple xtension cube + # multiple file cube + # mosaic extension + # mosaic image xtension + # mosaic cube xtension + # mosaic image cube xtension + + set cnt [$current(frame) get fits count] + + if {$cnt > 0} { + set slb(count) 0 + + # check for primary + set fn [$current(frame) get fits file name 1] + set xten \ + [string trim [$current(frame) get fits header 1 keyword {XTENSION}]] + if {$xten != {}} { + set bb [string first {[} $fn] + if {$bb>0} { + set pn [string range $fn 0 [expr $bb-1]] + } else { + set pn "primary" + } + incr slb(count) + set slb($slb(count),item) $pn + set slb($slb(count),value) -1 + } + + set last {} + for {set ii 1} {$ii <= $cnt} {incr ii} { + set fn [$current(frame) get fits file name $ii] + set bb [string first {[} $fn] + if {$bb<0} { + set nn [$current(frame) get fits ext $ii] + if {$nn > 0} { + set fn "$fn\[\]" + } + } + + if {$fn != $last} { + incr slb(count) + set slb($slb(count),item) $fn + set slb($slb(count),value) $ii + set last $fn + } + } + + if {$slb(count) <= 1} { + DisplayHeader $current(frame) 1 $fn + } else { + if {[SLBDialog slb {Select Header} 40]} { + DisplayHeader $current(frame) $slb(value) $slb(item) + } + } + } +} + +proc DisplayHeader {frame id title} { + global current + + set varname "hd-$frame-$id" + upvar #0 $varname var + global $varname + + SimpleTextDialog $varname $title 80 40 insert top \ + [$current(frame) get fits header $id] + + # create a special text tag for keywords + $var(text) tag configure keyword -foreground blue + + # color tag keywords + set stop [$var(text) index end] + for {set ii 1.0} {$ii<$stop} {set ii [expr $ii+1]} { + $var(text) tag add keyword $ii "$ii +8 chars" + } +} + +proc UpdateHeaderDialog {} { + global current + + set frame $current(frame) + set cnt 1 + if {[$frame has fits mosaic]} { + set cnt [$frame get fits count] + } + + for {set id 1} {$id <= $cnt} {incr id} { + set varname "hd-$frame-$id" + upvar #0 $varname var + global $varname + if {![info exists var(top)]} { + continue + } + if {![winfo exists $var(top)]} { + continue + } + + $var(text) delete 1.0 end + $var(text) insert end [$frame get fits header $id] + + # color tag keywords + set stop [$var(text) index end] + for {set ii 1.0} {$ii<$stop} {set ii [expr $ii+1]} { + $var(text) tag add keyword $ii "$ii +8 chars" + } + } +} + +proc DestroyHeader {frame} { + set cnt 1 + if {[$frame has fits mosaic]} { + set cnt [$frame get fits count] + } + + for {set id 1} {$id <= $cnt} {incr id} { + set varname "hd-$frame-$id" + upvar #0 $varname var + global $varname + + if {[info exists $varname]} { + if {[winfo exists $var(top)]} { + SimpleTextDestroy $varname + } + } + } +} + +proc ProcessHeaderCmd {varname iname} { + upvar $varname var + upvar $iname i + + set item [string tolower [lindex $var $i]] + switch -- $item { + close - + save {incr i} + } + + if {[lindex $var $i] != {} && [string is integer [lindex $var $i]]} { + set jj [lindex $var $i] + incr i + } else { + set jj 1 + } + + global current + if {$current(frame) != {}} { + switch -- $item { + close { + set vvarname "hd[string range $current(frame) end end]-$jj" + upvar #0 $vvarname vvar + global $vvarname + + if {[info exists vvar(top)]} { + SimpleTextDestroy $vvarname + } + incr i -1 + } + save { + set fn [lindex $var $i] + if {$fn != {}} { + if {[catch {set ch [open "| cat > \"$fn\"" w]}]} { + Error [msgcat::mc {An error has occurred while saving}] + return + } + puts -nonewline $ch [$current(frame) get fits header $jj] + close $ch + } + } + default { + catch {DisplayHeader $current(frame) $jj \ + [$current(frame) get fits file name $jj]} + incr i -1 + } + } + } +} + |