home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / prefsHandling.tcl < prev    next >
Encoding:
Text File  |  1997-12-03  |  8.5 KB  |  367 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "prefsHandling.tcl"
  6.  #                                    created: 24/2/95 {9:52:30 pm} 
  7.  #                                last update: 1/12/97 {10:02:47 am} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Reorganisation carried out by Vince Darley with much help from Tom 
  15.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  16.  # Alpha is shareware; please register with the author using the register 
  17.  # button in the about box.
  18.  #  
  19.  #  Description: 
  20.  # 
  21.  # Procedures for dealing with the user's preferences
  22.  # ###################################################################
  23.  ##
  24.  
  25. namespace eval mode {}
  26. namespace eval global {}
  27.  
  28. proc addArrDef {arr def val} {
  29.     addDef [list $arr $def] $val arr
  30. }
  31.  
  32. proc removeArrDef {arr def} {
  33.     removeDef [list $arr $def] arr
  34. }
  35.  
  36. proc addDef {def val {prefix {}}} {
  37.     global ${prefix}prefDefs
  38.     
  39.     readDefs $prefix
  40.     set ${prefix}prefDefs($def) $val
  41.     writeDefs $prefix
  42.     catch {unset ${prefix}prefDefs}
  43. }
  44.  
  45. proc removeDef {def {prefix {}}} {
  46.     global ${prefix}prefDefs
  47.     
  48.     readDefs $prefix
  49.     catch {unset ${prefix}prefDefs($def)}
  50.     writeDefs $prefix
  51.     catch {unset ${prefix}prefDefs}
  52. }
  53.  
  54. ##
  55.  # -------------------------------------------------------------------------
  56.  #
  57.  # "removeArr" --
  58.  #
  59.  #  Remove all elements of $arr from arrdefs.tcl
  60.  # -------------------------------------------------------------------------
  61.  ##
  62. proc removeArr {arr} {
  63.     global arrprefDefs $arr
  64.     
  65.     readDefs arr
  66.     foreach def [array names $arr] {
  67.         catch {unset arrprefDefs([list $arr $def])}
  68.     }
  69.     writeDefs arr
  70.     catch {unset arrprefDefs}
  71. }
  72.  
  73. proc addArr {arr} {
  74.     global arrprefDefs $arr
  75.     
  76.     readDefs arr
  77.     foreach def [array names $arr] {
  78.         catch {set arrprefDefs([list $arr $def]) [set ${arr}($def)]}
  79.     }
  80.     writeDefs arr
  81.     catch {unset arrprefDefs}
  82. }
  83.  
  84. proc readDefs {{prefix {}}} {
  85.     global PREFS
  86.     if {![file exists "$PREFS:${prefix}defs.tcl"]} return
  87.     uplevel \#0 [list source "$PREFS:${prefix}defs.tcl"]
  88. }
  89.  
  90. proc writeDefs {{prefix {}}} {
  91.     global HOME PREFS ${prefix}prefDefs 
  92.     
  93.     if {![info exists ${prefix}prefDefs]} {
  94.         catch {removeFile "$PREFS:${prefix}defs.tcl"}
  95.         return
  96.     }
  97.     
  98.     if {![file exists "$PREFS"]} {
  99.         mkdir "$PREFS"
  100.     }
  101.     set fd [open "$PREFS:${prefix}defs.tcl" "w"]
  102.     foreach nm [array names ${prefix}prefDefs] {
  103.         puts $fd [list set ${prefix}prefDefs($nm) [set ${prefix}prefDefs($nm)]]
  104.     }
  105.     close $fd
  106. }
  107.  
  108.  
  109. proc alpha::readUserDefs {} {
  110.     namespace eval :: {
  111.     global prefDefs arrprefDefs PREFS
  112.     
  113.     if {[file exists "$PREFS:defs.tcl"]} {
  114.         source "$PREFS:defs.tcl"
  115.         
  116.         foreach nm [array names prefDefs] {
  117.                 global $nm
  118.                 if [catch {set $nm $prefDefs($nm)}] {
  119.                     set ns ""
  120.                     while {[regexp "^($ns\[a-zA-Z_\]+::)" $nm ns]} {
  121.                         namespace eval $ns {}
  122.                     }
  123.                     set $nm $prefDefs($nm)
  124.                 }
  125.             
  126.         }
  127.         catch {unset prefDefs}
  128.     }
  129.     
  130.     if {[file exists "$PREFS:arrdefs.tcl"]} {
  131.         source "$PREFS:arrdefs.tcl"
  132.         
  133.         foreach nm [array names arrprefDefs] {
  134.             set arr [lindex $nm 0]
  135.             set field [lindex $nm 1]
  136.             set val $arrprefDefs($nm)
  137.                 global $arr
  138.                 set ${arr}($field) $val
  139.                 if [catch {set ${arr}($field) $val}] {
  140.                     set ns ""
  141.                     while {[regexp "^($ns\[a-zA-Z_\]+::)" $arr ns]} {
  142.                         namespace eval $ns {}
  143.                     }
  144.                     set ${arr}($field) $val
  145.                 }
  146.         }
  147.         catch {unset arrprefDefs}
  148.     }
  149. }
  150.  
  151. }
  152.  
  153. proc alpha::readUserPrefs {} {
  154.     global PREFS
  155.     # Use "prefs.tcl" to define or change any tcl information. 
  156.     if {![file exists "$PREFS:prefs.tcl"]} {
  157.         if {![file exists "$PREFS"]} {
  158.             mkdir "$PREFS"
  159.         }
  160.         set fd [open "$PREFS:prefs.tcl" "w"]
  161.         close $fd
  162.     }
  163.     uplevel #0 {
  164.         if {[catch {source "$PREFS:prefs.tcl"}]} {
  165.             if {[dialog::yesno "An error occurred while loading \"prefs.tcl\".  Shall I make a trace on the error?"]} {
  166.                 dumpTraces "prefs.tcl error" $errorInfo
  167.             }
  168.         }
  169.     }
  170. }
  171.  
  172.     
  173. proc viewSavedSetting {} {
  174.     global prefDefs arrprefDefs
  175.  
  176.     saveModifiedVars
  177.     
  178.     set res [listpick -p "The following settings have been saved:" [getSavedSettings]]
  179.  
  180.     if {[regexp {([^(]+)\(([^)]+)\)} $res dummy arr field]} {
  181.         set arg [list $arr $field]
  182.         set val $arrprefDefs($arg)
  183.     } else {
  184.         global $res
  185.         set val $prefDefs($res)
  186.     }    
  187.     viewValue $res $val
  188.     unset prefDefs arrprefDefs
  189. }
  190.  
  191. proc viewValue {name val} {
  192.     if {[string length $val] > 80} {
  193.         if {([llength $val] > 3) && ([llength $val] > 6 || [string length $val] > 160)} {
  194.             listpick -p "'$name's value is:" $val
  195.         } else {        
  196.             global tileLeft tileTop tileWidth
  197.             regsub -all : $name . name1
  198.             new -g $tileLeft $tileTop $tileWidth 100 -n "* $name1 *" -m Text
  199.             insertText "'$name's value is:\r\r$val\r"
  200.             winReadOnly
  201.         }
  202.     } else {
  203.         alertnote "'$name's value is:\r\r$val\r"
  204.     }
  205. }
  206.  
  207. ## 
  208.  # -------------------------------------------------------------------------
  209.  # 
  210.  # "removeSavedSetting" --
  211.  # 
  212.  #  This proc shouldn't 'unset' the variables it removes, because most
  213.  #  such variables will be in use/have default values until restart.
  214.  # -------------------------------------------------------------------------
  215.  ##
  216. proc removeSavedSetting {} {
  217.     global prefDefs arrprefDefs
  218.     
  219.     saveModifiedVars
  220.     set res [listpick -p "Remove which setting?" [lsort -ignore [getSavedSettings]]]
  221.  
  222.     if {$res == ""} return
  223.     if {[regexp {([^(]+)\(([^)]+)\)} $res dummy arr field]} {
  224.         global $arr
  225.         removeArrDef $arr $field
  226.     } else {
  227.         global $res
  228.         removeDef $res
  229.     }
  230.  
  231.     unset prefDefs arrprefDefs
  232. }
  233.  
  234.  
  235. proc getSavedSettings {} {
  236.     global prefDefs arrprefDefs
  237.     
  238.     readDefs
  239.     readDefs arr
  240.     
  241.     set names [array names prefDefs]
  242.     foreach pair [array names arrprefDefs] {
  243.         lappend names "[lindex $pair 0]([lindex $pair 1])"
  244.     }
  245.     
  246.     return [lsort $names]
  247. }
  248.  
  249. #===============================================================================
  250.  
  251. proc global::editPrefsFile {} {
  252.     global PREFS
  253.     if {![file exists "$PREFS:prefs.tcl"]} {
  254.         set fd [open "$PREFS:prefs.tcl" "w"]
  255.         close $fd
  256.     }
  257.     edit "$PREFS:prefs.tcl"
  258. }
  259.  
  260. # Automatically add a line to the user input file
  261. proc addUserLine {line} {
  262.     global PREFS
  263.  
  264.     if {![file exists "$PREFS"]} {
  265.         mkdir "$PREFS"
  266.     }
  267.     set fid [open "$PREFS:prefs.tcl" "a+"]
  268.     if {![catch {seek $fid -1 end}]} {
  269.         if {[read $fid 1] == "\r"} {
  270.             set line "\r$line"
  271.         }
  272.     }
  273.     seek $fid 0 end
  274.     puts $fid $line
  275.     close $fid
  276. }
  277.  
  278.  
  279.  
  280. #===============================================================================
  281.  
  282. ## 
  283.  # -------------------------------------------------------------------------
  284.  # 
  285.  # "mode::sourcePrefs" --
  286.  # 
  287.  #  Fixes 'uplevel #0' problem
  288.  # -------------------------------------------------------------------------
  289.  ##
  290. proc mode::sourcePrefsFile {} { 
  291.     global mode PREFS
  292.     if {[file exists "${PREFS}:${mode}Prefs.tcl"]} {
  293.         uplevel #0 [list source "${PREFS}:${mode}Prefs.tcl"]
  294.     } else {
  295.         beep; message "Sorry, no preferences for '$mode' mode"
  296.     }
  297. }
  298.  
  299. proc mode::editPrefsFile {{m ""}} { 
  300.     global PREFS mode
  301.     if {$m == ""} { set m $mode }
  302.     message $m
  303.     # assume it is a mode, since we made the menu
  304.     
  305.     set f "$PREFS:${m}Prefs.tcl"
  306.     if [file exists $f] {
  307.         edit $f
  308.     } else {
  309.         if {[dialog::yesno "No '$m' prefs file exists, do you want to create one?"]} {
  310.             set fd [open $f "w"]
  311.             close $fd
  312.             edit $f
  313.             insertText {## 
  314.  # This    file will be sourced automatically, immediately after 
  315.  # the _first_ time    the    file which defines its mode is sourced.
  316.  # Use this    file to    insert your    own    mode-specific preferences
  317.  # and changes,    rather than    altering the originals.
  318.  # 
  319.  # You can redefine    menus, procedures, variables,...
  320.  ##
  321.  
  322. }}}
  323.             
  324.     hook::callAll mode::editPrefsFile
  325. }
  326.  
  327. proc saveModifiedVars {} {
  328.     global modifiedVars modifiedModeVars modifiedArrVars \
  329.         modifiedModeMenus modeMenus prefDefs modifiedArrayElements \
  330.         package::loaded
  331.       
  332.     cache::snippetWrite activepackages ${package::loaded}
  333.     
  334.     foreach f [lunique $modifiedModeMenus] {
  335.         addArrDef modeMenus $f $modeMenus($f)
  336.     }
  337.     foreach f [lunique $modifiedArrVars] {
  338.         addArr $f
  339.     }
  340.     foreach f [lunique $modifiedVars] {
  341.         global $f
  342.         if [info exists $f] {
  343.             addDef $f [set $f]
  344.         } else {
  345.             removeDef $f
  346.         }
  347.     }
  348.     # these two lists actually behave identically
  349.     foreach f [concat [lunique $modifiedArrayElements] \
  350.       [lunique $modifiedModeVars]] {
  351.         set elt [lindex $f 0]
  352.         set arr [lindex $f 1]
  353.         global $arr
  354.         if [info exists [set arr]($elt)] {
  355.             addArrDef [set arr] $elt [set [set arr]($elt)]
  356.         } else {
  357.             removeArrDef [set arr] $elt
  358.         }
  359.     }
  360.     
  361.     set modifiedVars {}
  362.     set modifiedArrVars {}
  363.     set modifiedModeVars {}
  364.     set modifiedArrayElements {}
  365.     set modifiedModeMenus {}
  366. }
  367.