# Copyright (c) 2000, Red Hat, Inc. # # This file is part of Source-Navigator. # # Source-Navigator is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License as published # by the Free Software Foundation; either version 2, or (at your option) # any later version. # # Source-Navigator 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. # # You should have received a copy of the GNU General Public License along # with Source-Navigator; see the file COPYING. If not, write to # the Free Software Foundation, 59 Temple Place - Suite 330, Boston, # MA 02111-1307, USA. # # hooks.tcl - Hook functions. # Copyright (C) 1997 Cygnus Solutions. # Written by Tom Tromey . proc add_hook {hook command} { upvar \#0 ${hook} var lappend var ${command} } proc remove_hook {hook command} { upvar \#0 ${hook} var set var [lremove ${var} ${command}] } proc define_hook {hook} { upvar \#0 ${hook} var if {! [info exists var]} { set var {} } } proc run_hooks {hook args} { upvar \#0 ${hook} var foreach thunk ${var} { uplevel \#0 ${thunk} ${args} } } # def.tcl - Definining commands. # Copyright (C) 1997 Cygnus Solutions. # Written by Tom Tromey . # Define a global array. proc defarray {name {value {}}} { upvar \#0 ${name} ary if {! [info exists ary]} { set ary(_) {} unset ary(_) array set ary ${value} } } # Define a global variable. proc defvar {name {value {}}} { upvar \#0 ${name} var if {! [info exists var]} { set var ${value} } } # Define a "constant". For now this is just a pretty way to declare a # global variable. proc defconst {name value} { upvar \#0 ${name} var set var ${value} } # prefs.tcl - Preference handling. # Copyright (C) 1997 Cygnus Solutions. # Written by Tom Tromey . # KNOWN BUGS: # * When we move to the next tcl/itcl, rewrite to use namespaces and # possibly ensembles. set PREFS_state(ide_running) 0 # Global state. defarray PREFS_state { inhibit-event 0 initialized 0 } # This is called when a trace on some option fires. It makes sure the # relevant handlers get run. proc PREFS_run_handlers {name1 name2 op} { upvar ${name1} state set option [lindex ${name2} 0] global PREFS_state # Notify everybody else unless we've inhibited event generation. if {! $PREFS_state(inhibit-event) && $PREFS_state(ide_running)} { ide_property set preference/${option} $state([list ${option} value])\ global } # Run local handlers. run_hooks PREFS_state([list ${option} handler]) ${option} $state([list\ ${option} value]) } # This is run when we see a property event. It updates our internal # state. proc PREFS_handle_property_event {exists property value} { global PREFS_state # If it isn't a preference property, ignore it. if {! [string match preference/* ${property}]} { return } # [string length preference/] == 11. set name [string range ${property} 11 end] if {${exists}} { incr PREFS_state(inhibit-event) set PREFS_state([list ${name} value]) ${value} incr PREFS_state(inhibit-event) -1 }\ elseif {$PREFS_state(ide_running)} then else { # It doesn't make sense to remove a property that mirrors some # preference. So disallow by immediately redefining. Use # initialize and not set because several clients are likely to run # this at once. ide_property initialize preference/${name} $PREFS_state([list ${name}\ value]) global } } # pref define NAME DEFAULT # Define a new option # NAME is the option name # DEFAULT is the default value of the option proc PREFS_cmd_define {name default} { global PREFS_state # If the option has already been defined, do nothing. if {[info exists PREFS_state([list ${name} value])]} { return } if {$PREFS_state(ide_running)} { # We only store the value in the database. ide_property initialize preference/${name} ${default} global set default [ide_property get preference/${name}] } # We set our internal state no matter what. It is harmless if our # definition causes a property-set event. set PREFS_state([list ${name} value]) ${default} set PREFS_state([list ${name} handler]) {} # Set up a variable trace so that the handlers can be run. trace variable PREFS_state([list ${name} value]) w PREFS_run_handlers } # pref get NAME # Return value of option NAME proc PREFS_cmd_get {name} { global PREFS_state return $PREFS_state([list ${name} value]) } # pref getd NAME # Return value of option NAME # or define it if necessary and return "" proc PREFS_cmd_getd {name} { global PREFS_state PREFS_cmd_define ${name} "" return [pref get ${name}] } # pref varname NAME # Return name of global variable that represents option NAME # This is suitable for (eg) a -variable option on a radiobutton proc PREFS_cmd_varname {name} { return PREFS_state([list ${name} value]) } # pref set NAME VALUE # Set the option NAME to VALUE proc PREFS_cmd_set {name value} { global PREFS_state # For debugging purposes, make sure the preference has already been # defined. if {! [info exists PREFS_state([list ${name} value])]} { error "attempt to set undefined preference ${name}" } set PREFS_state([list ${name} value]) ${value} } # pref setd NAME VALUE # Set the option NAME to VALUE # or define NAME and set the default to VALUE proc PREFS_cmd_setd {name value} { global PREFS_state if {[info exists PREFS_state([list ${name} value])]} { set PREFS_state([list ${name} value]) ${value} } else { PREFS_cmd_define ${name} ${value} } } # pref add_hook NAME HOOK # Add a command to the hook that is run when the preference name NAME # changes. The command is run with the name of the changed option and # the new value as arguments. proc PREFS_cmd_add_hook {name hook} { add_hook PREFS_state([list ${name} handler]) ${hook} } # pref remove_hook NAME HOOK # Remove a command from the per-preference hook. proc PREFS_cmd_remove_hook {name hook} { remove_hook PREFS_state([list ${name} handler]) ${hook} } # pref init ?IDE_RUNNING? # Initialize the preference module. IDE_RUNNING is an optional # boolean argument. If 0, then the preference module will assume that # it is not connected to the IDE backplane. The default is based on # the global variable IDE. proc PREFS_cmd_init {{ide_running "unset"}} { global PREFS_state IDE if {! $PREFS_state(initialized)} { if {${ide_running} == "unset"} { if {[info exists IDE]} { set ide_running ${IDE} } else { set ide_running 0 } } set PREFS_state(initialized) 1 set PREFS_state(ide_running) ${ide_running} if {${ide_running}} { property add_hook "" PREFS_handle_property_event } } } # pref list # Return a list of the names of all preferences defined by this # application. proc PREFS_cmd_list {} { global PREFS_state set list {} foreach item [array names PREFS_state] { if {[lindex ${item} 1] == "value"} { lappend list [lindex ${item} 0] } } return ${list} } # The primary interface to all preference subcommands. proc pref {dispatch args} { if {[info commands PREFS_cmd_${dispatch}] == ""} { error "unrecognized key \"${dispatch}\"" } eval PREFS_cmd_${dispatch} ${args} } # font.tcl - Font handling. # Copyright (C) 1997 Cygnus Solutions. # Written by Tom Tromey . # This function is called whenever a font preference changes. We use # this information to update the appropriate symbolic font. proc FONT_track_change {symbolic prefname value} { eval font configure [list ${symbolic}] ${value} } # Primary interface to font handling. # define_font SYMBOLIC_NAME ARGS # Define a new font, named SYMBOLIC_NAME. ARGS is the default font # specification; it is a list of options such as those passed to `font # create'. proc define_font {symbolic args} { # We do a little trick with the names here, by inserting `font' in # the appropriate place in the name. set split [split ${symbolic} /] set name [join [linsert ${split} 1 font] /] pref define ${name} ${args} eval font create [list ${symbolic}] [pref get ${name}] pref add_hook ${name} [list FONT_track_change ${symbolic}] }