1array set _tclReg { 2 init 0 3 hasreg 0 4 usereg 0 5 loaded 0 6 changed 0 7 fname "" 8 base "" 9} 10 11proc tclreg_init {args} { 12 global tcl_platform tcl_version env 13 global _tclReg _tclRegData 14 15 catch tclreg_close 16 array set _tclReg { 17 init 1 18 hasreg 0 19 usereg 0 20 loaded 0 21 changed 0 22 } 23 catch {unset _tclRegData} 24 25 if {$tcl_platform(platform) == "windows"} { 26 if {[info commands registry] == ""} { 27 set vers [join [split $tcl_version .] {}] 28 catch {load tclreg$vers registry} 29 } 30 if {[info commands registry] != ""} { 31 set _tclReg(hasreg) 1 32 set _tclReg(usereg) 1 33 } 34 if {[info exists env(USERPROFILE)]} { 35 set home [join [split $env(USERPROFILE) \\] /] 36 } elseif {[info exists env(HOME)]} { 37 set home [join [split $env(HOME) \\] /] 38 } else { 39 set home ~ 40 } 41 set _tclReg(fname) "$home/_tclreg" 42 } else { 43 if {[info exists env(HOME)]} { 44 set home $env(HOME) 45 } else { 46 set home ~ 47 } 48 set _tclReg(fname) "$home/.tclreg" 49 } 50 51 foreach {tag value} $args { 52 switch -- $tag { 53 -usereg { 54 set _tclReg(usereg) $value 55 } 56 -fname { 57 if {$tcl_platform(platform) == "windows"} { 58 set value [join [split $value \\] /] 59 } 60 if {[string first / $value] < 0} { 61 set _tclReg(fname) "$home/$value" 62 } else { 63 set _tclReg(fname) $value 64 } 65 } 66 -base { 67 set _tclReg(base) $value 68 } 69 } 70 } 71 72 if {$_tclReg(usereg) && !$_tclReg(hasreg)} {return 0} 73 return 1 74} 75 76proc tclreg_open {} { 77 global _tclReg _tclRegData 78 if {!$_tclReg(init)} tclreg_init 79 if {$_tclReg(usereg)} return 80 catch tclreg_close 81 catch {unset _tclRegData} 82 catch {source $_tclReg(fname)} 83 set _tclReg(changed) 0 84 set _tclReg(loaded) 1 85} 86 87proc tclreg_close {} { 88 global _tclReg _tclRegData 89 if {$_tclReg(usereg) || !$_tclReg(changed)} return 90 catch {unset _tclRegTemp} 91 foreach key [array names _tclRegData] { 92 set _tclRegTemp($key) $_tclRegData($key) 93 } 94 catch {source $_tclReg(fname)} 95 foreach key [array names _tclRegTemp] { 96 set _tclRegData($key) $_tclRegTemp($key) 97 } 98 set f [open $_tclReg(fname) w+] 99 puts $f "array set _tclRegData \{" 100 foreach key [array names _tclRegData] { 101 puts $f " \{$key\} \{$_tclRegData($key)\}" 102 } 103 puts $f "\}" 104 close $f 105 set _tclReg(changed) 0 106} 107 108proc tclreg_get {key value} { 109 global _tclReg _tclRegData 110 if {!$_tclReg(init)} tclreg_init 111 if {$_tclReg(usereg)} { 112 if {$_tclReg(hasreg)} { 113 if {$_tclReg(base) != ""} { 114 set key "$_tclReg(base)/$key" 115 } 116 set key [join [split $key /] \\] 117 if {[catch {registry get $key $value} data]} { 118 set data "" 119 } 120 } else { 121 set data "" 122 } 123 return $data 124 } 125 if {!$_tclReg(loaded)} tclreg_open 126 set key [join [split $key \\] /] 127 if {[info exists _tclRegData($key,$value)]} { 128 return $_tclRegData($key,$value) 129 } 130 return "" 131} 132 133proc tclreg_set {key value data} { 134 global _tclReg _tclRegData 135 if {!$_tclReg(init)} tclreg_init 136 if {$_tclReg(usereg)} { 137 if {$_tclReg(hasreg)} { 138 if {$_tclReg(base) != ""} { 139 set key "$_tclReg(base)/$key" 140 } 141 set key [join [split $key /] \\] 142 registry set $key $value $data 143 } 144 } else { 145 if {!$_tclReg(loaded)} tclreg_open 146 set key [join [split $key \\] /] 147 set _tclRegData($key,$value) $data 148 incr _tclReg(changed) 149 } 150} 151 152