saods9-data 7.2+dfsg-4 / usr / share / saods9 / src / debug.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 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,watch) 0
    set debug(tcl,hv) 0
    set debug(tcl,cat) 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(saotk,ast) 0
    set debug(saotk,mosaic) 0
    set debug(saotk,parser) 0
    set debug(saotk,perf) 0
    set debug(saotk,wcs) 0
    set debug(saotk,bin) 0
    set debug(saotk,compress) 0
    set debug(saotk,gz) 0
    set debug(saotk,rgb) 0
    set debug(saotk,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 {SAOTk} -menu $ds9(mb).debug.saotk
    $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 {Watch} \
	-variable debug(tcl,watch)
    $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 {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.saotk
    $ds9(mb).debug.saotk add checkbutton -label {AST} \
	-variable debug(saotk,ast) \
	-command "Debug ast debug(saotk,ast)"
    $ds9(mb).debug.saotk add checkbutton -label {Mosaic} \
	-variable debug(saotk,mosaic) \
	-command "Debug mosaic debug(saotk,mosaic)"
    $ds9(mb).debug.saotk add checkbutton -label {Parser} \
	-variable debug(saotk,parser) \
	-command "Debug parser debug(saotk,parser)"    
    $ds9(mb).debug.saotk add checkbutton -label {Perf} \
	-variable debug(saotk,perf) \
	-command "Debug perf debug(saotk,perf)"    
    $ds9(mb).debug.saotk add checkbutton -label {WCS} \
	-variable debug(saotk,wcs) \
	-command "Debug wcs debug(saotk,wcs)"    
    $ds9(mb).debug.saotk add checkbutton -label {Bin} \
	-variable debug(saotk,bin) \
	-command "Debug bin debug(saotk,bin)"    
    $ds9(mb).debug.saotk add checkbutton -label {Compress} \
	-variable debug(saotk,compress) \
	-command "Debug compress debug(saotk,compress)"    
    $ds9(mb).debug.saotk add checkbutton -label {GZ} \
	-variable debug(saotk,gz) \
	-command "Debug gz debug(saotk,gz)"    
    $ds9(mb).debug.saotk add checkbutton -label {RGB} \
	-variable debug(saotk,rgb) \
	-command "Debug rgb debug(saotk,rgb)"    
    $ds9(mb).debug.saotk add checkbutton -label {Crop} \
	-variable debug(saotk,crop) \
	-command "Debug crop debug(saotk,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}
	watch {set debug(tcl,watch) 1}
	hv {set debug(tcl,hv) 1}
	cat {set debug(tcl,cat) 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(saotk,ast) 1
	    Debug ast debug(saotk,ast)
	}
	mosaic {
	    set debug(saotk,mosaic) 1
	    Debug mosaic debug(saotk,mosaic)
	}
	parser {
	    set debug(saotk,parser) 1
	    Debug parser debug(saotk,parser)
	}
	perf {
	    set debug(saotk,perf) 1
	    Debug perf debug(saotk,perf)
	}
	wcs {
	    set debug(saotk,wcs) 1
	    Debug wcs debug(saotk,wcs)
	}
	bin {
	    set debug(saotk,bin) 1
	    Debug bin debug(saotk,bin)
	}
	compress {
	    set debug(saotk,compress) 1
	    Debug compress debug(saotk,compress)
	}
	gz {
	    set debug(saotk,gz) 1
	    Debug gz debug(saotk,gz)
	}
	iis {
	    set debug(iis) 1
	    IISDebug
	}
	rgb {
	    set debug(saotk,rgb) 1
	    Debug rgb debug(saotk,rgb)
	}
	crop {
	    set debug(saotk,crop) 1
	    Debug crop debug(saotk,crop)
	}

	events -
	update -
	idletasks -
	layout -
	info -
	marker -
	watch -
	hv -
	cat -
	samp -
	grid -
	restore -
	http -
	ftp -
	xpa -
	image {}

	default {
	    incr ${iname} -1
	}
    }
}