home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / prefsHandling.tcl < prev    next >
Encoding:
Text File  |  1999-01-16  |  9.7 KB  |  404 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: 16/1/1999 {10:20:02 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 [file join $PREFS ${prefix}defs.tcl]]} return
  87.     uplevel \#0 [list source [file join $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 {file delete [file join $PREFS ${prefix}defs.tcl]}
  95.     return
  96.     }
  97.     
  98.     if {![file exists "$PREFS"]} {
  99.     file mkdir "$PREFS"
  100.     }
  101.     set fd [open [file join $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 [file join $PREFS defs.tcl]]} {
  114.         source [file join $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 [file join $PREFS arrdefs.tcl]]} {
  131.         source [file join $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 [file join $PREFS prefs.tcl]]} {
  157.     if {![file exists "$PREFS"]} {
  158.         file mkdir "$PREFS"
  159.     }
  160.     set fd [open [file join $PREFS prefs.tcl] "w"]
  161.     close $fd
  162.     }
  163.     uplevel #0 {
  164.     if {[catch {source [file join $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.     catch {unset prefDefs}
  189.     catch {unset arrprefDefs}
  190. }
  191.  
  192. proc viewValue {name val} {
  193.     set header "'$name's value is:"
  194.     set response "\r$val\r"
  195.     if {[string length $val] > 80} {
  196.     if {([llength $val] > 3) && ([llength $val] > 6 || [string length $val] > 160)} {
  197.         listpick -p "'$name's value is:" $val
  198.     } else {
  199.         if {[tclLog $header$response]} {
  200.         global tileLeft tileTop tileWidth
  201.         if {[info tclversion] < 8.0} {
  202.             regsub -all : $name . name1
  203.             new -g $tileLeft $tileTop $tileWidth 100 -n "* $name1 *" -m Text \
  204.               -info "'$name's value is:\r\r$val\r"
  205.         } else {
  206.             new -g $tileLeft $tileTop $tileWidth 100 -n "* $name *" -m Text \
  207.               -info "'$name's value is:\r\r$val\r"
  208.         }
  209.         }
  210.     }
  211.     } else {
  212.     global mode
  213.     if {$mode == "Shel"} {
  214.         goto [maxPos]
  215.         tclLog $header$response
  216.         insertText [Alpha::Prompt]
  217.     } else {
  218.         alertnote "$header\r$response"
  219.     }
  220.     }
  221. }
  222.  
  223. ## 
  224.  # -------------------------------------------------------------------------
  225.  # 
  226.  # "removeSavedSetting" --
  227.  # 
  228.  #  This proc shouldn't 'unset' the variables it removes, because most
  229.  #  such variables will be in use/have default values until restart.
  230.  # -------------------------------------------------------------------------
  231.  ##
  232. proc removeSavedSetting {} {
  233.     global prefDefs arrprefDefs
  234.     
  235.     saveModifiedVars
  236.     set res [listpick -p "Remove which setting?" [lsort -ignore [getSavedSettings]]]
  237.     
  238.     if {$res == ""} return
  239.     if {[regexp {([^(]+)\(([^)]+)\)} $res dummy arr field]} {
  240.     global $arr
  241.     removeArrDef $arr $field
  242.     } else {
  243.     global $res
  244.     removeDef $res
  245.     }
  246.     
  247.     catch {unset prefDefs}
  248.     catch {unset arrprefDefs}
  249. }
  250.  
  251.  
  252. proc getSavedSettings {} {
  253.     global prefDefs arrprefDefs
  254.     
  255.     readDefs
  256.     readDefs arr
  257.     
  258.     set names [array names prefDefs]
  259.     foreach pair [array names arrprefDefs] {
  260.     lappend names "[lindex $pair 0]([lindex $pair 1])"
  261.     }
  262.     
  263.     return [lsort $names]
  264. }
  265.  
  266. #===============================================================================
  267.  
  268. proc global::editPrefsFile {} {
  269.     global PREFS
  270.     if {![file exists [file join $PREFS prefs.tcl]]} {
  271.     set fd [open [file join $PREFS prefs.tcl] "w"]
  272.     close $fd
  273.     }
  274.     edit [file join $PREFS prefs.tcl]
  275. }
  276.  
  277. # Automatically add a line to the user input file
  278. proc addUserLine {line} {
  279.     global PREFS
  280.     
  281.     if {![file exists "$PREFS"]} {
  282.     file mkdir "$PREFS"
  283.     }
  284.     set fid [open [file join $PREFS prefs.tcl] "a+"]
  285.     if {![catch {seek $fid -1 end}]} {
  286.     if {[read $fid 1] == "\r"} {
  287.         set line "\r$line"
  288.     }
  289.     }
  290.     seek $fid 0 end
  291.     puts $fid $line
  292.     close $fid
  293. }
  294.  
  295. # Automatically add a line to a mode's pref file -trf
  296. proc mode::addUserLine {line} {
  297.     global PREFS mode
  298.     
  299.     if {![file exists "$PREFS"]} {
  300.     file mkdir "$PREFS"
  301.     }
  302.     set fid [open [file join $PREFS ${mode}prefs.tcl] "a+"]
  303.     if {![catch {seek $fid -1 end}]} {
  304.     if {[read $fid 1] != "\r"} {
  305.         set line "\r$line"
  306.     }
  307.     }
  308.     seek $fid 0 end
  309.     puts $fid $line
  310.     close $fid
  311. }
  312.  
  313.  
  314.  
  315. #===============================================================================
  316.  
  317. ## 
  318.  # -------------------------------------------------------------------------
  319.  # 
  320.  # "mode::sourcePrefs" --
  321.  # 
  322.  #  Fixes 'uplevel #0' problem
  323.  # -------------------------------------------------------------------------
  324.  ##
  325. proc mode::sourcePrefsFile {} { 
  326.     global mode PREFS
  327.     if {[file exists [file join ${PREFS} ${mode}Prefs.tcl]]} {
  328.     uplevel #0 [list source [file join ${PREFS} ${mode}Prefs.tcl]]
  329.     } else {
  330.     beep; message "Sorry, no preferences for '$mode' mode"
  331.     }
  332. }
  333.  
  334. proc mode::editPrefsFile {{m ""}} { 
  335.     global PREFS mode
  336.     if {$m == ""} { set m $mode }
  337.     message $m
  338.     # assume it is a mode, since we made the menu
  339.     
  340.     set f [file join $PREFS ${m}Prefs.tcl]
  341.     if {[file exists $f]} {
  342.     edit $f
  343.     } else {
  344.     if {[dialog::yesno "No '$m' prefs file exists, do you want to create one?"]} {
  345.         close [open $f "w"]
  346.         edit $f
  347.         insertText {
  348. ## 
  349.  # This    file will be sourced automatically, immediately after 
  350.  # the _first_ time the file which defines its mode is sourced.
  351.  # Use this file to insert your own mode-specific preferences
  352.  # and changes,    rather than altering the originals.
  353.  # 
  354.  # You can redefine menus, procedures, variables,...
  355.  ##
  356.  
  357.     }}}
  358.     
  359.     hook::callAll mode::editPrefsFile
  360.     }
  361.  
  362. proc saveModifiedVars {} {
  363.     global modifiedVars modifiedModeVars modifiedArrVars \
  364.       mode::features prefDefs modifiedArrayElements global::features
  365.     
  366.     cache::delete configuration
  367.     cache::add configuration variable global::features
  368.     
  369.     foreach f [lunique $modifiedArrVars] {
  370.     addArr $f
  371.     }
  372.     foreach f [lunique $modifiedVars] {
  373.     global $f
  374.     if {[info exists $f]} {
  375.         addDef $f [set $f]
  376.     } else {
  377.         removeDef $f
  378.     }
  379.     }
  380.     # these two lists actually behave identically
  381.     foreach f [concat [lunique $modifiedArrayElements]  [lunique $modifiedModeVars]] {
  382.     set elt [lindex $f 0]
  383.     set arr [lindex $f 1]
  384.     global $arr
  385.     if {[info exists [set arr]($elt)]} {
  386.         addArrDef [set arr] $elt [set [set arr]($elt)]
  387.     } else {
  388.         removeArrDef [set arr] $elt
  389.     }
  390.     }
  391.     
  392.     set modifiedVars {}
  393.     set modifiedArrVars {}
  394.     set modifiedModeVars {}
  395.     set modifiedArrayElements {}
  396. }
  397.  
  398.  
  399.  
  400.  
  401.  
  402.  
  403.  
  404.