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