diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:01:15 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:01:15 (GMT) |
commit | 12166aa342f7c8d905097e43a1f50e0775503069 (patch) | |
tree | 73a6e7296fbf9898633a02c2503a3e959789d8c3 /ds9/library/photo.tcl | |
parent | d4d595fa7fb12903db9227d33d48b2b00120dbd1 (diff) | |
download | blt-12166aa342f7c8d905097e43a1f50e0775503069.zip blt-12166aa342f7c8d905097e43a1f50e0775503069.tar.gz blt-12166aa342f7c8d905097e43a1f50e0775503069.tar.bz2 |
Initial commit
Diffstat (limited to 'ds9/library/photo.tcl')
-rw-r--r-- | ds9/library/photo.tcl | 300 |
1 files changed, 300 insertions, 0 deletions
diff --git a/ds9/library/photo.tcl b/ds9/library/photo.tcl new file mode 100644 index 0000000..fe70891 --- /dev/null +++ b/ds9/library/photo.tcl @@ -0,0 +1,300 @@ +# 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 ImportPhotoFile {fn mode} { + global loadParam + + set loadParam(file,type) photo + set loadParam(file,mode) $mode + set loadParam(load,type) photo + + # find stdin + if {[string range $fn 0 4] == "stdin" || + [string range $fn 0 4] == "STDIN" || + [string range $fn 0 0] == "-"} { + + fconfigure stdin -translation binary -encoding binary + if {[catch {image create photo -data [read -nonewline stdin]} ph]} { + Error [msgcat::mc {An error has occurred while reading image.}] + return + } + set loadParam(file,name) stdin + } else { + if {[catch {image create photo -file $fn} ph]} { + Error [msgcat::mc {An error has occurred while reading image.}] + return + } + set loadParam(file,name) $fn + } + set loadParam(var,name) $ph + + # mask not supported + set loadParam(load,layer) {} + + ProcessLoad + + image delete $ph +} + +proc ImportPhotoAlloc {path fn mode} { + global loadParam + + set loadParam(file,type) photo + set loadParam(file,mode) $mode + set loadParam(load,type) photo + + if {[catch {image create photo -file $path} ph]} { + Error [msgcat::mc {An error has occurred while reading image.}] + return + } + set loadParam(file,name) $fn + set loadParam(var,name) $ph + + # mask not supported + set loadParam(load,layer) {} + + ProcessLoad + + image delete $ph +} + +proc ImportPhotoSocket {ch fn mode} { + global loadParam + + set loadParam(file,type) photo + set loadParam(file,mode) $mode + set loadParam(load,type) photo + set loadParam(file,name) $fn + + fconfigure $ch -translation binary -encoding binary + if {[catch {image create photo -data [read $ch]} ph]} { + Error [msgcat::mc {An error has occurred while reading image.}] + return 0 + } + set loadParam(var,name) $ph + + # mask not supported + set loadParam(load,layer) {} + + set rr [ProcessLoad 0] + + image delete $ph + return $rr +} + +proc ExportPhotoFile {fn format opt} { + global export + global current + + if {$fn == {} || $current(frame) == {}} { + return + } + + if {![$current(frame) has fits]} { + return + } + + if {[catch {image create photo} ph]} { + Error [msgcat::mc {An error has occurred while creating image.}] + return + } + + $current(frame) save photo $ph + set ff $format + switch -- $format { + jpeg { + if {$opt == {}} { + set opt $export(jpeg,quality) + } + set ff [list $format -quality $opt] + } + tiff { + if {$opt == {}} { + set opt $export(tiff,compress) + } + set ff [list $format -compression $opt] + } + } + if {[catch {$ph write $fn -format $ff}]} { + Error [msgcat::mc {An error has occurred while writing image.}] + } + + image delete $ph +} + +proc ExportPhotoSocket {ch format opt} { + global export + global current + + if {$current(frame) == {}} { + return + } + + if {![$current(frame) has fits]} { + return + } + + if {[catch {image create photo} ph]} { + Error [msgcat::mc {An error has occurred while creating image.}] + return + } + + $current(frame) save photo $ph + + fconfigure $ch -translation binary -encoding binary + set ff $format + switch -- $format { + jpeg { + if {$opt == {}} { + set opt $export(jpeg,quality) + } + set ff [list $format -quality $opt] + } + tiff { + if {$opt == {}} { + set opt $export(tiff,compress) + } + set ff [list $format -compression $opt] + } + } + if {[catch {$ph data -format $ff} data]} { + Error [msgcat::mc {An error has occurred while writing image.}] + return + } + puts -nonewline $ch [base64::decode $data] + + image delete $ph +} + +# Process Cmds + +proc ProcessGIFCmd {varname iname ch fn} { + upvar $varname var + upvar $iname i + + ProcessPhotoCmd $varname $iname $ch $fn +} + +proc ProcessJPEGCmd {varname iname ch fn} { + upvar $varname var + upvar $iname i + + ProcessPhotoCmd $varname $iname $ch $fn +} + +proc ProcessPNGCmd {varname iname ch fn} { + upvar $varname var + upvar $iname i + + ProcessPhotoCmd $varname $iname $ch $fn +} + +proc ProcessTIFFCmd {varname iname ch fn} { + upvar $varname var + upvar $iname i + + ProcessPhotoCmd $varname $iname $ch $fn +} + +proc ProcessPhotoCmd {varname iname ch fn} { + upvar 2 $varname var + upvar 2 $iname i + + global loadParam + global current + + set mode {} + + switch -- [string tolower [lindex $var $i]] { + new { + incr i + CreateFrame + } + mask { + incr i + # not supported + } + slice { + incr i + set mode slice + } + } + set param [lindex $var $i] + + StartLoad + if {$ch != {}} { + # xpa + global tcl_platform + switch $tcl_platform(os) { + Linux - + Darwin - + SunOS { + if {![ImportPhotoSocket $ch $param $mode]} { + InitError xpa + ImportPhotoFile $param $mode + } + } + {Windows NT} {ImportPhotoFile $param $mode} + } + } else { + # comm + if {$fn != {}} { + ImportPhotoAlloc $fn $param $mode + } else { + ImportPhotoFile $param $mode + } + } + FinishLoad +} + +proc ProcessSendGIFCmd {proc id param ch fn} { + global current + + ProcessSendPhotoCmd gif $proc $id $param $ch $fn +} + +proc ProcessSendJPEGCmd {proc id param ch fn} { + global current + + ProcessSendPhotoCmd jpeg $proc $id $param $ch $fn +} + +proc ProcessSendPNGCmd {proc id param ch fn} { + global current + + ProcessSendPhotoCmd png $proc $id $param $ch $fn +} + +proc ProcessSendTIFFCmd {proc id param ch fn} { + global current + + ProcessSendPhotoCmd tiff $proc $id $param $ch $fn +} + +proc ProcessSendPhotoCmd {format proc id param ch fn} { + global current + global export + + if {$current(frame) == {}} { + return + } + + set opt [string tolower [lindex $param 0]] + if {$ch != {}} { + # xpa + global tcl_platform + switch $tcl_platform(os) { + Linux - + Darwin - + SunOS {ExportPhotoSocket $ch $format $opt} + {Windows NT} {} + } + } elseif {$fn != {}} { + # comm + ExportPhotoFile $fn $format $opt + $proc $id {} $fn + } +} |