diff options
Diffstat (limited to 'ds9/library/debug.tcl')
| -rw-r--r-- | ds9/library/debug.tcl | 285 |
1 files changed, 285 insertions, 0 deletions
diff --git a/ds9/library/debug.tcl b/ds9/library/debug.tcl new file mode 100644 index 0000000..32188dc --- /dev/null +++ b/ds9/library/debug.tcl @@ -0,0 +1,285 @@ +# 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 DebugDef {} { + global debug + + set debug(tcl,events) 0 + set debug(tcl,update) 0 + set debug(tcl,idletasks) 0 + set debug(tcl,layout) 0 + set debug(tcl,info) 0 + set debug(tcl,marker) 0 + set debug(tcl,hv) 0 + set debug(tcl,cat) 0 + set debug(tcl,sia) 0 + set debug(tcl,ime) 0 + set debug(tcl,samp) 0 + set debug(tcl,grid) 0 + set debug(tcl,restore) 0 + set debug(tcl,http) 0 + set debug(tcl,ftp) 0 + set debug(tcl,xpa) 0 + set debug(tcl,image) 0 + + set debug(tksao,ast) 0 + set debug(tksao,mosaic) 0 + set debug(tksao,parser) 0 + set debug(tksao,perf) 0 + set debug(tksao,wcs) 0 + set debug(tksao,bin) 0 + set debug(tksao,block) 0 + set debug(tksao,compress) 0 + set debug(tksao,gz) 0 + set debug(tksao,rgb) 0 + set debug(tksao,crop) 0 + + set debug(iis) 0 +} + +proc Debug {which varname} { + upvar $varname var + global current + + if {$current(frame) != {}} { + $current(frame) debug $which $var + } +} + +proc DebugMenu {} { + global ds9 + global debug + + if {[winfo exists $ds9(mb).debug]} { + return + } + + $ds9(mb) add cascade -label {Debug} -menu $ds9(mb).debug + + menu $ds9(mb).debug + $ds9(mb).debug add cascade -label {Tcl} -menu $ds9(mb).debug.tcl + $ds9(mb).debug add cascade -label {TKSAO} -menu $ds9(mb).debug.tksao + $ds9(mb).debug add cascade -label {IIS} -menu $ds9(mb).debug.iis + + menu $ds9(mb).debug.tcl + $ds9(mb).debug.tcl add checkbutton -label {Events} \ + -variable debug(tcl,events) + $ds9(mb).debug.tcl add checkbutton -label {Update} \ + -variable debug(tcl,update) + $ds9(mb).debug.tcl add checkbutton -label {Idletasks} \ + -variable debug(tcl,idletasks) + $ds9(mb).debug.tcl add checkbutton -label {Layout} \ + -variable debug(tcl,layout) + $ds9(mb).debug.tcl add checkbutton -label {Info} \ + -variable debug(tcl,info) + $ds9(mb).debug.tcl add checkbutton -label {Marker} \ + -variable debug(tcl,marker) + $ds9(mb).debug.tcl add checkbutton -label {HV} \ + -variable debug(tcl,hv) + $ds9(mb).debug.tcl add checkbutton -label {Catalog} \ + -variable debug(tcl,cat) + $ds9(mb).debug.tcl add checkbutton -label {SIA} \ + -variable debug(tcl,sia) + $ds9(mb).debug.tcl add checkbutton -label {IME} \ + -variable debug(tcl,ime) + $ds9(mb).debug.tcl add checkbutton -label {SAMP} \ + -variable debug(tcl,samp) + $ds9(mb).debug.tcl add checkbutton -label {Grid} \ + -variable debug(tcl,grid) + $ds9(mb).debug.tcl add checkbutton -label {Restore} \ + -variable debug(tcl,restore) + $ds9(mb).debug.tcl add checkbutton -label {HTTP} \ + -variable debug(tcl,http) + $ds9(mb).debug.tcl add checkbutton -label {FTP} \ + -variable debug(tcl,ftp) + $ds9(mb).debug.tcl add checkbutton -label {XPA} \ + -variable debug(tcl,xpa) + $ds9(mb).debug.tcl add checkbutton -label {IMAGE} \ + -variable debug(tcl,image) + + menu $ds9(mb).debug.tksao + $ds9(mb).debug.tksao add checkbutton -label {AST} \ + -variable debug(tksao,ast) \ + -command "Debug ast debug(tksao,ast)" + $ds9(mb).debug.tksao add checkbutton -label {Mosaic} \ + -variable debug(tksao,mosaic) \ + -command "Debug mosaic debug(tksao,mosaic)" + $ds9(mb).debug.tksao add checkbutton -label {Parser} \ + -variable debug(tksao,parser) \ + -command "Debug parser debug(tksao,parser)" + $ds9(mb).debug.tksao add checkbutton -label {Perf} \ + -variable debug(tksao,perf) \ + -command "Debug perf debug(tksao,perf)" + $ds9(mb).debug.tksao add checkbutton -label {WCS} \ + -variable debug(tksao,wcs) \ + -command "Debug wcs debug(tksao,wcs)" + $ds9(mb).debug.tksao add checkbutton -label {Bin} \ + -variable debug(tksao,bin) \ + -command "Debug bin debug(tksao,bin)" + $ds9(mb).debug.tksao add checkbutton -label {Block} \ + -variable debug(tksao,block) \ + -command "Debug block debug(tksao,block)" + $ds9(mb).debug.tksao add checkbutton -label {Compress} \ + -variable debug(tksao,compress) \ + -command "Debug compress debug(tksao,compress)" + $ds9(mb).debug.tksao add checkbutton -label {GZ} \ + -variable debug(tksao,gz) \ + -command "Debug gz debug(tksao,gz)" + $ds9(mb).debug.tksao add checkbutton -label {RGB} \ + -variable debug(tksao,rgb) \ + -command "Debug rgb debug(tksao,rgb)" + $ds9(mb).debug.tksao add checkbutton -label {Crop} \ + -variable debug(tksao,crop) \ + -command "Debug crop debug(tksao,crop)" + + menu $ds9(mb).debug.iis + $ds9(mb).debug.iis add checkbutton -label {IIS} \ + -variable debug(iis) -command IISDebug +} + +proc DumpURL {varname} { + upvar $varname r + + puts stderr "r(scheme)=$r(scheme)" + puts stderr "r(authority)=$r(authority)" + puts stderr "r(path)=$r(path)" + puts stderr "r(query)=$r(query)" + puts stderr "r(fragment)=$r(fragment)" +} + +proc DumpCallStack {} { + for {set x [expr [info level]-1]} {$x>0} {incr x -1} { + puts stderr "$x: [info level $x]" + } +} + +proc DumpArray {varname} { + upvar $varname var + global $varname + foreach f [array names $varname] { + puts stderr "${varname}($f) = $var($f)" + } +} + +# Process Cmds + +proc ProcessDebugTclCmd {varname iname} { + upvar $varname var + upvar $iname i + + # default debug dialog + if {[info proc bgerror] != {}} { + rename bgerror {} + } + + global debug + switch -- [string tolower [lindex $var $i]] { + events {set debug(tcl,events) 1} + update {set debug(tcl,update) 1} + idletasks {set debug(tcl,idletasks) 1} + layout {set debug(tcl,layout) 1} + info {set debug(tcl,info) 1} + marker {set debug(tcl,marker) 1} + hv {set debug(tcl,hv) 1} + cat {set debug(tcl,cat) 1} + sia {set debug(tcl,sia) 1} + ime {set debug(tcl,ime) 1} + samp {set debug(tcl,samp) 1} + grid {set debug(tcl,grid) 1} + restore {set debug(tcl,restore) 1} + http {set debug(tcl,http) 1} + ftp {set debug(tcl,ftp) 1} + xpa {set debug(tcl,xpa) 1} + image { + set debug(tcl,hv) 1 + set debug(tcl,http) 1 + set debug(tcl,image) 1 + } + } +} + +proc ProcessDebugCmd {varname iname} { + upvar $varname var + upvar $iname i + + DebugMenu + + global debug + switch -- [string tolower [lindex $var $i]] { + ast { + set debug(tksao,ast) 1 + Debug ast debug(tksao,ast) + } + mosaic { + set debug(tksao,mosaic) 1 + Debug mosaic debug(tksao,mosaic) + } + parser { + set debug(tksao,parser) 1 + Debug parser debug(tksao,parser) + } + perf { + set debug(tksao,perf) 1 + Debug perf debug(tksao,perf) + } + wcs { + set debug(tksao,wcs) 1 + Debug wcs debug(tksao,wcs) + } + bin { + set debug(tksao,bin) 1 + Debug bin debug(tksao,bin) + } + block { + set debug(tksao,block) 1 + Debug block debug(tksao,block) + } + compress { + set debug(tksao,compress) 1 + Debug compress debug(tksao,compress) + } + gz { + set debug(tksao,gz) 1 + Debug gz debug(tksao,gz) + } + iis { + set debug(iis) 1 + IISDebug + } + rgb { + set debug(tksao,rgb) 1 + Debug rgb debug(tksao,rgb) + } + crop { + set debug(tksao,crop) 1 + Debug crop debug(tksao,crop) + } + + events - + update - + idletasks - + layout - + info - + marker - + watch - + hv - + cat - + sia - + ime - + samp - + grid - + restore - + http - + ftp - + xpa - + image {} + + default { + incr ${iname} -1 + } + } +} + |