OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [gdb/] [gdbtcl/] [prefs.tcl] - Blame information for rev 1767

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
# Local preferences functions for GDBtk.
2
# Copyright 1997, 1998, 1999 Cygnus Solutions
3
#
4
# This program is free software; you can redistribute it and/or modify it
5
# under the terms of the GNU General Public License (GPL) as published by
6
# the Free Software Foundation; either version 2 of the License, or (at
7
# your option) any later version.
8
#
9
# This program is distributed in the hope that it will be useful,
10
# but WITHOUT ANY WARRANTY; without even the implied warranty of
11
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12
# GNU General Public License for more details.
13
 
14
 
15
# On STARTUP:
16
# 1. Options database (.Xdefaults on Unix  or ? on Windows) is read
17
# 2. GDB prefs file is read ("gdbtk.ini" on Windows; ".gdbtkinit" on Unix)
18
# 3. GDB init script is read
19
#
20
# Normally all preferences will be set in the prefs file, which is
21
# a generated file.  Hand-editing, if necessary, should be done to the
22
# GDB init script.
23
#
24
# when "save options" is selected, the contents of the
25
# preferences array is written out to the GDB prefs file.
26
#
27
# Usage:
28
#   pref_save
29
#   pref_read
30
# ----------------------------------------------------------------------
31
#
32
 
33
proc pref_read {} {
34
  global prefs_init_filename env gdb_ImageDir GDBTK_LIBRARY GDBStartup
35
  global tcl_platform
36
 
37
  if {[info exists env(HOME)]} {
38
    if {$tcl_platform(platform) == "windows"} {
39
      set home [ide_cygwin_path to_win32 $env(HOME)]
40
    } else {
41
      set home $env(HOME)
42
    }
43
  } else {
44
    set home ""
45
  }
46
 
47
  if {$tcl_platform(platform) == "windows"} {
48
    set prefs_init_filename "gdbtk.ini"
49
  } else {
50
    set prefs_init_filename ".gdbtkinit"
51
  }
52
 
53
  if {!$GDBStartup(inhibit_prefs)} {
54
    set file_opened 0
55
    if {[file exists $prefs_init_filename]} {
56
      if {[catch {open $prefs_init_filename r} fd]} {
57
        debug "$fd"
58
        return
59
      }
60
      set file_opened 1
61
    } elseif {$home != ""} {
62
      set name [file join $home $prefs_init_filename]
63
      if {[file exists $name]} {
64
        if {[catch {open $name r} fd]} {
65
          debug "$fd"
66
          return
67
        }
68
        set prefs_init_filename $name
69
        set file_opened 1
70
      }
71
    }
72
 
73
    if {$file_opened == "1"} {
74
      set section gdb
75
      set version 0
76
      while {[gets $fd line] >= 0} {
77
        switch -regexp -- $line {
78
          {^[ \t\n]*#.*} {
79
            # Comment.  We recognize one magic comment that includes
80
            # the version number.
81
            if {[regexp -- "^GDBtkInitVersion: (\[0-9\]+)\$" $line v]} {
82
              set version $v
83
            }
84
          }
85
 
86
          {^[ \t\n]*$} {
87
            ;# empty line; ignore it
88
          }
89
 
90
          {\[.*\]} {
91
            regexp {\[(.*)\]} $line match section
92
          }
93
 
94
          {[ \t\n]*option.*} {
95
            set line [string trimleft $line]
96
            eval $line
97
          }
98
 
99
          default {
100
            regexp "\[ \t\n\]*\(.+\)=\(.+\)" $line a name val
101
            # Must unescape equal signs in val
102
            set val [unescape_value $val $version]
103
            if {$section == "gdb"} {
104
              pref setd gdb/$name $val
105
            } elseif {$section == "global" && [regexp "^font/" $name]} {
106
              set name [split $name /]
107
              set f global/
108
              append f [join [lrange $name 1 end] /]
109
              if {[lsearch [font names] $f] == -1} {
110
                # new font
111
                eval define_font $f $val
112
              } else {
113
                # existing font
114
                pref set global/font/[join [lrange $name 1 end] /] $val
115
              }
116
            } elseif {$section == "global"} {
117
              pref setd $section/$name $val
118
            } else {
119
              pref setd gdb/$section/$name $val
120
            }
121
          }
122
        }
123
      }
124
      close $fd
125
    } elseif {$home != ""} {
126
      set prefs_init_filename [file join $home $prefs_init_filename]
127
    }
128
 
129
    # now set global options
130
    set gdb_ImageDir [file join $GDBTK_LIBRARY [pref get gdb/ImageDir]]
131
  }
132
}
133
 
134
# ------------------------------------------------------------------
135
#  PROC:  pref_save - save preferences to a file and delete window
136
# ------------------------------------------------------------------
137
proc pref_save {{win {}}} {
138
  global prefs_init_filename GDBStartup
139
 
140
  if {!$GDBStartup(inhibit_prefs)} {
141
    debug "pref_save $prefs_init_filename"
142
 
143
    if {[catch {open $prefs_init_filename w} fd]} {
144
      debug "ERROR: $fd"
145
      return
146
    }
147
 
148
    puts $fd "\# GDBtk Init file"
149
    puts $fd {# GDBtkInitVersion: 1}
150
 
151
    set plist [pref list]
152
    # write out global options
153
    puts $fd "\[global\]"
154
    foreach var $plist {
155
      set t [split $var /]
156
      if {[lindex $t 0] == "global"} {
157
        set x [join [lrange $t 1 end] /]
158
        set v [escape_value [pref get $var]]
159
 
160
        if {$x != "" && $v != ""} {
161
          puts $fd "\t$x=$v"
162
        }
163
      }
164
    }
165
 
166
    # write out gdb-global options
167
    puts $fd "\[gdb\]"
168
    foreach var $plist {
169
      set t [split $var /]
170
      # We use the funny join/lreplace code because the session code
171
      # can generate a key where [lindex $t 2] is empty but there is
172
      # still stuff after that.  This happens because the session code
173
      # uses filenames, which can start with `/'.
174
      if {[lindex $t 0] == "gdb"
175
          && [string compare [join [lreplace $t 0 1] /] ""] == 0} {
176
        set x [lindex $t 1]
177
        if {$x != ""} {
178
          set v [escape_value [pref get $var]]
179
          puts $fd "\t$x=$v"
180
        }
181
      }
182
    }
183
 
184
    # now loop through all sections writing out values
185
    # FIXME: this is broken.  We should discover the list
186
    # dynamically.
187
    lappend secs load console src reg stack locals watch bp search \
188
      process geometry help browser kod window session mem
189
 
190
    foreach section $secs {
191
      puts $fd "\[$section\]"
192
      foreach var $plist {
193
        set t [split $var /]
194
        if {[lindex $t 0] == "gdb" && [lindex $t 1] == $section} {
195
          set x [join [lrange $t 2 end] /]
196
          set v [escape_value [pref get $var]]
197
          if {$x != "" && $v != ""} {
198
            puts $fd "\t$x=$v"
199
          }
200
        }
201
      }
202
    }
203
    close $fd
204
  }
205
 
206
  if {$win != ""} {
207
    $win delete
208
  }
209
}
210
 
211
# -------------------------------------------------------
212
#  PROC: escape_value - escape all equal signs for saving
213
#         prefs to a file
214
# -------------------------------------------------------
215
proc escape_value {val} {
216
  # We use a URL-style quoting.  We encode `=', `%', the `[]'
217
  # characters and newlines.  We use a cute trick here: we regsub in
218
  # command expressions which we then expand using subst.
219
  regsub -all -- "(\[\]\[=%\n\])" $val \
220
    {[format "%%%02x" [scan {\1} %c x; set x]]} newval
221
  return [subst -nobackslashes -novariables $newval]
222
}
223
 
224
# -------------------------------------------------------
225
#  PROC: unescape_value - unescape all equal signs for
226
#         reading prefs from a file.  VERSION is the version
227
#         number of the encoding.
228
#  version 0 only encoded `='.
229
#  version 1 correctly encoded more values
230
# -------------------------------------------------------
231
proc unescape_value {val version} {
232
  switch -exact -- $version {
233
 
234
      # Old-style encoding.
235
      if {[regsub -all -- {!%} $val = newval]} {
236
        return $newval
237
      }
238
    }
239
 
240
    1 {
241
      # Version 1 uses URL encoding.
242
      regsub -all -- "%(..)" $val \
243
        {[format %c 0x\1]} newval
244
      return [subst -nobackslashes -novariables $newval]
245
    }
246
 
247
    default {
248
      error "Unknown encoding version $version"
249
    }
250
  }
251
 
252
  return $val
253
}
254
 
255
# ------------------------------------------------------------------
256
#  PROC:  pref_set_defaults - set up default values
257
# ------------------------------------------------------------------
258
proc pref_set_defaults {} {
259
  global GDBTK_LIBRARY tcl_platform gdb_ImageDir
260
 
261
  # Gdb global defaults
262
  pref define gdb/ImageDir                images2
263
  set gdb_ImageDir [file join $GDBTK_LIBRARY [pref get gdb/ImageDir]]
264
  pref define gdb/font_cache              ""
265
  pref define gdb/mode                    0;     # 0 no tracing, 1 tracing enabled
266
  pref define gdb/control_target          1;     # 0 can't control target (EMC), 1 can
267
  pref define gdb/B1_behavior             1;     # 0 means set/clear breakpoints,
268
                                                 # 1 means set/clear tracepoints.
269
  pref define gdb/use_icons               1;     # For Unix, use gdbtk_icon.gif as an icon
270
                                                 # some window managers can't deal with it.
271
 
272
  # set download and execution options
273
  pref define gdb/load/verbose 0
274
  pref define gdb/load/main 1
275
  pref define gdb/load/exit 1
276
  pref define gdb/load/check 0
277
  pref define gdb/load/bp_at_func 0
278
  pref define gdb/load/bp_func ""
279
  pref define gdb/load/baud 38400
280
  if {$tcl_platform(platform) == "windows"}  {
281
    pref define gdb/load/port com1
282
  } else {
283
    pref define gdb/load/port "/dev/ttyS0"
284
  }
285
 
286
  # The list of active windows:
287
  pref define gdb/window/active           {}
288
 
289
  # Console defaults
290
  pref define gdb/console/prompt          "(gdb) "
291
  pref define gdb/console/deleteLeft      1
292
  pref define gdb/console/wrap            0
293
  pref define gdb/console/prompt_fg       DarkGreen
294
  pref define gdb/console/error_fg        red
295
  pref define gdb/console/log_fg          green
296
  pref define gdb/console/target_fg       blue
297
  pref define gdb/console/font            src-font
298
 
299
  # Source window defaults
300
  pref define gdb/src/PC_TAG              green
301
  pref define gdb/src/STACK_TAG           gold
302
  pref define gdb/src/BROWSE_TAG          \#9595e2
303
  pref define gdb/src/handlebg            red
304
  pref define gdb/src/bp_fg               red
305
  pref define gdb/src/temp_bp_fg          orange
306
  pref define gdb/src/disabled_fg         black
307
  pref define gdb/src/font                src-font
308
  pref define gdb/src/break_fg            black
309
  pref define gdb/src/source2_fg          navy
310
  pref define gdb/src/variableBalloons    1
311
  pref define gdb/src/trace_fg            magenta
312
  pref define gdb/src/tab_size            8
313
  pref define gdb/src/linenums            1
314
  pref define gdb/src/thread_fg           pink
315
  pref define gdb/src/top_control         1;    # 1 srctextwin controls on top, 0 bottom
316
 
317
  # Define the run button's functions. These are defined here in case
318
  # we do a "run" with an exec target (which never causes target.tcl to 
319
  # source)...
320
  pref define gdb/src/run_attach          0
321
  pref define gdb/src/run_load            0
322
  pref define gdb/src/run_run             1
323
  pref define gdb/src/run_cont            0
324
 
325
  # This is the disassembly flavor.  For now this is only supported on x86
326
  # machines.
327
 
328
  pref define gdb/src/disassembly-flavor  ""
329
 
330
  # set up src-font
331
  set val [pref get global/font/fixed]
332
  eval font create src-font $val
333
 
334
  # Trace the global/font/fixed preference
335
  pref add_hook global/font/fixed pref_src-font_trace
336
 
337
  # Variable Window defaults
338
  pref define gdb/variable/font           src-font
339
  pref define gdb/variable/highlight_fg   blue
340
  pref define gdb/variable/disabled_fg    gray
341
 
342
  # Stack Window
343
  pref define gdb/stack/font              src-font
344
 
345
  # Register Window
346
  pref define gdb/reg/highlight_fg        blue
347
  pref define gdb/reg/rows                16
348
 
349
  # Global Prefs Dialogs
350
  pref define gdb/global_prefs/save_fg    red
351
  pref define gdb/global_prefs/message_fg white
352
  pref define gdb/global_prefs/message_bg red
353
 
354
  # Browser Window Search
355
  pref define gdb/search/last_symbol      ""
356
  pref define gdb/search/filter_mode     "starts with"
357
 
358
  pref define gdb/browser/hide_h          0
359
  pref define gdb/browser/width           0
360
  pref define gdb/browser/top_height       0
361
  pref define gdb/browser/view_height      -1
362
  pref define gdb/browser/view_is_open    0
363
 
364
  # BP (breakpoint)
365
  pref define gdb/bp/show_threads         0
366
 
367
  # Help
368
  pref define gdb/help/browser            0
369
 
370
  # Kernel Objects (kod)
371
  pref define gdb/kod/show_icon           0
372
 
373
  # Various possible "main" functions. What's for Java?
374
  pref define gdb/main_names              [list MAIN___ MAIN__ main]
375
 
376
  # These are the classes of warning dialogs, and whether the user plans
377
  # to ignore them.
378
  pref define gdb/warnings/signal         0
379
 
380
  # Memory window.
381
  pref define gdb/mem/size 4
382
  pref define gdb/mem/numbytes 0
383
  pref define gdb/mem/format x
384
  pref define gdb/mem/ascii 1
385
  pref define gdb/mem/ascii_char .
386
  pref define gdb/mem/bytes_per_row 16
387
  pref define gdb/mem/color green
388
}
389
 
390
# This traces the global/fixed font and forces src-font to
391
# to be the same.
392
proc pref_src-font_trace {varname val} {
393
  eval font configure src-font $val
394
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.