summaryrefslogtreecommitdiff
path: root/gdb/gdbtk/library/prefs.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'gdb/gdbtk/library/prefs.tcl')
-rw-r--r--gdb/gdbtk/library/prefs.tcl715
1 files changed, 0 insertions, 715 deletions
diff --git a/gdb/gdbtk/library/prefs.tcl b/gdb/gdbtk/library/prefs.tcl
deleted file mode 100644
index 2241d49d0bd..00000000000
--- a/gdb/gdbtk/library/prefs.tcl
+++ /dev/null
@@ -1,715 +0,0 @@
-# Local preferences functions for Insight.
-# Copyright 1997, 1998, 1999, 2002, 2003 Red Hat
-#
-# This program is free software; you can redistribute it and/or modify it
-# under the terms of the GNU General Public License (GPL) as published by
-# the Free Software Foundation; either version 2 of the License, or (at
-# your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-
-
-# On STARTUP:
-# 1. Options database (.Xdefaults on Unix or ? on Windows) is read
-# 2. GDB prefs file is read ("gdbtk.ini" on Windows; ".gdbtkinit" on Unix)
-# 3. GDB init script is read
-#
-# Normally all preferences will be set in the prefs file, which is
-# a generated file. Hand-editing, if necessary, should be done to the
-# GDB init script.
-#
-# when "save options" is selected, the contents of the
-# preferences array is written out to the GDB prefs file.
-#
-# Usage:
-# pref_save
-# pref_read
-# ----------------------------------------------------------------------
-#
-
-proc pref_read {} {
- global prefs_init_filename env gdb_ImageDir GDBTK_LIBRARY GDBStartup
- global tcl_platform
-
- if {[info exists env(HOME)]} {
- if {$tcl_platform(platform) == "windows"} {
- set home [ide_cygwin_path to_win32 $env(HOME)]
- } else {
- set home $env(HOME)
- }
- } else {
- set home ""
- }
-
- if {$tcl_platform(platform) == "windows"} {
- set prefs_init_filename "gdbtk.ini"
- } else {
- set prefs_init_filename ".gdbtkinit"
- }
-
- if {!$GDBStartup(inhibit_prefs)} {
- set file_opened 0
- if {[file exists $prefs_init_filename]} {
- if {[catch {open $prefs_init_filename r} fd]} {
- dbug E "$fd"
- return
- }
- set file_opened 1
- } elseif {$home != ""} {
- set name [file join $home $prefs_init_filename]
- if {[file exists $name]} {
- if {[catch {open $name r} fd]} {
- dbug E "$fd"
- return
- }
- set prefs_init_filename $name
- set file_opened 1
- }
- }
-
- if {$file_opened == "1"} {
- set section gdb
- set version 0
- while {[gets $fd line] >= 0} {
- switch -regexp -- $line {
- {^[ \t\n]*#.*} {
- # Comment. We recognize one magic comment that includes
- # the version number.
- if {[regexp -- "^# GDBtkInitVersion: (\[0-9\]+)\$" $line \
- dummy v]} {
- set version $v
- }
- }
-
- {^[ \t\n]*$} {
- ;# empty line; ignore it
- }
-
- {^[ \t\n]*\[.*\]} {
- regexp {\[(.*)\]} $line match section
- }
-
- {^[ \t\n]*option.*} {
- set line [string trimleft $line]
- eval $line
- }
-
- default {
- set a ""
- set name ""
- set val ""
- regexp "\[ \t\n\]*\(.+\)=\(.+\)" $line a name val
- if {$a == "" || $name == ""} {
- dbug W "Cannot parse line: $line"
- } else {
- # Must unescape equal signs in val
- set val [unescape_value $val $version]
- if {$section == "gdb"} {
- pref setd gdb/$name $val
- } elseif {$section == "global" && [regexp "^font/" $name]} {
- set name [split $name /]
- set f global/
- append f [join [lrange $name 1 end] /]
- if {[lsearch [font names] $f] == -1} {
- # new font
- eval define_font $f $val
- } else {
- # existing font
- pref set global/font/[join [lrange $name 1 end] /] $val
- }
- } elseif {$section == "global"} {
- pref setd $section/$name $val
- } else {
- # backwards compatibility. recognize old src-font name
- if {$val == "src-font"} {set val "global/fixed"}
- pref setd gdb/$section/$name $val
- }
- }
- }
- }
- }
- close $fd
- } elseif {$home != ""} {
- set prefs_init_filename [file join $home $prefs_init_filename]
- }
-
- # now set global options
- set gdb_ImageDir [file join $GDBTK_LIBRARY [pref get gdb/ImageDir]]
-
- }
-
- # finally set colors, from system if possible
- pref_set_colors $home
-}
-
-# ------------------------------------------------------------------
-# PROC: pref_save - save preferences to a file and delete window
-# ------------------------------------------------------------------
-proc pref_save {{win {}}} {
- global prefs_init_filename GDBStartup
-
- if {!$GDBStartup(inhibit_prefs)} {
- debug "pref_save $prefs_init_filename"
-
- if {[catch {open $prefs_init_filename w} fd]} {
- debug "ERROR: $fd"
- return
- }
-
- puts $fd "\# GDBtk Init file"
- puts $fd {# GDBtkInitVersion: 1}
-
- set plist [pref list]
- # write out global options
- puts $fd "\[global\]"
- foreach var $plist {
- set t [split $var /]
- if {[lindex $t 0] == "global"} {
- set x [join [lrange $t 1 end] /]
- set v [escape_value [pref get $var]]
-
- if {$x != "" && $v != ""} {
- puts $fd "\t$x=$v"
- }
- }
- }
-
- # write out gdb-global options
- puts $fd "\[gdb\]"
- foreach var $plist {
- set t [split $var /]
- # We use the funny join/lreplace code because the session code
- # can generate a key where [lindex $t 2] is empty but there is
- # still stuff after that. This happens because the session code
- # uses filenames, which can start with `/'.
- if {[lindex $t 0] == "gdb"
- && [string compare [join [lreplace $t 0 1] /] ""] == 0} {
- set x [lindex $t 1]
- set v [escape_value [pref get $var]]
- if {$x != "" && $v != ""} {
- puts $fd "\t$x=$v"
- }
- }
- }
-
- # now loop through all sections writing out values
- # FIXME: this is broken. We should discover the list
- # dynamically.
- lappend secs load console src reg stack locals watch bp search \
- process geometry help browser kod window session mem
-
- foreach section $secs {
- puts $fd "\[$section\]"
- foreach var $plist {
- set t [split $var /]
- if {[lindex $t 0] == "gdb" && [lindex $t 1] == $section} {
- set x [join [lrange $t 2 end] /]
- set v [escape_value [pref get $var]]
- if {$x != "" && $v != ""} {
- puts $fd "\t$x=$v"
- }
- }
- }
- }
- close $fd
- }
-
- if {$win != ""} {
- $win delete
- }
-}
-
-# -------------------------------------------------------
-# PROC: escape_value - escape all equal signs for saving
-# prefs to a file
-# -------------------------------------------------------
-proc escape_value {val} {
- # We use a URL-style quoting. We encode `=', `%', the `[]'
- # characters and newlines. We use a cute trick here: we regsub in
- # command expressions which we then expand using subst.
- if {[info tclversion] >= 8.1} {
- set expr {([\[\]=%\n])}
- } else {
- set expr "(\[\]\[=%\n\])"
- }
- regsub -all -- $expr $val \
- {[format "%%%02x" [scan {\1} %c x; set x]]} newval
- return [subst -nobackslashes -novariables $newval]
-}
-
-# -------------------------------------------------------
-# PROC: unescape_value - unescape all equal signs for
-# reading prefs from a file. VERSION is the version
-# number of the encoding.
-# version 0 only encoded `='.
-# version 1 correctly encoded more values
-# -------------------------------------------------------
-proc unescape_value {val version} {
- switch -exact -- $version {
- 0 {
- # Old-style encoding.
- if {[regsub -all -- {!%} $val = newval]} {
- return $newval
- }
- }
-
- 1 {
- # Version 1 uses URL encoding.
- regsub -all -- "%(..)" $val \
- {[format %c 0x\1]} newval
- return [subst -nobackslashes -novariables $newval]
- }
-
- default {
- error "Unknown encoding version $version"
- }
- }
-
- return $val
-}
-
-# ------------------------------------------------------------------
-# PROC: pref_set_defaults - set up default values
-# ------------------------------------------------------------------
-proc pref_set_defaults {} {
- global GDBTK_LIBRARY tcl_platform gdb_ImageDir
- debug
-
- # Gdb global defaults
- pref define gdb/ImageDir images2
- set gdb_ImageDir [file join $GDBTK_LIBRARY [pref get gdb/ImageDir]]
- pref define gdb/font_cache ""
- pref define gdb/mode 0; # 0 no tracing, 1 tracing enabled
- pref define gdb/control_target 1; # 0 can't control target (EMC), 1 can
- pref define gdb/B1_behavior 1; # 0 means set/clear breakpoints,
- # 1 means set/clear tracepoints.
- pref define gdb/use_icons 1; # For Unix, use gdbtk_icon.gif as an icon
- # some window managers can't deal with it.
-
- # OS compatibility. Valid values are "Windows", "GNOME", "KDE", and "default"
- if {$tcl_platform(platform) == "windows"} {
- pref define gdb/compat "Windows"
- } elseif {$tcl_platform(platform) == "unix"} {
- pref define gdb/compat "GNOME"
- } else {
- pref define gdb/compat "default"
- }
-
- # set download and execution options
- pref define gdb/load/verbose 0
- pref define gdb/load/main 1
- pref define gdb/load/exit 1
- pref define gdb/load/check 0
- pref define gdb/load/bp_at_func 0
- pref define gdb/load/bp_func ""
- pref define gdb/load/baud 38400
- if {$tcl_platform(platform) == "windows"} {
- pref define gdb/load/port com1
- } else {
- pref define gdb/load/port "/dev/ttyS0"
- }
-
- # The list of active windows:
- pref define gdb/window/active {}
-
- # Console defaults
- pref define gdb/console/prompt "(gdb) "
- pref define gdb/console/deleteLeft 1
- pref define gdb/console/wrap 0
- pref define gdb/console/prompt_fg DarkGreen
- pref define gdb/console/error_fg red
- pref define gdb/console/log_fg green
- pref define gdb/console/target_fg blue
- pref define gdb/console/font global/fixed
-
- # Source window defaults
- pref define gdb/src/PC_TAG green
- pref define gdb/src/STACK_TAG gold
- pref define gdb/src/BROWSE_TAG \#9595e2
- pref define gdb/src/handlebg red
- pref define gdb/src/bp_fg red
- pref define gdb/src/temp_bp_fg orange
- pref define gdb/src/disabled_fg black
- pref define gdb/src/font global/fixed
- pref define gdb/src/break_fg black
- pref define gdb/src/source2_fg navy
- pref define gdb/src/variableBalloons 1
- pref define gdb/src/trace_fg magenta
- pref define gdb/src/tab_size 8
- pref define gdb/src/linenums 1
- pref define gdb/src/thread_fg pink
- pref define gdb/src/top_control 1; # 1 srctextwin controls on top, 0 bottom
-
- # Define the run button's functions. These are defined here in case
- # we do a "run" with an exec target (which never causes target.tcl to
- # source)...
- pref define gdb/src/run_attach 0
- pref define gdb/src/run_load 0
- pref define gdb/src/run_run 1
- pref define gdb/src/run_cont 0
-
- # This is the disassembly flavor. For now this is only supported on x86
- # machines.
-
- pref define gdb/src/disassembly-flavor ""
-
- # Variable Window defaults
- pref define gdb/variable/font global/fixed
- pref define gdb/variable/disabled_fg gray
-
- # Stack Window
- pref define gdb/stack/font global/fixed
-
- # Register Window
- pref define gdb/reg/rows 16
-
- # Global Prefs Dialogs
- pref define gdb/global_prefs/save_fg red
- pref define gdb/global_prefs/message_fg white
- pref define gdb/global_prefs/message_bg red
-
- # Browser Window Search
- pref define gdb/search/last_symbol ""
- pref define gdb/search/filter_mode "starts with"
-
- pref define gdb/browser/hide_h 0
- pref define gdb/browser/layout 2
-
- # BP (breakpoint)
- pref define gdb/bp/show_threads 0
-
- # Help
- pref define gdb/help/browsername ""
-
- # Kernel Objects (kod)
- pref define gdb/kod/show_icon 0
-
- # Various possible "main" functions. What's for Java?
- pref define gdb/main_names [list main MAIN___ MAIN__ cyg_user_start cyg_start ]
-
- # These are the classes of warning dialogs, and whether the user plans
- # to ignore them.
- pref define gdb/warnings/signal 0
-
- # Memory window.
- pref define gdb/mem/size 4
- pref define gdb/mem/numbytes 0
- pref define gdb/mem/format x
- pref define gdb/mem/ascii 1
- pref define gdb/mem/ascii_char .
- pref define gdb/mem/bytes_per_row 16
- pref define gdb/mem/color green
-
- # External editor.
- pref define gdb/editor ""
-}
-
-proc pref_set_colors {home} {
- # set color palette
-
- # In the past, tk widgets got their color information from Windows or
- # the X resource database. Unfortunately Insight is a mixture of widgets
- # from all over and was coded first in tcl and later in itcl. So lots of
- # color inheritance is broken or wrong. And Insight has some special color
- # requirements. We also have to deal with new Unix desktops that don't use the Xrdb.
- # To enable us to fix that without hardcoding colors, we create a color
- # array here and use it as needed to force widgets to the correct colors.
-
- global Colors tcl_platform
- debug
-
- # UNIX colors
-
- # For KDE3 (and probably earlier versions) when the user sets
- # a color scheme from the KDE control center, the appropriate color
- # information is set in the X resource database. Well, most of it
- # is there but it is missing some settings, so we will carefully
- # adjust things.
- #
- # For GNOME, we read .gtkrc or .gtkrc-1.2-gnome2 and parse it
- # for the color information. We cannot really get this right,
- # but with luck we can read enough to get the colors to mostly match.
-
- # If there is no information, we provide reasonable defaults.
-
- # If some theme sets the text foreground and background to something unusual
- # then Insight won't be able to display sources and highlight things properly.
- # Therefore we will not change the textfg and textbg.
-
- switch [pref get gdb/compat] {
-
- "Windows" {
- debug "loading OS colors for Windows"
- set Colors(fg) SystemButtonText
- set Colors(bg) SystemButtonFace
- #set Colors(textfg) SystemWindowText
- #set Colors(textbg) SystemWindow
- set Colors(textfg) black
- set Colors(textbg) white
- set Colors(sfg) SystemHighlightText
- set Colors(sbg) SystemHighlight
- pref_set_option_db 0
- }
-
- "KDE" {
- debug "loading OS colors for KDE"
-
- pref_load_default
- # try loading "~/.gtkrc-kde"
- if {[pref_load_gnome $home [list .gtkrc-kde]]} {
- debug "loaded gnome file"
- pref_set_option_db 0
- debug "loaded option file"
- } else {
- # no .gtkrc-kde so assume X defaults have been set
-
- # create an empty entry widget so we can query its colors
- entry .e
-
- # text background
- # set Colors(textbg) [option get .e background {}]
- set Colors(textbg) white
-
- # text foreground
- #set Colors(textfg) [option get .e foreground {}]
- set Colors(textfg) black
-
- # background
- set Colors(bg) [option get . background {}]
- if {$Colors(bg) == ""} {set Colors(bg) lightgray}
-
- # foreground
- set Colors(fg) [option get . foreground {}]
- if {$Colors(fg) == ""} {set Colors(fg) black}
-
- # selectBackground
- set Colors(sbg) [option get .e selectBackground {}]
- if {$Colors(sbg) == ""} {set Colors(sbg) blue}
-
- # selectForeground
- set Colors(sfg) [option get .e selectForeground {}]
- if {$Colors(sfg) == ""} {set Colors(sfg) white}
-
- destroy .e
- pref_set_option_db 1
- }
- }
-
- "GNOME" {
- pref_load_default
- pref_load_gnome $home
- pref_set_option_db 0
- }
-
- "default" {
- pref_load_default
- pref_set_option_db 1
- }
- }
-}
-
-proc pref_load_default {} {
- global Colors
- debug "loading default colors"
-
- set Colors(textbg) white
- set Colors(textfg) black
- set Colors(bg) lightgray
- set Colors(fg) black
-
- # selectBackground
- set Colors(sbg) blue
-
- # selectForeground
- set Colors(sfg) white
-}
-
-
-# load GNOME colors and fonts, if possible.
-proc pref_load_gnome {home {possible_names {}}} {
- debug "loading OS colors for GNOME"
-
- if {$possible_names == ""} {
- set possible_names {.gtkrc .gtkrc-1.2-gnome2}
- }
-
- set found 0
- foreach name $possible_names {
- debug "home=$home name=$name"
- set fname [file join $home $name]
- debug "fname=$fname"
- if {[file exists $fname]} {
- if {[catch {open $fname r} fd]} {
- dbug W "cannot open $fname: $fd"
- return 0
- }
- set found 1
- break
- }
- }
- if {$found} {
- set found [load_gnome_file $fd]
- close $fd
- }
- return $found
-}
-
-proc load_gnome_file {fd} {
- global Colors
- set found 0
-
- while {[gets $fd line] >= 0} {
- if {[regexp {include \"([^\"]*)} $line foo incname]} {
- debug "include $incname $found"
- if {$found == 0 && [file exists $incname]} {
- if {[catch {open $incname r} fd2]} {
- dbug W "cannot open $incname: $fd2"
- } else {
- set found [load_gnome_file $fd2]
- close $fd2
- if {$found} {
- return $found
- }
- }
- }
- continue
- } elseif {[regexp "\[ \t\n\]*\(.+\) = \(.+\)" $line a name val] == 0} {
- continue
- }
-
- if {[regexp "\"#......\"" $val a] == 1} {
- set val [lindex $a 0]
- } else {
- set res [scan $val "\{ %f, %f, %f \}" r g b]
- if {$res != 3} {
- continue
- }
- set r [expr int($r*255)]
- set g [expr int($g*255)]
- set b [expr int($b*255)]
- set val [format "\#%02x%02x%02x" $r $g $b]
- }
-
- debug "name=\"$name\" val=\"$val\""
-
- # This is a bit of a hack and probably only
- # works for trivial cases. Scan for colors and
- # use the first one found.
- switch [string trimright $name] {
- {bg[NORMAL]} {
- set found 1
- if {![info exists new(bg)]} {
- debug "setting bg to $val"
- set new(bg) $val
- }
- }
- {base[NORMAL]} {
- #if {![info exists new(textbg)]} {
- # set new(textbg) $val
- #}
- }
- {text[NORMAL]} {
- #if {![info exists new(textfg)]} {
- # set new(textfg) $val
- #}
- }
- {fg[NORMAL]} {
- if {![info exists new(fg)]} {
- set new(fg) $val
- }
- }
- {fg[ACTIVE]} {
- if {![info exists new(afg)]} {
- set new(afg) $val
- }
- }
- {bg[SELECTED]} {
- if {![info exists new(sbg)]} {
- set new(sbg) $val
- }
- }
- {base[SELECTED]} {
- if {![info exists new(sbg)]} {
- set new(sbg) $val
- }
- }
- {fg[SELECTED]} {
- if {![info exists new(sfg)]} {
- set new(sfg) $val
- }
- }
- {fg[INSENSITIVE]} {
- if {![info exists new(dfg)]} {
- set new(dfg) $val
- }
- }
- {bg[PRELIGHT]} {
- set Colors(prelight) $val
- }
- {base[PRELIGHT]} {
- set Colors(prelight) $val
- }
- }
- }
-
- foreach c {fg bg sfg sbg dfg} {
- if {[info exists new($c)]} {
- set Colors($c) $new($c)
- }
- }
- return 1
-}
-
-
-# load the colors into the tcl option database
-proc pref_set_option_db {makebg} {
- global Colors
-
- # The color of text that indicates changed items
- # We standardize on one color here so that changed
- # items don't blend into any OS color scheme
- set Colors(change) "green"
-
- option add *background $Colors(bg)
- option add *Text*background $Colors(textbg)
- option add *Entry*background $Colors(textbg)
- option add *foreground $Colors(fg)
- option add *Text*foreground $Colors(textfg)
- option add *Entry*foreground $Colors(textfg)
-
- option add *highlightBackground $Colors(bg)
- option add *selectBackground $Colors(sbg)
-
- if {$::tcl_platform(platform) == "unix"} {
- option add *activeBackground $Colors(sbg)
- }
-
- option add *selectForeground $Colors(sfg)
- option add *Menu*activeForeground $Colors(sfg)
-
- if {[info exists Colors(prelight)]} {
- option add *Button*activeBackground $Colors(prelight)
- }
- if {[info exists Colors(dfg)]} {
- option add *disabledForeground $Colors(dfg)
- }
-
- if {$makebg} {
- # compute a slightly darker background color
- # and use for activeBackground and troughColor
- set bg2 [winfo rgb . $Colors(bg)]
- set dbg [format #%02x%02x%02x [expr {(9*[lindex $bg2 0])/2560}] \
- [expr {(9*[lindex $bg2 1])/2560}] [expr {(9*[lindex $bg2 2])/2560}]]
- option add *activeBackground $dbg
- option add *troughColor $dbg
- }
-
- # Change the default select color for checkbuttons, etc to match
- # selectBackground.
- if {$::tcl_platform(platform) == "unix"} {
- option add *selectColor $Colors(sbg)
- }
-}
View Lorry Controller Status